justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Linting

Browse Source
This commit is contained in:
justin
2021-04-23 11:10:45 +02:00
parent c740ca0844
commit ffe4a8083b
14 changed files with 329 additions and 286 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Default.hs
+50 -45
View File
@@ -24,31 +24,34 @@ import qualified Data.Set as S
import Data.Graph.Inductive.Graph hiding ((&)) import Data.Graph.Inductive.Graph hiding ((&))
import Data.List import Data.List
defaultWall = Wall { _wlLine = [(0,0),(50,0)] defaultWall = Wall
, _wlID = 0 { _wlLine = [(0,0),(50,0)]
, _wlColor = greyN 0.6 , _wlID = 0
, _wlDraw = Nothing , _wlColor = greyN 0.6
, _wlSeen = False , _wlDraw = Nothing
, _wlIsSeeThrough = False , _wlSeen = False
} , _wlIsSeeThrough = False
defaultAutoDoor = Door { _wlLine = [(0,0),(50,0)] }
, _wlID = 0 defaultAutoDoor = Door
, _doorMech = id { _wlLine = [(0,0),(50,0)]
, _wlColor = light $ dim $ dim $ dim $ yellow , _wlID = 0
, _wlDraw = Nothing , _doorMech = id
, _wlSeen = False , _wlColor = light $ dim $ dim $ dim $ yellow
, _wlIsSeeThrough = False , _wlDraw = Nothing
, _doorPathable = True , _wlSeen = False
} , _wlIsSeeThrough = False
defaultDoor = Door { _wlLine = [(0,0),(50,0)] , _doorPathable = True
, _wlID = 0 }
, _doorMech = id defaultDoor = Door
, _wlColor = light $ dim $ dim $ dim $ yellow { _wlLine = [(0,0),(50,0)]
, _wlDraw = Nothing , _wlID = 0
, _wlSeen = False , _doorMech = id
, _wlIsSeeThrough = False , _wlColor = light $ dim $ dim $ dim $ yellow
, _doorPathable = False , _wlDraw = Nothing
} , _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
}
defaultCreature :: Creature defaultCreature :: Creature
defaultCreature = Creature defaultCreature = Creature
{ _crPos = (0,0) { _crPos = (0,0)
@@ -68,14 +71,15 @@ defaultCreature = Creature
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10 , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10
, _crIsAnimate = True , _crIsAnimate = True
} }
defaultState = CrSt { _goals = [] defaultState = CrSt
, _stance = Stance {_carriage=Walking 0 0,_posture=AtEase} { _goals = []
, _faction = NoFaction , _stance = Stance {_carriage=Walking 0 0,_posture=AtEase}
, _crDamage = [] , _faction = NoFaction
, _crPastDamage = 0 , _crDamage = []
, _crSpState = GenCr , _crPastDamage = 0
, _crApplyDamage = defaultApplyDamage' , _crSpState = GenCr
} , _crApplyDamage = defaultApplyDamage
}
defaultEquipment = Equipment defaultEquipment = Equipment
{ _itIdentity = Generic { _itIdentity = Generic
, _itName = "genericEquipment" , _itName = "genericEquipment"
@@ -108,16 +112,17 @@ defaultConsumable = Consumable
, _itEffect = wpRecock , _itEffect = wpRecock
, _itHammer = HammerUp , _itHammer = HammerUp
} }
defaultApplyDamage' :: [DamageType] -> Creature -> (World -> World, Creature) defaultApplyDamage :: [DamageType] -> Creature -> (World -> World, Creature)
defaultApplyDamage' ds cr = (id, doPoisonDam $ foldr (\d c -> snd $ defaultApplyDamage d c) cr ds') defaultApplyDamage ds cr = (id, doPoisonDam $ foldr (\d c -> snd $ applyIndividualDamage d c) cr ds')
where (ps,ds') = partition isPoison ds where
isPoison (PoisonDam {}) = True (ps,ds') = partition isPoison ds
isPoison _ = False isPoison (PoisonDam {}) = True
poisonDam = quot (max 0 (sum (map _dmAmount ps) - 0)) 10 isPoison _ = False
doPoisonDam = over crHP (\hp -> hp - poisonDam) poisonDam = quot (max 0 (sum (map _dmAmount ps))) 10
doPoisonDam = over crHP (\hp -> hp - poisonDam)
defaultApplyDamage :: DamageType -> Creature -> (World -> World, Creature) applyIndividualDamage :: DamageType -> Creature -> (World -> World, Creature)
defaultApplyDamage (Concussive amount from push pushexp pushRad) cr applyIndividualDamage (Concussive amount from push pushexp pushRad) cr
= ( id = ( id
, over crHP (\hp -> hp - amount) , over crHP (\hp -> hp - amount)
$ over crPos (+.+ (pushAmount *.* safeNormalizeV (_crPos cr -.- from))) $ over crPos (+.+ (pushAmount *.* safeNormalizeV (_crPos cr -.- from)))
@@ -127,14 +132,14 @@ defaultApplyDamage (Concussive amount from push pushexp pushRad) cr
= 0 = 0
| otherwise = min 5 $ | otherwise = min 5 $
(push*5*pushRad / (dist (_crPos cr) from * _crMass cr))**pushexp (push*5*pushRad / (dist (_crPos cr) from * _crMass cr))**pushexp
defaultApplyDamage (TorqueDam amount rot) cr applyIndividualDamage (TorqueDam amount rot) cr
= ( id = ( id
, over crHP (\hp -> hp - amount) $ over crDir (+ rot) cr) , over crHP (\hp -> hp - amount) $ over crDir (+ rot) cr)
defaultApplyDamage (PushDam amount pback) cr applyIndividualDamage (PushDam amount pback) cr
= ( id = ( id
, over crHP (\hp -> hp - amount) $ over crPos (+.+ ((1/_crMass cr) *.* pback )) cr , over crHP (\hp -> hp - amount) $ over crPos (+.+ ((1/_crMass cr) *.* pback )) cr
) )
defaultApplyDamage dt cr applyIndividualDamage dt cr
= ( id , over crHP (\hp -> hp - _dmAmount dt) cr ) = ( id , over crHP (\hp -> hp - _dmAmount dt) cr )
defaultFlIt = FlIt {_flItRot=0,_flIt = defaultIt, _flItPos = (0,0), _flItID = 0} defaultFlIt = FlIt {_flItRot=0,_flIt = defaultIt, _flItPos = (0,0), _flItID = 0}
defaultIt = Consumable defaultIt = Consumable
src/Dodge/Layout/Tree/Annotate.hs
+2 -2
View File
@@ -65,8 +65,8 @@ annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
annoToRoomTree [StartRoom] = do annoToRoomTree [StartRoom] = do
w <- state $ randomR (100,400) w <- state $ randomR (100,400)
h <- state $ randomR (200,400) h <- state $ randomR (200,400)
fmap (pure . Right) $ return (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h) >>= randomiseOutLinks fmap (pure . Right) $ randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h)
annoToRoomTree _ = do annoToRoomTree _ = do
w <- state $ randomR (100,400) w <- state $ randomR (100,400)
h <- state $ randomR (200,400) h <- state $ randomR (200,400)
fmap (pure . Right) $ return (roomRectAutoLinks w h) >>= randomiseOutLinks fmap (pure . Right) . randomiseOutLinks $ roomRectAutoLinks w h
src/Dodge/LevelGen/StaticWalls.hs
+2 -2
View File
@@ -156,8 +156,8 @@ addPolyWall (p1,p2) walls =
p3 = 0.5 *.* (p1 +.+ p2) p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
maybeWs = -- listToMaybe . maybeWs = -- listToMaybe .
fmap fst fmap (fst . unzip)
. fmap unzip -- . fmap unzip
. listToMaybe . listToMaybe
$ groupBy ((==) `on` (dist p3 . snd)) $ groupBy ((==) `on` (dist p3 . snd))
wlsP wlsP
src/Dodge/Path.hs
+8 -5
View File
@@ -26,13 +26,16 @@ worldGraph w p = HS.unions $ fmap (\q -> HS.fromList $ pointsAlong w p (p +.+ q)
pointsAlong :: World -> Point2 -> Point2 -> [Point2] pointsAlong :: World -> Point2 -> Point2 -> [Point2]
pointsAlong w p q = divideLineFixed 50 p p' pointsAlong w p q = divideLineFixed 50 p p'
where p' = furthestPointWalkable p q $ wallsAlongLine p q w where
p' = furthestPointWalkable p q $ wallsAlongLine p q w
divideLineFixed :: Float -> Point2 -> Point2 -> [Point2] divideLineFixed :: Float -> Point2 -> Point2 -> [Point2]
divideLineFixed x a b = fmap (\i -> a +.+ i * x *.* normalizeV (b -.- a)) divideLineFixed x a b = fmap
$ fmap fromIntegral ns ( \i -> a +.+ i * x *.* normalizeV (b -.- a) )
where numPoints = floor $ dist a b / x ns
ns = [1 .. numPoints] where
numPoints = floor $ dist a b / x
ns = map fromIntegral [1 .. numPoints]
-- ok, astar or something like it -- ok, astar or something like it
src/Dodge/Room/Teleport.hs
-6
View File
@@ -38,13 +38,7 @@ telRoomLev i = do
} }
ppFootprint = rectNSEW 20 (-20) 20 (-20) ppFootprint = rectNSEW 20 (-20) 20 (-20)
levelReset pp w levelReset pp w
-- | crInPolygon (you w) (ppPoly pp) = undefined -- makeExplosionAt (_ppPos pp) $ startNewGame w
| dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) $ startNewGame w | dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) $ startNewGame w
| otherwise = w | otherwise = w
ppPoly pp = map (+.+ (_ppPos pp)) ppFootprint ppPoly pp = map (+.+ (_ppPos pp)) ppFootprint
startNewGame w = w & worldTriggers %~ S.insert (ResetLevel i) startNewGame w = w & worldTriggers %~ S.insert (ResetLevel i)
-- generateFromList levx
-- $ initialWorld
-- & randGen .~ _randGen w
-- & windowX .~ _windowX w
-- & windowY .~ _windowY w
src/Dodge/WorldEvent/SpawnParticle.hs
+78 -75
View File
@@ -42,30 +42,32 @@ makeFlame t pos vel maycid = over particles' (aFlameParticle t pos vel maycid :
drawFlame :: Point2 -> Particle' -> Picture drawFlame :: Point2 -> Particle' -> Picture
drawFlame rotd pt = thePic drawFlame rotd pt = thePic
where ep = _btPos' pt where
thePic = pictures ep = _btPos' pt
[ glow thePic = pictures
, aPic prot2 0.2998 (scaleChange + 1,2) red [ glow
, aPic prot 0.2996 (scaleChange + 0.5,1.5) orange , aPic prot2 0.2998 (scaleChange + 1,2) red
, aPic prot3 0.2994 (scaleChange,1) white , aPic prot 0.2996 (scaleChange + 0.5,1.5) orange
] , aPic prot3 0.2994 (scaleChange,1) white
aPic :: (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture ]
aPic offset depth (scalex,scaley) col aPic :: (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
= setLayer 1 aPic offset depth (scalex,scaley) col
. setDepth depth = setLayer 1
. uncurry translate (offset ep) . setDepth depth
. rotate (pi * 0.5 + argV rotd) . uncurry translate (offset ep)
. scale scalex scaley . rotate (pi * 0.5 + argV rotd)
. color col . scale scalex scaley
$ circleSolid 5 . color col
glow = setLayer 1 $ setDepth 0.3 $ uncurry translate ep $ circleSolid 5
$ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50 glow = setLayer 1 $ setDepth 0.3 $ uncurry translate ep
time = _btTimer' pt $ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50
scaleChange | time < 80 = 3 time = _btTimer' pt
| otherwise = 3 - (fromIntegral time - 80) * 0.2 scaleChange
prot p' = p' +.+ rotateV (fromIntegral time * 1) (0,1) | time < 80 = 3
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time * 1) (0,1) | otherwise = 3 - (fromIntegral time - 80) * 0.2
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2) prot p' = p' +.+ rotateV (fromIntegral time) (0,1)
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (0,1)
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2)
moveFlame :: Point2 -> World -> Particle' -> (World, Maybe Particle') moveFlame :: Point2 -> World -> Particle' -> (World, Maybe Particle')
moveFlame rotd w pt moveFlame rotd w pt
@@ -74,34 +76,35 @@ moveFlame rotd w pt
((p,(E3x1 cr)):_) -> (soundAndGlare damcrs , mvPt') ((p,(E3x1 cr)):_) -> (soundAndGlare damcrs , mvPt')
(thing@(p,(E3x2 wl)):_) -> (fst $ hiteff [thing] damcrs , rfl wl p) (thing@(p,(E3x2 wl)):_) -> (fst $ hiteff [thing] damcrs , rfl wl p)
_ -> (soundAndGlare damcrs , mvPt) _ -> (soundAndGlare damcrs , mvPt)
where time = _btTimer' pt where
soundAndGlare = soundFrom Flame fireSound 2 500 time = _btTimer' pt
. over worldEvents ((.) $ flameGlareAt ep) soundAndGlare = soundFrom Flame fireSound 2 500
sp = _btPos' pt . over worldEvents ((.) $ flameGlareAt ep)
vel = _btVel' pt sp = _btPos' pt
ep = sp +.+ vel vel = _btVel' pt
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep ep = sp +.+ vel
, _btPassThrough' = Nothing mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep
,_btVel' = 0.98 *.* vel} , _btPassThrough' = Nothing
mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep ,_btVel' = 0.98 *.* vel}
, _btPassThrough' = Nothing mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep
,_btVel' = 0.7 *.* vel} , _btPassThrough' = Nothing
damcrs = foldr ($) w $ map (\cr -> fst . hiteff [(ep,E3x1 cr)]) $ filter closeCrs ,_btVel' = 0.7 *.* vel}
$ IM.elems $ _creatures w damcrs = foldr ($) w $ map (\cr -> fst . hiteff [(ep,E3x1 cr)]) $ filter closeCrs
closeCrs cr = dist ep (_crPos cr) $ IM.elems $ _creatures w
< _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80)) closeCrs cr = dist ep (_crPos cr)
+ 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd) < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80))
angleCoeff x = abs $ 1 - (abs $ (x * 2 - pi) / (pi)) + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd)
hiteff = _btHitEffect' pt pt angleCoeff x = abs $ 1 - (abs $ (x * 2 - pi) / (pi))
rfl wl p = Just $ pt {_btTimer' = time -1, _btPos' = pOut p hiteff = _btHitEffect' pt pt
, _btVel' = reflV wl--, _ptDraw = const $ thepic $ pOut p rfl wl p = Just $ pt {_btTimer' = time -1, _btPos' = pOut p
} , _btVel' = reflV wl--, _ptDraw = const $ thepic $ pOut p
pOut p = p +.+ safeNormalizeV (sp -.- p) }
reflV wall = (0.3 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0) pOut p = p +.+ safeNormalizeV (sp -.- p)
vel ) reflV wall = (0.3 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0)
+.+ vel )
(0.2 *.* vel) +.+
smokeGen = makeFlamerSmokeAt ep (0.2 *.* vel)
smokeGen = makeFlamerSmokeAt ep
makeFlameletTimed :: Point2 -> Point2 -> Maybe Int -> Float -> Int -> World -> World makeFlameletTimed :: Point2 -> Point2 -> Maybe Int -> Float -> Int -> World -> World
makeFlameletTimed pos vel maycid size time w makeFlameletTimed pos vel maycid size time w
@@ -311,30 +314,30 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
g (E3x1 cr1) = dist p $ _crPos cr1 g (E3x1 cr1) = dist p $ _crPos cr1
(arcLen,_) = randomR (25,50) $ _randGen w (arcLen,_) = randomR (25,50) $ _randGen w
-- if the spark is created by another Particle', it cannot be directly added to -- | Create a spark.
-- the list, hence the redirect through worldEvents -- If the spark is created by another Particle, it cannot be directly added to
-- the list, hence the redirect through worldEvents.
createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
createSpark time colid pos dir maycid w = over worldEvents createSpark time colid pos dir maycid w
((.) $ ( over particles' ((:) spark) = over worldEvents ((.) ( over particles' (spark :) . sparkFlashAt pos')) w
-- . flareAt' white 0.02 0.05 pos') where
. sparkFlashAt pos') spark = Bul' { _ptDraw = drawBul
) w , _ptUpdate' = mvGenBullet'
where spark = Bul' { _ptDraw = drawBul , _btVel' = rotateV dir (5,0)
, _ptUpdate' = mvGenBullet' , _btColor' = numColor colid
, _btVel' = rotateV dir (5,0) , _btTrail' = [pos]
, _btColor' = numColor colid , _btPassThrough' = maycid
, _btTrail' = [pos] , _btWidth' = 1
, _btPassThrough' = maycid , _btTimer' = time
, _btWidth' = 1 , _btHitEffect' = destroyOnImpact sparkEff noEff noEff
, _btTimer' = time }
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff x = fst $ randomR (0,20) $ _randGen w
} pos' = pos +.+ rotateV dir (x,0)
x = fst $ randomR (0,20) $ _randGen w sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
pos' = pos +.+ rotateV dir (x,0) ((:) $ SparkDam 1 sp p ep)
sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage) where
((:) $ SparkDam 1 sp p ep) sp = head (_btTrail' bt)
where sp = head (_btTrail' bt) ep = sp +.+ _btVel' bt
ep = sp +.+ _btVel' bt
drawBul :: Particle' -> Picture drawBul :: Particle' -> Picture
drawBul pt = setLayer 1 . color white $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt) drawBul pt = setLayer 1 . color white $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt)
src/Dodge/WorldEvent/ThingsHit.hs
+37 -37
View File
@@ -10,26 +10,26 @@ import Data.List
import Data.Maybe import Data.Maybe
import Data.Function (on) import Data.Function (on)
thingsHit :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))] thingsHit :: Point2 -> Point2 -> World -> [(Point2, Either3 Creature Wall ForceField)]
thingsHit sp ep w thingsHit sp ep w
| sp == ep = [] | sp == ep = []
| otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) | otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
where where
hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr)) hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
$ _creatures w $ _creatures w
-- $ creaturesAlongLine sp ep w -- $ creaturesAlongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
crs = zip crPs (map E3x1 hitCrs) crs = zip crPs (map E3x1 hitCrs)
hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1]
, b<-[y-1,y,y+1]]) , b<-[y-1,y,y+1]])
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep)) (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
f i m = case IM.lookup i m of Just val -> val f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty _ -> IM.empty
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1) hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w) hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World
@@ -37,34 +37,34 @@ thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World
thingsHitExceptCr Nothing sp ep = thingsHit sp ep thingsHitExceptCr Nothing sp ep = thingsHit sp ep
thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
where where
crNotCid (_,(E3x1 cr)) = _crID cr /= cid crNotCid (_,E3x1 cr) = _crID cr /= cid
crNotCid _ = True crNotCid _ = True
thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World
-> [(Point2, (Either3 Creature Wall ForceField))] -> [(Point2, Either3 Creature Wall ForceField)]
thingsHitExceptCrLongLine Nothing sp ep = thingsHitLongLine sp ep thingsHitExceptCrLongLine Nothing sp ep = thingsHitLongLine sp ep
thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine sp ep thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine sp ep
where crNotCid (_,(E3x1 cr)) = _crID cr /= cid where crNotCid (_,E3x1 cr) = _crID cr /= cid
crNotCid _ = True crNotCid _ = True
thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))] thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, Either3 Creature Wall ForceField)]
thingsHitLongLine sp ep w thingsHitLongLine sp ep w
| sp == ep = [] | sp == ep = []
| otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) | otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
where where
crs = zip crPs (map E3x1 hitCrs) crs = zip crPs (map E3x1 hitCrs)
hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr)) hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
$ _creatures w $ _creatures w
-- $ creaturesAlongLine sp ep w -- $ creaturesAlongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
hitPoint wl = intersectSegSeg' sp ep (_wlLine wl !! 0) (_wlLine wl !! 1) hitPoint wl = intersectSegSeg' sp ep (_wlLine wl !! 0) (_wlLine wl !! 1)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w) hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
thingsHitOnPath :: [Point2] -> World -> [ [ ( Point2, (Either3 Creature Wall ForceField) ) ] ] thingsHitOnPath :: [Point2] -> World -> [ [ ( Point2, Either3 Creature Wall ForceField ) ] ]
thingsHitOnPath [] _ = error "tried to find thingsHitOnPath containing no points" thingsHitOnPath [] _ = error "tried to find thingsHitOnPath containing no points"
thingsHitOnPath ps w = map (flip (uncurry thingsHit) w) . zip ps $ tail ps thingsHitOnPath ps w = zipWith (\ a b -> thingsHit a b w) ps $ tail ps
src/Geometry.hs
+5 -5
View File
@@ -373,11 +373,11 @@ reflectInParam x line vec =
--reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 --reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2
--reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1) --reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1)
--isOnSeg :: Point2 -> Point2 -> Point2 -> Bool isOnSeg :: Point2 -> Point2 -> Point2 -> Bool
--isOnSeg l1 l2 p = isOnSeg l1 l2 p =
-- errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0 errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
-- && errorClosestPointOnLineParam 11 l1 l2 p <= 1 && errorClosestPointOnLineParam 11 l1 l2 p <= 1
-- && errorClosestPointOnLineParam 12 l1 l2 p >= 0 && errorClosestPointOnLineParam 12 l1 l2 p >= 0
-- | Divide a segment into a list of points with a maximal distance between -- | Divide a segment into a list of points with a maximal distance between
-- them. -- them.
src/Geometry/Intersect.hs
+41 -37
View File
@@ -9,9 +9,9 @@ intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den == 0 = Nothing | den == 0 = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
-- | If two segments intersect, return 'Just' that point. -- | If two segments intersect, return 'Just' that point.
intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
@@ -23,10 +23,10 @@ intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den) | den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den)
= Nothing = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
-- | Intended to intersect a segment with a half-line-segment, ie a segment -- | Intended to intersect a segment with a half-line-segment, ie a segment
-- extending infinitely in one direction. -- extending infinitely in one direction.
@@ -39,10 +39,10 @@ intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den < 0 && ( t' > 0 || u' > 0 || t' < den ) | den < 0 && ( t' > 0 || u' > 0 || t' < den )
= Nothing = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
-- | Similar to 'intersectSegLineFrom'', but this version is probably not correct... -- | Similar to 'intersectSegLineFrom'', but this version is probably not correct...
intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
@@ -54,10 +54,10 @@ intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den < 0 && ( t' > 0 || u' > - den || t' < den ) | den < 0 && ( t' > 0 || u' > - den || t' < den )
= Nothing = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
-- | Intersect a segment with a line. -- | Intersect a segment with a line.
intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
@@ -69,10 +69,10 @@ intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den < 0 && (t' > 0 || t' < den) | den < 0 && (t' > 0 || t' < den)
= Nothing = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
-- | Due to floating point issues, 'intersectSegSeg'' is not always -- | Due to floating point issues, 'intersectSegSeg'' is not always
-- accurate---'myIntersectSegSeg' -- accurate---'myIntersectSegSeg'
@@ -86,34 +86,38 @@ myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLin
Just (x,y) -> if inbetween x && inbetween' y Just (x,y) -> if inbetween x && inbetween' y
then Just (x,y) then Just (x,y)
else Nothing else Nothing
where inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) && where
((cx <= x && x <= dx) || (dx <= x && x <= cx)) inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax))
inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) && && ((cx <= x && x <= dx) || (dx <= x && x <= cx))
((cy <= y && y <= dy) || (dy <= y && y <= cy)) inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay))
&& ((cy <= y && y <= dy) || (dy <= y && y <= cy))
-- | Polymorphic intersection of fractional line points. -- | Polymorphic intersection of fractional line points.
myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a) myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a)
myIntersectLineLine a@(ax,ay) b c@(cx,cy) d myIntersectLineLine a@(ax,ay) b c@(cx,cy) d
| linGrad a b == Nothing = fmap ((,) ax) $ axisInt (c *-* (ax,0)) (d *-* (ax,0)) | linGrad a b == Nothing = ((,) ax) <$> axisInt (c *-* (ax,0)) (d *-* (ax,0))
| linGrad c d == Nothing = fmap ((,) cx) $ axisInt (a *-* (cx,0)) (b *-* (cx,0)) | linGrad c d == Nothing = ((,) cx) <$> axisInt (a *-* (cx,0)) (b *-* (cx,0))
| otherwise | otherwise
= case linGrad a b ^-^ linGrad c d of = case linGrad a b ^-^ linGrad c d of
Just 0 -> Nothing Just 0 -> Nothing
_ -> liftA2 (,) newx _ -> liftA2 (,) newx ((linGrad a b ^*^ newx) ^+^ axisInt a b)
((linGrad a b ^*^ newx) ^+^ axisInt a b)
where (^-^) = liftA2 (-) where
(^+^) = liftA2 (+) (^-^) = liftA2 (-)
(^/^) = liftA2 (/) (^+^) = liftA2 (+)
(^*^) = liftA2 (*) (^/^) = liftA2 (/)
newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d) (^*^) = liftA2 (*)
(*-*) (ax,ay) (bx,by) = (ax-bx,ay-by) newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d)
(*-*) (ax,ay) (bx,by) = (ax-bx,ay-by)
-- | Transforms floating points to rationals then performs line intersection. -- | Transforms floating points to rationals then performs line intersection.
ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d) ratIntersectLineLine a b c d = toNumPoint2
where toRatPoint2 (x,y) = (toRational x, toRational y) <$> myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d)
toNumPoint2 (x,y) = (fromRational x, fromRational y) where
f = toRatPoint2 . roundPoint2 toRatPoint2 (x,y) = (toRational x, toRational y)
toNumPoint2 (x,y) = (fromRational x, fromRational y)
f = toRatPoint2 . roundPoint2
{- | Round the floats within a 'Point2' to the nearest integer. {- | Round the floats within a 'Point2' to the nearest integer.
__Examples__ __Examples__
src/Picture/Data.hs
+6 -12
View File
@@ -1,25 +1,18 @@
{-# LANGUAGE TemplateHaskell #-} --{-# LANGUAGE TemplateHaskell #-}
--{-# LANGUAGE Strict #-} --{-# LANGUAGE Strict #-}
module Picture.Data module Picture.Data
where where
import Geometry.Data
import Data.Monoid import Data.Monoid
import Data.Traversable
import qualified Data.Foldable as F import qualified Data.Foldable as F
import qualified Data.Sequence as Se import qualified Data.Sequence as Se
import qualified Data.DList as DL import qualified Data.DList as DL
import qualified Data.Vector as V import qualified Data.Vector as V
import Geometry.Data
import Control.Lens import Control.Lens
--import Foreign
--import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
import Control.Monad import Control.Monad
import Data.Traversable
data RenderType data RenderType
= RenderPoly [(Point3,Point4)] = RenderPoly [(Point3,Point4)]
| RenderBezQ [(Point3,Point4,Point4)] | RenderBezQ [(Point3,Point4,Point4)]
@@ -42,6 +35,7 @@ instance Foldable FTree where
foldMap g (FLeaf x) = g x foldMap g (FLeaf x) = g x
{-# INLINE foldMap #-} {-# INLINE foldMap #-}
{- Tree with values at and only at the leaves. -}
data LTree a data LTree a
= LBranches [LTree a] = LBranches [LTree a]
| LLeaf a | LLeaf a
@@ -50,7 +44,7 @@ instance Foldable LTree where
foldMap g (LLeaf a) = g a foldMap g (LLeaf a) = g a
{-# INLINE foldMap #-} {-# INLINE foldMap #-}
instance Functor LTree where instance Functor LTree where
fmap f (LBranches ts) = LBranches $ (fmap (fmap f)) ts fmap f (LBranches ts) = LBranches $ fmap (fmap f) ts
fmap f (LLeaf x) = LLeaf (f x) fmap f (LLeaf x) = LLeaf (f x)
data RTree a b data RTree a b
@@ -61,7 +55,7 @@ instance Foldable (RTree a) where
foldMap g (RLeaf x) = g x foldMap g (RLeaf x) = g x
{-# INLINE foldMap #-} {-# INLINE foldMap #-}
instance Functor (RTree a) where instance Functor (RTree a) where
fmap f (RBranches i ts) = RBranches i $ (fmap (fmap f)) ts fmap f (RBranches i ts) = RBranches i $ fmap (fmap f) ts
fmap f (RLeaf x) = RLeaf (f x) fmap f (RLeaf x) = RLeaf (f x)
flat2 (x,y) = [x,y] flat2 (x,y) = [x,y]
src/Picture/Preload.hs
+1 -1
View File
@@ -123,7 +123,7 @@ setupFramebuffer = do
framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer fboRBO framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer fboRBO
fboStatus <- framebufferStatus Framebuffer fboStatus <- framebufferStatus Framebuffer
putStrLn $ show fboStatus print fboStatus
return (fboName, fboTO, fboRBO) return (fboName, fboTO, fboRBO)
src/Picture/Render.hs
+45 -42
View File
@@ -1,40 +1,43 @@
--{-# LANGUAGE Strict #-} --{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-} {-
Rendering of a picture.
-}
module Picture.Render module Picture.Render
( module Picture.Render ( module Picture.Render
, picToLTree , picToLTree
-- , perspectiveMatrix
) )
where where
import Shader import Shader
import MatrixHelper import MatrixHelper
import Control.Lens
import Control.Monad
import qualified Control.Foldl as F
import Picture.Preload import Picture.Preload
import Picture.Data import Picture.Data
import Picture.Tree import Picture.Tree
import Geometry import Geometry
import Control.Lens
import Control.Monad
import qualified Control.Foldl as F
import Foreign hiding (rotate) import Foreign hiding (rotate)
import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,imageWidth,Polygon,Color,T) import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
import Data.Foldable import Data.Foldable
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import qualified SDL
import qualified SDL as SDL renderPicture
:: RenderData -- ^ Preloaded render data
renderPicture' :: RenderData -> Float -> Float -> Point2 -> Point2 -> -> Float -- ^ Rotation
[((Point2,Point2),Point4)] -> [((Point2,Point2),Point4)] -> [Point4] -> -> Float -- ^ Zoom
(Float,Float) -> Picture -> IO (Word32) -> Point2 -- ^ Translation
renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol windowPoints lightPoints -> Point2 -- ^ Window size
-> [((Point2,Point2),Point4)] -- ^ Wall data
-> [((Point2,Point2),Point4)] -- ^ Window data
-> [Point4] -- ^ Lights data
-> (Float,Float) -- ^ View from point
-> Picture -- ^ Picture
-> IO Word32 -- ^ Time taken according to SDL.ticks
renderPicture pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol windowPoints lightPoints
viewFroms@(viewFromx,viewFromy) pic = do viewFroms@(viewFromx,viewFromy) pic = do
startTicks <- SDL.ticks startTicks <- SDL.ticks
let wallPoints = map fst wallPointsCol let wallPoints = map fst wallPointsCol
@@ -83,27 +86,27 @@ renderWalls pdata wps pmat = do
n <- F.foldM (pokeShader $ _wallFaceShader pdata) wps n <- F.foldM (pokeShader $ _wallFaceShader pdata) wps
bindShaderBuffers [_wallFaceShader pdata] [n] bindShaderBuffers [_wallFaceShader pdata] [n]
currentProgram $= Just (_shaderProgram $ _wallFaceShader pdata) currentProgram $= Just (_shaderProgram $ _wallFaceShader pdata)
uniform ( (fromJust $ _shaderCustomUnis $ _wallFaceShader pdata) !! 0) uniform (head (fromJust $ _shaderCustomUnis $ _wallFaceShader pdata) )
$= pmat $= pmat
drawShader (_wallFaceShader pdata) n drawShader (_wallFaceShader pdata) n
setWallDepth :: RenderData -> [(Point2,Point2)] -> (Float,Float) -> GLmatrix GLfloat -> IO Word32 setWallDepth :: RenderData -> [(Point2,Point2)] -> (Float,Float) -> GLmatrix GLfloat -> IO Word32
setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat = do setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat = do
startTicks <- SDL.ticks startTicks <- SDL.ticks
colorMask $= (Color4 Disabled Disabled Disabled Disabled) colorMask $= Color4 Disabled Disabled Disabled Disabled
nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints
bindShaderBuffers [_wallShadowShader pdata] [nWalls] bindShaderBuffers [_wallShadowShader pdata] [nWalls]
currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata) currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
$= Vector2 viewFromx viewFromy $= Vector2 viewFromx viewFromy
uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 1) uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 1)
$= pmat $= pmat
uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 2) uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 2)
$= (0 :: Float) $= (0 :: Float)
-- cullFace $= Just Front -- cullFace $= Just Front
drawShader (_wallShadowShader pdata) nWalls drawShader (_wallShadowShader pdata) nWalls
colorMask $= (Color4 Enabled Enabled Enabled Enabled) colorMask $= Color4 Enabled Enabled Enabled Enabled
endTicks <- SDL.ticks endTicks <- SDL.ticks
return $ endTicks - startTicks return $ endTicks - startTicks
@@ -113,7 +116,7 @@ createLightMap :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
(viewFromx,viewFromy) pmat = do (viewFromx,viewFromy) pmat = do
bindFramebuffer Framebuffer $= (_spareFBO pdata) bindFramebuffer Framebuffer $= _spareFBO pdata
-- clear buffer to full alpha and furthest depth -- clear buffer to full alpha and furthest depth
clearColor $= Color4 0 0 0 1 clearColor $= Color4 0 0 0 1
clearDepth $= 1 clearDepth $= 1
@@ -126,17 +129,17 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
bindShaderBuffers [_wallShadowShader pdata] [nWalls] bindShaderBuffers [_wallShadowShader pdata] [nWalls]
-- set uniforms for shader that draws lights -- set uniforms for shader that draws lights
currentProgram $= Just (_shaderProgram $ _wallLightShader pdata) currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 1) uniform ( fromJust (_shaderCustomUnis $ _wallLightShader pdata) !! 1)
$= pmat $= pmat
-- draw walls from your point of view in order to set z buffer -- draw walls from your point of view in order to set z buffer
colorMask $= (Color4 Disabled Disabled Disabled Disabled) colorMask $= Color4 Disabled Disabled Disabled Disabled
let (tx,ty) = (tranx,trany) -.- (viewFromx,viewFromy) let (tx,ty) = (tranx,trany) -.- (viewFromx,viewFromy)
currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata) currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
$= Vector2 viewFromx viewFromy $= Vector2 viewFromx viewFromy
uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 1) uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 1)
$= pmat $= pmat
uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 2) uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 2)
$= (0 :: Float) $= (0 :: Float)
cullFace $= Just Back cullFace $= Just Back
drawShader (_wallShadowShader pdata) nWalls drawShader (_wallShadowShader pdata) nWalls
@@ -169,27 +172,27 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
drawShader (_wallShadowShader pdata) nWalls drawShader (_wallShadowShader pdata) nWalls
-- draw floor light circles -- draw floor light circles
cullFace $= Nothing cullFace $= Nothing
colorMask $= (Color4 Disabled Disabled Disabled Enabled) colorMask $= Color4 Disabled Disabled Disabled Enabled
bindShaderBuffers [_lightSourceShader pdata] [1] bindShaderBuffers [_lightSourceShader pdata] [1]
stencilFunc $= (Equal, 0, 255) stencilFunc $= (Equal, 0, 255)
drawShader (_lightSourceShader pdata) 1 drawShader (_lightSourceShader pdata) 1
-- draw wall light "circles" -- draw wall light "circles"
currentProgram $= Just (_shaderProgram $ _wallLightShader pdata) currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata) uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
$= Vector2 x y $= Vector2 x y
uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 2) uniform (fromJust (_shaderCustomUnis $ _wallLightShader pdata) !! 2)
$= Vector2 r lum $= Vector2 r lum
drawShader (_wallLightShader pdata) nWallLights drawShader (_wallLightShader pdata) nWallLights
depthMask $= Enabled depthMask $= Enabled
cullFace $= Nothing cullFace $= Nothing
stencilTest $= Disabled stencilTest $= Disabled
blend $= Disabled blend $= Disabled
bindFramebuffer Framebuffer $= defaultFramebufferObject bindFramebuffer Framebuffer $= defaultFramebufferObject
colorMask $= (Color4 Disabled Disabled Disabled Enabled) colorMask $= Color4 Disabled Disabled Disabled Enabled
bindShaderBuffers [_fullscreenShader pdata] [4] bindShaderBuffers [_fullscreenShader pdata] [4]
textureBinding Texture2D $= Just (_fboTexture pdata) textureBinding Texture2D $= Just (_fboTexture pdata)
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
colorMask $= (Color4 Enabled Enabled Enabled Enabled) colorMask $= Color4 Enabled Enabled Enabled Enabled
blend $= Enabled blend $= Enabled
renderBackground :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO () renderBackground :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
@@ -202,20 +205,20 @@ renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do
currentProgram $= Just (_shaderProgram $ _backgroundShader pdata) currentProgram $= Just (_shaderProgram $ _backgroundShader pdata)
bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata) bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata)
let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata) !! 1 backPtr2 = (\(_,x,_) -> x) $ _vaoBufferTargets (_shaderVAO $ _backgroundShader pdata) !! 1
pokeFourOff backPtr 0 (tranx,trany,rot,zoom) pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
pokeTwoOff backPtr2 0 (winx,winy) pokeTwoOff backPtr2 0 (winx,winy)
textureBinding Texture2D $= (fmap _textureObject $ _shaderTexture $ _backgroundShader pdata) textureBinding Texture2D $= _textureObject <$> _shaderTexture (_backgroundShader pdata)
drawArrays Points (fromIntegral 0) (fromIntegral 1) drawArrays Points 0 1
setCommonUniforms :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO () setCommonUniforms :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do
setShaderUniforms rot zoom (tranx,trany) (winx,winy) setShaderUniforms rot zoom (tranx,trany) (winx,winy)
( (extractProgAndUnis $ _lightSourceShader pdata) ( extractProgAndUnis (_lightSourceShader pdata)
: (extractProgAndUnis $ _wallShadowShader pdata) : extractProgAndUnis (_wallShadowShader pdata)
: (extractProgAndUnis $ _wallLightShader pdata) : extractProgAndUnis (_wallLightShader pdata)
: (extractProgAndUnis $ _backgroundShader pdata) : extractProgAndUnis (_backgroundShader pdata)
: (map extractProgAndUnis $ _listShaders pdata) : map extractProgAndUnis (_listShaders pdata)
) )
renderFoldable :: Foldable f => RenderData -> f RenderType -> IO Word32 renderFoldable :: Foldable f => RenderData -> f RenderType -> IO Word32
src/Picture/Tree.hs
+24 -14
View File
@@ -1,3 +1,4 @@
{- Transform a picture into renderable objects. -}
module Picture.Tree module Picture.Tree
( picToLTree ( picToLTree
) )
@@ -10,7 +11,11 @@ import Data.List
-- todo: refactor out the layer check somehow -- todo: refactor out the layer check somehow
-- consider generalising to alternative rather than using LTree -- consider generalising to alternative rather than using LTree
picToLTree :: Maybe Int -> Picture -> LTree RenderType -- | Transform a picture into a tree of renderable objects
picToLTree
:: Maybe Int -- ^ Layer filter. Draw if 'Nothing' or when value is the same as at the leaf.
-> Picture
-> LTree RenderType
{-# INLINE picToLTree #-} {-# INLINE picToLTree #-}
picToLTree mx (Polygon i ps) picToLTree mx (Polygon i ps)
= filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
@@ -28,20 +33,22 @@ picToLTree mx (Circle i colC colE r)
,( ( r,-r,0), black) ,( ( r,-r,0), black)
] ]
picToLTree mx (ThickArc i startA endA rad wdth) picToLTree mx (ThickArc i startA endA rad wdth)
= filtB mx i $ LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth)) = filtB mx i $ LLeaf $ RenderArc ((0,0,0),black,(startA,endA,rad,wdth))
picToLTree mx (Line i ps) picToLTree mx (Line i ps)
= filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
picToLTree mx (LineCol i vs) picToLTree mx (LineCol i vs)
= filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
where (ps,cs) = unzip vs where (ps,cs) = unzip vs
picToLTree mx (Text i s) picToLTree mx (Text i s)
= filtB mx i $ LLeaf $ RenderText $ stringToList s = filtB mx i $ LLeaf $ RenderText $ stringToList s
picToLTree j Blank = LBranches [] picToLTree j Blank = LBranches []
picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic)) picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic))
= picToLTree j $ OverPic (f . g) (f' . g') (r + s) (f'' . g'') pic = picToLTree j $ OverPic (f . g) (f' . g') (r + s) (f'' . g'') pic
picToLTree j (OverPic f f' r f'' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f' r f'') ps) picToLTree j (OverPic f f' r f'' (Pictures ps))
picToLTree j (OverPic f f' r f'' pic) = fmap (overPos f . overSca f' . overRot r . overCol f'') $ picToLTree j pic = LBranches (map (picToLTree j . OverPic f f' r f'') ps)
picToLTree j (OverPic f f' r f'' pic)
= (overPos f . overSca f' . overRot r . overCol f'') <$> picToLTree j pic
picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
| otherwise = LBranches [] | otherwise = LBranches []
picToLTree Nothing (OnLayer _ pic) = picToLTree Nothing pic picToLTree Nothing (OnLayer _ pic) = picToLTree Nothing pic
@@ -53,7 +60,7 @@ filtB mx i t | Just i == mx || Nothing == mx = t
doubleLine :: [a] -> [a] doubleLine :: [a] -> [a]
{-# INLINE doubleLine #-} {-# INLINE doubleLine #-}
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs) doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (: []) (y:xs)
doubleLine _ = [] doubleLine _ = []
white = (1,1,1,1) white = (1,1,1,1)
@@ -70,8 +77,8 @@ scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y))
overPos :: (Point3 -> Point3) -> RenderType -> RenderType overPos :: (Point3 -> Point3) -> RenderType -> RenderType
{-# INLINE overPos #-} {-# INLINE overPos #-}
overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs overPos f (RenderPoly vs) = RenderPoly $ map (first f) vs
overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs overPos f (RenderLine vs) = RenderLine $ map (first f) vs
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
@@ -84,12 +91,12 @@ overRot _ ren = ren
overCol :: (Point4 -> Point4) -> RenderType -> RenderType overCol :: (Point4 -> Point4) -> RenderType -> RenderType
{-# INLINE overCol #-} {-# INLINE overCol #-}
overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs overCol f (RenderPoly vs) = RenderPoly $ map (second f) vs
overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs overCol f (RenderLine vs) = RenderLine $ map (second f) vs
overCol f (RenderEllipse vs) = RenderEllipse $ map (second $ f) vs overCol f (RenderEllipse vs) = RenderEllipse $ map (second f) vs
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
overCol f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs overCol f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs
overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c) overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
overSca :: (Point2 -> Point2) -> RenderType -> RenderType overSca :: (Point2 -> Point2) -> RenderType -> RenderType
{-# INLINE overSca #-} {-# INLINE overSca #-}
@@ -110,12 +117,15 @@ charToTuple :: Char -> (Point3,Point4,Point3)
charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText)) charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText))
where offset = fromIntegral (fromEnum c) - 32 where offset = fromIntegral (fromEnum c) - 32
{- Translate a 3D vector in the x and y directions. -}
translate3 :: Float -> Float -> Point3 -> Point3 translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-} {-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z) translate3 a b (x,y,z) = (x+a,y+b,z)
{- Scale a 3D vector in the x and y directions. -}
scale3 :: Float -> Float -> Point3 -> Point3 scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-} {-# INLINE scale3 #-}
scale3 a b (x,y,z) = (x*a,y*b,z) scale3 a b (x,y,z) = (x*a,y*b,z)
{- Rotate a 3D vector in the x-y plane. -}
rotate3 :: Float -> Point3 -> Point3 rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-} {-# INLINE rotate3 #-}
rotate3 a (x,y,z) = (x',y',z) rotate3 a (x,y,z) = (x',y',z)
src/Shader/Data.hs
+30 -3
View File
@@ -1,14 +1,38 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-
Datatypes used to setup and pass data to shaders.
-}
module Shader.Data module Shader.Data
where ( VAO (..)
, FullShader (..)
, ShaderTexture (..)
-- lens functions
, vao
, vaoBufferTargets
, shaderProgram
, shaderUniforms
, shaderVAO
, shaderPokeStrategy
, shaderDrawPrimitive
, shaderTexture
, shaderCustomUnis
-- , textureObject
) where
import Graphics.Rendering.OpenGL import Graphics.Rendering.OpenGL
import Foreign import Foreign
import Control.Lens import Control.Lens
{- Vertex array object: contains the reference to the object,
and its buffer targets.
-}
data VAO = VAO data VAO = VAO
{ _vao :: VertexArrayObject { _vao :: VertexArrayObject
, _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)] , _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)]
} }
{-
Datatype containing the necessary information for a single shader.
-}
data FullShader a = FullShader data FullShader a = FullShader
{ _shaderProgram :: Program { _shaderProgram :: Program
, _shaderUniforms :: [UniformLocation] , _shaderUniforms :: [UniformLocation]
@@ -18,7 +42,10 @@ data FullShader a = FullShader
, _shaderTexture :: Maybe ShaderTexture , _shaderTexture :: Maybe ShaderTexture
, _shaderCustomUnis :: Maybe [UniformLocation] , _shaderCustomUnis :: Maybe [UniformLocation]
} }
data ShaderTexture = ShaderTexture {-
Datatype containing the reference to a texture object.
-}
newtype ShaderTexture = ShaderTexture
{ _textureObject :: TextureObject } { _textureObject :: TextureObject }
makeLenses ''VAO makeLenses ''VAO