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

Mid strictifying

Browse Source
This commit is contained in:
justin
2021-07-29 23:42:27 +02:00
parent 67aa5c05c7
commit bd8ef3f416
22 changed files with 359 additions and 325 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+14 -14
View File
@@ -708,17 +708,17 @@ makeLenses ''Action
makeLenses ''CrGroupParams makeLenses ''CrGroupParams
numColor :: Int -> Color numColor :: Int -> Color
numColor 0 = (1,0,0,1) numColor 0 = toV4 (1,0,0,1)
numColor 1 = (0,1,0,1) numColor 1 = toV4 (0,1,0,1)
numColor 2 = (0,0,1,1) numColor 2 = toV4 (0,0,1,1)
numColor 3 = (1,1,0,1) numColor 3 = toV4 (1,1,0,1)
numColor 4 = (0,1,1,1) numColor 4 = toV4 (0,1,1,1)
numColor 5 = (1,0,1,1) numColor 5 = toV4 (1,0,1,1)
numColor 6 = (1,0,0.5,1) numColor 6 = toV4 (1,0,0.5,1)
numColor 7 = (0.5,0,1,1) numColor 7 = toV4 (0.5,0,1,1)
numColor 8 = (0,0.5,1,1) numColor 8 = toV4 (0,0.5,1,1)
numColor 9 = (0,1,0.5,1) numColor 9 = toV4 (0,1,0.5,1)
numColor 10 = (0.5,1,0,1) numColor 10 = toV4 (0.5,1,0,1)
numColor 11 = (1,0.5,0,1) numColor 11 = toV4 (1,0.5,0,1)
numColor 12 = (1,1,1,1) numColor 12 = toV4 (1,1,1,1)
numColor _ = (1,1,1,1) numColor _ = toV4 (1,1,1,1)
src/Dodge/Default/Wall.hs
+7 -6
View File
@@ -3,10 +3,11 @@ module Dodge.Default.Wall
import Dodge.Data import Dodge.Data
import Picture import Picture
import qualified DoubleStack as DS import qualified DoubleStack as DS
import Geometry.Data
{- Indestructible wall. -} {- Indestructible wall. -}
defaultWall :: Wall defaultWall :: Wall
defaultWall = Wall defaultWall = Wall
{ _wlLine = ((0,0),(50,0)) { _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0 , _wlID = 0
, _wlColor = greyN 0.6 , _wlColor = greyN 0.6
, _wlSeen = False , _wlSeen = False
@@ -15,7 +16,7 @@ defaultWall = Wall
{- Indestructible see-through wall. -} {- Indestructible see-through wall. -}
defaultCrystalWall :: Wall defaultCrystalWall :: Wall
defaultCrystalWall = Wall defaultCrystalWall = Wall
{ _wlLine = ((0,0),(50,0)) { _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0 , _wlID = 0
, _wlColor = withAlpha 0.5 aquamarine , _wlColor = withAlpha 0.5 aquamarine
, _wlSeen = False , _wlSeen = False
@@ -25,26 +26,26 @@ defaultCrystalWall = Wall
Pathable. -} Pathable. -}
defaultAutoDoor :: Wall defaultAutoDoor :: Wall
defaultAutoDoor = Door defaultAutoDoor = Door
{ _wlLine = ((0,0),(50,0)) { _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0 , _wlID = 0
, _doorMech = id , _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow , _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False , _wlSeen = False
, _wlIsSeeThrough = False , _wlIsSeeThrough = False
, _doorPathable = True , _doorPathable = True
, _drPositions = DS.singleton ((0,0),(50,0)) , _drPositions = DS.singleton ((V2 0 0),(V2 50 0))
} }
{- {-
Non-pathable door. Non-pathable door.
-} -}
defaultDoor :: Wall defaultDoor :: Wall
defaultDoor = Door defaultDoor = Door
{ _wlLine = ((0,0),(50,0)) { _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0 , _wlID = 0
, _doorMech = id , _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow , _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False , _wlSeen = False
, _wlIsSeeThrough = False , _wlIsSeeThrough = False
, _doorPathable = False , _doorPathable = False
, _drPositions = DS.singleton ((0,0),(50,0)) , _drPositions = DS.singleton ((V2 0 0),(V2 50 0))
} }
src/Dodge/LevelGen/StaticWalls.hs
+73 -71
View File
@@ -6,11 +6,13 @@ module Dodge.LevelGen.StaticWalls
where where
import Dodge.Data import Dodge.Data
import Geometry import Geometry
import Geometry.Data
import FoldableHelp import FoldableHelp
--import Control.Lens --import Control.Lens
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Bifunctor
-- | Describe a wall as two points. -- | Describe a wall as two points.
-- Order is important: the wall face is to the left of the line going from -- Order is important: the wall face is to the left of the line going from
-- 'fst' to 'snd'. -- 'fst' to 'snd'.
@@ -136,7 +138,7 @@ cutPoly qs wls =
expandPolyBy :: Float -> [Point2] -> [Point2] expandPolyBy :: Float -> [Point2] -> [Point2]
expandPolyBy x ps = map f ps expandPolyBy x ps = map f ps
where where
cp = 1/fromIntegral (length ps) *.* foldr (+.+) (0,0) ps cp = 1/fromIntegral (length ps) *.* foldr (+.+) (V2 0 0) ps
f p = p +.+ x *.* (p -.- cp) f p = p +.+ x *.* (p -.- cp)
--f p = p +.+ x *.* normalizeV (p -.- cp) --f p = p +.+ x *.* normalizeV (p -.- cp)
-- | Given a polygon expressed as a list of points and a collection of walls, -- | Given a polygon expressed as a list of points and a collection of walls,
@@ -231,20 +233,20 @@ findWallsInPolygon ps = filter cond
cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
brokenWalls :: [(Point2,Point2)] brokenWalls :: [(Point2,Point2)]
brokenWalls = brokenWalls = map (first toV2 . second toV2)
[((330.12192,3032.2456),(190.52365,2995.8352)),((190.52365,2995.8352),(203.94716,2945.9377)),((214.33855,2907.311),(230.12193,2859.0405)),((230.12193,2859.0405),(366.7245,2895.643)),((366.7245,2895.643),(330.12192,3032.2456)),((366.7245,2895.643),(230.12193,2859.0405)),((230.12193,2859.0405),(266.7245,2722.438)),((266.7245,2722.438),(403.32703,2759.0405)),((403.32703,2759.0405),(503.32703,2932.2456)),((466.72446,3068.8481),(330.12192,3032.2456)),((330.12192,3032.2456),(366.7245,2895.643)),((503.32703,2932.2456),(466.72446,3068.8481)),((203.94716,2945.9377),(145.99155,2930.4084)),((156.38292,2891.7817),(214.33855,2907.311)),((107.47222,2920.979),(34.06077,2901.2295)),((34.06077,2901.2295),(52.571453,2832.4224)),((70.17772,2796.55),(174.45558,2824.6025)),((174.45558,2824.6025),(156.38292,2891.7817)),((100.76944,2955.4202),(107.47222,2920.979)),((145.99155,2930.4084),(140.79587,2949.722)),((52.571453,2832.4224),(35.882084,2827.9504)),((31.745949,2785.4312),(70.17772,2796.55)),((88.14497,3002.5354),(100.76944,2955.4202)),((140.79587,2949.722),(120.21855,3027.0303)),((35.882084,2827.9504),(-22.07344,2812.4214)),((-31.039248,2768.608),(31.745949,2785.4312)),((-261.32483,3408.5737),(-303.9881,3451.237)),((-303.9881,3451.237),(-332.27234,3422.9526)),((-332.27234,3422.9526),(-289.84595,3380.5264)),((-261.56174,3352.242),(88.14497,3002.5354)),((120.21855,3027.0303),(-233.27742,3380.5264)),((-289.84595,3380.5264),(-332.2724,3338.0999)),((-332.2724,3338.0999),(-303.9881,3309.8157)),((-303.9881,3309.8157),(-261.56174,3352.242)),((-22.07344,2812.4214),(-89.68823,2794.304)),((-79.335526,2755.667),(-31.039248,2768.608)),((-210.16953,3456.4133),(-261.32483,3408.5737)),((-233.27742,3380.5264),(-194.64026,3419.1633)),((-128.32533,2783.9514),(-200.79468,3054.4106)),((-200.79468,3054.4106),(-780.35016,2899.1191)),((-780.35016,2899.1191),(-625.05865,2319.5635)),((-625.05865,2319.5635),(-45.503174,2474.855)),((-45.503174,2474.855),(-117.97253,2745.3142)),((-89.68823,2794.304),(-128.32533,2783.9514)),((-117.97253,2745.3142),(-79.335526,2755.667)),((-178.49438,3590.2566),(-241.50847,3573.372)),((-241.50847,3573.372),(-210.16953,3456.4133)),((-194.64026,3419.1633),(-136.80266,3434.6611)),((-98.165634,3445.014),(-139.85736,3600.6094)),((-92.98925,3425.6953),(-98.165634,3445.014)),((-136.80266,3434.6611),(-127.74397,3400.8535)),((-187.553,3624.064),(-178.49438,3590.2566)),((-139.85736,3600.6094),(-148.91603,3634.4167)),((-127.74397,3400.8535),(-111.20285,3339.121)),((-78.55679,3371.8325),(-92.98925,3425.6953)),((-349.5008,4383.0093),(-388.13782,4372.6563)),((-388.13782,4372.6563),(-485.18823,3653.0168)),((-485.18823,3653.0168),(-477.42368,3624.039)),((-477.42368,3624.039),(-206.96445,3696.5085)),((-168.32744,3706.861),(102.131805,3779.3306)),((102.131805,3779.3306),(94.36725,3808.308)),((94.36725,3808.308),(-349.5008,4383.0093)),((-206.96445,3696.5085),(-187.553,3624.064)),((-148.91603,3634.4167),(-168.32744,3706.861)),((299.35522,3346.2668),(97.2383,3547.9797)),((97.2383,3547.9797),(-78.55679,3371.8325)),((-111.20285,3339.121),(116.74672,3110.6904)),((116.74672,3110.6904),(320.08704,3314.438)),((352.084,3395.578),(299.35522,3346.2668)),((320.08704,3314.438),(367.6133,3358.328)),((495.06226,3666.979),(293.8115,3613.054)),((293.8115,3613.054),(352.084,3395.578)),((367.6133,3358.328),(563.6875,3410.866)),((563.6875,3410.866),(495.06226,3666.979))] [((330.12192,3032.2456),(190.52365,2995.8352)),((190.52365,2995.8352),(203.94716,2945.9377)),((214.33855,2907.311),(230.12193,2859.0405)),((230.12193,2859.0405),(366.7245,2895.643)),((366.7245,2895.643),(330.12192,3032.2456)),((366.7245,2895.643),(230.12193,2859.0405)),((230.12193,2859.0405),(266.7245,2722.438)),((266.7245,2722.438),(403.32703,2759.0405)),((403.32703,2759.0405),(503.32703,2932.2456)),((466.72446,3068.8481),(330.12192,3032.2456)),((330.12192,3032.2456),(366.7245,2895.643)),((503.32703,2932.2456),(466.72446,3068.8481)),((203.94716,2945.9377),(145.99155,2930.4084)),((156.38292,2891.7817),(214.33855,2907.311)),((107.47222,2920.979),(34.06077,2901.2295)),((34.06077,2901.2295),(52.571453,2832.4224)),((70.17772,2796.55),(174.45558,2824.6025)),((174.45558,2824.6025),(156.38292,2891.7817)),((100.76944,2955.4202),(107.47222,2920.979)),((145.99155,2930.4084),(140.79587,2949.722)),((52.571453,2832.4224),(35.882084,2827.9504)),((31.745949,2785.4312),(70.17772,2796.55)),((88.14497,3002.5354),(100.76944,2955.4202)),((140.79587,2949.722),(120.21855,3027.0303)),((35.882084,2827.9504),(-22.07344,2812.4214)),((-31.039248,2768.608),(31.745949,2785.4312)),((-261.32483,3408.5737),(-303.9881,3451.237)),((-303.9881,3451.237),(-332.27234,3422.9526)),((-332.27234,3422.9526),(-289.84595,3380.5264)),((-261.56174,3352.242),(88.14497,3002.5354)),((120.21855,3027.0303),(-233.27742,3380.5264)),((-289.84595,3380.5264),(-332.2724,3338.0999)),((-332.2724,3338.0999),(-303.9881,3309.8157)),((-303.9881,3309.8157),(-261.56174,3352.242)),((-22.07344,2812.4214),(-89.68823,2794.304)),((-79.335526,2755.667),(-31.039248,2768.608)),((-210.16953,3456.4133),(-261.32483,3408.5737)),((-233.27742,3380.5264),(-194.64026,3419.1633)),((-128.32533,2783.9514),(-200.79468,3054.4106)),((-200.79468,3054.4106),(-780.35016,2899.1191)),((-780.35016,2899.1191),(-625.05865,2319.5635)),((-625.05865,2319.5635),(-45.503174,2474.855)),((-45.503174,2474.855),(-117.97253,2745.3142)),((-89.68823,2794.304),(-128.32533,2783.9514)),((-117.97253,2745.3142),(-79.335526,2755.667)),((-178.49438,3590.2566),(-241.50847,3573.372)),((-241.50847,3573.372),(-210.16953,3456.4133)),((-194.64026,3419.1633),(-136.80266,3434.6611)),((-98.165634,3445.014),(-139.85736,3600.6094)),((-92.98925,3425.6953),(-98.165634,3445.014)),((-136.80266,3434.6611),(-127.74397,3400.8535)),((-187.553,3624.064),(-178.49438,3590.2566)),((-139.85736,3600.6094),(-148.91603,3634.4167)),((-127.74397,3400.8535),(-111.20285,3339.121)),((-78.55679,3371.8325),(-92.98925,3425.6953)),((-349.5008,4383.0093),(-388.13782,4372.6563)),((-388.13782,4372.6563),(-485.18823,3653.0168)),((-485.18823,3653.0168),(-477.42368,3624.039)),((-477.42368,3624.039),(-206.96445,3696.5085)),((-168.32744,3706.861),(102.131805,3779.3306)),((102.131805,3779.3306),(94.36725,3808.308)),((94.36725,3808.308),(-349.5008,4383.0093)),((-206.96445,3696.5085),(-187.553,3624.064)),((-148.91603,3634.4167),(-168.32744,3706.861)),((299.35522,3346.2668),(97.2383,3547.9797)),((97.2383,3547.9797),(-78.55679,3371.8325)),((-111.20285,3339.121),(116.74672,3110.6904)),((116.74672,3110.6904),(320.08704,3314.438)),((352.084,3395.578),(299.35522,3346.2668)),((320.08704,3314.438),(367.6133,3358.328)),((495.06226,3666.979),(293.8115,3613.054)),((293.8115,3613.054),(352.084,3395.578)),((367.6133,3358.328),(563.6875,3410.866)),((563.6875,3410.866),(495.06226,3666.979))]
intersectingBrokenWalls :: [(Point2,Point2)] --intersectingBrokenWalls :: [(Point2,Point2)]
intersectingBrokenWalls = filter (uncurry test) brokenWalls --intersectingBrokenWalls = filter (uncurry test) brokenWalls
where -- where
polyPairs = zip brokenPoly (tail brokenPoly ++ [head brokenPoly]) -- polyPairs = zip brokenPoly (tail brokenPoly ++ [head brokenPoly])
test a b = any (isJust . uncurry (myIntersectSegSeg a b)) polyPairs -- test a b = any (isJust . uncurry (myIntersectSegSeg a b)) polyPairs
brokenPoly :: [Point2] --brokenPoly :: [Point2]
brokenPoly = [(434.66675,2833.3225),(503.9488,2793.3225),(523.9488,2827.9636),(454.66675,2867.9636)] --brokenPoly = [(434.66675,2833.3225),(503.9488,2793.3225),(523.9488,2827.9636),(454.66675,2867.9636)]
iBWall :: (Point2,Point2) --iBWall :: (Point2,Point2)
iBWall = ((403.32703,2759.0405),(503.32703,2932.2456)) --iBWall = ((403.32703,2759.0405),(503.32703,2932.2456))
expandToSquare :: (Point2,Point2) -> [(Point2,Point2)] expandToSquare :: (Point2,Point2) -> [(Point2,Point2)]
expandToSquare (a,b) = [(a,b),(b,c),(c,d),(d,a)] expandToSquare (a,b) = [(a,b),(b,c),(c,d),(d,a)]
@@ -253,65 +255,65 @@ expandToSquare (a,b) = [(a,b),(b,c),(c,d),(d,a)]
c = b +.+ vNormal v c = b +.+ vNormal v
d = a +.+ vNormal v d = a +.+ vNormal v
minWalls :: [(Point2,Point2)] --minWalls :: [(Point2,Point2)]
minWalls = expandToSquare iBWall --minWalls = expandToSquare iBWall
brokenZs :: [Point2] --brokenZs :: [Point2]
brokenCwals :: [WallP] --brokenCwals :: [WallP]
(brokenZs,brokenCwals) = cutWallsWithPoints brokenPoly brokenWalls --(brokenZs,brokenCwals) = cutWallsWithPoints brokenPoly brokenWalls
minZs :: [Point2] --minZs :: [Point2]
minCwals :: [WallP] --minCwals :: [WallP]
(minZs,minCwals) = cutWallsWithPoints brokenPoly minWalls --(minZs,minCwals) = cutWallsWithPoints brokenPoly minWalls
--
brokenRs :: [Point2] --brokenRs :: [Point2]
brokenRs = orderPolygon $ nub $ minZs ++ brokenPoly --brokenRs = orderPolygon $ nub $ minZs ++ brokenPoly
--
brokenAfterRemovedWalls :: [WallP] --brokenAfterRemovedWalls :: [WallP]
brokenAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) brokenCwals --brokenAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) brokenCwals
minAfterRemovedWalls :: [WallP] --minAfterRemovedWalls :: [WallP]
minAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) minCwals --minAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) minCwals
--
brokenRemovedWalls :: [WallP] --brokenRemovedWalls :: [WallP]
brokenRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) brokenCwals --brokenRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) brokenCwals
minRemovedWalls :: [WallP] --minRemovedWalls :: [WallP]
minRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) minCwals --minRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) minCwals
--
addedPolyWalls :: [Point2] -> [WallP] -> [WallP] --addedPolyWalls :: [Point2] -> [WallP] -> [WallP]
addedPolyWalls ps wls = addPolyWalls ps wls \\ wls --addedPolyWalls ps wls = addPolyWalls ps wls \\ wls
--
brokenAddedWalls :: [WallP] --brokenAddedWalls :: [WallP]
brokenAddedWalls = addedPolyWalls brokenRs brokenAfterRemovedWalls --brokenAddedWalls = addedPolyWalls brokenRs brokenAfterRemovedWalls
minAddedWalls :: [WallP] --minAddedWalls :: [WallP]
minAddedWalls = addedPolyWalls brokenRs minAfterRemovedWalls --minAddedWalls = addedPolyWalls brokenRs minAfterRemovedWalls
--
brokenAdd :: WallP --brokenAdd :: WallP
brokenAdd = head brokenAddedWalls --brokenAdd = head brokenAddedWalls
--
findShadowWall :: WallP -> [WallP] -> Maybe WallP --findShadowWall :: WallP -> [WallP] -> Maybe WallP
findShadowWall (p1,p2) wls = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls --findShadowWall (p1,p2) wls = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
where -- where
p3 = 0.5 *.* (p1 +.+ p2) -- p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* rotateV (negate $ pi/4) (vNormal (p2 -.- p1)) -- p4 = p3 +.+ 10000 *.* rotateV (negate $ pi/4) (vNormal (p2 -.- p1))
f = uncurry $ myIntersectSegSeg p3 p4 -- f = uncurry $ myIntersectSegSeg p3 p4
--
findShadowWalls :: WallP -> [WallP] -> [WallP] --findShadowWalls :: WallP -> [WallP] -> [WallP]
findShadowWalls (p1,p2) wls = hitWls --findShadowWalls (p1,p2) wls = hitWls
where -- where
hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls -- hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
p3 = 0.5 *.* (p1 +.+ p2) -- p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) -- p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
f = uncurry $ myIntersectSegSeg p3 p4 -- f = uncurry $ myIntersectSegSeg p3 p4
--
addWallDebug :: WallP -> [WallP] -> [WallP] --addWallDebug :: WallP -> [WallP] -> [WallP]
addWallDebug (p1,p2) wls = --addWallDebug (p1,p2) wls =
case maybeWs of -- case maybeWs of
Just ws -> if uncurry isLHS ws p3 -- Just ws -> if uncurry isLHS ws p3
then wls -- then wls
else (p1,p2) : wls -- else (p1,p2) : wls
Nothing -> (p1,p2) : wls -- Nothing -> (p1,p2) : wls
where -- where
maybeWs = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls -- maybeWs = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
p3 = 0.5 *.* (p1 +.+ p2) -- p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) -- p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
f = uncurry $ myIntersectSegSeg p3 p4 -- f = uncurry $ myIntersectSegSeg p3 p4
src/Dodge/LevelGen/Switch.hs
+5 -4
View File
@@ -5,6 +5,7 @@ import Dodge.SoundLogic
import Dodge.Picture.Layer import Dodge.Picture.Layer
import Picture import Picture
import Geometry import Geometry
import Geometry.Data
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import Control.Lens import Control.Lens
@@ -14,7 +15,7 @@ makeButton
-> Button -> Button
makeButton c eff = Button makeButton c eff = Button
{ _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10) { _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
, _btPos = (0,0) , _btPos = (V2 0 0)
, _btRot = 0 , _btRot = 0
, _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b)) , _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
-- . set (buttons . ix (_btID b) . btPict) -- . set (buttons . ix (_btID b) . btPict)
@@ -38,7 +39,7 @@ makeSwitch
-> Button -> Button
makeSwitch c effOn effOff = Button makeSwitch c effOn effOff = Button
{ _btPict = offPict { _btPict = offPict
, _btPos = (0,0) , _btPos = (V2 0 0)
, _btRot = 0 , _btRot = 0
, _btEvent = flipSwitch , _btEvent = flipSwitch
, _btID = 0 , _btID = 0
@@ -53,11 +54,11 @@ makeSwitch c effOn effOff = Button
_ -> error "Trying to switch a button with no label" _ -> error "Trying to switch a button with no label"
offPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5 offPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) 10 polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)] ,polygon $ map toV2 [(-2,-5),(-10,4),(-6,4),(2,-5)]
] ]
onPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5 onPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) 10 polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon [(-2,-5), (6,4),( 10,4),(2,-5)] ,polygon $ map toV2 [(-2,-5), (6,4),( 10,4),(2,-5)]
] ]
turnOn :: Button -> Button turnOn :: Button -> Button
turnOn bt = bt turnOn bt = bt
src/Dodge/LightSources.hs
+11 -11
View File
@@ -10,9 +10,9 @@ import Geometry.Data
--import qualified Data.IntMap.Strict as IM --import qualified Data.IntMap.Strict as IM
lightAt :: Point3 -> Int -> LightSource lightAt :: Point3 -> Int -> LightSource
lightAt (x,y,z) i = lightAt (V3 x y z) i =
LS {_lsID = i LS {_lsID = i
,_lsPos = (x,y,z) ,_lsPos = (V3 x y z)
,_lsDir = 0 ,_lsDir = 0
,_lsRad = 700 ,_lsRad = 700
,_lsIntensity = 0.75 ,_lsIntensity = 0.75
@@ -20,18 +20,18 @@ lightAt (x,y,z) i =
basicLS :: PSType basicLS :: PSType
basicLS = PutLS ls dec basicLS = PutLS ls dec
where where
ls = lightAt (0,0,0) 0 ls = lightAt (V3 0 0 0) 0
dec = onLayer PtLayer $ color white $ circleSolid 8 dec = onLayer PtLayer $ color white $ circleSolid 8
tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
tLightFade 0 rmax intensityF (x,y) = TLS tLightFade 0 rmax intensityF (V2 x y) = TLS
{ _tlsPos = (x,y,0) { _tlsPos = (V3 x y 0)
, _tlsRad = rmax , _tlsRad = rmax
, _tlsIntensity = intensityF 0 , _tlsIntensity = intensityF 0
, _tlsUpdate = \w _ -> (w, Nothing) , _tlsUpdate = \w _ -> (w, Nothing)
} }
tLightFade i rmax intensityF p@(x,y) = TLS tLightFade i rmax intensityF p@(V2 x y) = TLS
{ _tlsPos = (x,y,0) { _tlsPos = (V3 x y 0)
, _tlsRad = rmax , _tlsRad = rmax
, _tlsIntensity = intensityF i , _tlsIntensity = intensityF i
, _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p) , _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p)
@@ -43,14 +43,14 @@ tLightRad
-> Float -- ^ minimal radius (unused) -> Float -- ^ minimal radius (unused)
-> Point2 -> Point2
-> TempLightSource -> TempLightSource
tLightRad 0 rmax _ (x,y) = TLS tLightRad 0 rmax _ (V2 x y) = TLS
{ _tlsPos = (x,y,0) { _tlsPos = (V3 x y 0)
, _tlsRad = rmax , _tlsRad = rmax
, _tlsIntensity = 0.5 , _tlsIntensity = 0.5
, _tlsUpdate = \w _ -> (w, Nothing) , _tlsUpdate = \w _ -> (w, Nothing)
} }
tLightRad i rmax rmin p@(x,y) = TLS tLightRad i rmax rmin p@(V2 x y) = TLS
{ _tlsPos = (x,y,0) { _tlsPos = (V3 x y 0)
, _tlsRad = rmax , _tlsRad = rmax
, _tlsIntensity = 0.5 , _tlsIntensity = 0.5
, _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p) , _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p)
src/Dodge/Picture.hs
+5 -5
View File
@@ -36,21 +36,21 @@ wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
wedgeOfThickness t x y wedgeOfThickness t x y
| x == y = blank | x == y = blank
| otherwise = pictures | otherwise = pictures
[uncurry translate x $ circleSolid (0.5*t) [uncurryV translate x $ circleSolid (0.5*t)
,polygon [x +.+ n x y, x -.- n x y, y] ,polygon [x +.+ n x y, x -.- n x y, y]
] ]
where where
n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b)) n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
verticalPipe :: Float -> Color -> Point2 -> Float -> Float -> Picture verticalPipe :: Float -> Color -> Point2 -> Float -> Float -> Picture
verticalPipe w col (xx,xy) za zb = pictures $ map (poly3Col . f) ps verticalPipe w col (V2 xx xy) za zb = pictures $ map (poly3Col . f) ps
where where
x = (xx,xy,0) x = (V3 xx xy 0)
xs = map (\(a,b) -> x +.+.+ (a,b,za)) [(w,0),(0,w),(-w,0),(0,-w)] xs = map (\(V2 a b) -> x +.+.+ (V3 a b za)) (map toV2 [(w,0),(0,w),(-w,0),(0,-w)])
ps = zip xs (tail xs ++ [head xs]) ps = zip xs (tail xs ++ [head xs])
f (a,b) = map f' [a,b,g b,g a] f (a,b) = map f' [a,b,g b,g a]
g :: Point3 -> Point3 g :: Point3 -> Point3
g (a,b,_) = (a,b,zb) g (V3 a b _) = (V3 a b zb)
f' a = (a,col) f' a = (a,col)
expandLine :: Point3 -> Point3 -> Point3 -> [Point3] expandLine :: Point3 -> Point3 -> Point3 -> [Point3]
src/Dodge/RandomHelp.hs
+5 -5
View File
@@ -73,15 +73,15 @@ randOnUnitSphere :: RandomGen g => State g Point3
randOnUnitSphere = do randOnUnitSphere = do
z <- state $ randomR (negate 1,1) z <- state $ randomR (negate 1,1)
longitude <- state $ randomR (0, 2*pi) longitude <- state $ randomR (0, 2*pi)
let (x,y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude let (V2 x y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude
return (x,y,z) return (V3 x y z)
randOnHemisphere :: RandomGen g => State g Point3 randOnHemisphere :: RandomGen g => State g Point3
randOnHemisphere = do randOnHemisphere = do
z <- state $ randomR (0,1) z <- state $ randomR (0,1)
longitude <- state $ randomR (0, 2*pi) longitude <- state $ randomR (0, 2*pi)
let (x,y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude let (V2 x y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude
return (x,y,z) return (V3 x y z)
randInHemisphere :: RandomGen g => State g Point3 randInHemisphere :: RandomGen g => State g Point3
randInHemisphere = do randInHemisphere = do
@@ -92,7 +92,7 @@ randInHemisphere = do
randInRect :: RandomGen g => Float -> Float -> State g Point2 randInRect :: RandomGen g => Float -> Float -> State g Point2
randInRect w h = do x <- state $ randomR (0,w) randInRect w h = do x <- state $ randomR (0,w)
y <- state $ randomR (0,h) y <- state $ randomR (0,h)
return (x,y) return (V2 x y)
maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a) maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a)
maybeTakeOne [] = return Nothing maybeTakeOne [] = return Nothing
src/Dodge/Render/MenuScreen.hs
+3 -2
View File
@@ -11,6 +11,7 @@ import Dodge.Config.Data
--import Dodge.Base (halfWidth,halfHeight) --import Dodge.Base (halfWidth,halfHeight)
import Picture import Picture
import Geometry import Geometry
import Geometry.Data
menuScreen menuScreen
:: Configuration :: Configuration
@@ -108,8 +109,8 @@ controlsList = pictures $ concat $ zipWith butAndEff
screenBox screenBox
:: Float -- ^ Half screen width :: Float -- ^ Half screen width
-> Float -- ^ Half screen height -> Float -- ^ Half screen height
-> [(Float,Float)] -> [Point2]
screenBox halfW halfH = screenBox halfW halfH = map toV2
[ (halfW, halfH) [ (halfW, halfH)
, (-halfW, halfH) , (-halfW, halfH)
, (-halfW,-halfH) , (-halfW,-halfH)
src/Geometry.hs
+16 -16
View File
@@ -53,13 +53,13 @@ closestPointOnLineParam !a !b !p
= (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a) = (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a)
-- | Draw a rectangle based on maximal N E S W values. -- | Draw a rectangle based on maximal N E S W values.
rectNESW :: Float -> Float -> Float -> Float -> [Point2] rectNESW :: Float -> Float -> Float -> Float -> [Point2]
rectNESW !a !b !c !d = [(b,a),(b,c),(d,c),(d,a) ] rectNESW !a !b !c !d = [(V2 b a),(V2 b c),(V2 d c),(V2 d a) ]
-- | Draw a rectangle based on maximal N S E W values. -- | Draw a rectangle based on maximal N S E W values.
rectNSEW :: Float -> Float -> Float -> Float -> [Point2] rectNSEW :: Float -> Float -> Float -> Float -> [Point2]
rectNSEW !n !s !e !w = rectNESW n e s w rectNSEW !n !s !e !w = rectNESW n e s w
-- | Draw a rectangle based on maximal N S W E values. -- | Draw a rectangle based on maximal N S W E values.
rectNSWE :: Float -> Float -> Float -> Float -> [Point2] rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
rectNSWE !n !s !w !e = [ (w,n), (w,s), (e,s), (e,n)] rectNSWE !n !s !w !e = [ (V2 w n), (V2 w s), (V2 e s), (V2 e n)]
-- | Draw a rectangle around the origin with given height and width -- | Draw a rectangle around the origin with given height and width
rectWdthHght :: Float -> Float -> [Point2] rectWdthHght :: Float -> Float -> [Point2]
rectWdthHght w h = rectNSWE h (-h) (-w) w rectWdthHght w h = rectNSWE h (-h) (-w) w
@@ -83,12 +83,12 @@ errorPointInPolygon !i !p xs
| otherwise = error $ "errorPointInPolygon "++ show i | otherwise = error $ "errorPointInPolygon "++ show i
-- | Debug version of 'normalizeV'. -- | Debug version of 'normalizeV'.
errorNormalizeV :: Int -> Point2 -> Point2 errorNormalizeV :: Int -> Point2 -> Point2
errorNormalizeV !i (0,0) = error $ "problem with function: errorNormalizeV "++show i errorNormalizeV !i (V2 0 0) = error $ "problem with function: errorNormalizeV "++show i
errorNormalizeV _ !p = normalizeV p errorNormalizeV _ !p = normalizeV p
-- | Debug version of 'angleVV'. -- | Debug version of 'angleVV'.
errorAngleVV :: Int -> Point2 -> Point2 -> Float errorAngleVV :: Int -> Point2 -> Point2 -> Float
errorAngleVV !i (0,0) _ = error $ "problem with function: errorAngleVV "++show i errorAngleVV !i (V2 0 0) _ = error $ "problem with function: errorAngleVV "++show i
errorAngleVV !i _ (0,0) = error $ "problem with function: errorAngleVV "++show i errorAngleVV !i _ (V2 0 0) = error $ "problem with function: errorAngleVV "++show i
errorAngleVV _ !p !p' = angleVV p p' errorAngleVV _ !p !p' = angleVV p p'
-- | Debug version of 'isLHS'. -- | Debug version of 'isLHS'.
errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool
@@ -114,9 +114,9 @@ isLHS
-> Bool -> Bool
{-# INLINE isLHS #-} {-# INLINE isLHS #-}
isLHS isLHS
(x,y) (V2 x y)
(x',y') (V2 x' y')
(x'',y'') (V2 x'' y'')
| (x,y) == (x',y') = False | (x,y) == (x',y') = False
| otherwise = a1 * b2 - a2 * b1 > 0 | otherwise = a1 * b2 - a2 * b1 > 0
where where
@@ -133,9 +133,9 @@ isRHS
-> Bool -> Bool
{-# INLINE isRHS #-} {-# INLINE isRHS #-}
isRHS isRHS
(x,y) (V2 x y)
(x',y') (V2 x' y')
(x'',y'') (V2 x'' y'')
| (x,y) == (x',y') = False | (x,y) == (x',y') = False
| otherwise = a1 * b2 - a2 * b1 < 0 | otherwise = a1 * b2 - a2 * b1 < 0
where where
@@ -166,7 +166,7 @@ addPointPolygon p ps
| otherwise = orderPolygon $ p : ps | otherwise = orderPolygon $ p : ps
-- | Creates the convex hull of a set of points. -- | Creates the convex hull of a set of points.
convexHull :: [Point2] -> [Point2] convexHull :: [Point2] -> [Point2]
convexHull (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(a,b) -> (b,a)) (x:y:z:xs) convexHull (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs)
convexHull _ = error "Tried to create the convex hull of two or fewer points" convexHull _ = error "Tried to create the convex hull of two or fewer points"
grahamScan :: [Point2] -> [Point2] grahamScan :: [Point2] -> [Point2]
@@ -259,10 +259,10 @@ polyToTris _ = []
-- | Return n equidistant points on a circle with a radius of 600. -- | Return n equidistant points on a circle with a radius of 600.
nRays :: Int -> [Point2] nRays :: Int -> [Point2]
nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (600,0) nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (V2 600 0)
-- | Return n equidistant points on a circle with a radius of x. -- | Return n equidistant points on a circle with a radius of x.
nRaysRad :: Int -> Float -> [Point2] nRaysRad :: Int -> Float -> [Point2]
nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (x,0) nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (V2 x 0)
-- | Test whether an angle is to the left of another angle, according to the -- | Test whether an angle is to the left of another angle, according to the
-- smallest change in rotation between them. -- smallest change in rotation between them.
-- This appears to sometimes fail if the angles are not normalized. -- This appears to sometimes fail if the angles are not normalized.
@@ -366,7 +366,7 @@ reflectInParam :: Float -> Point2 -> Point2 -> Point2
reflectInParam x line vec = reflectInParam x line vec =
let angle = 2 * angleBetween line vec let angle = 2 * angleBetween line vec
rAng = rotateV angle vec rAng = rotateV angle vec
p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng p = x *.* errorClosestPointOnLine 3 (V2 0 0) (vNormal line) rAng
in rAng -.- p in rAng -.- p
--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)
@@ -497,4 +497,4 @@ pointIsInCone
pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p
-- | TODO: implement using Control.Foldl -- | TODO: implement using Control.Foldl
centroid :: Foldable t => t Point2 -> Point2 centroid :: Foldable t => t Point2 -> Point2
centroid xs = 1 / fromIntegral (length xs) *.* foldl' (+.+) (0,0) xs centroid xs = 1 / fromIntegral (length xs) *.* foldl' (+.+) (V2 0 0) xs
src/Geometry/Data.hs
+20 -3
View File
@@ -2,8 +2,25 @@ module Geometry.Data
( Point2 ( Point2
, Point3 , Point3
, Point4 , Point4
, V2 (..)
, V3 (..)
, V4 (..)
, toV2
, toV3
, toV4
, uncurryV
) )
where where
type Point2 = (Float,Float) import Linear.V2
type Point3 = (Float,Float,Float) import Linear.V3
type Point4 = (Float,Float,Float,Float) import Linear.V4
type Point2 = V2 Float
type Point3 = V3 Float
type Point4 = V4 Float
toV2 (a,b) = V2 a b
toV3 (a,b,c) = V3 a b c
toV4 (a,b,c,d) = V4 a b c d
uncurryV :: (a -> a -> b) -> V2 a -> b
uncurryV f (V2 x y) = f x y
src/Geometry/Intersect.hs
+26 -29
View File
@@ -11,22 +11,22 @@ import Data.Maybe (isNothing)
-- | If two lines intersect, return 'Just' that point. -- | If two lines intersect, return 'Just' that point.
intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectLineLine' #-} {-# INLINE intersectLineLine' #-}
intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) intersectLineLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing | den == 0 = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) | otherwise = Just $ V2 (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
{-# INLINE intersectSegSeg' #-} {-# INLINE intersectSegSeg' #-}
intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4) intersectSegSeg' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing | den == 0 = Nothing
| den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den) | den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den)
= Nothing = Nothing
| 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 $ V2 (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)
@@ -35,13 +35,13 @@ intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
-- extending infinitely in one direction. -- extending infinitely in one direction.
intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLineFrom' #-} {-# INLINE intersectSegLineFrom' #-}
intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4) intersectSegLineFrom' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing | den == 0 = Nothing
| den > 0 && ( t' < 0 || u' < 0 || t' > den ) | den > 0 && ( t' < 0 || u' < 0 || t' > den )
= Nothing = Nothing
| 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 $ V2 (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)
@@ -49,13 +49,13 @@ intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
-- | 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
{-# INLINE intersectSegLineext #-} {-# INLINE intersectSegLineext #-}
intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4) intersectSegLineext (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing | den == 0 = Nothing
| den > 0 && ( t' < 0 || u' < den || t' > den ) | den > 0 && ( t' < 0 || u' < den || t' > den )
= Nothing = Nothing
| 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 $ V2 (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)
@@ -63,13 +63,13 @@ intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4)
-- | 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
{-# INLINE intersectSegLine' #-} {-# INLINE intersectSegLine' #-}
intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) intersectSegLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing | den == 0 = Nothing
| den > 0 && (t' < 0 || t' > den) | den > 0 && (t' < 0 || t' > den)
= Nothing = Nothing
| 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 $ V2 (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)
@@ -87,10 +87,10 @@ myIntersectSegSeg
-> Point2 -> Point2
-> Point2 -> Point2
-> Maybe Point2 -> Maybe Point2
myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of myIntersectSegSeg a@(V2 ax ay) b@(V2 bx by) c@(V2 cx cy) d@(V2 dx dy) = case ratIntersectLineLine a b c d of
Nothing -> Nothing Nothing -> Nothing
Just (x,y) -> if inbetween x && inbetween' y Just (V2 x y) -> if inbetween x && inbetween' y
then Just (x,y) then Just (V2 x y)
else Nothing else Nothing
where where
inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax))
@@ -98,28 +98,28 @@ myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLin
inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay))
&& ((cy <= y && y <= dy) || (dy <= y && y <= cy)) && ((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) => V2 a -> V2 a -> V2 a -> V2 a -> Maybe (V2 a)
myIntersectLineLine a@(ax,_) b c@(cx,_) d myIntersectLineLine a@(V2 ax _) b c@(V2 cx _) d
| isNothing (linGrad a b) = (ax ,) <$> axisInt (c *-* (ax,0)) (d *-* (ax,0)) | isNothing (linGrad a b) = (V2 ax) <$> axisInt (c *-* (V2 ax 0)) (d *-* (V2 ax 0))
| isNothing (linGrad c d) = (cx ,) <$> axisInt (a *-* (cx,0)) (b *-* (cx,0)) | isNothing (linGrad c d) = (V2 cx) <$> axisInt (a *-* (V2 cx 0)) (b *-* (V2 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 ((linGrad a b ^*^ newx) ^+^ axisInt a b) _ -> liftA2 (V2) newx ((linGrad a b ^*^ newx) ^+^ axisInt a b)
where where
(^-^) = liftA2 (-) (^-^) = liftA2 (-)
(^+^) = liftA2 (+) (^+^) = liftA2 (+)
(^/^) = liftA2 (/) (^/^) = liftA2 (/)
(^*^) = liftA2 (*) (^*^) = liftA2 (*)
newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d) newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d)
(*-*) (ax',ay) (bx,by) = (ax'-bx,ay-by) (*-*) (V2 ax' ay) (V2 bx by) = V2 (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 = toNumPoint2 ratIntersectLineLine a b c d = toNumPoint2
<$> myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d) <$> myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d)
where where
toRatPoint2 (x,y) = (toRational x, toRational y) toRatPoint2 (V2 x y) = V2 (toRational x) (toRational y)
toNumPoint2 (x,y) = (fromRational x, fromRational y) toNumPoint2 (V2 x y) = V2 (fromRational x) (fromRational y)
{- | Round the floats within a 'Point2' to the nearest integer. {- | Round the floats within a 'Point2' to the nearest integer.
__Examples__ __Examples__
Rounding jumps after intervals of .5: Rounding jumps after intervals of .5:
@@ -134,18 +134,15 @@ but is symmetric around 0:
-} -}
roundPoint2 :: Point2 -> Point2 roundPoint2 :: Point2 -> Point2
roundPoint2 (x,y) = (fromIntegral (round x :: Int),fromIntegral (round y :: Int)) roundPoint2 (V2 x y) = V2 (fromIntegral (round x :: Int)) (fromIntegral (round y :: Int))
-- | Given two points, finds the linear gradient if it is non-infinite. -- | Given two points, finds the linear gradient if it is non-infinite.
linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a linGrad :: (Eq a,Fractional a) => V2 a -> V2 a -> Maybe a
linGrad (x,y) (a,b) linGrad (V2 x y) (V2 a b)
| x-a == 0 = Nothing | x-a == 0 = Nothing
| otherwise = Just $ (y-b)/(x-a) | otherwise = Just $ (y-b)/(x-a)
-- | Given two points, finds the intersection with the y axis if it exists. -- | Given two points, finds the intersection with the y axis if it exists.
axisInt :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a axisInt :: (Eq a,Fractional a) => V2 a -> V2 a -> Maybe a
axisInt p (a,b) = pure b ^-^ (pure a ^*^ linGrad p (a,b)) axisInt p (V2 a b) = fmap (\lg -> b - (a*lg)) $ linGrad p (V2 a b)
where
(^-^) = liftA2 (-)
(^*^) = liftA2 (*)
-- | Placeholder, undefined. -- | Placeholder, undefined.
intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2 intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2
intersectSegsSeg = undefined intersectSegsSeg = undefined
src/Geometry/Vector.hs
+28 -27
View File
@@ -5,7 +5,7 @@ import Geometry.Data
{- | Moves from two to three dimensions, adding zero in z direction. -} {- | Moves from two to three dimensions, adding zero in z direction. -}
zeroZ :: Point2 -> Point3 zeroZ :: Point2 -> Point3
{-# INLINE zeroZ #-} {-# INLINE zeroZ #-}
zeroZ (x,y) = (x,y,0) zeroZ (V2 x y) = V3 x y 0
infixl 6 +.+, -.- infixl 6 +.+, -.-
infixl 7 *.* infixl 7 *.*
@@ -13,27 +13,29 @@ infixl 7 *.*
{- | 2D coordinate-wise addition. -} {- | 2D coordinate-wise addition. -}
(+.+) :: Point2 -> Point2 -> Point2 (+.+) :: Point2 -> Point2 -> Point2
{-# INLINE (+.+) #-} {-# INLINE (+.+) #-}
(x1, y1) +.+ (x2, y2) = (+.+) = (+)
let --(x1, y1) +.+ (x2, y2) =
!x = x1 + x2 -- let
!y = y1 + y2 -- !x = x1 + x2
in (x, y) -- !y = y1 + y2
-- in (x, y)
{- | 2D coordinate-wise subtraction. -} {- | 2D coordinate-wise subtraction. -}
(-.-) :: Point2 -> Point2 -> Point2 (-.-) :: Point2 -> Point2 -> Point2
{-# INLINE (-.-) #-} {-# INLINE (-.-) #-}
(x1, y1) -.- (x2, y2) = (-.-) = (-)
let --(x1, y1) -.- (x2, y2) =
!x = x1 - x2 -- let
!y = y1 - y2 -- !x = x1 - x2
in (x, y) -- !y = y1 - y2
-- in (x, y)
{- | 2D scalar multiplication. -} {- | 2D scalar multiplication. -}
(*.*) :: Float -> Point2 -> Point2 (*.*) :: Float -> Point2 -> Point2
{-# INLINE (*.*) #-} {-# INLINE (*.*) #-}
a *.* (x2, y2) = a *.* V2 x2 y2 =
let let
!x = a * x2 !x = a * x2
!y = a * y2 !y = a * y2
in (x, y) in V2 x y
{- | Normalize a vector to length 1. -} {- | Normalize a vector to length 1. -}
normalizeV :: Point2 -> Point2 normalizeV :: Point2 -> Point2
@@ -53,31 +55,30 @@ angleVV a b
safeAngleVV :: Point2 -> Point2 -> Float safeAngleVV :: Point2 -> Point2 -> Float
{-# INLINE safeAngleVV #-} {-# INLINE safeAngleVV #-}
safeAngleVV a b safeAngleVV a b
| a == (0,0) || b == (0,0) = 0 | a == V2 0 0 || b == V2 0 0 = 0
| otherwise = angleVV a b | otherwise = angleVV a b
{- | Dot product. -} {- | Dot product. -}
dotV :: Point2 -> Point2 -> Float dotV :: Point2 -> Point2 -> Float
{-# INLINE dotV #-} {-# INLINE dotV #-}
dotV (x,y) (z,w) = x*z + y*w dotV (V2 x y) (V2 z w) = x*z + y*w
{- | Given vector, returns the angle, anticlockwise from +ve x-axis, in radians. -} {- | Given vector, returns the angle, anticlockwise from +ve x-axis, in radians. -}
argV :: Point2 -> Float argV :: Point2 -> Float
{-# INLINE argV #-} {-# INLINE argV #-}
argV (x,y) = normalizeAngle $ atan2 y x argV (V2 x y) = normalizeAngle $ atan2 y x
{- | Determinant of the matrix formed by two vectors. -} {- | Determinant of the matrix formed by two vectors. -}
detV :: Point2 -> Point2 -> Float detV :: Point2 -> Point2 -> Float
{-# INLINE detV #-} {-# INLINE detV #-}
detV (x1, y1) (x2, y2) = x1 * y2 - y1 * x2 detV (V2 x1 y1) (V2 x2 y2) = x1 * y2 - y1 * x2
{- | Given an angle in radians, anticlockwise from +ve x-axis, {- | Given an angle in radians, anticlockwise from +ve x-axis,
- returns the corresponding unit vector. -} - returns the corresponding unit vector. -}
unitVectorAtAngle :: Float -> Point2 unitVectorAtAngle :: Float -> Point2
{-# INLINE unitVectorAtAngle #-} {-# INLINE unitVectorAtAngle #-}
unitVectorAtAngle r = (cos r, sin r) unitVectorAtAngle r = V2 (cos r) (sin r)
-- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise. -- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise.
rotateV :: Float -> Point2 -> Point2 rotateV :: Float -> Point2 -> Point2
rotateV r (x, y) = rotateV r (V2 x y) = V2
( x * cos r - y * sin r (x * cos r - y * sin r)
, x * sin r + y * cos r (x * sin r + y * cos r)
)
{-# INLINE rotateV #-} {-# INLINE rotateV #-}
-- | Convert degrees to radians -- | Convert degrees to radians
degToRad :: Float -> Float degToRad :: Float -> Float
@@ -97,23 +98,23 @@ normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi))
{- | Rotate vector by pi/2 clockwise. -} {- | Rotate vector by pi/2 clockwise. -}
vNormal :: Point2 -> Point2 vNormal :: Point2 -> Point2
{-# INLINE vNormal #-} {-# INLINE vNormal #-}
vNormal (x,y) = (y,-x) vNormal (V2 x y) = V2 y (negate x)
{- | Negate a vector. -} {- | Negate a vector. -}
vInverse :: Point2 -> Point2 vInverse :: Point2 -> Point2
vInverse (x,y) = (-x,-y) vInverse (V2 x y) = V2 (-x) (-y)
{- | Normalize a vector safely: on (0,0) return (0,0). -} {- | Normalize a vector safely: on (0,0) return (0,0). -}
safeNormalizeV :: Point2 -> Point2 safeNormalizeV :: Point2 -> Point2
{-# INLINE safeNormalizeV #-} {-# INLINE safeNormalizeV #-}
safeNormalizeV (0,0) = (0,0) safeNormalizeV (V2 0 0) = V2 0 0
safeNormalizeV p = (1/magV p ) *.* p safeNormalizeV p = (1/magV p ) *.* p
{- | Magnitude of a vector. -} {- | Magnitude of a vector. -}
magV :: Point2 -> Float magV :: Point2 -> Float
{-# INLINE magV #-} {-# INLINE magV #-}
magV (x,y) = sqrt $ x^(2::Int) + y^(2::Int) magV (V2 x y) = sqrt $ x^(2::Int) + y^(2::Int)
{- | Magnitude of the cross product of two vectors. {- | Magnitude of the cross product of two vectors.
Identical to detV. -} Identical to detV. -}
crossV :: Point2 -> Point2 -> Float crossV :: Point2 -> Point2 -> Float
crossV (ax,ay) (bx,by) = ax*by - ay*bx crossV (V2 ax ay) (V2 bx by) = ax*by - ay*bx
{- | TO CHECK Orthographic projection of one vector onto another. -} {- | TO CHECK Orthographic projection of one vector onto another. -}
projV :: Point2 -> Point2 -> Point2 projV :: Point2 -> Point2 -> Point2
projV fromv onv projV fromv onv
src/Geometry/Vector3D.hs
+28 -27
View File
@@ -12,55 +12,56 @@ infixl 7 *.*.*
{- | 3D coordinate-wise addition. -} {- | 3D coordinate-wise addition. -}
(+.+.+) :: Point3 -> Point3 -> Point3 (+.+.+) :: Point3 -> Point3 -> Point3
{-# INLINE (+.+.+) #-} {-# INLINE (+.+.+) #-}
(x1, y1, z1) +.+.+ (x2, y2, z2) = (+.+.+) = (+)
let --(x1, y1, z1) +.+.+ (x2, y2, z2) =
!x = x1 + x2 -- let
!y = y1 + y2 -- !x = x1 + x2
!z = z1 + z2 -- !y = y1 + y2
in (x, y, z) -- !z = z1 + z2
-- in (x, y, z)
{- | 3D coordinate-wise subtraction. -} {- | 3D coordinate-wise subtraction. -}
(-.-.-) :: Point3 -> Point3 -> Point3 (-.-.-) :: Point3 -> Point3 -> Point3
{-# INLINE (-.-.-) #-} {-# INLINE (-.-.-) #-}
(x1, y1, z1) -.-.- (x2, y2, z2) = (-.-.-) = (-)
let --(x1, y1, z1) -.-.- (x2, y2, z2) =
!x = x1 - x2 -- let
!y = y1 - y2 -- !x = x1 - x2
!z = z1 - z2 -- !y = y1 - y2
in (x, y, z) -- !z = z1 - z2
-- in (x, y, z)
{- | 3D scalar multiplication. -} {- | 3D scalar multiplication. -}
(*.*.*) :: Float -> Point3 -> Point3 (*.*.*) :: Float -> Point3 -> Point3
{-# INLINE (*.*.*) #-} {-# INLINE (*.*.*) #-}
a *.*.* (x2, y2, z2) = a *.*.* (V3 x2 y2 z2) =
let let
!x = a * x2 !x = a * x2
!y = a * y2 !y = a * y2
!z = a * z2 !z = a * z2
in (x, y, z) in V3 x y z
crossProd :: Point3 -> Point3 -> Point3 crossProd :: Point3 -> Point3 -> Point3
crossProd (x,y,z) (a,b,c) = crossProd (V3 x y z) (V3 a b c) = V3
( y * c - z * b ( y * c - z * b)
, z * a - x * c ( z * a - x * c)
, x * b - y * a ( x * b - y * a)
)
rotate3 :: Float -> Point3 -> Point3 rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-} {-# INLINE rotate3 #-}
rotate3 a (x,y,z) = (x',y',z) rotate3 a (V3 x y z) = V3 x' y' z
where where
(x',y') = rotateV a (x,y) (V2 x' y') = rotateV a (V2 x y)
magV3 :: Point3 -> Float magV3 :: Point3 -> Float
magV3 (x,y,z) = sqrt $ x^i + y^i + z^i magV3 (V3 x y z) = sqrt $ x^i + y^i + z^i
where where
i = 2 :: Int i = 2 :: Int
normalizeV3 :: Point3 -> Point3 normalizeV3 :: Point3 -> Point3
normalizeV3 (0,0,0) = (0,0,0) normalizeV3 (V3 0 0 0) = V3 0 0 0
normalizeV3 p = (1 / magV3 p) *.*.* p normalizeV3 p = (1 / magV3 p) *.*.* p
addZ :: Float -> Point2 -> Point3 addZ :: Float -> Point2 -> Point3
addZ z (x,y) = (x,y,z) addZ z (V2 x y) = V3 x y z
orderAround3 orderAround3
:: Point3 -- ^ Vector to order around :: Point3 -- ^ Vector to order around
@@ -70,16 +71,16 @@ orderAround3 v ps = sortOn (argV . prj) ps
where where
xdir = crossProd v (head ps) xdir = crossProd v (head ps)
ydir = crossProd v xdir ydir = crossProd v xdir
prj p = (dotV3 xdir p, dotV3 ydir p) prj p = V2 (dotV3 xdir p) (dotV3 ydir p)
vCen3 :: [Point3] -> Point3 vCen3 :: [Point3] -> Point3
vCen3 ps = (1 / fromIntegral (length ps)) *.*.* foldr (+.+.+) (0,0,0) ps vCen3 ps = (1 / fromIntegral (length ps)) *.*.* foldr (+.+.+) (V3 0 0 0) ps
dotV3 dotV3
:: Point3 :: Point3
-> Point3 -> Point3
-> Float -> Float
dotV3 (x,y,z) (a,b,c) = x*a + y*b + z*c dotV3 (V3 x y z) (V3 a b c) = x*a + y*b + z*c
projV3 projV3
:: Point3 :: Point3
src/MatrixHelper.hs
+9 -9
View File
@@ -16,16 +16,16 @@ perspectiveMatrixb
-> Point2 -- ^ Window size -> Point2 -- ^ Window size
-> Point2 -- ^ View froms -> Point2 -- ^ View froms
-> [GLfloat] -> [GLfloat]
perspectiveMatrixb rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy) = perspectiveMatrixb rot zoom (V2 tranx trany) (V2 winx winy) (V2 viewFromx viewFromy) =
concatMap vToL concatMap vToL
. vToL . vToL
. lmt . lmt
$ scaleMat (2*zoom/winx,2*zoom/winy) $ scaleMat (V2 (2*zoom/winx) (2*zoom/winy))
-- $ scaleMat (2/winx,2/winy) -- $ scaleMat (2/winx,2/winy)
!*! rotMatr (-rot) !*! rotMatr (-rot)
!*! transMat (viewFromx-tranx,viewFromy-trany) !*! transMat (V2 (viewFromx-tranx) (viewFromy-trany))
!*! perMat (zoom * 0.4) !*! perMat (zoom * 0.4)
!*! transMat (-viewFromx,-viewFromy) !*! transMat (V2 (-viewFromx) (-viewFromy))
!*! vertScale !*! vertScale
!*! vertTrans 20 !*! vertTrans 20
-- !*! vertTrans 80 -- !*! vertTrans 80
@@ -36,12 +36,12 @@ isoMatrix
-> Point2 -- ^ Translation -> Point2 -- ^ Translation
-> Point2 -- ^ Window size -> Point2 -- ^ Window size
-> [GLfloat] -> [GLfloat]
isoMatrix rot zoom (tranx,trany) (winx,winy) = concatMap vToL isoMatrix rot zoom (V2 tranx trany) (V2 winx winy) = concatMap vToL
. vToL . vToL
. lmt . lmt
$ scaleMat (2*zoom/winx,2*zoom/winy) $ scaleMat (V2 (2*zoom/winx) (2*zoom/winy))
!*! rotMatr (-rot) !*! rotMatr (-rot)
!*! transMat (-tranx,-trany) !*! transMat (V2 (-tranx) (-trany))
lmt :: V4 (V4 a) -> V4 (V4 a) lmt :: V4 (V4 a) -> V4 (V4 a)
lmt = Linear.Matrix.transpose lmt = Linear.Matrix.transpose
@@ -57,7 +57,7 @@ perMat x = V4
(V4 0 0 x 1) (V4 0 0 x 1)
scaleMat :: Point2 -> V4 (V4 Float) scaleMat :: Point2 -> V4 (V4 Float)
scaleMat (x,y) = V4 scaleMat (V2 x y) = V4
(V4 x 0 0 0) (V4 x 0 0 0)
(V4 0 y 0 0) (V4 0 y 0 0)
(V4 0 0 1 0) (V4 0 0 1 0)
@@ -71,7 +71,7 @@ rotMatr a = V4
(V4 0 0 0 1) (V4 0 0 0 1)
transMat :: Point2 -> V4 (V4 Float) transMat :: Point2 -> V4 (V4 Float)
transMat (x,y) = V4 transMat (V2 x y) = V4
(V4 1 0 0 x) (V4 1 0 0 x)
(V4 0 1 0 y) (V4 0 1 0 y)
(V4 0 0 1 0) (V4 0 0 1 0)
src/Picture.hs
+59 -58
View File
@@ -63,7 +63,7 @@ import Picture.Data
import Control.Lens import Control.Lens
black :: RGBA black :: RGBA
black = (0,0,0,1) black = (V4 0 0 0 1)
--zl :: RenderType -> [(Int,RenderType)] --zl :: RenderType -> [(Int,RenderType)]
--zl rt = [(0,rt)] --zl rt = [(0,rt)]
@@ -84,7 +84,7 @@ polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-} {-# INLINE polygonCol #-}
polygonCol vs = map f $ polyToTris vs polygonCol vs = map f $ polyToTris vs
where where
f ((x,y),col) = Verx (x,y,0) col PolyV 0 f ((V2 x y),col) = Verx (V3 x y 0) col PolyV 0
poly3 :: [Point3] -> Picture poly3 :: [Point3] -> Picture
{-# INLINE poly3 #-} {-# INLINE poly3 #-}
@@ -103,13 +103,13 @@ bezierQuad cola colc ra rc a b c
| a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
| otherwise = bzhelp | otherwise = bzhelp
[-- ( (0,0) , cola, (0,0), (0,0) ) [-- ( (0,0) , cola, (0,0), (0,0) )
(aIn, cola, (fa aIn,fc aIn) , (1,0) ) (aIn, cola, (V2 (fa aIn) (fc aIn)) , (V2 1 0) )
,(aIn, cola, (fa aIn,fc aIn) , (1,0) ) ,(aIn, cola, (V2 (fa aIn) (fc aIn)) , (V2 1 0) )
,(cIn, colc, (fa cIn,fc cIn) , (0,1) ) ,(cIn, colc, (V2 (fa cIn) (fc cIn)) , (V2 0 1) )
,( aX, cola, (1,0) , (fa' aX,fc' aX) ) ,( aX, cola, (V2 1 0) , (V2 (fa' aX) (fc' aX)) )
,( cX, colc, (0,1) , (fa' cX,fc' cX) ) ,( cX, colc, (V2 0 1) , (V2 (fa' cX) (fc' cX)) )
,( bX, colb, (0,0) , (fa' bX,fc' bX) ) ,( bX, colb, (V2 0 0) , (V2 (fa' bX) (fc' bX)) )
,( bX, colb, (0,0) , (fa' bX,fc' bX) ) ,( bX, colb, (V2 0 0) , (V2 (fa' bX) (fc' bX)) )
] ]
where where
colb = mixColors 0.5 0.5 cola colc colb = mixColors 0.5 0.5 cola colc
@@ -131,16 +131,16 @@ bezierQuad cola colc ra rc a b c
fa' = extrapolate aIn cIn bIn fa' = extrapolate aIn cIn bIn
fc' = extrapolate cIn aIn bIn fc' = extrapolate cIn aIn bIn
bzhelp :: [(Point2, Point4, (Float, Float), (Float, Float))] -> Picture bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
bzhelp = map f bzhelp = map f
where where
f ((x,y),col,(a,b),(c,d)) = Verx (x,y,0) col (BezV (a,b,c,d)) 0 f ((V2 x y),col,(V2 a b),(V2 c d)) = Verx (V3 x y 0) col (BezV (V4 a b c d)) 0
-- given a one and two zeros of a linear function over x and y, -- given a one and two zeros of a linear function over x and y,
-- determine the function -- determine the function
-- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f -- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f
extrapolate :: Point2 -> Point2 -> Point2 -> Point2 -> Float extrapolate :: Point2 -> Point2 -> Point2 -> Point2 -> Float
extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) = extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) =
( x * ( ay - by ) ( x * ( ay - by )
+ y * ( bx - ax ) + y * ( bx - ax )
+ (ax * by - bx * ay) + (ax * by - bx * ay)
@@ -157,7 +157,7 @@ color c = map $ overCol (const c)
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 (V3 x y z) = V3 (x+a) (y+b) z
translate :: Float -> Float -> Picture -> Picture translate :: Float -> Float -> Picture -> Picture
--{-# INLINE translate #-} --{-# INLINE translate #-}
@@ -167,12 +167,12 @@ translate x y = map $ overPos (translate3 x y)
setDepth :: Float -> Picture -> Picture setDepth :: Float -> Picture -> Picture
--{-# INLINE setDepth #-} --{-# INLINE setDepth #-}
--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d)) --setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
setDepth d = map $ overPos (\(x,y,_) -> (x,y,d)) setDepth d = map $ overPos (\(V3 x y _) -> V3 x y d)
addDepth :: Float -> Picture -> Picture addDepth :: Float -> Picture -> Picture
--{-# INLINE addDepth #-} --{-# INLINE addDepth #-}
--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d)) --addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
addDepth d = map $ overPos (\(x,y,z) -> (x,y,z+d)) addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d))
setLayer :: Int -> Picture -> Picture setLayer :: Int -> Picture -> Picture
{-# INLINE setLayer #-} {-# INLINE setLayer #-}
@@ -182,7 +182,7 @@ setLayer i = map f
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 (V3 x y z) = (V3 (x*a) (y*b) (z))
scale :: Float -> Float -> Picture -> Picture scale :: Float -> Float -> Picture -> Picture
--{-# INLINE scale #-} --{-# INLINE scale #-}
@@ -197,9 +197,9 @@ pictures :: [Picture] -> Picture
{-# INLINE pictures #-} {-# INLINE pictures #-}
pictures = concat pictures = concat
makeArc :: Float -> (Float,Float) -> [Point2] makeArc :: Float -> Point2 -> [Point2]
{-# INLINE makeArc #-} {-# INLINE makeArc #-}
makeArc rad (a,b) = map (`rotateV` (0,rad)) angles makeArc rad (V2 a b) = map (`rotateV` (V2 0 rad)) angles
where where
angles = [a,a+step.. b] angles = [a,a+step.. b]
step = pi * 0.2 step = pi * 0.2
@@ -211,9 +211,9 @@ circleSolid = circleSolidCol white white
circleSolidCol :: Color -> Color -> Float -> Picture circleSolidCol :: Color -> Color -> Float -> Picture
{-# INLINE circleSolidCol #-} {-# INLINE circleSolidCol #-}
circleSolidCol colC colE r = map f circleSolidCol colC colE r = map f
[( (-r, r,0), colC) [( (V3 (-r) ( r) (0)), colC)
,( (-r,-r,0), colE) ,( (V3 (-r) (-r) (0)), colE)
,( ( r,-r,0), black) ,( (V3 ( r) (-r) (0)), black)
] ]
where where
f (pos,col) = Verx pos col EllV 0 f (pos,col) = Verx pos col EllV 0
@@ -273,7 +273,7 @@ arcSolid
-> Float -- ^ Radius -> Float -- ^ Radius
-> Picture -> Picture
{-# INLINE arcSolid #-} {-# INLINE arcSolid #-}
arcSolid startA endA rad = polygon $ (0,0) : makeArc rad (startA,endA) arcSolid startA endA rad = polygon $ (V2 0 0) : makeArc rad (V2 startA endA)
arc arc
:: Float -- ^ Start angle :: Float -- ^ Start angle
@@ -297,60 +297,61 @@ thickArc startA endA rad wdth
thickArcHelp :: Float -> Float -> Float -> Float -> [Verx] thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
thickArcHelp startA endA rad wdth = map f thickArcHelp startA endA rad wdth = map f
[( (0,0,0),black,(0,0,wdth)) [( (V3 0 0 0),black,(V3 0 0 wdth))
,((xa,ya,0),black,(1,0,wdth)) ,((V3 xa ya 0),black,(V3 1 0 wdth))
,((xb,yb,0),black,(1,1,wdth)) ,((V3 xb yb 0),black,(V3 1 1 wdth))
,( (0,0,0),black,(0,0,wdth)) ,( (V3 0 0 0),black,(V3 0 0 wdth))
,((xb,yb,0),black,(1,1,wdth)) ,((V3 xb yb 0),black,(V3 1 1 wdth))
,((xc,yc,0),black,(0,1,wdth)) ,((V3 xc yc 0),black,(V3 0 1 wdth))
] ]
where where
(xa,ya) = rotateV startA (rad,0) (V2 xa ya) = rotateV startA (V2 rad 0)
(xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0) (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) (0))
(xc,yc) = rotateV endA (rad,0) (V2 xc yc) = rotateV endA (V2 rad 0)
f (pos,col,val) = Verx pos col (ArcV val) 0 f (pos,col,val) = Verx pos col (ArcV val) 0
withAlpha :: Float -> RGBA -> RGBA withAlpha :: Float -> RGBA -> RGBA
{-# INLINE withAlpha #-} {-# INLINE withAlpha #-}
withAlpha a (x,y,z,a') = (x,y,z,a*a') withAlpha a (V4 x y z a') = (V4 x y z (a*a'))
red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::Color red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::Color
red = (1,0,0,1) red = toV4 (1,0,0,1)
green = (0,1,0,1) green = toV4 (0,1,0,1)
blue = (0,0,1,1) blue = toV4 (0,0,1,1)
yellow = (1,1,0,1) yellow = toV4 (1,1,0,1)
cyan = (0,1,1,1) cyan = toV4 (0,1,1,1)
magenta = (1,0,1,1) magenta = toV4 (1,0,1,1)
rose = (1,0,0.5,1) rose = toV4 (1,0,0.5,1)
violet = (0.5,0,1,1) violet = toV4 (0.5,0,1,1)
azure = (0,0.5,1,1) azure = toV4 (0,0.5,1,1)
aquamarine= (0,1,0.5,1) aquamarine= toV4 (0,1,0.5,1)
chartreuse= (0.5,1,0,1) chartreuse= toV4 (0.5,1,0,1)
orange = (1,0.5,0,1) orange = toV4 (1,0.5,0,1)
white = (1,1,1,1) white = toV4 (1,1,1,1)
mixColors :: Float -> Float -> Color -> Color -> Color mixColors :: Float -> Float -> Color -> Color -> Color
mixColors rata ratb (r0,g0,b0,a0) (r2,g2,b2,a2) = mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) =
let fullrat = rata + ratb let fullrat = rata + ratb
normrata = rata / fullrat normrata = rata / fullrat
normratb = ratb / fullrat normratb = ratb / fullrat
f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int) f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int)
in (f r0 r2 , f g0 g2 , f b0 b2 , normrata * a0 + normratb * a2) in (V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2))
light :: Color -> Color light :: Color -> Color
light (r,g,b,a) = (r+0.2,g+0.2,b+0.2,a) light (V4 r g b a) = (V4 (r+0.2) (g+0.2) (b+0.2) (a))
dark :: Color -> Color dark :: Color -> Color
dark (r,g,b,a) = (r-0.2,g-0.2,b-0.2,a) dark (V4 r g b a) = (V4 (r-0.2) (g-0.2) (b-0.2) (a))
dim :: Color -> Color dim :: Color -> Color
dim (r,g,b,a) = (r/1.2,g/1.2,b/1.2,a) dim (V4 r g b a) = (V4 (r/1.2) (g/1.2) (b/1.2) (a))
bright :: Color -> Color bright :: Color -> Color
bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a) bright (V4 r g b a) = (V4 (r*1.2) (g*1.2) (b*1.2) (a))
greyN :: Float -> Color greyN :: Float -> Color
greyN x = (x,x,x,1) greyN x = toV4 (x,x,x,1)
overPos :: (Point3 -> Point3) -> Verx -> Verx overPos :: (Point3 -> Point3) -> Verx -> Verx
{-# INLINE overPos #-} {-# INLINE overPos #-}
@@ -370,12 +371,12 @@ stringToList s = concatMap (uncurry charToTuple) $ zip [0,0.9*dimText ..] s
charToTuple :: Float -> Char -> [(Point3,Point4,Point2)] charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
{-# INLINE charToTuple #-} {-# INLINE charToTuple #-}
charToTuple x c = charToTuple x c =
[((x-50,-100,0), white,(offset,1)) [((V3 (x-50) (-100) (0)), white,(V2 offset 1))
,((x-50,100,0), white,(offset,0)) ,((V3 (x-50) (100) (0)), white,(V2 offset 0))
,((x+50,100,0), white,(offset+1,0)) ,((V3 (x+50) (100) (0)), white,(V2 (offset+1) 0))
,((x-50,-100,0), white,(offset,1)) ,((V3 (x-50) (-100) (0)), white,(V2 offset 1))
,((x+50,-100,0), white,(offset+1,1)) ,((V3 (x+50) (-100) (0)), white,(V2 (offset+1) 1))
,((x+50,100,0), white,(offset+1,0)) ,((V3 (x+50) (100) (0)), white,(V2 (offset+1) 0))
] ]
where where
offset = fromIntegral (fromEnum c) - 32 offset = fromIntegral (fromEnum c) - 32
src/Picture/Data.hs
+17 -8
View File
@@ -49,8 +49,8 @@ data RenderType
deriving Generic deriving Generic
instance NFData RenderType instance NFData RenderType
type RGBA = (Float,Float,Float,Float) type RGBA = Point4
type Color = (Float,Float,Float,Float) type Color = Point4
data FTree a data FTree a
= FBranch (a -> a) (FTree a) = FBranch (a -> a) (FTree a)
@@ -103,15 +103,24 @@ 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 :: (a,a) -> [a] flat2 :: V2 a -> [a]
flat2 (x,y) = [x,y] flat2 (V2 x y) = [x,y]
flat3 :: (a,a,a) -> [a] flat3 :: V3 a -> [a]
flat3 (x,y,z) = [x,y,z] flat3 (V3 x y z) = [x,y,z]
flat4 :: (a,a,a,a) -> [a] flat4 :: V4 a -> [a]
flat4 (x,y,z,w) = [x,y,z,w] flat4 (V4 x y z w) = [x,y,z,w]
{-# INLINE flat2 #-} {-# INLINE flat2 #-}
{-# INLINE flat3 #-} {-# INLINE flat3 #-}
{-# INLINE flat4 #-} {-# INLINE flat4 #-}
tflat2 :: (a,a) -> [a]
tflat2 (x,y) = [x,y]
tflat3 :: (a,a,a) -> [a]
tflat3 (x,y,z) = [x,y,z]
tflat4 :: (a,a,a,a) -> [a]
tflat4 (x,y,z,w) = [x,y,z,w]
{-# INLINE tflat2 #-}
{-# INLINE tflat3 #-}
{-# INLINE tflat4 #-}
type Picture = [Verx] type Picture = [Verx]
src/Polyhedra.hs
+9 -9
View File
@@ -15,7 +15,7 @@ import Control.Lens
translateXY :: Float -> Float -> Polyhedra -> Polyhedra translateXY :: Float -> Float -> Polyhedra -> Polyhedra
translateXY x y = pyFaces %~ map (map $ first tran) translateXY x y = pyFaces %~ map (map $ first tran)
where where
tran (a,b,c) = (a+x,b+y,c) tran (V3 a b c) = (V3 (a+x) (b+y) (c))
rotateXY :: Float -> Polyhedra -> Polyhedra rotateXY :: Float -> Polyhedra -> Polyhedra
rotateXY a = over pyFaces $ map $ map $ first $ rotate3 a rotateXY a = over pyFaces $ map $ map $ first $ rotate3 a
@@ -49,7 +49,7 @@ faceEdges xs = zipWith addNormal xs (tail xs ++ [head xs])
rhombus :: Point3 -> Point3 -> [Point3] rhombus :: Point3 -> Point3 -> [Point3]
rhombus a b = rhombus a b =
[(0,0,0) [(V3 0 0 0)
,a ,a
,a +.+.+ b ,a +.+.+ b
,b ,b
@@ -58,16 +58,16 @@ rhombus a b =
boxXYZ :: Float -> Float -> Float -> [[Point3]] boxXYZ :: Float -> Float -> Float -> [[Point3]]
boxXYZ x y z = boxXYZ x y z =
[ bottomFace [ bottomFace
, map (+.+.+ (0,0,z)) $ reverse bottomFace , map (+.+.+ (V3 0 0 z)) $ reverse bottomFace
, frontFace , frontFace
, map (+.+.+ (0,y,0)) $ reverse frontFace , map (+.+.+ (V3 0 y 0)) $ reverse frontFace
, sideFace , sideFace
, map (+.+.+ (x,0,0)) $ reverse sideFace , map (+.+.+ (V3 x 0 0)) $ reverse sideFace
] ]
where where
bottomFace = rhombus (0,y,0) (x,0,0) bottomFace = rhombus (V3 0 y 0) (V3 x 0 0)
frontFace = rhombus (x,0,0) (0,0,z) frontFace = rhombus (V3 x 0 0) (V3 0 0 z)
sideFace = rhombus (0,0,z) (0,y,0) sideFace = rhombus (V3 0 0 z) (V3 0 y 0)
boxABC :: Point3 -> Point3 -> Point3 -> [[Point3]] boxABC :: Point3 -> Point3 -> Point3 -> [[Point3]]
boxABC a b c = boxABC a b c =
[ faceNC [ faceNC
@@ -98,7 +98,7 @@ polyToEdges = constructEdges . map (map fst) . _pyFaces
-- rendering for silhouette -- rendering for silhouette
polyToRender :: Polyhedra -> [RenderType] polyToRender :: Polyhedra -> [RenderType]
polyToRender = map (Render3 . flat4) . polyToEdges polyToRender = map (Render3 . tflat4) . polyToEdges
-- rendering for shape -- rendering for shape
polyToGeoRender :: Polyhedra -> [RenderType] polyToGeoRender :: Polyhedra -> [RenderType]
polyToGeoRender = map (Render3 . polyToTris . map fst) . _pyFaces polyToGeoRender = map (Render3 . polyToTris . map fst) . _pyFaces
src/Polyhedra/Geodesic.hs
+1 -1
View File
@@ -10,7 +10,7 @@ import qualified Data.Map as M
icosahedronPoints :: [Point3] icosahedronPoints :: [Point3]
icosahedronPoints = concat icosahedronPoints = concat
[ [(0,one,gr),(one, gr, 0),(gr, 0, one)] [ [V3 0 one gr, V3 one gr 0, V3 gr 0 one]
| one <- [-1,1] | one <- [-1,1]
, gr <- [negate (1 + sqrt 5)/2, (1 + sqrt 5)/2 ] , gr <- [negate (1 + sqrt 5)/2, (1 + sqrt 5)/2 ]
] ]
src/Preload/Render.hs
+5 -4
View File
@@ -12,6 +12,7 @@ import Shader.Compile
import Shader.AuxAddition import Shader.AuxAddition
import Shader.Parameters import Shader.Parameters
import Data.Preload.Render import Data.Preload.Render
import Geometry.Data
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
import Graphics.GL.Core43 import Graphics.GL.Core43
@@ -229,19 +230,19 @@ poke3 (Render3 vs) = map flat3 vs
poke3 _ = undefined poke3 _ = undefined
pokeWPStrat :: RenderType -> [[Float]] pokeWPStrat :: RenderType -> [[Float]]
pokeWPStrat Render22{_unRender22 = ((x,y),(z,w))} = [[x,y,z,w]] pokeWPStrat Render22{_unRender22 = ((V2 x y),(V2 z w))} = [[x,y,z,w]]
pokeWPStrat _ = undefined pokeWPStrat _ = undefined
pokeRadDist :: RenderType -> [[Float]] pokeRadDist :: RenderType -> [[Float]]
pokeRadDist Render2221{_unRender2221 = ((a,b),(c,d),(e,f),g)} = [[a,b,c,d,e,f,g]] pokeRadDist Render2221{_unRender2221 = (V2 a b,V2 c d,V2 e f,g)} = [[a,b,c,d,e,f,g]]
pokeRadDist _ = undefined pokeRadDist _ = undefined
pokeWPColStrat :: RenderType -> [[Float]] pokeWPColStrat :: RenderType -> [[Float]]
pokeWPColStrat Render22x4{_unRender22x4=(((x,y),(z,w)),(r,g,b,a))} = [[x,y,z,w,r,g,b,a]] pokeWPColStrat Render22x4{_unRender22x4=((V2 x y,V2 z w),V4 r g b a)} = [[x,y,z,w,r,g,b,a]]
pokeWPColStrat _ = undefined pokeWPColStrat _ = undefined
poke33 :: RenderType -> [[Float]] poke33 :: RenderType -> [[Float]]
poke33 Render3x3{_unRender3x3=((x,y,z),(a,b,c))} = [[x,y,z,a,b,c]] poke33 Render3x3{_unRender3x3=(V3 x y z,V3 a b c)} = [[x,y,z,a,b,c]]
poke33 _ = undefined poke33 _ = undefined
isPolyV, isArcV, isEllV, isTextV, isBezV, isPolyzV :: VertexType -> Bool isPolyV, isArcV, isEllV, isTextV, isBezV, isPolyzV :: VertexType -> Bool
src/Render.hs
+1 -1
View File
@@ -57,7 +57,7 @@ createLightMap pdata lightPoints nWalls nSils nsurfVs = do
blendFunc $= (Zero, OneMinusSrcAlpha) blendFunc $= (Zero, OneMinusSrcAlpha)
stencilTest $= Enabled stencilTest $= Enabled
depthFunc $= Just Lequal depthFunc $= Just Lequal
forM_ lightPoints $ \((x,y,z),r,lum) -> do forM_ lightPoints $ \((V3 x y z),r,lum) -> do
-- stencil out shadows -- stencil out shadows
colorMask $= Color4 Disabled Disabled Disabled Disabled colorMask $= Color4 Disabled Disabled Disabled Disabled
clear [StencilBuffer] clear [StencilBuffer]
src/Shader/Poke.hs
+9 -9
View File
@@ -66,19 +66,19 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case t
>> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 7 x
where where
thePtr = plusPtr (_vboPtr $ _psPolyz vbos) (_psPolyz offsets * 8 * floatSize) thePtr = plusPtr (_vboPtr $ _psPolyz vbos) (_psPolyz offsets * 8 * floatSize)
BezV (x,y,z,w) -> poke34 thePtr thePos theCol BezV (V4 x y z w) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y >> pokeElemOff thePtr 8 y
>> pokeElemOff thePtr 9 z >> pokeElemOff thePtr 9 z
>> pokeElemOff thePtr 10 w >> pokeElemOff thePtr 10 w
where where
thePtr = plusPtr (_vboPtr $ _psBez vbos) (_psBez offsets * 11 * floatSize) thePtr = plusPtr (_vboPtr $ _psBez vbos) (_psBez offsets * 11 * floatSize)
TextV (x,y) -> poke34 thePtr thePos theCol TextV (V2 x y) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y >> pokeElemOff thePtr 8 y
where where
thePtr = plusPtr (_vboPtr $ _psText vbos) (_psText offsets * 9 * floatSize) thePtr = plusPtr (_vboPtr $ _psText vbos) (_psText offsets * 9 * floatSize)
ArcV (x,y,z) -> poke34 thePtr thePos theCol ArcV (V3 x y z) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y >> pokeElemOff thePtr 8 y
>> pokeElemOff thePtr 9 z >> pokeElemOff thePtr 9 z
@@ -88,7 +88,7 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case t
poke34 :: Ptr Float -> Point3 -> Point4 -> IO () poke34 :: Ptr Float -> Point3 -> Point4 -> IO ()
{-# INLINE poke34 #-} {-# INLINE poke34 #-}
poke34 ptr (a,b,c) (d,e,f,g) = do poke34 ptr (V3 a b c) (V4 d e f g) = do
pokeElemOff ptr 0 a pokeElemOff ptr 0 a
pokeElemOff ptr 1 b pokeElemOff ptr 1 b
pokeElemOff ptr 2 c pokeElemOff ptr 2 c
@@ -148,7 +148,7 @@ pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int
pokePoint33s ptr vals0 = go vals0 0 pokePoint33s ptr vals0 = go vals0 0
where where
go [] n = return n go [] n = return n
go ( ((a,b,c),(d,e,f)):vals) n = do go ( ((V3 a b c),(V3 d e f)):vals) n = do
pokeElemOff ptr (off 0) a pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c pokeElemOff ptr (off 2) c
@@ -163,7 +163,7 @@ pokePoint3s :: Ptr Float -> [Point3] -> IO Int
pokePoint3s ptr vals0 = go vals0 0 pokePoint3s ptr vals0 = go vals0 0
where where
go [] n = return n go [] n = return n
go ( (a,b,c):vals) n = do go ( (V3 a b c):vals) n = do
pokeElemOff ptr (off 0) a pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c pokeElemOff ptr (off 2) c
@@ -186,19 +186,19 @@ pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vx
>> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 7 x
where where
thePtr = plusPtr (_vboPtr $ _psPolyz vbos) ((_psPolyz offsets + layOff) * 8 * floatSize) thePtr = plusPtr (_vboPtr $ _psPolyz vbos) ((_psPolyz offsets + layOff) * 8 * floatSize)
BezV (x,y,z,w) -> poke34 thePtr thePos theCol BezV (V4 x y z w) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y >> pokeElemOff thePtr 8 y
>> pokeElemOff thePtr 9 z >> pokeElemOff thePtr 9 z
>> pokeElemOff thePtr 10 w >> pokeElemOff thePtr 10 w
where where
thePtr = plusPtr (_vboPtr $ _psBez vbos) ((_psBez offsets + layOff) * 11 * floatSize) thePtr = plusPtr (_vboPtr $ _psBez vbos) ((_psBez offsets + layOff) * 11 * floatSize)
TextV (x,y) -> poke34 thePtr thePos theCol TextV (V2 x y) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y >> pokeElemOff thePtr 8 y
where where
thePtr = plusPtr (_vboPtr $ _psText vbos) ((_psText offsets + layOff) * 9 * floatSize) thePtr = plusPtr (_vboPtr $ _psText vbos) ((_psText offsets + layOff) * 9 * floatSize)
ArcV (x,y,z) -> poke34 thePtr thePos theCol ArcV (V3 x y z) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y >> pokeElemOff thePtr 8 y
>> pokeElemOff thePtr 9 z >> pokeElemOff thePtr 9 z
src/Tile.hs
+8 -6
View File
@@ -10,8 +10,11 @@ tToRender t = map Render3x3 $ polyToTris $ zip ps3 coords3
where where
ps = _tilePoly t ps = _tilePoly t
coords = map (calcTexCoord (_tileCenter t) (_tileX t) (_tileY t)) ps coords = map (calcTexCoord (_tileCenter t) (_tileX t) (_tileY t)) ps
ps3 = map (mkTrip 0) ps ps3 = map (addToV2 0) ps
coords3 = map (mkTrip (_tileZ t)) coords coords3 = map (addToV2 (_tileZ t)) coords
addToV2 :: a -> V2 a -> V3 a
addToV2 z (V2 x y) = V3 x y z
mkTrip :: c -> (a,b) -> (a,b,c) mkTrip :: c -> (a,b) -> (a,b,c)
mkTrip z (x,y) = (x,y,z) mkTrip z (x,y) = (x,y,z)
@@ -22,10 +25,9 @@ calcTexCoord
-> Point2 -- ^ tile (0,1) -> Point2 -- ^ tile (0,1)
-> Point2 -- ^ world point -> Point2 -- ^ world point
-> Point2 -> Point2
calcTexCoord cen x' y' p = calcTexCoord cen x' y' p = V2
( magV (projV (p -.- cen) x) / magV x ( magV (projV (p -.- cen) x) / magV x )
, magV (projV (p -.- cen) y) / magV y ( magV (projV (p -.- cen) y) / magV y )
)
where where
x = x' -.- cen x = x' -.- cen
y = y' -.- cen y = y' -.- cen