{-# LINE 1 "Physics/Hipmunk/Shape.hsc" #-}-----------------------------------------------------------------------------{-# LINE 2 "Physics/Hipmunk/Shape.hsc" #-}-- |-- Module : Physics/Hipmunk/Shape.hsc-- Copyright : (c) 2008-2010 Felipe A. Lessa-- License : MIT (see LICENSE)---- Maintainer : felipe.lessa@gmail.com-- Stability : provisional-- Portability : portable (needs FFI)---- Shapes used for collisions, their properties and some useful-- polygon functions.-------------------------------------------------------------------------------modulePhysics.Hipmunk.Shape(-- * ShapesShape,ShapeType(..),newShape,-- * Properties-- ** Collision typeCollisionType,collisionType,-- ** GroupGroup,group,-- ** LayersLayers,layers,-- ** ElasticityElasticity,elasticity,-- ** FrictionFriction,friction,-- ** Surface velocitySurfaceVel,surfaceVel,-- * Utilitiesbody,momentForShape,momentForCircle,momentForSegment,momentForPoly,shapePointQuery,shapeSegmentQuery,-- ** For polygons-- $polygon_utilSegment,Intersection(..),epsilon,(.==.),isLeft,isClockwise,isConvex,intersects,polyReduce,polyCenter,convexHull)whereimportData.List(foldl',sortBy)importData.StateVarimportForeignhiding(rotate,new)importForeign.C{-# LINE 72 "Physics/Hipmunk/Shape.hsc" #-}importPhysics.Hipmunk.CommonimportPhysics.Hipmunk.InternalimportPhysics.Hipmunk.Body(Mass,Moment)-- | There are three types of shapes that can be attached-- to bodies:dataShapeType=-- | A circle is the fastest collision type. It also-- rolls smoothly.Circle{radius::!Distance}-- | A line segment is meant to be used as a static-- shape. (It can be used with moving bodies, however-- two line segments never generate collisions between-- each other.)|LineSegment{start::!Position,end::!Position,thickness::!Distance}-- | Polygons are the slowest of all shapes but-- the most flexible. The list of vertices must form-- a convex hull with clockwise winding.-- Note that if you want a non-convex polygon you may-- add several convex polygons to the body.|Polygon{vertices::![Position]}deriving(Eq,Ord,Show)-- | @newShape b type off@ creates a new shape attached to-- body @b@ at offset @off@. Note that you have to-- add the shape to a space otherwise it won't generate-- collisions.newShape::Body->ShapeType->Position->IOShapenewShapebody_@(Bb)(Circler)off=withForeignPtrb$\b_ptr->withoff$\off_ptr->mallocForeignPtrBytes(140)>>=\shape->{-# LINE 110 "Physics/Hipmunk/Shape.hsc" #-}withForeignPtrshape$\shape_ptr->dowrCircleShapeInitshape_ptrb_ptroff_ptrrreturn(Sshapebody_)newShapebody_@(Bb)(LineSegmentp1p2r)off=withForeignPtrb$\b_ptr->with(p1+off)$\p1off_ptr->with(p2+off)$\p2off_ptr->mallocForeignPtrBytes(204)>>=\shape->{-# LINE 119 "Physics/Hipmunk/Shape.hsc" #-}withForeignPtrshape$\shape_ptr->dowrSegmentShapeInitshape_ptrb_ptrp1off_ptrp2off_ptrrreturn(Sshapebody_)newShapebody_@(Bb)(Polygonverts)off=withForeignPtrb$\b_ptr->withoff$\off_ptr->withArrayLenverts$\verts_lenverts_ptr->mallocForeignPtrBytes(120)>>=\shape->{-# LINE 128 "Physics/Hipmunk/Shape.hsc" #-}withForeignPtrshape$\shape_ptr->doletverts_len'=fromIntegralverts_lenwrPolyShapeInitshape_ptrb_ptrverts_len'verts_ptroff_ptraddForeignPtrFinalizercpShapeDestroyshapereturn(Sshapebody_)foreignimportccallunsafe"wrapper.h"wrCircleShapeInit::ShapePtr->BodyPtr->VectorPtr->CpFloat->IO()foreignimportccallunsafe"wrapper.h"wrSegmentShapeInit::ShapePtr->BodyPtr->VectorPtr->VectorPtr->CpFloat->IO()foreignimportccallunsafe"wrapper.h"wrPolyShapeInit::ShapePtr->BodyPtr->CInt->VectorPtr->VectorPtr->IO()foreignimportccallunsafe"wrapper.h &cpShapeDestroy"cpShapeDestroy::FunPtr(ShapePtr->IO())-- | @body s@ is the body that this shape is associated-- to. Useful especially in a space callback.body::Shape->Bodybody(S_b)=b-- | The collision type is used to determine which collision-- callback will be called. Its actual value doesn't have a-- meaning for Chipmunk other than the correspondence between-- shapes and the collision pair functions you add. (default is-- zero)typeCollisionType=Word32{-# LINE 160 "Physics/Hipmunk/Shape.hsc" #-}collisionType::Shape->StateVarCollisionTypecollisionType(Sshape_)=makeStateVargettersetterwheregetter=withForeignPtrshape(\hsc_ptr->peekByteOffhsc_ptr80){-# LINE 164 "Physics/Hipmunk/Shape.hsc" #-}setter=withForeignPtrshape.flip(\hsc_ptr->pokeByteOffhsc_ptr80){-# LINE 165 "Physics/Hipmunk/Shape.hsc" #-}-- | Groups are used to filter collisions between shapes. If-- the group is zero, then it imposes no restriction-- to the collisions. However, if the group is non-zero then-- the shape will not collide with other shapes in the same-- non-zero group. (default is zero)---- This is primarely used to create multi-body, multi-shape-- objects such as ragdolls. It may be thought as a lightweight-- alternative to creating a callback that filters the-- collisions.typeGroup=Word32{-# LINE 177 "Physics/Hipmunk/Shape.hsc" #-}group::Shape->StateVarGroupgroup(Sshape_)=makeStateVargettersetterwheregetter=withForeignPtrshape(\hsc_ptr->peekByteOffhsc_ptr84){-# LINE 181 "Physics/Hipmunk/Shape.hsc" #-}setter=withForeignPtrshape.flip(\hsc_ptr->pokeByteOffhsc_ptr84){-# LINE 182 "Physics/Hipmunk/Shape.hsc" #-}-- | Layers are similar to groups, but use a bitmask. For a collision-- to occur, two shapes must have at least one layer in common.-- In other words, @layer1 .&. layer2@ should be non-zero.-- (default is @-1@, meaning all bits set)---- Note that although this type may have more than 32 bits,-- for portability you should only rely on the lower 32 bits.typeLayers=Word32{-# LINE 191 "Physics/Hipmunk/Shape.hsc" #-}layers::Shape->StateVarLayerslayers(Sshape_)=makeStateVargettersetterwheregetter=withForeignPtrshape(\hsc_ptr->peekByteOffhsc_ptr88){-# LINE 195 "Physics/Hipmunk/Shape.hsc" #-}setter=withForeignPtrshape.flip(\hsc_ptr->pokeByteOffhsc_ptr88){-# LINE 196 "Physics/Hipmunk/Shape.hsc" #-}-- | The elasticity of the shape is such that @0.0@ gives no bounce-- while @1.0@ give a \"perfect\" bounce. Note that due to-- inaccuracies using @1.0@ or greater is not recommended.---- The amount of elasticity applied during a collision is-- calculated by multiplying the elasticity of both shapes.-- (default is zero)---- By default old-style elastic iterations are done when the-- space @step@s. This used to result in a not-so-good-- simulation, but now this is the recommended setting.typeElasticity=CpFloatelasticity::Shape->StateVarElasticityelasticity(Sshape_)=makeStateVargettersetterwheregetter=withForeignPtrshape(\hsc_ptr->peekByteOffhsc_ptr44){-# LINE 213 "Physics/Hipmunk/Shape.hsc" #-}setter=withForeignPtrshape.flip(\hsc_ptr->pokeByteOffhsc_ptr44){-# LINE 214 "Physics/Hipmunk/Shape.hsc" #-}-- | The friction coefficient of the shape according-- to Coulumb friction model (i.e. @0.0@ is frictionless,-- iron on iron is around @1.0@, and it could be greater-- then @1.0@).---- The amount of friction applied during a collision is-- determined by multiplying the friction coefficient-- of both shapes. (default is zero)typeFriction=CpFloatfriction::Shape->StateVarFrictionfriction(Sshape_)=makeStateVargettersetterwheregetter=withForeignPtrshape(\hsc_ptr->peekByteOffhsc_ptr52){-# LINE 228 "Physics/Hipmunk/Shape.hsc" #-}setter=withForeignPtrshape.flip(\hsc_ptr->pokeByteOffhsc_ptr52){-# LINE 229 "Physics/Hipmunk/Shape.hsc" #-}-- | The surface velocity of the shape. Useful to create-- conveyor belts and players that move around. This-- value is only used when calculating friction, not-- collision. (default is zero)typeSurfaceVel=VectorsurfaceVel::Shape->StateVarSurfaceVelsurfaceVel(Sshape_)=makeStateVargettersetterwheregetter=withForeignPtrshape(\hsc_ptr->peekByteOffhsc_ptr60){-# LINE 239 "Physics/Hipmunk/Shape.hsc" #-}setter=withForeignPtrshape.flip(\hsc_ptr->pokeByteOffhsc_ptr60){-# LINE 240 "Physics/Hipmunk/Shape.hsc" #-}-- | @momentForShape m s off@ is a convenience function that calculates-- the moment of inertia for shape @s@ with mass @m@ and at a-- offset @off@ of the body's center. Uses 'momentForCircle',-- 'momentForSegment' and 'momentForPoly' internally.momentForShape::Mass->ShapeType->Position->MomentmomentForShapem(Circler)off=m*(r*r+(off`dot`off))momentForShapem(LineSegmentp1p2_)off=momentForSegmentm(p1+off)(p2+off)momentForShapem(Polygonverts)off=momentForPolymvertsoff-- | @momentForCircle m (ri,ro) off@ is the moment of inertia-- of a circle of @m@ mass, inner radius of @ri@, outer radius-- of @ro@ and at an offset @off@ from the center of the body.momentForCircle::Mass->(Distance,Distance)->Position->MomentmomentForCirclem(ri,ro)off=(m/2)*(ri*ri+ro*ro)+m*(off`dot`off)-- We recoded the C function to avoid FFI and unsafePerformIO-- on this simple function.-- | @momentForSegment m p1 p2@ is the moment of inertia of a-- segment of mass @m@ going from point @p1@ to point @p2@.momentForSegment::Mass->Position->Position->MomentmomentForSegmentmp1p2=letlen'=len(p2-p1)offset=scale(p1+p2)(recip2)inm*len'*len'/12+m*offset`dot`offset-- We recoded the C function to avoid FFI and unsafePerformIO-- on this simple function.-- | @momentForPoly m verts off@ is the moment of inertia of a-- polygon of @m@ mass, at offset @off@ from the center of-- the body and comprised of @verts@ vertices. This is similar-- to 'Polygon' (and the same restrictions for the vertices-- apply as well).momentForPoly::Mass->[Position]->Position->MomentmomentForPolymvertsoff=(m*sum1)/(6*sum2)whereverts'=ifoff/=0thenmap(+off)vertselseverts(sum1,sum2)=calc(pairs(,)verts')00calcabc|a`seq`b`seq`c`seq`False=undefinedcalc[]acc1acc2=(acc1,acc2)calc((v1,v2):vs)acc1acc2=leta=v2`cross`v1b=v1`dot`v1+v1`dot`v2+v2`dot`v2incalcvs(acc1+a*b)(acc2+a)-- We recoded the C function to avoid FFI, unsafePerformIO-- and a bunch of malloc + poke. Is it worth?-- | Internal. For @l = [x1,x2,...,xn]@, @pairs f l@ is-- @[f x1 x2, f x2 x3, ...,f xn x1]@.pairs::(a->a->b)->[a]->[b]pairsfl=zipWithfl(tail$cyclel)-- | @shapePointQuery shape p@ returns @True@ iff the point-- in position @p@ (in world's coordinates) lies within the-- shape @shape@.shapePointQuery::Shape->Position->IOBoolshapePointQuery(Sshape_)p=withForeignPtrshape$\shape_ptr->withp$\p_ptr->doi<-wrShapePointQueryshape_ptrp_ptrreturn(i/=0)foreignimportccallunsafe"wrapper.h"wrShapePointQuery::ShapePtr->VectorPtr->IOCInt-- | @shapeSegmentQuery shape p1 p2@ returns @Just (t,n)@ iff the-- segment from @p1@ to @p2@ (in world's coordinates)-- intersects with the shape @shape@. In that case, @0 <= t <=-- 1@ indicates that one of the intersections is at point @p1 +-- (p2 - p1) \`scale\` t@ with normal @n@.shapeSegmentQuery::Shape->Position->Position->IO(Maybe(CpFloat,Vector))shapeSegmentQuery(Sshape_)p1p2=withForeignPtrshape$\shape_ptr->withp1$\p1_ptr->withp2$\p2_ptr->allocaBytes(28)$\info_ptr->do{-# LINE 324 "Physics/Hipmunk/Shape.hsc" #-}i<-wrShapeSegmentQueryshape_ptrp1_ptrp2_ptrinfo_ptrif(i==0)thenreturnNothingelsedot<-(\hsc_ptr->peekByteOffhsc_ptr4)info_ptr{-# LINE 327 "Physics/Hipmunk/Shape.hsc" #-}n<-(\hsc_ptr->peekByteOffhsc_ptr12)info_ptr{-# LINE 328 "Physics/Hipmunk/Shape.hsc" #-}return$Just(t,n)foreignimportccallunsafe"wrapper.h"wrShapeSegmentQuery::ShapePtr->VectorPtr->VectorPtr->Ptr()->IOCInt-- $polygon_util-- This section is inspired by @pymunk.util@,-- a Python module made from <http://code.google.com/p/pymunk/>,-- although implementations are quite different.---- Also, unless noted otherwise all polygons are-- assumed to be simple (i.e. no overlapping edges).-- | The epsilon used in the algorithms below when necessary-- to compare floats for \"equality\".epsilon::CpFloatepsilon=1e-25-- | \"Equality\" under 'epsilon'. That is, @a .==. b@-- if @abs (a - b) <= epsilon@.(.==.)::CpFloat->CpFloat->Boola.==.b=abs(a-b)<=epsilon-- | A line segment.typeSegment=(Position,Position)-- | /O(n)/. @isClockwise verts@ is @True@ iff @verts@ form-- a clockwise polygon.isClockwise::[Position]->BoolisClockwise=(<=0).foldl'(+)0.pairscross-- | @isLeft (p1,p2) vert@ is---- * @LT@ if @vert@ is at the left of the line defined by @(p1,p2)@.---- * @EQ@ if @vert@ is at the line @(p1,p2)@.---- * @GT@ otherwise.isLeft::(Position,Position)->Position->OrderingisLeft(p1,p2)vert=compare0$(p1-vert)`cross`(p2-vert)-- | /O(n)/. @isConvex verts@ is @True@ iff @vers@ form a convex-- polygon.isConvex::[Position]->BoolisConvex=foldl1(==).map(0<).filter(0/=).pairscross.pairs(-)-- From http://apocalisp.wordpress.com/category/programming/haskell/page/2/-- | /O(1)/. @intersects seg1 seg2@ is the intersection between-- the two segments @seg1@ and @seg2@. See 'Intersection'.intersects::Segment->Segment->Intersectionintersects(a0,a1)(b0,b1)=letu=a1-a0v@(Vectorvxvy)=b1-b0w@(Vectorwxwy)=a0-b0d=u`cross`vparallel=d.==.0-- Parallel casecollinear=all(.==.0)[u`cross`w,v`cross`w]a_is_point=u`dot`u.==.0b_is_point=v`dot`v.==.0(Vectorw2xw2y)=a1-b0(a_in_b,a_in_b')=ifvx.==.0thenswap(wy/vy,w2y/vy)elseswap(wx/vx,w2x/vx)whereswapt@(x,y)|x<y=t|otherwise=(y,x)-- Non-parallel casesI=v`cross`w/dtI=u`cross`w/d-- Auxiliary functionsinSegmentp(c0,c1)|vertical=test(gyp)(gyc0,gyc1)|otherwise=test(gxp)(gxc0,gxc1)wherevertical=gxc0.==.gxc1(gx,gy)=(\(Vectorx_)->x,\(Vector_y)->y)testq(d0,d1)=any(insideq)[(d0,d1),(d1,d0)]insiden(l,r)=l<=n&&n<=rinifparallelthencase(collinear,a_is_point,b_is_point)of(False,_,_)->-- Parallel and non-collinearIntNowhere(_,False,False)->-- Both are parallel, collinear segmentscase(a_in_b>1||a_in_b'<0,maxa_in_b0,mina_in_b'1)of(True,_,_)->IntNowhere(_,i0,i1)|i0.==.i1->IntPointp0|otherwise->IntSegmt(p0,p1)wherep0=b0+v`scale`i0p1=b0+v`scale`i1(_,True,True)->-- Both are pointsiflen(b0-a0).==.0thenIntPointa0elseIntNowhere_->-- One is a point, another is a segmentlet(point,segment)|a_is_point=(a0,(b0,b1))|otherwise=(b0,(a0,a1))inifinSegmentpointsegmentthenIntPointpointelseIntNowhereelseifall(\x->insidex(0,1))[sI,tI]thenIntPoint(a0+u`scale`sI)elseIntNowhere-- | A possible intersection between two segments.dataIntersection=IntNowhere-- ^ Don't intercept.|IntPoint!Position-- ^ Intercept in a point.|IntSegmt!Segment-- ^ Share a segment.deriving(Eq,Ord,Show)-- | /O(n)/. @polyReduce delta verts@ removes from @verts@ all-- points that have less than @delta@ distance-- in relation to the one preceding it.---- Note that a very small polygon may be completely \"eaten\"-- if all its vertices are within a @delta@ radius from the-- first.polyReduce::Distance->[Position]->[Position]polyReducedelta=gowherego(p1:p2:ps)|len(p2-p1)<delta=go(p1:ps)|otherwise=p1:go(p2:ps)goother=other-- | /O(n)/. @polyCenter verts@ is the position in the center-- of the polygon formed by @verts@.polyCenter::[Position]->PositionpolyCenterverts=foldl'(+)0verts`scale`swheres=recip$toEnum$lengthverts-- | /O(n log n)/. @convexHull verts@ is the convex hull of the-- polygon defined by @verts@. The vertices of the convex-- hulls are given in clockwise winding. The polygon-- doesn't have to be simple.---- Implemented using Graham scan, see-- <http://cgm.cs.mcgill.ca/~beezer/cs507/3coins.html>.convexHull::[Position]->[Position]convexHullverts=let(p0,ps)=takeMinimumverts(_:p1:points)=p0:sortBy(isLeft.(,)p0)ps-- points is going counterclockwise now.-- In go we use 'hull' with the last added-- vertex as the head, so our result is clockwise.-- Remove right turnsgohull@(h1:h2:hs)(q1:qs)=case(isLeft(h2,h1)q1,hs)of(LT,_)->go(q1:hull)qs-- Left turn(_,[])->go(q1:hull)qs-- Maintain at least 2 points_->go(h2:hs)(q1:qs)-- Right turn or straightgohull[]=hullgo__=error"Physics.Hipmunk.Shape.convexHull: never get here"ingo[p1,p0]points-- | Internal. Works like minimum but also returns the-- list without it. The order of the list may be changed.-- We have @fst (takeMinimum xs) == minimum xs@ and-- @sort (uncurry (:) $ takeMinimum xs) == sort xs@takeMinimum::Orda=>[a]->(a,[a])takeMinimum[]=error"Physics.Hipmunk.Shape.takeMinimum: empty list"takeMinimum(x:xs)=gox[]xswheregomin_acc(y:ys)|y<min_=goy(min_:acc)ys|otherwise=gomin_(y:acc)ysgomin_acc[]=(min_,acc)