Initial implementation of bezier bullet
This commit is contained in:
@@ -35,6 +35,11 @@ midPadL :: Int -> a -> [a] -> [a] -> [a]
|
||||
midPadL i x xs ys = take j (xs ++ repeat x) ++ ys
|
||||
where j = i - length ys
|
||||
|
||||
takeUntil :: (a -> Bool) -> [a] -> [a]
|
||||
takeUntil f ps = case span f ps of
|
||||
(xs,[]) -> xs
|
||||
(xs,(y:_)) -> xs ++ [y]
|
||||
|
||||
you :: World -> Creature
|
||||
you w = _creatures w IM.! _yourID w
|
||||
|
||||
|
||||
@@ -1425,14 +1425,11 @@ bezierControl targetp cid w = resetGun $ shootWithSound 0 (mkBezierBul startp co
|
||||
resetGun = set (creatures . ix cid . crInv . ix j . wpFire) $ bezierTarget
|
||||
|
||||
mkBezierBul :: Point2 -> Point2 -> Point2 -> Int -> World -> World
|
||||
mkBezierBul startp controlp targetp cid w = over particles' (bbul 30 :) w
|
||||
mkBezierBul startp controlp targetp cid w = over particles' (bbul :) w
|
||||
where
|
||||
bbul i = Particle'
|
||||
{_ptPict' = onLayerL [levLayer PtLayer ] $ bezierQuad white white 5 5 startp controlp targetp
|
||||
,_ptUpdate' = \w p -> case i of 0 -> (w, Nothing)
|
||||
n -> (w, Just $ bbul (i-1))
|
||||
}
|
||||
|
||||
bbul = aCurveBulAt (Just cid) white startp controlp targetp
|
||||
(threeEff' bulHitCr' bulHitWall' bulHitFF') 5
|
||||
|
||||
fireRemoteLauncher :: Int -> World -> World
|
||||
fireRemoteLauncher cid w = setLocation $ resetFire $ resetName
|
||||
$ soundOnce (fromIntegral launcherSound)
|
||||
|
||||
@@ -231,6 +231,22 @@ aGenBulAt' maycid col pos vel hiteff width = Bul'
|
||||
, _btTrail' = [pos]
|
||||
, _btPassThrough' = maycid
|
||||
, _btWidth' = width
|
||||
, _btTimer' = 90
|
||||
, _btTimer' = 100
|
||||
, _btHitEffect' = hiteff
|
||||
}
|
||||
|
||||
aCurveBulAt :: Maybe Int -> Color -> Point2 -> Point2 -> Point2 -> HitEffect' -> Float -> Particle'
|
||||
aCurveBulAt maycid col pos control targ hiteff width = Bul'
|
||||
{ _ptPict' = blank
|
||||
, _ptUpdate' = mvBulletTrajectory f
|
||||
, _btVel' = (0,0)
|
||||
, _btColor' = col
|
||||
, _btTrail' = [pos]
|
||||
, _btPassThrough' = maycid
|
||||
, _btWidth' = width
|
||||
, _btTimer' = 100
|
||||
, _btHitEffect' = hiteff
|
||||
}
|
||||
where f i = g $ (100 - fromIntegral i) / 10
|
||||
g x = map (bf . (+ x)) [0,0.01..0.09]
|
||||
bf = bQuadToF (pos,control,targ)
|
||||
|
||||
@@ -1,4 +1,10 @@
|
||||
module Dodge.WorldActions where
|
||||
module Dodge.WorldActions
|
||||
( module Dodge.WorldActions
|
||||
, module Dodge.WorldActions.Bullet
|
||||
)
|
||||
where
|
||||
|
||||
import Dodge.WorldActions.Bullet
|
||||
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
@@ -425,93 +431,8 @@ threeEff' crEff wlEff ffEff pt thing w = case thing of
|
||||
(p,E3x2 wl) -> wlEff pt p wl w
|
||||
(p,E3x3 ff) -> ffEff pt p ff w
|
||||
|
||||
mvGenBullet' :: World -> Particle' -> (World, Maybe Particle')
|
||||
mvGenBullet' w bt
|
||||
| t <= 0 = (w, Nothing)
|
||||
| t < 4 = (w, Just $ set btPassThrough' Nothing
|
||||
$ set btTrail' (p:p:ps)
|
||||
$ set ptPict' (bulLine col wth (p:p:ps))
|
||||
$ set btTimer' (t-1) bt
|
||||
)
|
||||
| otherwise = case thingsHitExceptCr mcr p (p +.+ vel) w of
|
||||
[] -> (w, Just $ set btPassThrough' Nothing
|
||||
$ set btTrail' (p +.+ vel :p:ps)
|
||||
$ set ptPict' (bulLine col wth (p +.+ vel:p:ps))
|
||||
$ set btTimer' (t-1) bt
|
||||
)
|
||||
((hitp,thing):_)
|
||||
-> ( hiteff bt (hitp,thing) w
|
||||
, Just $ set btPassThrough' Nothing
|
||||
$ set btTrail' (hitp:p:ps)
|
||||
$ set ptPict' (bulLine col wth (hitp:p:ps))
|
||||
$ set btTimer' 3 bt
|
||||
)
|
||||
where mcr = _btPassThrough' bt
|
||||
col = _btColor' bt
|
||||
(p:ps) = _btTrail' bt
|
||||
vel = _btVel' bt
|
||||
hiteff = _btHitEffect' bt
|
||||
wth = _btWidth' bt
|
||||
t = _btTimer' bt
|
||||
|
||||
bulLine c w = setLayer 1 . bulLinea c w
|
||||
|
||||
bulLinea :: Color -> Float -> [Point2] -> Picture
|
||||
bulLinea _ _ [] = blank
|
||||
bulLinea _ _ (x:[]) = blank
|
||||
bulLinea col width (a:b:[]) -- (a:b:[])
|
||||
= onLayer HPtLayer $ pictures $ reverse
|
||||
[polygonCol $ zip (wedgeGeom width b a) $ [white,withAlpha 0 white,withAlpha 0 white]
|
||||
,polygonCol $ zip (lineGeom (width+1.5) a b) $ [col,col,withAlpha 0 col,withAlpha 0 col]
|
||||
]
|
||||
bulLinea col width (a:b:c:[]) -- (a:b:[])
|
||||
= onLayer HPtLayer $ pictures $ reverse
|
||||
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
|
||||
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
|
||||
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
|
||||
]
|
||||
bulLinea col width (a:b:_:c:[]) -- (a:b:[])
|
||||
= onLayer HPtLayer $ pictures $ reverse
|
||||
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
|
||||
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
|
||||
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
|
||||
]
|
||||
bulLinea col width (a:b:_:_:c:_) -- (a:b:[])
|
||||
= onLayer HPtLayer $ pictures $ reverse
|
||||
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
|
||||
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
|
||||
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
|
||||
]
|
||||
-- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,b]
|
||||
-- ,color white $ wedgeOfThickness width a b
|
||||
--bulLine col width (a:b:c:_)
|
||||
-- = onLayer HPtLayer $ pictures
|
||||
-- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c]
|
||||
-- ,color white $ wedgeOfThickness width a c
|
||||
|
||||
thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World
|
||||
-> [(Point2, (Either3 Creature Wall ForceField))]
|
||||
thingsHitExceptCr Nothing sp ep = thingsHit sp ep
|
||||
thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
|
||||
where crNotCid (_,(E3x1 cr)) = _crID cr /= cid
|
||||
crNotCid _ = True
|
||||
|
||||
thingsHit :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))]
|
||||
thingsHit sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
|
||||
where hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
|
||||
$ creaturesAlongLine sp ep w
|
||||
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
|
||||
crs = zip crPs (map E3x1 hitCrs)
|
||||
-- hitWls = wallsOnLine sp ep (f y $ f x $ _wallsZone w)
|
||||
hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1]
|
||||
, b<-[y-1,y,y+1]])
|
||||
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
|
||||
f i m = case IM.lookup i m of Just val -> val
|
||||
_ -> IM.empty
|
||||
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
|
||||
hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
|
||||
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
|
||||
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
|
||||
|
||||
thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World
|
||||
-> [(Point2, (Either3 Creature Wall ForceField))]
|
||||
|
||||
+6
-254
@@ -2,9 +2,15 @@
|
||||
module Geometry
|
||||
( module Geometry
|
||||
, module Geometry.Data
|
||||
, module Geometry.Intersect
|
||||
, module Geometry.Bezier
|
||||
, module Geometry.Vector
|
||||
)
|
||||
where
|
||||
import Geometry.Data
|
||||
import Geometry.Intersect
|
||||
import Geometry.Bezier
|
||||
import Geometry.Vector
|
||||
|
||||
import Data.Function
|
||||
import Data.List
|
||||
@@ -12,81 +18,6 @@ import Data.Maybe
|
||||
|
||||
import Control.Applicative
|
||||
|
||||
zeroZ :: Point2 -> Point3
|
||||
{-# INLINE zeroZ #-}
|
||||
zeroZ (x,y) = (x,y,0)
|
||||
|
||||
infixl 6 +.+, -.-
|
||||
infixl 7 *.*
|
||||
|
||||
(+.+) :: Point2 -> Point2 -> Point2
|
||||
{-# INLINE (+.+) #-}
|
||||
(x1, y1) +.+ (x2, y2) =
|
||||
let
|
||||
!x = x1 + x2
|
||||
!y = y1 + y2
|
||||
in (x, y)
|
||||
|
||||
(-.-) :: Point2 -> Point2 -> Point2
|
||||
{-# INLINE (-.-) #-}
|
||||
(x1, y1) -.- (x2, y2) =
|
||||
let
|
||||
!x = x1 - x2
|
||||
!y = y1 - y2
|
||||
in (x, y)
|
||||
|
||||
(*.*) :: Float -> Point2 -> Point2
|
||||
{-# INLINE (*.*) #-}
|
||||
a *.* (x2, y2) =
|
||||
let
|
||||
!x = a * x2
|
||||
!y = a * y2
|
||||
in (x, y)
|
||||
|
||||
infixl 6 +.+.+, -.-.-
|
||||
infixl 7 *.*.*
|
||||
|
||||
(+.+.+) :: Point3 -> Point3 -> Point3
|
||||
{-# INLINE (+.+.+) #-}
|
||||
(x1, y1, z1) +.+.+ (x2, y2, z2) =
|
||||
let
|
||||
!x = x1 + x2
|
||||
!y = y1 + y2
|
||||
!z = z1 + z2
|
||||
in (x, y, z)
|
||||
|
||||
(-.-.-) :: Point3 -> Point3 -> Point3
|
||||
{-# INLINE (-.-.-) #-}
|
||||
(x1, y1, z1) -.-.- (x2, y2, z2) =
|
||||
let
|
||||
!x = x1 - x2
|
||||
!y = y1 - y2
|
||||
!z = z1 - z2
|
||||
in (x, y, z)
|
||||
|
||||
(*.*.*) :: Point3 -> Point3 -> Point3
|
||||
{-# INLINE (*.*.*) #-}
|
||||
(x1, y1, z1) *.*.* (x2, y2, z2) =
|
||||
let
|
||||
!x = x1 * x2
|
||||
!y = y1 * y2
|
||||
!z = z1 * z2
|
||||
in (x, y, z)
|
||||
|
||||
normalizeV :: Point2 -> Point2
|
||||
{-# INLINE normalizeV #-}
|
||||
normalizeV p = (1 / magV p) *.* p
|
||||
|
||||
angleVV :: Point2 -> Point2 -> Float
|
||||
{-# INLINE angleVV #-}
|
||||
angleVV a b = let ma = magV a
|
||||
mb = magV b
|
||||
d = a `dotV` b
|
||||
in acos $ d / (ma * mb)
|
||||
|
||||
dotV :: Point2 -> Point2 -> Float
|
||||
{-# INLINE dotV #-}
|
||||
dotV (x,y) (z,w) = x*z + y*w
|
||||
|
||||
closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2
|
||||
{-# INLINE closestPointOnLine #-}
|
||||
@@ -99,46 +30,7 @@ closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float
|
||||
closestPointOnLineParam a b p
|
||||
= (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a)
|
||||
|
||||
argV :: Point2 -> Float
|
||||
{-# INLINE argV #-}
|
||||
argV (x,y) = normalizeAngle $ atan2 y x
|
||||
|
||||
detV :: Point2 -> Point2 -> Float
|
||||
{-# INLINE detV #-}
|
||||
detV (x1, y1) (x2, y2)
|
||||
= x1 * y2 - y1 * x2
|
||||
|
||||
-- | Angle in radians, anticlockwise from +ve x-axis.
|
||||
unitVectorAtAngle :: Float -> Point2
|
||||
{-# INLINE unitVectorAtAngle #-}
|
||||
unitVectorAtAngle r
|
||||
= (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)
|
||||
{-# INLINE rotateV #-}
|
||||
|
||||
-- | Convert degrees to radians
|
||||
degToRad :: Float -> Float
|
||||
degToRad d = d * pi / 180
|
||||
{-# INLINE degToRad #-}
|
||||
|
||||
|
||||
-- | Convert radians to degrees
|
||||
radToDeg :: Float -> Float
|
||||
radToDeg r = r * 180 / pi
|
||||
{-# INLINE radToDeg #-}
|
||||
|
||||
|
||||
-- | Normalize an angle to be between 0 and 2*pi radians
|
||||
normalizeAngle :: Float -> Float
|
||||
normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi))
|
||||
where floor' :: Float -> Float
|
||||
floor' x = fromIntegral (floor x :: Int)
|
||||
{-# INLINE normalizeAngle #-}
|
||||
|
||||
-- the following helper draws a rectangle based on maximal N E S W values
|
||||
rectNESW :: Float -> Float -> Float -> Float -> [Point2]
|
||||
@@ -225,79 +117,14 @@ orderPolygon [] = []
|
||||
orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps
|
||||
where cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps
|
||||
|
||||
vNormal :: Point2 -> Point2
|
||||
{-# INLINE vNormal #-}
|
||||
vNormal (x,y) = (y,-x)
|
||||
|
||||
vInverse :: Point2 -> Point2
|
||||
vInverse (x,y) = (-x,-y)
|
||||
|
||||
dist :: Point2 -> Point2 -> Float
|
||||
{-# INLINE dist #-}
|
||||
dist p1 p2 = magV (p2 -.- p1)
|
||||
|
||||
normV :: Point2 -> Point2
|
||||
{-# INLINE normV #-}
|
||||
normV (0,0) = (0,0)
|
||||
normV p = (1/magV p ) *.* p
|
||||
|
||||
magV :: Point2 -> Float
|
||||
{-# INLINE magV #-}
|
||||
magV (x,y) = sqrt $ x^2 + y^2
|
||||
|
||||
pHalf :: Point2 -> Point2 -> Point2
|
||||
pHalf a b = 0.5 *.* (a +.+ b)
|
||||
|
||||
linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a
|
||||
linGrad (x,y) (a,b) | x-a == 0 = Nothing
|
||||
| otherwise = Just $ (y-b)/(x-a)
|
||||
|
||||
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 (*)
|
||||
|
||||
-- intersectSegSeg is sometimes broken-- the following fixes at least some of
|
||||
-- the cases
|
||||
-- it is, however, slow
|
||||
myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of
|
||||
Nothing -> Nothing
|
||||
Just (x,y) -> if inbetween x && inbetween' y
|
||||
then Just (x,y)
|
||||
else Nothing
|
||||
where inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) &&
|
||||
((cx <= x && x <= dx) || (dx <= x && x <= cx))
|
||||
inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) &&
|
||||
((cy <= y && y <= dy) || (dy <= y && y <= cy))
|
||||
|
||||
crossV :: Point2 -> Point2 -> Float
|
||||
crossV (ax,ay) (bx,by) = ax*by - ay*bx
|
||||
|
||||
myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a)
|
||||
myIntersectLineLine a@(ax,ay) b c@(cx,cy) d
|
||||
| linGrad a b == Nothing = fmap ((,) ax) $ axisInt (c *-* (ax,0)) (d *-* (ax,0))
|
||||
| linGrad c d == Nothing = fmap ((,) cx) $ axisInt (a *-* (cx,0)) (b *-* (cx,0))
|
||||
| otherwise
|
||||
= case linGrad a b ^-^ linGrad c d of
|
||||
Just 0 -> Nothing
|
||||
_ -> liftA2 (,) newx
|
||||
((linGrad a b ^*^ newx) ^+^ axisInt a b)
|
||||
where (^-^) = liftA2 (-)
|
||||
(^+^) = liftA2 (+)
|
||||
(^/^) = liftA2 (/)
|
||||
(^*^) = liftA2 (*)
|
||||
newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d)
|
||||
(*-*) (ax,ay) (bx,by) = (ax-bx,ay-by)
|
||||
|
||||
ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d)
|
||||
where toRatPoint2 (x,y) = (toRational x, toRational y)
|
||||
toNumPoint2 (x,y) = (fromRational x, fromRational y)
|
||||
f = toRatPoint2 . roundPoint2
|
||||
|
||||
roundPoint2 :: Point2 -> Point2
|
||||
roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y)
|
||||
|
||||
circOnLine' :: Point2 -> Point2 -> Point2 -> Float -> Bool
|
||||
circOnLine' p1 p2 c rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
|
||||
where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
|
||||
@@ -502,78 +329,3 @@ lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps
|
||||
|| any (isJust . uncurry (intersectSegSeg' a b)) pss
|
||||
where pss = zip ps (tail ps ++ [head ps])
|
||||
|
||||
--intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
--intersectSegLineFrom a b c d
|
||||
-- = case intersectSegLine a b c d of
|
||||
-- Just p | closestPointOnLineParam c d p >= 0 -> Just p
|
||||
-- | otherwise -> Nothing
|
||||
-- Nothing -> Nothing
|
||||
|
||||
intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectSegSeg' #-}
|
||||
intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
-- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0
|
||||
-- = Nothing
|
||||
| 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
|
||||
-- | den > 0 && (t' < 0 || t' > den)
|
||||
-- = Nothing
|
||||
-- | den < 0 && (t' > 0 || t' < 0-den)
|
||||
-- = Nothing
|
||||
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
|
||||
where
|
||||
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
|
||||
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
|
||||
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
|
||||
|
||||
intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectSegLineFrom' #-}
|
||||
intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
-- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0
|
||||
-- = Nothing
|
||||
| den == 0 = Nothing
|
||||
| den > 0 && ( t' < 0 || u' < 0 || t' > den )
|
||||
= Nothing
|
||||
| den < 0 && ( t' > 0 || u' > 0 || t' < den )
|
||||
= Nothing
|
||||
-- | den > 0 && (t' < 0 || t' > den)
|
||||
-- = Nothing
|
||||
-- | den < 0 && (t' > 0 || t' < 0-den)
|
||||
-- = Nothing
|
||||
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
|
||||
where
|
||||
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
|
||||
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
|
||||
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
|
||||
|
||||
intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectSegLine' #-}
|
||||
intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
-- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0
|
||||
-- = Nothing
|
||||
| den == 0 = Nothing
|
||||
| den > 0 && (t' < 0 || t' > den)
|
||||
= Nothing
|
||||
| den < 0 && (t' > 0 || t' < den)
|
||||
= Nothing
|
||||
-- | den > 0 && (t' < 0 || t' > den)
|
||||
-- = Nothing
|
||||
-- | den < 0 && (t' > 0 || t' < 0-den)
|
||||
-- = Nothing
|
||||
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
|
||||
where
|
||||
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
|
||||
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
|
||||
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
|
||||
|
||||
intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectLineLine' #-}
|
||||
intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
| den == 0 = Nothing
|
||||
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
|
||||
where
|
||||
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
|
||||
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
|
||||
|
||||
+4
-1
@@ -71,7 +71,10 @@ polygonCol = PolygonCol 0
|
||||
|
||||
-- note that much of work computing the width of the bezier curve is done here
|
||||
bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
|
||||
bezierQuad cola colc ra rc a b c = BezierQuad 0 [-- ( (0,0) , cola, (0,0), (0,0) )
|
||||
bezierQuad cola colc ra rc a b c
|
||||
| a == b && b == c = blank
|
||||
| a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
|
||||
| otherwise = BezierQuad 0 [-- ( (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) )
|
||||
|
||||
Reference in New Issue
Block a user