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

Linting

Browse Source
This commit is contained in:
jgk
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.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
src/Dodge/Layout/Tree/Annotate.hs
+2 -2
View File
@@ -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
src/Dodge/LevelGen/StaticWalls.hs
+2 -2
View File
@@ -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
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 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
src/Dodge/Room/Teleport.hs
-6
View File
@@ -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
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 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)
src/Dodge/WorldEvent/ThingsHit.hs
+37 -37
View File
@@ -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
src/Geometry.hs
+5 -5
View File
@@ -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.
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)
| 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__
src/Picture/Data.hs
+6 -12
View File
@@ -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]
src/Picture/Preload.hs
+1 -1
View File
@@ -123,7 +123,7 @@ setupFramebuffer = do
framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer fboRBO
fboStatus <- framebufferStatus Framebuffer
putStrLn $ show fboStatus
print fboStatus
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
, 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
src/Picture/Tree.hs
+24 -14
View File
@@ -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)
src/Shader/Data.hs
+30 -3
View File
@@ -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