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:
jgk
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
numColor :: Int -> Color
numColor 0 = (1,0,0,1)
numColor 1 = (0,1,0,1)
numColor 2 = (0,0,1,1)
numColor 3 = (1,1,0,1)
numColor 4 = (0,1,1,1)
numColor 5 = (1,0,1,1)
numColor 6 = (1,0,0.5,1)
numColor 7 = (0.5,0,1,1)
numColor 8 = (0,0.5,1,1)
numColor 9 = (0,1,0.5,1)
numColor 10 = (0.5,1,0,1)
numColor 11 = (1,0.5,0,1)
numColor 12 = (1,1,1,1)
numColor _ = (1,1,1,1)
numColor 0 = toV4 (1,0,0,1)
numColor 1 = toV4 (0,1,0,1)
numColor 2 = toV4 (0,0,1,1)
numColor 3 = toV4 (1,1,0,1)
numColor 4 = toV4 (0,1,1,1)
numColor 5 = toV4 (1,0,1,1)
numColor 6 = toV4 (1,0,0.5,1)
numColor 7 = toV4 (0.5,0,1,1)
numColor 8 = toV4 (0,0.5,1,1)
numColor 9 = toV4 (0,1,0.5,1)
numColor 10 = toV4 (0.5,1,0,1)
numColor 11 = toV4 (1,0.5,0,1)
numColor 12 = toV4 (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 Picture
import qualified DoubleStack as DS
import Geometry.Data
{- Indestructible wall. -}
defaultWall :: Wall
defaultWall = Wall
{ _wlLine = ((0,0),(50,0))
{ _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0
, _wlColor = greyN 0.6
, _wlSeen = False
@@ -15,7 +16,7 @@ defaultWall = Wall
{- Indestructible see-through wall. -}
defaultCrystalWall :: Wall
defaultCrystalWall = Wall
{ _wlLine = ((0,0),(50,0))
{ _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0
, _wlColor = withAlpha 0.5 aquamarine
, _wlSeen = False
@@ -25,26 +26,26 @@ defaultCrystalWall = Wall
Pathable. -}
defaultAutoDoor :: Wall
defaultAutoDoor = Door
{ _wlLine = ((0,0),(50,0))
{ _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = True
, _drPositions = DS.singleton ((0,0),(50,0))
, _drPositions = DS.singleton ((V2 0 0),(V2 50 0))
}
{-
Non-pathable door.
-}
defaultDoor :: Wall
defaultDoor = Door
{ _wlLine = ((0,0),(50,0))
{ _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False
, _wlIsSeeThrough = 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
import Dodge.Data
import Geometry
import Geometry.Data
import FoldableHelp
--import Control.Lens
import Data.List
import Data.Maybe
import Data.Bifunctor
-- | Describe a wall as two points.
-- Order is important: the wall face is to the left of the line going from
-- 'fst' to 'snd'.
@@ -136,7 +138,7 @@ cutPoly qs wls =
expandPolyBy :: Float -> [Point2] -> [Point2]
expandPolyBy x ps = map f ps
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 *.* normalizeV (p -.- cp)
-- | 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
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))]
intersectingBrokenWalls :: [(Point2,Point2)]
intersectingBrokenWalls = filter (uncurry test) brokenWalls
where
polyPairs = zip brokenPoly (tail brokenPoly ++ [head brokenPoly])
test a b = any (isJust . uncurry (myIntersectSegSeg a b)) polyPairs
--intersectingBrokenWalls :: [(Point2,Point2)]
--intersectingBrokenWalls = filter (uncurry test) brokenWalls
-- where
-- polyPairs = zip brokenPoly (tail brokenPoly ++ [head brokenPoly])
-- test a b = any (isJust . uncurry (myIntersectSegSeg a b)) polyPairs
brokenPoly :: [Point2]
brokenPoly = [(434.66675,2833.3225),(503.9488,2793.3225),(523.9488,2827.9636),(454.66675,2867.9636)]
--brokenPoly :: [Point2]
--brokenPoly = [(434.66675,2833.3225),(503.9488,2793.3225),(523.9488,2827.9636),(454.66675,2867.9636)]
iBWall :: (Point2,Point2)
iBWall = ((403.32703,2759.0405),(503.32703,2932.2456))
--iBWall :: (Point2,Point2)
--iBWall = ((403.32703,2759.0405),(503.32703,2932.2456))
expandToSquare :: (Point2,Point2) -> [(Point2,Point2)]
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
d = a +.+ vNormal v
minWalls :: [(Point2,Point2)]
minWalls = expandToSquare iBWall
--minWalls :: [(Point2,Point2)]
--minWalls = expandToSquare iBWall
brokenZs :: [Point2]
brokenCwals :: [WallP]
(brokenZs,brokenCwals) = cutWallsWithPoints brokenPoly brokenWalls
--brokenZs :: [Point2]
--brokenCwals :: [WallP]
--(brokenZs,brokenCwals) = cutWallsWithPoints brokenPoly brokenWalls
minZs :: [Point2]
minCwals :: [WallP]
(minZs,minCwals) = cutWallsWithPoints brokenPoly minWalls
brokenRs :: [Point2]
brokenRs = orderPolygon $ nub $ minZs ++ brokenPoly
brokenAfterRemovedWalls :: [WallP]
brokenAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) brokenCwals
minAfterRemovedWalls :: [WallP]
minAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) minCwals
brokenRemovedWalls :: [WallP]
brokenRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) brokenCwals
minRemovedWalls :: [WallP]
minRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) minCwals
addedPolyWalls :: [Point2] -> [WallP] -> [WallP]
addedPolyWalls ps wls = addPolyWalls ps wls \\ wls
brokenAddedWalls :: [WallP]
brokenAddedWalls = addedPolyWalls brokenRs brokenAfterRemovedWalls
minAddedWalls :: [WallP]
minAddedWalls = addedPolyWalls brokenRs minAfterRemovedWalls
brokenAdd :: WallP
brokenAdd = head brokenAddedWalls
findShadowWall :: WallP -> [WallP] -> Maybe WallP
findShadowWall (p1,p2) wls = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
where
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* rotateV (negate $ pi/4) (vNormal (p2 -.- p1))
f = uncurry $ myIntersectSegSeg p3 p4
findShadowWalls :: WallP -> [WallP] -> [WallP]
findShadowWalls (p1,p2) wls = hitWls
where
hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
f = uncurry $ myIntersectSegSeg p3 p4
addWallDebug :: WallP -> [WallP] -> [WallP]
addWallDebug (p1,p2) wls =
case maybeWs of
Just ws -> if uncurry isLHS ws p3
then wls
else (p1,p2) : wls
Nothing -> (p1,p2) : wls
where
maybeWs = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
f = uncurry $ myIntersectSegSeg p3 p4
--minZs :: [Point2]
--minCwals :: [WallP]
--(minZs,minCwals) = cutWallsWithPoints brokenPoly minWalls
--
--brokenRs :: [Point2]
--brokenRs = orderPolygon $ nub $ minZs ++ brokenPoly
--
--brokenAfterRemovedWalls :: [WallP]
--brokenAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) brokenCwals
--minAfterRemovedWalls :: [WallP]
--minAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) minCwals
--
--brokenRemovedWalls :: [WallP]
--brokenRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) brokenCwals
--minRemovedWalls :: [WallP]
--minRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) minCwals
--
--addedPolyWalls :: [Point2] -> [WallP] -> [WallP]
--addedPolyWalls ps wls = addPolyWalls ps wls \\ wls
--
--brokenAddedWalls :: [WallP]
--brokenAddedWalls = addedPolyWalls brokenRs brokenAfterRemovedWalls
--minAddedWalls :: [WallP]
--minAddedWalls = addedPolyWalls brokenRs minAfterRemovedWalls
--
--brokenAdd :: WallP
--brokenAdd = head brokenAddedWalls
--
--findShadowWall :: WallP -> [WallP] -> Maybe WallP
--findShadowWall (p1,p2) wls = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
-- where
-- p3 = 0.5 *.* (p1 +.+ p2)
-- p4 = p3 +.+ 10000 *.* rotateV (negate $ pi/4) (vNormal (p2 -.- p1))
-- f = uncurry $ myIntersectSegSeg p3 p4
--
--findShadowWalls :: WallP -> [WallP] -> [WallP]
--findShadowWalls (p1,p2) wls = hitWls
-- where
-- hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
-- p3 = 0.5 *.* (p1 +.+ p2)
-- p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
-- f = uncurry $ myIntersectSegSeg p3 p4
--
--addWallDebug :: WallP -> [WallP] -> [WallP]
--addWallDebug (p1,p2) wls =
-- case maybeWs of
-- Just ws -> if uncurry isLHS ws p3
-- then wls
-- else (p1,p2) : wls
-- Nothing -> (p1,p2) : wls
-- where
-- maybeWs = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
-- p3 = 0.5 *.* (p1 +.+ p2)
-- p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
-- 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 Picture
import Geometry
import Geometry.Data
import qualified Data.IntMap.Strict as IM
import Control.Lens
@@ -14,7 +15,7 @@ makeButton
-> Button
makeButton c eff = Button
{ _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
, _btPos = (0,0)
, _btPos = (V2 0 0)
, _btRot = 0
, _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
-- . set (buttons . ix (_btID b) . btPict)
@@ -38,7 +39,7 @@ makeSwitch
-> Button
makeSwitch c effOn effOff = Button
{ _btPict = offPict
, _btPos = (0,0)
, _btPos = (V2 0 0)
, _btRot = 0
, _btEvent = flipSwitch
, _btID = 0
@@ -53,11 +54,11 @@ makeSwitch c effOn effOff = Button
_ -> error "Trying to switch a button with no label"
offPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
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
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 bt = bt
src/Dodge/LightSources.hs
+11 -11
View File
@@ -10,9 +10,9 @@ import Geometry.Data
--import qualified Data.IntMap.Strict as IM
lightAt :: Point3 -> Int -> LightSource
lightAt (x,y,z) i =
lightAt (V3 x y z) i =
LS {_lsID = i
,_lsPos = (x,y,z)
,_lsPos = (V3 x y z)
,_lsDir = 0
,_lsRad = 700
,_lsIntensity = 0.75
@@ -20,18 +20,18 @@ lightAt (x,y,z) i =
basicLS :: PSType
basicLS = PutLS ls dec
where
ls = lightAt (0,0,0) 0
ls = lightAt (V3 0 0 0) 0
dec = onLayer PtLayer $ color white $ circleSolid 8
tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
tLightFade 0 rmax intensityF (x,y) = TLS
{ _tlsPos = (x,y,0)
tLightFade 0 rmax intensityF (V2 x y) = TLS
{ _tlsPos = (V3 x y 0)
, _tlsRad = rmax
, _tlsIntensity = intensityF 0
, _tlsUpdate = \w _ -> (w, Nothing)
}
tLightFade i rmax intensityF p@(x,y) = TLS
{ _tlsPos = (x,y,0)
tLightFade i rmax intensityF p@(V2 x y) = TLS
{ _tlsPos = (V3 x y 0)
, _tlsRad = rmax
, _tlsIntensity = intensityF i
, _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p)
@@ -43,14 +43,14 @@ tLightRad
-> Float -- ^ minimal radius (unused)
-> Point2
-> TempLightSource
tLightRad 0 rmax _ (x,y) = TLS
{ _tlsPos = (x,y,0)
tLightRad 0 rmax _ (V2 x y) = TLS
{ _tlsPos = (V3 x y 0)
, _tlsRad = rmax
, _tlsIntensity = 0.5
, _tlsUpdate = \w _ -> (w, Nothing)
}
tLightRad i rmax rmin p@(x,y) = TLS
{ _tlsPos = (x,y,0)
tLightRad i rmax rmin p@(V2 x y) = TLS
{ _tlsPos = (V3 x y 0)
, _tlsRad = rmax
, _tlsIntensity = 0.5
, _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
| x == y = blank
| 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]
]
where
n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
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
x = (xx,xy,0)
xs = map (\(a,b) -> x +.+.+ (a,b,za)) [(w,0),(0,w),(-w,0),(0,-w)]
x = (V3 xx xy 0)
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])
f (a,b) = map f' [a,b,g b,g a]
g :: Point3 -> Point3
g (a,b,_) = (a,b,zb)
g (V3 a b _) = (V3 a b zb)
f' a = (a,col)
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
z <- state $ randomR (negate 1,1)
longitude <- state $ randomR (0, 2*pi)
let (x,y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude
return (x,y,z)
let (V2 x y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude
return (V3 x y z)
randOnHemisphere :: RandomGen g => State g Point3
randOnHemisphere = do
z <- state $ randomR (0,1)
longitude <- state $ randomR (0, 2*pi)
let (x,y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude
return (x,y,z)
let (V2 x y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude
return (V3 x y z)
randInHemisphere :: RandomGen g => State g Point3
randInHemisphere = do
@@ -92,7 +92,7 @@ randInHemisphere = do
randInRect :: RandomGen g => Float -> Float -> State g Point2
randInRect w h = do x <- state $ randomR (0,w)
y <- state $ randomR (0,h)
return (x,y)
return (V2 x y)
maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a)
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 Picture
import Geometry
import Geometry.Data
menuScreen
:: Configuration
@@ -108,8 +109,8 @@ controlsList = pictures $ concat $ zipWith butAndEff
screenBox
:: Float -- ^ Half screen width
-> Float -- ^ Half screen height
-> [(Float,Float)]
screenBox halfW halfH =
-> [Point2]
screenBox halfW halfH = map toV2
[ (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)
-- | Draw a rectangle based on maximal N E S W values.
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.
rectNSEW :: Float -> Float -> Float -> Float -> [Point2]
rectNSEW !n !s !e !w = rectNESW n e s w
-- | Draw a rectangle based on maximal N S W E values.
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
rectWdthHght :: Float -> Float -> [Point2]
rectWdthHght w h = rectNSWE h (-h) (-w) w
@@ -83,12 +83,12 @@ errorPointInPolygon !i !p xs
| otherwise = error $ "errorPointInPolygon "++ show i
-- | Debug version of 'normalizeV'.
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
-- | Debug version of 'angleVV'.
errorAngleVV :: Int -> Point2 -> Point2 -> Float
errorAngleVV !i (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 !i _ (V2 0 0) = error $ "problem with function: errorAngleVV "++show i
errorAngleVV _ !p !p' = angleVV p p'
-- | Debug version of 'isLHS'.
errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool
@@ -114,9 +114,9 @@ isLHS
-> Bool
{-# INLINE isLHS #-}
isLHS
(x,y)
(x',y')
(x'',y'')
(V2 x y)
(V2 x' y')
(V2 x'' y'')
| (x,y) == (x',y') = False
| otherwise = a1 * b2 - a2 * b1 > 0
where
@@ -133,9 +133,9 @@ isRHS
-> Bool
{-# INLINE isRHS #-}
isRHS
(x,y)
(x',y')
(x'',y'')
(V2 x y)
(V2 x' y')
(V2 x'' y'')
| (x,y) == (x',y') = False
| otherwise = a1 * b2 - a2 * b1 < 0
where
@@ -166,7 +166,7 @@ addPointPolygon p ps
| otherwise = orderPolygon $ p : ps
-- | Creates the convex hull of a set of points.
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"
grahamScan :: [Point2] -> [Point2]
@@ -259,10 +259,10 @@ polyToTris _ = []
-- | Return n equidistant points on a circle with a radius of 600.
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.
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
-- smallest change in rotation between them.
-- This appears to sometimes fail if the angles are not normalized.
@@ -366,7 +366,7 @@ reflectInParam :: Float -> Point2 -> Point2 -> Point2
reflectInParam x line vec =
let angle = 2 * angleBetween line 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
--reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2
--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
-- | TODO: implement using Control.Foldl
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
, Point3
, Point4
, V2 (..)
, V3 (..)
, V4 (..)
, toV2
, toV3
, toV4
, uncurryV
)
where
type Point2 = (Float,Float)
type Point3 = (Float,Float,Float)
type Point4 = (Float,Float,Float,Float)
import Linear.V2
import Linear.V3
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.
intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# 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
| 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
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
{-# 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 && (t' < 0 || u' < 0 || t' > den || u' > den)
= Nothing
| den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den)
= 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
den = (x1-x2)*(y3-y4) - (y1-y2)*(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.
intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# 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 && ( t' < 0 || u' < 0 || t' > den )
= Nothing
| den < 0 && ( t' > 0 || u' > 0 || t' < den )
= 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
den = (x1-x2)*(y3-y4) - (y1-y2)*(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...
intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# 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 && ( t' < 0 || u' < den || t' > den )
= Nothing
| den < 0 && ( t' > 0 || u' > - den || t' < den )
= 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
den = (x1-x2)*(y3-y4) - (y1-y2)*(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.
intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# 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 && (t' < 0 || t' > den)
= Nothing
| den < 0 && (t' > 0 || t' < den)
= 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
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
@@ -87,10 +87,10 @@ myIntersectSegSeg
-> Point2
-> 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
Just (x,y) -> if inbetween x && inbetween' y
then Just (x,y)
Just (V2 x y) -> if inbetween x && inbetween' y
then Just (V2 x y)
else Nothing
where
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))
&& ((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,_) b c@(cx,_) d
| isNothing (linGrad a b) = (ax ,) <$> axisInt (c *-* (ax,0)) (d *-* (ax,0))
| isNothing (linGrad c d) = (cx ,) <$> axisInt (a *-* (cx,0)) (b *-* (cx,0))
myIntersectLineLine :: (Eq a,Fractional a) => V2 a -> V2 a -> V2 a -> V2 a -> Maybe (V2 a)
myIntersectLineLine a@(V2 ax _) b c@(V2 cx _) d
| isNothing (linGrad a b) = (V2 ax) <$> axisInt (c *-* (V2 ax 0)) (d *-* (V2 ax 0))
| isNothing (linGrad c d) = (V2 cx) <$> axisInt (a *-* (V2 cx 0)) (b *-* (V2 cx 0))
| otherwise
= case linGrad a b ^-^ linGrad c d of
Just 0 -> Nothing
_ -> liftA2 (,) newx ((linGrad a b ^*^ newx) ^+^ axisInt a b)
_ -> liftA2 (V2) 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)
(*-*) (V2 ax' ay) (V2 bx by) = V2 (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 = 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)
toRatPoint2 (V2 x y) = V2 (toRational x) (toRational y)
toNumPoint2 (V2 x y) = V2 (fromRational x) (fromRational y)
{- | Round the floats within a 'Point2' to the nearest integer.
__Examples__
Rounding jumps after intervals of .5:
@@ -134,18 +134,15 @@ but is symmetric around 0:
-}
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.
linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a
linGrad (x,y) (a,b)
linGrad :: (Eq a,Fractional a) => V2 a -> V2 a -> Maybe a
linGrad (V2 x y) (V2 a b)
| x-a == 0 = Nothing
| otherwise = Just $ (y-b)/(x-a)
-- | 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 p (a,b) = pure b ^-^ (pure a ^*^ linGrad p (a,b))
where
(^-^) = liftA2 (-)
(^*^) = liftA2 (*)
axisInt :: (Eq a,Fractional a) => V2 a -> V2 a -> Maybe a
axisInt p (V2 a b) = fmap (\lg -> b - (a*lg)) $ linGrad p (V2 a b)
-- | Placeholder, undefined.
intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2
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. -}
zeroZ :: Point2 -> Point3
{-# INLINE zeroZ #-}
zeroZ (x,y) = (x,y,0)
zeroZ (V2 x y) = V3 x y 0
infixl 6 +.+, -.-
infixl 7 *.*
@@ -13,27 +13,29 @@ infixl 7 *.*
{- | 2D coordinate-wise addition. -}
(+.+) :: Point2 -> Point2 -> Point2
{-# INLINE (+.+) #-}
(x1, y1) +.+ (x2, y2) =
let
!x = x1 + x2
!y = y1 + y2
in (x, y)
(+.+) = (+)
--(x1, y1) +.+ (x2, y2) =
-- let
-- !x = x1 + x2
-- !y = y1 + y2
-- in (x, y)
{- | 2D coordinate-wise subtraction. -}
(-.-) :: Point2 -> Point2 -> Point2
{-# INLINE (-.-) #-}
(x1, y1) -.- (x2, y2) =
let
!x = x1 - x2
!y = y1 - y2
in (x, y)
(-.-) = (-)
--(x1, y1) -.- (x2, y2) =
-- let
-- !x = x1 - x2
-- !y = y1 - y2
-- in (x, y)
{- | 2D scalar multiplication. -}
(*.*) :: Float -> Point2 -> Point2
{-# INLINE (*.*) #-}
a *.* (x2, y2) =
a *.* V2 x2 y2 =
let
!x = a * x2
!y = a * y2
in (x, y)
in V2 x y
{- | Normalize a vector to length 1. -}
normalizeV :: Point2 -> Point2
@@ -53,31 +55,30 @@ angleVV a b
safeAngleVV :: Point2 -> Point2 -> Float
{-# INLINE safeAngleVV #-}
safeAngleVV a b
| a == (0,0) || b == (0,0) = 0
| a == V2 0 0 || b == V2 0 0 = 0
| otherwise = angleVV a b
{- | Dot product. -}
dotV :: Point2 -> Point2 -> Float
{-# 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. -}
argV :: Point2 -> Float
{-# 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. -}
detV :: Point2 -> Point2 -> Float
{-# 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,
- returns the corresponding unit vector. -}
unitVectorAtAngle :: Float -> Point2
{-# 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.
rotateV :: Float -> Point2 -> Point2
rotateV r (x, y) =
( x * cos r - y * sin r
, x * sin r + y * cos r
)
rotateV r (V2 x y) = V2
(x * cos r - y * sin r)
(x * sin r + y * cos r)
{-# INLINE rotateV #-}
-- | Convert degrees to radians
degToRad :: Float -> Float
@@ -97,23 +98,23 @@ normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi))
{- | Rotate vector by pi/2 clockwise. -}
vNormal :: Point2 -> Point2
{-# INLINE vNormal #-}
vNormal (x,y) = (y,-x)
vNormal (V2 x y) = V2 y (negate x)
{- | Negate a vector. -}
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). -}
safeNormalizeV :: Point2 -> Point2
{-# INLINE safeNormalizeV #-}
safeNormalizeV (0,0) = (0,0)
safeNormalizeV (V2 0 0) = V2 0 0
safeNormalizeV p = (1/magV p ) *.* p
{- | Magnitude of a vector. -}
magV :: Point2 -> Float
{-# 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.
Identical to detV. -}
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. -}
projV :: Point2 -> Point2 -> Point2
projV fromv onv
src/Geometry/Vector3D.hs
+28 -27
View File
@@ -12,55 +12,56 @@ infixl 7 *.*.*
{- | 3D coordinate-wise addition. -}
(+.+.+) :: Point3 -> Point3 -> Point3
{-# INLINE (+.+.+) #-}
(x1, y1, z1) +.+.+ (x2, y2, z2) =
let
!x = x1 + x2
!y = y1 + y2
!z = z1 + z2
in (x, y, z)
(+.+.+) = (+)
--(x1, y1, z1) +.+.+ (x2, y2, z2) =
-- let
-- !x = x1 + x2
-- !y = y1 + y2
-- !z = z1 + z2
-- in (x, y, z)
{- | 3D coordinate-wise subtraction. -}
(-.-.-) :: Point3 -> Point3 -> Point3
{-# INLINE (-.-.-) #-}
(x1, y1, z1) -.-.- (x2, y2, z2) =
let
!x = x1 - x2
!y = y1 - y2
!z = z1 - z2
in (x, y, z)
(-.-.-) = (-)
--(x1, y1, z1) -.-.- (x2, y2, z2) =
-- let
-- !x = x1 - x2
-- !y = y1 - y2
-- !z = z1 - z2
-- in (x, y, z)
{- | 3D scalar multiplication. -}
(*.*.*) :: Float -> Point3 -> Point3
{-# INLINE (*.*.*) #-}
a *.*.* (x2, y2, z2) =
a *.*.* (V3 x2 y2 z2) =
let
!x = a * x2
!y = a * y2
!z = a * z2
in (x, y, z)
in V3 x y z
crossProd :: Point3 -> Point3 -> Point3
crossProd (x,y,z) (a,b,c) =
( y * c - z * b
, z * a - x * c
, x * b - y * a
)
crossProd (V3 x y z) (V3 a b c) = V3
( y * c - z * b)
( z * a - x * c)
( x * b - y * a)
rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-}
rotate3 a (x,y,z) = (x',y',z)
rotate3 a (V3 x y z) = V3 x' y' z
where
(x',y') = rotateV a (x,y)
(V2 x' y') = rotateV a (V2 x y)
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
i = 2 :: Int
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
addZ :: Float -> Point2 -> Point3
addZ z (x,y) = (x,y,z)
addZ z (V2 x y) = V3 x y z
orderAround3
:: Point3 -- ^ Vector to order around
@@ -70,16 +71,16 @@ orderAround3 v ps = sortOn (argV . prj) ps
where
xdir = crossProd v (head ps)
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 ps = (1 / fromIntegral (length ps)) *.*.* foldr (+.+.+) (0,0,0) ps
vCen3 ps = (1 / fromIntegral (length ps)) *.*.* foldr (+.+.+) (V3 0 0 0) ps
dotV3
:: Point3
-> Point3
-> 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
:: Point3
src/MatrixHelper.hs
+9 -9
View File
@@ -16,16 +16,16 @@ perspectiveMatrixb
-> Point2 -- ^ Window size
-> Point2 -- ^ View froms
-> [GLfloat]
perspectiveMatrixb rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy) =
perspectiveMatrixb rot zoom (V2 tranx trany) (V2 winx winy) (V2 viewFromx viewFromy) =
concatMap vToL
. vToL
. lmt
$ scaleMat (2*zoom/winx,2*zoom/winy)
$ scaleMat (V2 (2*zoom/winx) (2*zoom/winy))
-- $ scaleMat (2/winx,2/winy)
!*! rotMatr (-rot)
!*! transMat (viewFromx-tranx,viewFromy-trany)
!*! transMat (V2 (viewFromx-tranx) (viewFromy-trany))
!*! perMat (zoom * 0.4)
!*! transMat (-viewFromx,-viewFromy)
!*! transMat (V2 (-viewFromx) (-viewFromy))
!*! vertScale
!*! vertTrans 20
-- !*! vertTrans 80
@@ -36,12 +36,12 @@ isoMatrix
-> Point2 -- ^ Translation
-> Point2 -- ^ Window size
-> [GLfloat]
isoMatrix rot zoom (tranx,trany) (winx,winy) = concatMap vToL
isoMatrix rot zoom (V2 tranx trany) (V2 winx winy) = concatMap vToL
. vToL
. lmt
$ scaleMat (2*zoom/winx,2*zoom/winy)
$ scaleMat (V2 (2*zoom/winx) (2*zoom/winy))
!*! rotMatr (-rot)
!*! transMat (-tranx,-trany)
!*! transMat (V2 (-tranx) (-trany))
lmt :: V4 (V4 a) -> V4 (V4 a)
lmt = Linear.Matrix.transpose
@@ -57,7 +57,7 @@ perMat x = V4
(V4 0 0 x 1)
scaleMat :: Point2 -> V4 (V4 Float)
scaleMat (x,y) = V4
scaleMat (V2 x y) = V4
(V4 x 0 0 0)
(V4 0 y 0 0)
(V4 0 0 1 0)
@@ -71,7 +71,7 @@ rotMatr a = V4
(V4 0 0 0 1)
transMat :: Point2 -> V4 (V4 Float)
transMat (x,y) = V4
transMat (V2 x y) = V4
(V4 1 0 0 x)
(V4 0 1 0 y)
(V4 0 0 1 0)
src/Picture.hs
+59 -58
View File
@@ -63,7 +63,7 @@ import Picture.Data
import Control.Lens
black :: RGBA
black = (0,0,0,1)
black = (V4 0 0 0 1)
--zl :: RenderType -> [(Int,RenderType)]
--zl rt = [(0,rt)]
@@ -84,7 +84,7 @@ polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol vs = map f $ polyToTris vs
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
{-# 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
| otherwise = bzhelp
[-- ( (0,0) , cola, (0,0), (0,0) )
(aIn, cola, (fa aIn,fc aIn) , (1,0) )
,(aIn, cola, (fa aIn,fc aIn) , (1,0) )
,(cIn, colc, (fa cIn,fc cIn) , (0,1) )
,( aX, cola, (1,0) , (fa' aX,fc' aX) )
,( cX, colc, (0,1) , (fa' cX,fc' cX) )
,( bX, colb, (0,0) , (fa' bX,fc' bX) )
,( bX, colb, (0,0) , (fa' bX,fc' bX) )
(aIn, cola, (V2 (fa aIn) (fc aIn)) , (V2 1 0) )
,(aIn, cola, (V2 (fa aIn) (fc aIn)) , (V2 1 0) )
,(cIn, colc, (V2 (fa cIn) (fc cIn)) , (V2 0 1) )
,( aX, cola, (V2 1 0) , (V2 (fa' aX) (fc' aX)) )
,( cX, colc, (V2 0 1) , (V2 (fa' cX) (fc' cX)) )
,( bX, colb, (V2 0 0) , (V2 (fa' bX) (fc' bX)) )
,( bX, colb, (V2 0 0) , (V2 (fa' bX) (fc' bX)) )
]
where
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
fc' = extrapolate cIn aIn bIn
bzhelp :: [(Point2, Point4, (Float, Float), (Float, Float))] -> Picture
bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
bzhelp = map f
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,
-- determine the function
-- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f
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 )
+ y * ( bx - ax )
+ (ax * by - bx * ay)
@@ -157,7 +157,7 @@ color c = map $ overCol (const c)
translate3 :: Float -> Float -> Point3 -> Point3
{-# 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
--{-# INLINE translate #-}
@@ -167,12 +167,12 @@ translate x y = map $ overPos (translate3 x y)
setDepth :: Float -> Picture -> Picture
--{-# INLINE setDepth #-}
--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
--{-# INLINE addDepth #-}
--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
{-# INLINE setLayer #-}
@@ -182,7 +182,7 @@ setLayer i = map f
scale3 :: Float -> Float -> Point3 -> Point3
{-# 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
--{-# INLINE scale #-}
@@ -197,9 +197,9 @@ pictures :: [Picture] -> Picture
{-# INLINE pictures #-}
pictures = concat
makeArc :: Float -> (Float,Float) -> [Point2]
makeArc :: Float -> Point2 -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (a,b) = map (`rotateV` (0,rad)) angles
makeArc rad (V2 a b) = map (`rotateV` (V2 0 rad)) angles
where
angles = [a,a+step.. b]
step = pi * 0.2
@@ -211,9 +211,9 @@ circleSolid = circleSolidCol white white
circleSolidCol :: Color -> Color -> Float -> Picture
{-# INLINE circleSolidCol #-}
circleSolidCol colC colE r = map f
[( (-r, r,0), colC)
,( (-r,-r,0), colE)
,( ( r,-r,0), black)
[( (V3 (-r) ( r) (0)), colC)
,( (V3 (-r) (-r) (0)), colE)
,( (V3 ( r) (-r) (0)), black)
]
where
f (pos,col) = Verx pos col EllV 0
@@ -273,7 +273,7 @@ arcSolid
-> Float -- ^ Radius
-> Picture
{-# 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
:: Float -- ^ Start angle
@@ -297,60 +297,61 @@ thickArc startA endA rad wdth
thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
thickArcHelp startA endA rad wdth = map f
[( (0,0,0),black,(0,0,wdth))
,((xa,ya,0),black,(1,0,wdth))
,((xb,yb,0),black,(1,1,wdth))
,( (0,0,0),black,(0,0,wdth))
,((xb,yb,0),black,(1,1,wdth))
,((xc,yc,0),black,(0,1,wdth))
[( (V3 0 0 0),black,(V3 0 0 wdth))
,((V3 xa ya 0),black,(V3 1 0 wdth))
,((V3 xb yb 0),black,(V3 1 1 wdth))
,( (V3 0 0 0),black,(V3 0 0 wdth))
,((V3 xb yb 0),black,(V3 1 1 wdth))
,((V3 xc yc 0),black,(V3 0 1 wdth))
]
where
(xa,ya) = rotateV startA (rad,0)
(xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
(xc,yc) = rotateV endA (rad,0)
(V2 xa ya) = rotateV startA (V2 rad 0)
(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) (0))
(V2 xc yc) = rotateV endA (V2 rad 0)
f (pos,col,val) = Verx pos col (ArcV val) 0
withAlpha :: Float -> RGBA -> RGBA
{-# 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 = (1,0,0,1)
green = (0,1,0,1)
blue = (0,0,1,1)
yellow = (1,1,0,1)
cyan = (0,1,1,1)
magenta = (1,0,1,1)
rose = (1,0,0.5,1)
violet = (0.5,0,1,1)
azure = (0,0.5,1,1)
aquamarine= (0,1,0.5,1)
chartreuse= (0.5,1,0,1)
orange = (1,0.5,0,1)
white = (1,1,1,1)
red = toV4 (1,0,0,1)
green = toV4 (0,1,0,1)
blue = toV4 (0,0,1,1)
yellow = toV4 (1,1,0,1)
cyan = toV4 (0,1,1,1)
magenta = toV4 (1,0,1,1)
rose = toV4 (1,0,0.5,1)
violet = toV4 (0.5,0,1,1)
azure = toV4 (0,0.5,1,1)
aquamarine= toV4 (0,1,0.5,1)
chartreuse= toV4 (0.5,1,0,1)
orange = toV4 (1,0.5,0,1)
white = toV4 (1,1,1,1)
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
normrata = rata / fullrat
normratb = ratb / fullrat
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 (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 (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 (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 (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 x = (x,x,x,1)
greyN x = toV4 (x,x,x,1)
overPos :: (Point3 -> Point3) -> Verx -> Verx
{-# INLINE overPos #-}
@@ -370,12 +371,12 @@ stringToList s = concatMap (uncurry charToTuple) $ zip [0,0.9*dimText ..] s
charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
{-# INLINE charToTuple #-}
charToTuple x c =
[((x-50,-100,0), white,(offset,1))
,((x-50,100,0), white,(offset,0))
,((x+50,100,0), white,(offset+1,0))
,((x-50,-100,0), white,(offset,1))
,((x+50,-100,0), white,(offset+1,1))
,((x+50,100,0), white,(offset+1,0))
[((V3 (x-50) (-100) (0)), white,(V2 offset 1))
,((V3 (x-50) (100) (0)), white,(V2 offset 0))
,((V3 (x+50) (100) (0)), white,(V2 (offset+1) 0))
,((V3 (x-50) (-100) (0)), white,(V2 offset 1))
,((V3 (x+50) (-100) (0)), white,(V2 (offset+1) 1))
,((V3 (x+50) (100) (0)), white,(V2 (offset+1) 0))
]
where
offset = fromIntegral (fromEnum c) - 32
src/Picture/Data.hs
+17 -8
View File
@@ -49,8 +49,8 @@ data RenderType
deriving Generic
instance NFData RenderType
type RGBA = (Float,Float,Float,Float)
type Color = (Float,Float,Float,Float)
type RGBA = Point4
type Color = Point4
data 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 (RLeaf x) = RLeaf (f x)
flat2 :: (a,a) -> [a]
flat2 (x,y) = [x,y]
flat3 :: (a,a,a) -> [a]
flat3 (x,y,z) = [x,y,z]
flat4 :: (a,a,a,a) -> [a]
flat4 (x,y,z,w) = [x,y,z,w]
flat2 :: V2 a -> [a]
flat2 (V2 x y) = [x,y]
flat3 :: V3 a -> [a]
flat3 (V3 x y z) = [x,y,z]
flat4 :: V4 a -> [a]
flat4 (V4 x y z w) = [x,y,z,w]
{-# INLINE flat2 #-}
{-# INLINE flat3 #-}
{-# 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]
src/Polyhedra.hs
+9 -9
View File
@@ -15,7 +15,7 @@ import Control.Lens
translateXY :: Float -> Float -> Polyhedra -> Polyhedra
translateXY x y = pyFaces %~ map (map $ first tran)
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 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 a b =
[(0,0,0)
[(V3 0 0 0)
,a
,a +.+.+ b
,b
@@ -58,16 +58,16 @@ rhombus a b =
boxXYZ :: Float -> Float -> Float -> [[Point3]]
boxXYZ x y z =
[ bottomFace
, map (+.+.+ (0,0,z)) $ reverse bottomFace
, map (+.+.+ (V3 0 0 z)) $ reverse bottomFace
, frontFace
, map (+.+.+ (0,y,0)) $ reverse frontFace
, map (+.+.+ (V3 0 y 0)) $ reverse frontFace
, sideFace
, map (+.+.+ (x,0,0)) $ reverse sideFace
, map (+.+.+ (V3 x 0 0)) $ reverse sideFace
]
where
bottomFace = rhombus (0,y,0) (x,0,0)
frontFace = rhombus (x,0,0) (0,0,z)
sideFace = rhombus (0,0,z) (0,y,0)
bottomFace = rhombus (V3 0 y 0) (V3 x 0 0)
frontFace = rhombus (V3 x 0 0) (V3 0 0 z)
sideFace = rhombus (V3 0 0 z) (V3 0 y 0)
boxABC :: Point3 -> Point3 -> Point3 -> [[Point3]]
boxABC a b c =
[ faceNC
@@ -98,7 +98,7 @@ polyToEdges = constructEdges . map (map fst) . _pyFaces
-- rendering for silhouette
polyToRender :: Polyhedra -> [RenderType]
polyToRender = map (Render3 . flat4) . polyToEdges
polyToRender = map (Render3 . tflat4) . polyToEdges
-- rendering for shape
polyToGeoRender :: Polyhedra -> [RenderType]
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 = 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]
, 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.Parameters
import Data.Preload.Render
import Geometry.Data
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
import Graphics.GL.Core43
@@ -229,19 +230,19 @@ poke3 (Render3 vs) = map flat3 vs
poke3 _ = undefined
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
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
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
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
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)
stencilTest $= Enabled
depthFunc $= Just Lequal
forM_ lightPoints $ \((x,y,z),r,lum) -> do
forM_ lightPoints $ \((V3 x y z),r,lum) -> do
-- stencil out shadows
colorMask $= Color4 Disabled Disabled Disabled Disabled
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
where
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 8 y
>> pokeElemOff thePtr 9 z
>> pokeElemOff thePtr 10 w
where
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 8 y
where
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 8 y
>> 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 ()
{-# 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 1 b
pokeElemOff ptr 2 c
@@ -148,7 +148,7 @@ pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int
pokePoint33s ptr vals0 = go vals0 0
where
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 1) b
pokeElemOff ptr (off 2) c
@@ -163,7 +163,7 @@ pokePoint3s :: Ptr Float -> [Point3] -> IO Int
pokePoint3s ptr vals0 = go vals0 0
where
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 1) b
pokeElemOff ptr (off 2) c
@@ -186,19 +186,19 @@ pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vx
>> pokeElemOff thePtr 7 x
where
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 8 y
>> pokeElemOff thePtr 9 z
>> pokeElemOff thePtr 10 w
where
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 8 y
where
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 8 y
>> pokeElemOff thePtr 9 z
src/Tile.hs
+8 -6
View File
@@ -10,8 +10,11 @@ tToRender t = map Render3x3 $ polyToTris $ zip ps3 coords3
where
ps = _tilePoly t
coords = map (calcTexCoord (_tileCenter t) (_tileX t) (_tileY t)) ps
ps3 = map (mkTrip 0) ps
coords3 = map (mkTrip (_tileZ t)) coords
ps3 = map (addToV2 0) ps
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 z (x,y) = (x,y,z)
@@ -22,10 +25,9 @@ calcTexCoord
-> Point2 -- ^ tile (0,1)
-> Point2 -- ^ world point
-> Point2
calcTexCoord cen x' y' p =
( magV (projV (p -.- cen) x) / magV x
, magV (projV (p -.- cen) y) / magV y
)
calcTexCoord cen x' y' p = V2
( magV (projV (p -.- cen) x) / magV x )
( magV (projV (p -.- cen) y) / magV y )
where
x = x' -.- cen
y = y' -.- cen