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/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