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