Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2010-02-14 12:42:37 -08:00
commit 8d9268bcc2
37 changed files with 1490 additions and 209 deletions

View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client checksums checksums.md5 splitting assocs
kernel io.files bootstrap.image sequences io urls ;
@ -19,9 +19,11 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
] [ drop t ] if ;
: download-image ( arch -- )
boot-image-name dup need-new-image? [
"Downloading " write dup write "..." print
url over >url derive-url download
url swap boot-image-name >url derive-url download ;
: maybe-download-image ( arch -- )
dup boot-image-name need-new-image? [
dup download-image
need-new-image? [
"Boot image corrupt, or checksums.txt on server out of date" throw
] when
@ -30,6 +32,6 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
drop
] if ;
: download-my-image ( -- ) my-arch download-image ;
: download-my-image ( -- ) my-arch maybe-download-image ;
MAIN: download-my-image

View File

@ -0,0 +1,11 @@
IN: core-foundation.arrays.tests
USING: core-foundation core-foundation.arrays
core-foundation.strings destructors sequences tools.test ;
[ { "1" "2" "3" } ] [
[
{ "1" "2" "3" }
[ <CFString> &CFRelease ] map
<CFArray> CF>string-array
] with-destructors
] unit-test

View File

@ -48,7 +48,7 @@ SYMBOL: error-hook
: call-error-hook ( error -- )
error-continuation get error-hook get
call( error continuation -- ) ;
call( continuation error -- ) ;
[ drop print-error-and-restarts ] error-hook set-global

View File

@ -11,6 +11,7 @@ ARTICLE: "polynomials" "Polynomials"
p-
p*
p-sq
p^
powers
n*p
p/mod
@ -74,6 +75,11 @@ HELP: p-sq
{ $description "Squares a polynomial." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 0 } p-sq ." "{ 1 4 4 0 0 }" } } ;
HELP: p^
{ $values { "p" "a polynomial" } { "n" number } { "p^n" "a polynomial" } }
{ $description "Computes " { $snippet "p" } " to the power of " { $snippet "n" } "." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 0 } 3 p^ ." "{ 1 6 12 8 0 0 0 }" } } ;
HELP: p/mod
{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } }
{ $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." }

View File

@ -15,6 +15,9 @@ IN: math.polynomials.tests
[ { 0 0 0 } ] [ { 0 0 0 } { 0 0 0 } p- ] unit-test
[ { 0 0 0 } ] [ 4 { 0 0 0 } n*p ] unit-test
[ { 4 8 0 12 } ] [ 4 { 1 2 0 3 } n*p ] unit-test
[ { 1 4 4 0 0 } ] [ { 1 2 0 } p-sq ] unit-test
[ { 1 6 12 8 0 0 0 } ] [ { 1 2 0 } 3 p^ ] unit-test
[ { 1 } ] [ { 1 2 0 } 0 p^ ] unit-test
[ { 1 4 7 6 0 0 0 0 0 } ] [ { 1 2 3 0 0 0 } { 1 2 0 0 } p* ] unit-test
[ V{ 7 -2 1 } V{ -20 0 0 } ] [ { 1 1 1 1 } { 3 1 } p/mod ] unit-test
[ V{ 0 0 } V{ 1 1 } ] [ { 1 1 } { 1 1 1 1 } p/mod ] unit-test

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel make math math.order math.vectors sequences
splitting vectors macros combinators ;
splitting vectors macros combinators math.bits ;
IN: math.polynomials
<PRIVATE
@ -38,6 +38,16 @@ PRIVATE>
: p-sq ( p -- p^2 )
dup p* ;
ERROR: negative-power-polynomial p n ;
: (p^) ( p n -- p^n )
make-bits { 1 } [ [ over p* ] when [ p-sq ] dip ] reduce nip ;
: p^ ( p n -- p^n )
dup 0 >=
[ (p^) ]
[ negative-power-polynomial ] if ;
<PRIVATE
: p/mod-setup ( p p -- p p n )

View File

@ -2258,3 +2258,10 @@ CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT1_EXT HEX: 83F1
CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT3_EXT HEX: 83F2
CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT5_EXT HEX: 83F3
! GL_EXT_texture_compression_latc
CONSTANT: GL_COMPRESSED_LUMINANCE_LATC1_EXT HEX: 8C70
CONSTANT: GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT HEX: 8C71
CONSTANT: GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT HEX: 8C72
CONSTANT: GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT HEX: 8C73

View File

@ -0,0 +1 @@
Erik Charlebois

View File

@ -0,0 +1,845 @@
! Copyright (C) 2010 Erik Charlebois
! See http:// factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax classes.struct combinators
combinators.short-circuit kernel math math.order sequences
specialized-arrays.instances.alien.c-types.void* typed
specialized-arrays locals system alien.libraries ;
IN: chipmunk
<< "chipmunk" {
{ [ os windows? ] [ "chipmunk.dll" ] }
{ [ os macosx? ] [ "libchipmunk.dylib" ] }
{ [ os unix? ] [ "libchipmunk.so" ] }
} cond "cdecl" add-library >>
LIBRARY: chipmunk
! chipmunk_types.h
TYPEDEF: double cpFloat
STRUCT: cpVect
{ x cpFloat }
{ y cpFloat } ;
SPECIALIZED-ARRAY: cpVect
TYPEDEF: uint cpHashValue
TYPEDEF: void* cpDataPointer
TYPEDEF: uint cpCollisionType
TYPEDEF: uint cpLayers
TYPEDEF: uint cpGroup
CONSTANT: CP_NO_GROUP 0
CONSTANT: CP_ALL_LAYERS HEX: ffffffff
! cpVect.h
TYPED: cpv ( x y -- v: cpVect )
cpVect <struct-boa> ; inline
TYPED: cpvzero ( -- v: cpVect )
0.0 0.0 cpv ; inline
FUNCTION: cpFloat cpvlength ( cpVect v ) ;
FUNCTION: cpVect cpvslerp ( cpVect v1, cpVect v2, cpFloat t ) ;
FUNCTION: cpVect cpvslerpconst ( cpVect v1, cpVect v2, cpFloat a ) ;
FUNCTION: cpVect cpvforangle ( cpFloat a ) ;
FUNCTION: cpFloat cpvtoangle ( cpVect v ) ;
FUNCTION: char* cpvstr ( cpVect v ) ;
TYPED: cpvadd ( v1: cpVect v2: cpVect -- v3: cpVect )
[ [ x>> ] bi@ + ]
[ [ y>> ] bi@ + ] 2bi cpv ; inline
TYPED: cpvneg ( v1: cpVect -- v2: cpVect )
[ x>> ] [ y>> ] bi [ neg ] bi@ cpv ; inline
TYPED: cpvsub ( v1: cpVect v2: cpVect -- v3: cpVect )
[ [ x>> ] bi@ - ]
[ [ y>> ] bi@ - ] 2bi cpv ; inline
TYPED: cpvmult ( v1: cpVect s -- v2: cpVect )
[ swap x>> * ]
[ swap y>> * ] 2bi cpv ; inline
TYPED: cpvdot ( v1: cpVect v2: cpVect -- s )
[ [ x>> ] bi@ * ]
[ [ y>> ] bi@ * ] 2bi + ; inline
TYPED: cpvcross ( v1: cpVect v2: cpVect -- s )
[ [ x>> ] [ y>> ] bi* * ]
[ [ y>> ] [ x>> ] bi* * ] 2bi - ; inline
TYPED: cpvperp ( v1: cpVect -- v2: cpVect )
[ y>> neg ] [ x>> ] bi cpv ; inline
TYPED: cpvrperp ( v1: cpVect -- v2: cpVect )
[ y>> ] [ x>> neg ] bi cpv ; inline
TYPED: cpvproject ( v1: cpVect v2: cpVect -- v3: cpVect )
[ nip ]
[ cpvdot ]
[ nip dup cpvdot ]
2tri / cpvmult ; inline
TYPED: cpvrotate ( v1: cpVect v2: cpVect -- v3: cpVect )
[
[ [ x>> ] bi@ * ]
[ [ y>> ] bi@ * ] 2bi -
]
[
[ [ x>> ] [ y>> ] bi* * ]
[ [ y>> ] [ x>> ] bi* * ] 2bi +
] 2bi cpv ; inline
TYPED: cpvunrotate ( v1: cpVect v2: cpVect -- v3: cpVect )
[
[ [ x>> ] bi@ * ]
[ [ y>> ] bi@ * ] 2bi +
]
[
[ [ y>> ] [ x>> ] bi* * ]
[ [ x>> ] [ y>> ] bi* * ] 2bi -
] 2bi cpv ; inline
TYPED: cpvlengthsq ( v: cpVect -- s )
dup cpvdot ; inline
TYPED: cpvlerp ( v1: cpVect v2: cpVect s -- v3: cpVect )
[ nip 1.0 swap - cpvmult ]
[ cpvmult nip ] 3bi cpvadd ; inline
TYPED: cpvnormalize ( v1: cpVect -- v2: cpVect )
dup cpvlength 1.0 swap / cpvmult ; inline
TYPED: cpvnormalize_safe ( v1: cpVect -- v2: cpVect )
dup [ x>> 0.0 = ] [ y>> 0.0 = ] bi and
[ drop cpvzero ]
[ cpvnormalize ] if ; inline
TYPED: cpvclamp ( v1: cpVect len -- v2: cpVect )
2dup
[ dup cpvdot ]
[ sq ] 2bi* >
[ [ cpvnormalize ] dip cpvmult ]
[ drop ] if ; inline
TYPED: cpvlerpconst ( v1: cpVect v2: cpVect d -- v3: cpVect )
[ 2drop ]
[ [ swap cpvsub ] dip cpvclamp ] 3bi cpvadd ; inline
TYPED: cpvdist ( v1: cpVect v2: cpVect -- dist )
cpvsub cpvlength ; inline
TYPED: cpvdistsq ( v1: cpVect v2: cpVect -- distsq )
cpvsub cpvlengthsq ; inline
TYPED: cpvnear ( v1: cpVect v2: cpVect dist -- ? )
[ cpvdistsq ] dip sq < ; inline
! cpBB.h
STRUCT: cpBB
{ l cpFloat }
{ b cpFloat }
{ r cpFloat }
{ t cpFloat } ;
TYPED: cpBBNew ( l b r t -- cpbb: cpBB )
cpBB <struct-boa> ; inline
TYPED: cpBBintersects ( a: cpBB b: cpBB -- ? )
{
[ [ l>> ] [ r>> ] bi* <= ]
[ [ r>> ] [ l>> ] bi* > ]
[ [ b>> ] [ t>> ] bi* <= ]
[ [ t>> ] [ b>> ] bi* > ]
} 2&& ; inline
TYPED: cpBBcontainsBB ( bb: cpBB other: cpBB -- ? )
{
[ [ l>> ] bi@ < ]
[ [ r>> ] bi@ > ]
[ [ b>> ] bi@ < ]
[ [ t>> ] bi@ > ]
} 2&& ; inline
TYPED: cpBBcontainsVect ( bb: cpBB v: cpVect -- ? )
{
[ [ l>> ] [ x>> ] bi* < ]
[ [ r>> ] [ x>> ] bi* > ]
[ [ b>> ] [ y>> ] bi* < ]
[ [ t>> ] [ y>> ] bi* > ]
} 2&& ; inline
TYPED: cpBBmerge ( a: cpBB b: cpBB -- c: cpBB )
{
[ [ l>> ] bi@ min ]
[ [ b>> ] bi@ min ]
[ [ r>> ] bi@ max ]
[ [ t>> ] bi@ max ]
} 2cleave cpBBNew ; inline
TYPED: cpBBexpand ( bb: cpBB v: cpVect -- b: cpBB )
{
[ [ l>> ] [ x>> ] bi* min ]
[ [ b>> ] [ y>> ] bi* min ]
[ [ r>> ] [ x>> ] bi* max ]
[ [ t>> ] [ y>> ] bi* max ]
} 2cleave cpBBNew ; inline
FUNCTION: cpVect cpBBClampVect ( cpBB bb, cpVect v ) ;
FUNCTION: cpVect cpBBWrapVect ( cpBB bb, cpVect v ) ;
! cpBody.h
C-TYPE: cpBody
CALLBACK: void cpBodyVelocityFunc ( cpBody* body, cpVect gravity, cpFloat damping, cpFloat dt ) ;
CALLBACK: void cpBodyPositionFunc ( cpBody* body, cpFloat dt ) ;
STRUCT: cpBody
{ velocity_func cpBodyVelocityFunc }
{ position_func cpBodyPositionFunc }
{ m cpFloat }
{ m_inv cpFloat }
{ i cpFloat }
{ i_inv cpFloat }
{ p cpVect }
{ v cpVect }
{ f cpVect }
{ a cpFloat }
{ w cpFloat }
{ t cpFloat }
{ rot cpVect }
{ data cpDataPointer }
{ v_limit cpFloat }
{ w_limit cpFloat }
{ v_bias cpVect }
{ w_bias cpFloat } ;
FUNCTION: cpBody* cpBodyAlloc ( ) ;
FUNCTION: cpBody* cpBodyInit ( cpBody* body, cpFloat m, cpFloat i ) ;
FUNCTION: cpBody* cpBodyNew ( cpFloat m, cpFloat i ) ;
FUNCTION: void cpBodyDestroy ( cpBody* body ) ;
FUNCTION: void cpBodyFree ( cpBody* body ) ;
FUNCTION: void cpBodySetMass ( cpBody* body, cpFloat m ) ;
FUNCTION: void cpBodySetMoment ( cpBody* body, cpFloat i ) ;
FUNCTION: void cpBodySetAngle ( cpBody* body, cpFloat a ) ;
FUNCTION: void cpBodySlew ( cpBody* body, cpVect pos, cpFloat dt ) ;
FUNCTION: void cpBodyUpdateVelocity ( cpBody* body, cpVect gravity, cpFloat damping, cpFloat dt ) ;
FUNCTION: void cpBodyUpdatePosition ( cpBody* body, cpFloat dt ) ;
TYPED: cpBodyLocal2World ( body: cpBody v: cpVect -- v2: cpVect )
[ drop p>> ]
[ swap rot>> cpvrotate ] 2bi cpvadd ; inline
TYPED: cpBodyWorld2Local ( body: cpBody v: cpVect -- v2: cpVect )
[ swap p>> cpvsub ]
[ drop rot>> ] 2bi cpvunrotate ; inline
TYPED: cpBodyApplyImpulse ( body: cpBody j: cpVect r: cpVect -- )
[
drop
[ drop dup v>> ]
[ swap m_inv>> cpvmult ] 2bi cpvadd >>v drop
]
[
[ 2drop dup w_bias>> ]
[ swap cpvcross [ i_inv>> ] dip * ] 3bi + >>w_bias drop
] 3bi ; inline
FUNCTION: void cpBodyResetForces ( cpBody* body ) ;
FUNCTION: void cpBodyApplyForce ( cpBody* body, cpVect f, cpVect r ) ;
FUNCTION: void cpApplyDampedSpring ( cpBody* a, cpBody* b, cpVect anchr1, cpVect anchr2, cpFloat rlen, cpFloat k, cpFloat dmp, cpFloat dt ) ;
! cpArray.h
STRUCT: cpArray
{ num int }
{ max int }
{ arr void** } ;
CALLBACK: void cpArrayIter ( void* ptr, void* data ) ;
FUNCTION: cpArray* cpArrayAlloc ( ) ;
FUNCTION: cpArray* cpArrayInit ( cpArray* arr, int size ) ;
FUNCTION: cpArray* cpArrayNew ( int size ) ;
FUNCTION: void cpArrayDestroy ( cpArray* arr ) ;
FUNCTION: void cpArrayFree ( cpArray* arr ) ;
FUNCTION: void cpArrayPush ( cpArray* arr, void* object ) ;
FUNCTION: void cpArrayDeleteIndex ( cpArray* arr, int idx ) ;
FUNCTION: void cpArrayDeleteObj ( cpArray* arr, void* obj ) ;
FUNCTION: void cpArrayEach ( cpArray* arr, cpArrayIter iterFunc, void* data ) ;
FUNCTION: int cpArrayContains ( cpArray* arr, void* ptr ) ;
! cpHashSet.h
STRUCT: cpHashSetBin
{ elt void* }
{ hash cpHashValue }
{ next cpHashSetBin* } ;
CALLBACK: int cpHashSetEqlFunc ( void* ptr, void* elt ) ;
CALLBACK: void* cpHashSetTransFunc ( void* ptr, void* data ) ;
CALLBACK: void cpHashSetIterFunc ( void* elt, void* data ) ;
CALLBACK: int cpHashSetFilterFunc ( void* elt, void* data ) ;
STRUCT: cpHashSet
{ entries int }
{ size int }
{ eql cpHashSetEqlFunc }
{ trans cpHashSetTransFunc }
{ default_value void* }
{ table cpHashSetBin** } ;
FUNCTION: void cpHashSetDestroy ( cpHashSet* set ) ;
FUNCTION: void cpHashSetFree ( cpHashSet* set ) ;
FUNCTION: cpHashSet* cpHashSetAlloc ( ) ;
FUNCTION: cpHashSet* cpHashSetInit ( cpHashSet* set, int size, cpHashSetEqlFunc eqlFunc, cpHashSetTransFunc trans ) ;
FUNCTION: cpHashSet* cpHashSetNew ( int size, cpHashSetEqlFunc eqlFunc, cpHashSetTransFunc trans ) ;
FUNCTION: void* cpHashSetInsert ( cpHashSet* set, cpHashValue hash, void* ptr, void* data ) ;
FUNCTION: void* cpHashSetRemove ( cpHashSet* set, cpHashValue hash, void* ptr ) ;
FUNCTION: void* cpHashSetFind ( cpHashSet* set, cpHashValue hash, void* ptr ) ;
FUNCTION: void cpHashSetEach ( cpHashSet* set, cpHashSetIterFunc func, void* data ) ;
FUNCTION: void cpHashSetFilter ( cpHashSet* set, cpHashSetFilterFunc func, void* data ) ;
! cpSpaceHash.h
STRUCT: cpHandle
{ obj void* }
{ retain int }
{ stamp int } ;
STRUCT: cpSpaceHashBin
{ handle cpHandle* }
{ next cpSpaceHashBin* } ;
CALLBACK: cpBB cpSpaceHashBBFunc ( void* obj ) ;
STRUCT: cpSpaceHash
{ numcells int }
{ celldim cpFloat }
{ bbfunc cpSpaceHashBBFunc }
{ handleSet cpHashSet* }
{ table cpSpaceHashBin** }
{ bins cpSpaceHashBin* }
{ stamp int } ;
FUNCTION: cpSpaceHash* cpSpaceHashAlloc ( ) ;
FUNCTION: cpSpaceHash* cpSpaceHashInit ( cpSpaceHash* hash, cpFloat celldim, int cells, cpSpaceHashBBFunc bbfunc ) ;
FUNCTION: cpSpaceHash* cpSpaceHashNew ( cpFloat celldim, int cells, cpSpaceHashBBFunc bbfunc ) ;
FUNCTION: void cpSpaceHashDestroy ( cpSpaceHash* hash ) ;
FUNCTION: void cpSpaceHashFree ( cpSpaceHash* hash ) ;
FUNCTION: void cpSpaceHashResize ( cpSpaceHash* hash, cpFloat celldim, int numcells ) ;
FUNCTION: void cpSpaceHashInsert ( cpSpaceHash* hash, void* obj, cpHashValue id, cpBB bb ) ;
FUNCTION: void cpSpaceHashRemove ( cpSpaceHash* hash, void* obj, cpHashValue id ) ;
CALLBACK: void cpSpaceHashIterator ( void* obj, void* data ) ;
FUNCTION: void cpSpaceHashEach ( cpSpaceHash* hash, cpSpaceHashIterator func, void* data ) ;
FUNCTION: void cpSpaceHashRehash ( cpSpaceHash* hash ) ;
FUNCTION: void cpSpaceHashRehashObject ( cpSpaceHash* hash, void* obj, cpHashValue id ) ;
CALLBACK: void cpSpaceHashQueryFunc ( void* obj1, void* obj2, void* data ) ;
FUNCTION: void cpSpaceHashPointQuery ( cpSpaceHash* hash, cpVect point, cpSpaceHashQueryFunc func, void* data ) ;
FUNCTION: void cpSpaceHashQuery ( cpSpaceHash* hash, void* obj, cpBB bb, cpSpaceHashQueryFunc func, void* data ) ;
FUNCTION: void cpSpaceHashQueryRehash ( cpSpaceHash* hash, cpSpaceHashQueryFunc func, void* data ) ;
CALLBACK: cpFloat cpSpaceHashSegmentQueryFunc ( void* obj1, void* obj2, void* data ) ;
FUNCTION: void cpSpaceHashSegmentQuery ( cpSpaceHash* hash, void* obj, cpVect a, cpVect b, cpFloat t_exit, cpSpaceHashSegmentQueryFunc func, void* data ) ;
! cpShape.h
C-TYPE: cpShape
C-TYPE: cpShapeClass
STRUCT: cpSegmentQueryInfo
{ shape cpShape* }
{ t cpFloat }
{ n cpVect } ;
C-ENUM:
CP_CIRCLE_SHAPE
CP_SEGMENT_SHAPE
CP_POLY_SHAPE
CP_NUM_SHAPES ;
TYPEDEF: int cpShapeType
CALLBACK: cpBB cacheData_cb ( cpShape* shape, cpVect p, cpVect rot ) ;
CALLBACK: void destroy_cb ( cpShape* shape ) ;
CALLBACK: int pointQuery_cb ( cpShape* shape, cpVect p ) ;
CALLBACK: void segmentQuery_cb ( cpShape* shape, cpVect a, cpVect b, cpSegmentQueryInfo* info ) ;
STRUCT: cpShapeClass
{ type cpShapeType }
{ cacheData cacheData_cb }
{ destroy destroy_cb }
{ pointQuery pointQuery_cb }
{ segmentQuery segmentQuery_cb } ;
STRUCT: cpShape
{ klass cpShapeClass* }
{ body cpBody* }
{ bb cpBB }
{ sensor int }
{ e cpFloat }
{ u cpFloat }
{ surface_v cpVect }
{ data cpDataPointer }
{ collision_type cpCollisionType }
{ group cpGroup }
{ layers cpLayers }
{ hashid cpHashValue } ;
FUNCTION: cpShape* cpShapeInit ( cpShape* shape, cpShapeClass* klass, cpBody* body ) ;
FUNCTION: void cpShapeDestroy ( cpShape* shape ) ;
FUNCTION: void cpShapeFree ( cpShape* shape ) ;
FUNCTION: cpBB cpShapeCacheBB ( cpShape* shape ) ;
FUNCTION: int cpShapePointQuery ( cpShape* shape, cpVect p ) ;
STRUCT: cpCircleShape
{ shape cpShape }
{ c cpVect }
{ r cpFloat }
{ tc cpVect } ;
FUNCTION: cpCircleShape* cpCircleShapeAlloc ( ) ;
FUNCTION: cpCircleShape* cpCircleShapeInit ( cpCircleShape* circle, cpBody* body, cpFloat radius, cpVect offset ) ;
FUNCTION: cpShape* cpCircleShapeNew ( cpBody* body, cpFloat radius, cpVect offset ) ;
STRUCT: cpSegmentShape
{ shape cpShape }
{ a cpVect }
{ b cpVect }
{ n cpVect }
{ r cpFloat }
{ ta cpVect }
{ tb cpVect }
{ tn cpVect } ;
FUNCTION: cpSegmentShape* cpSegmentShapeAlloc ( ) ;
FUNCTION: cpSegmentShape* cpSegmentShapeInit ( cpSegmentShape* seg, cpBody* body, cpVect a, cpVect b, cpFloat radius ) ;
FUNCTION: cpShape* cpSegmentShapeNew ( cpBody* body, cpVect a, cpVect b, cpFloat radius ) ;
FUNCTION: void cpResetShapeIdCounter ( ) ;
FUNCTION: void cpSegmentQueryInfoPrint ( cpSegmentQueryInfo* info ) ;
FUNCTION: int cpShapeSegmentQuery ( cpShape* shape, cpVect a, cpVect b, cpSegmentQueryInfo* info ) ;
TYPED: cpSegmentQueryHitPoint ( start: cpVect end: cpVect info: cpSegmentQueryInfo -- hit-point: cpVect )
t>> cpvlerp ; inline
TYPED: cpSegmentQueryHitDist ( start: cpVect end: cpVect info: cpSegmentQueryInfo -- hit-dist )
t>> [ cpvdist ] dip * ; inline
! cpPolyShape.h
STRUCT: cpPolyShapeAxis
{ n cpVect }
{ d cpFloat } ;
SPECIALIZED-ARRAY: cpPolyShapeAxis
STRUCT: cpPolyShape
{ shape cpShape }
{ numVerts int }
{ verts cpVect* }
{ axes cpPolyShapeAxis* }
{ tVerts cpVect* }
{ tAxes cpPolyShapeAxis* } ;
FUNCTION: cpPolyShape* cpPolyShapeAlloc ( ) ;
FUNCTION: cpPolyShape* cpPolyShapeInit ( cpPolyShape* poly, cpBody* body, int numVerts, cpVect* verts, cpVect offset ) ;
FUNCTION: cpShape* cpPolyShapeNew ( cpBody* body, int numVerts, cpVect* verts, cpVect offset ) ;
FUNCTION: int cpPolyValidate ( cpVect* verts, int numVerts ) ;
FUNCTION: int cpPolyShapeGetNumVerts ( cpShape* shape ) ;
FUNCTION: cpVect cpPolyShapeGetVert ( cpShape* shape, int idx ) ;
TYPED: cpPolyShapeValueOnAxis ( poly: cpPolyShape n: cpVect d -- min-dist )
swap rot [ numVerts>> ] [ tVerts>> swap <direct-cpVect-array> ] bi swap
[ cpvdot ] curry [ min ] reduce swap - ; inline
TYPED: cpPolyShapeContainsVert ( poly: cpPolyShape v: cpVect -- ? )
swap [ numVerts>> ] [ tAxes>> swap <direct-cpPolyShapeAxis-array> ] bi swap
[
[ [ n>> ] dip cpvdot ] [ drop d>> ] 2bi -
] curry [ max ] reduce 0.0 <= ; inline
TYPED: cpPolyShapeContainsVertPartial ( poly: cpPolyShape v: cpVect n: cpVect -- ? )
rot [ numVerts>> ] [ tAxes>> swap <direct-cpPolyShapeAxis-array> ] bi -rot
[| axis v n |
axis n>> n cpvdot 0.0 < 0
[ 0.0 ]
[ axis n>> v cpvdot axis d>> - ]
if
] 2curry [ max ] reduce 0.0 <= ; inline
! cpArbiter.h
C-TYPE: cpArbiter
C-TYPE: cpSpace
C-TYPE: cpCollisionHandler
STRUCT: cpContact
{ p cpVect }
{ n cpVect }
{ dist cpFloat }
{ r1 cpVect }
{ r2 cpVect }
{ nMass cpFloat }
{ tMass cpFloat }
{ bounce cpFloat }
{ jnAcc cpFloat }
{ jtAcc cpFloat }
{ jBias cpFloat }
{ bias cpFloat }
{ hash cpHashValue } ;
FUNCTION: cpContact* cpContactInit ( cpContact* con, cpVect p, cpVect n, cpFloat dist, cpHashValue hash ) ;
C-ENUM:
cpArbiterStateNormal
cpArbiterStateFirstColl
cpArbiterStateIgnore ;
TYPEDEF: int cpArbiterState
STRUCT: cpArbiter
{ numContacts int }
{ contacts cpContact* }
{ a cpShape* }
{ b cpShape* }
{ e cpFloat }
{ u cpFloat }
{ surface_vr cpVect }
{ stamp int }
{ handler cpCollisionHandler* }
{ swappedColl char }
{ state char } ;
FUNCTION: cpArbiter* cpArbiterAlloc ( ) ;
FUNCTION: cpArbiter* cpArbiterInit ( cpArbiter* arb, cpShape* a, cpShape* b ) ;
FUNCTION: cpArbiter* cpArbiterNew ( cpShape* a, cpShape* b ) ;
FUNCTION: void cpArbiterDestroy ( cpArbiter* arb ) ;
FUNCTION: void cpArbiterFree ( cpArbiter* arb ) ;
FUNCTION: void cpArbiterUpdate ( cpArbiter* arb, cpContact* contacts, int numContacts, cpCollisionHandler* handler, cpShape* a, cpShape* b ) ;
FUNCTION: void cpArbiterPreStep ( cpArbiter* arb, cpFloat dt_inv ) ;
FUNCTION: void cpArbiterApplyCachedImpulse ( cpArbiter* arb ) ;
FUNCTION: void cpArbiterApplyImpulse ( cpArbiter* arb, cpFloat eCoef ) ;
FUNCTION: cpVect cpArbiterTotalImpulse ( cpArbiter* arb ) ;
FUNCTION: cpVect cpArbiterTotalImpulseWithFriction ( cpArbiter* arb ) ;
FUNCTION: void cpArbiterIgnore ( cpArbiter* arb ) ;
TYPED: cpArbiterGetShapes ( arb: cpArbiter -- a: cpShape b: cpShape )
dup swappedColl>> 0 = [
[ a>> cpShape memory>struct ] [ b>> cpShape memory>struct ] bi
] [
[ b>> cpShape memory>struct ] [ a>> cpShape memory>struct ] bi
] if ; inline
TYPED: cpArbiterIsFirstContact ( arb: cpArbiter -- ? )
state>> cpArbiterStateFirstColl = ; inline
TYPED: cpArbiterGetNormal ( arb: cpArbiter i -- n: cpVect )
[
swap
[ numContacts>> ]
[ contacts>> swap <direct-void*-array> ] bi nth cpContact memory>struct n>>
]
[
drop swappedColl>> 0 = [ ] [ cpvneg ] if
] 2bi ; inline
TYPED: cpArbiterGetPoint ( arb: cpArbiter i -- p: cpVect )
swap
[ numContacts>> ]
[ contacts>> swap <direct-void*-array> ] bi
nth cpContact memory>struct p>> ; inline
! cpCollision.h
FUNCTION: int cpCollideShapes ( cpShape* a, cpShape* b, cpContact** arr ) ;
! cpConstraint.h
C-TYPE: cpConstraintClass
C-TYPE: cpConstraint
CALLBACK: void cpConstraintPreStepFunction ( cpConstraint* constraint, cpFloat dt, cpFloat dt_inv ) ;
CALLBACK: void cpConstraintApplyImpulseFunction ( cpConstraint* constraint ) ;
CALLBACK: cpFloat cpConstraintGetImpulseFunction ( cpConstraint* constraint ) ;
STRUCT: cpConstraintClass
{ preStep cpConstraintPreStepFunction }
{ applyImpulse cpConstraintApplyImpulseFunction }
{ getImpulse cpConstraintGetImpulseFunction } ;
STRUCT: cpConstraint
{ klass cpConstraintClass* }
{ a cpBody* }
{ b cpBody* }
{ maxForce cpFloat }
{ biasCoef cpFloat }
{ maxBias cpFloat }
{ data cpDataPointer } ;
FUNCTION: void cpConstraintDestroy ( cpConstraint* constraint ) ;
FUNCTION: void cpConstraintFree ( cpConstraint* constraint ) ;
FUNCTION: void cpConstraintCheckCast ( cpConstraint* constraint, cpConstraintClass* klass ) ;
! cpPinJoint.h
FUNCTION: cpConstraintClass* cpPinJointGetClass ( ) ;
STRUCT: cpPinJoint
{ constraint cpConstraint }
{ anchr1 cpVect }
{ anchr2 cpVect }
{ dist cpFloat }
{ r1 cpVect }
{ r2 cpVect }
{ n cpVect }
{ nMass cpFloat }
{ jnAcc cpFloat }
{ jnMax cpFloat }
{ bias cpFloat } ;
FUNCTION: cpPinJoint* cpPinJointAlloc ( ) ;
FUNCTION: cpPinJoint* cpPinJointInit ( cpPinJoint* joint, cpBody* a, cpBody* b, cpVect anchr1, cpVect anchr2 ) ;
FUNCTION: cpConstraint* cpPinJointNew ( cpBody* a, cpBody* b, cpVect anchr1, cpVect anchr2 ) ;
! cpSlideJoint.h
FUNCTION: cpConstraintClass* cpSlideJointGetClass ( ) ;
STRUCT: cpSlideJoint
{ constraint cpConstraint }
{ anchr1 cpVect }
{ anchr2 cpVect }
{ min cpFloat }
{ max cpFloat }
{ r1 cpVect }
{ r2 cpVect }
{ n cpVect }
{ nMass cpFloat }
{ jnAcc cpFloat }
{ jnMax cpFloat }
{ bias cpFloat } ;
FUNCTION: cpSlideJoint* cpSlideJointAlloc ( ) ;
FUNCTION: cpSlideJoint* cpSlideJointInit ( cpSlideJoint* joint, cpBody* a, cpBody* b, cpVect anchr1, cpVect anchr2, cpFloat min, cpFloat max ) ;
FUNCTION: cpConstraint* cpSlideJointNew ( cpBody* a, cpBody* b, cpVect anchr1, cpVect anchr2, cpFloat min, cpFloat max ) ;
! cpPivotJoint.h
FUNCTION: cpConstraintClass* cpPivotJointGetClass ( ) ;
STRUCT: cpPivotJoint
{ constraint cpConstraint }
{ anchr1 cpVect }
{ anchr2 cpVect }
{ r1 cpVect }
{ r2 cpVect }
{ k1 cpVect }
{ k2 cpVect }
{ jAcc cpVect }
{ jMaxLen cpFloat }
{ bias cpVect } ;
FUNCTION: cpPivotJoint* cpPivotJointAlloc ( ) ;
FUNCTION: cpPivotJoint* cpPivotJointInit ( cpPivotJoint* joint, cpBody* a, cpBody* b, cpVect anchr1, cpVect anchr2 ) ;
FUNCTION: cpConstraint* cpPivotJointNew ( cpBody* a, cpBody* b, cpVect pivot ) ;
FUNCTION: cpConstraint* cpPivotJointNew2 ( cpBody* a, cpBody* b, cpVect anchr1, cpVect anchr2 ) ;
! cpGrooveJoint.h
FUNCTION: cpConstraintClass* cpGrooveJointGetClass ( ) ;
STRUCT: cpGrooveJoint
{ constraint cpConstraint }
{ grv_n cpVect }
{ grv_a cpVect }
{ grv_b cpVect }
{ anchr2 cpVect }
{ grv_tn cpVect }
{ clamp cpFloat }
{ r1 cpVect }
{ r2 cpVect }
{ k1 cpVect }
{ k2 cpVect }
{ jAcc cpVect }
{ jMaxLen cpFloat }
{ bias cpVect } ;
FUNCTION: cpGrooveJoint* cpGrooveJointAlloc ( ) ;
FUNCTION: cpGrooveJoint* cpGrooveJointInit ( cpGrooveJoint* joint, cpBody* a, cpBody* b, cpVect groove_a, cpVect groove_b, cpVect anchr2 ) ;
FUNCTION: cpConstraint* cpGrooveJointNew ( cpBody* a, cpBody* b, cpVect groove_a, cpVect groove_b, cpVect anchr2 ) ;
! cpDampedSpring.h
CALLBACK: cpFloat cpDampedSpringForceFunc ( cpConstraint* spring, cpFloat dist ) ;
FUNCTION: cpConstraintClass* cpDampedSpringGetClass ( ) ;
STRUCT: cpDampedSpring
{ constraint cpConstraint }
{ anchr1 cpVect }
{ anchr2 cpVect }
{ restLength cpFloat }
{ stiffness cpFloat }
{ damping cpFloat }
{ springForceFunc cpDampedSpringForceFunc }
{ dt cpFloat }
{ target_vrn cpFloat }
{ r1 cpVect }
{ r2 cpVect }
{ nMass cpFloat }
{ n cpVect } ;
FUNCTION: cpDampedSpring* cpDampedSpringAlloc ( ) ;
FUNCTION: cpDampedSpring* cpDampedSpringInit ( cpDampedSpring* joint, cpBody* a, cpBody* b, cpVect anchr1, cpVect anchr2, cpFloat restLength, cpFloat stiffness, cpFloat damping ) ;
FUNCTION: cpConstraint* cpDampedSpringNew ( cpBody* a, cpBody* b, cpVect anchr1, cpVect anchr2, cpFloat restLength, cpFloat stiffness, cpFloat damping ) ;
! cpDampedRotarySpring.h
CALLBACK: cpFloat cpDampedRotarySpringTorqueFunc ( cpConstraint* spring, cpFloat relativeAngle ) ;
FUNCTION: cpConstraintClass* cpDampedRotarySpringGetClass ( ) ;
STRUCT: cpDampedRotarySpring
{ constraint cpConstraint }
{ restAngle cpFloat }
{ stiffness cpFloat }
{ damping cpFloat }
{ springTorqueFunc cpDampedRotarySpringTorqueFunc }
{ dt cpFloat }
{ target_wrn cpFloat }
{ iSum cpFloat } ;
FUNCTION: cpDampedRotarySpring* cpDampedRotarySpringAlloc ( ) ;
FUNCTION: cpDampedRotarySpring* cpDampedRotarySpringInit ( cpDampedRotarySpring* joint, cpBody* a, cpBody* b, cpFloat restAngle, cpFloat stiffness, cpFloat damping ) ;
FUNCTION: cpConstraint* cpDampedRotarySpringNew ( cpBody* a, cpBody* b, cpFloat restAngle, cpFloat stiffness, cpFloat damping ) ;
! cpRotaryLimitJoint.h
FUNCTION: cpConstraintClass* cpRotaryLimitJointGetClass ( ) ;
STRUCT: cpRotaryLimitJoint
{ constraint cpConstraint }
{ min cpFloat }
{ max cpFloat }
{ iSum cpFloat }
{ bias cpFloat }
{ jAcc cpFloat }
{ jMax cpFloat } ;
FUNCTION: cpRotaryLimitJoint* cpRotaryLimitJointAlloc ( ) ;
FUNCTION: cpRotaryLimitJoint* cpRotaryLimitJointInit ( cpRotaryLimitJoint* joint, cpBody* a, cpBody* b, cpFloat min, cpFloat max ) ;
FUNCTION: cpConstraint* cpRotaryLimitJointNew ( cpBody* a, cpBody* b, cpFloat min, cpFloat max ) ;
! cpRatchetJoint.h
FUNCTION: cpConstraintClass* cpRatchetJointGetClass ( ) ;
STRUCT: cpRatchetJoint
{ constraint cpConstraint }
{ angle cpFloat }
{ phase cpFloat }
{ ratchet cpFloat }
{ iSum cpFloat }
{ bias cpFloat }
{ jAcc cpFloat }
{ jMax cpFloat } ;
FUNCTION: cpRatchetJoint* cpRatchetJointAlloc ( ) ;
FUNCTION: cpRatchetJoint* cpRatchetJointInit ( cpRatchetJoint* joint, cpBody* a, cpBody* b, cpFloat phase, cpFloat ratchet ) ;
FUNCTION: cpConstraint* cpRatchetJointNew ( cpBody* a, cpBody* b, cpFloat phase, cpFloat ratchet ) ;
! cpGearJoint.h
FUNCTION: cpConstraintClass* cpGearJointGetClass ( ) ;
STRUCT: cpGearJoint
{ constraint cpConstraint }
{ phase cpFloat }
{ ratio cpFloat }
{ ratio_inv cpFloat }
{ iSum cpFloat }
{ bias cpFloat }
{ jAcc cpFloat }
{ jMax cpFloat } ;
FUNCTION: cpGearJoint* cpGearJointAlloc ( ) ;
FUNCTION: cpGearJoint* cpGearJointInit ( cpGearJoint* joint, cpBody* a, cpBody* b, cpFloat phase, cpFloat ratio ) ;
FUNCTION: cpConstraint* cpGearJointNew ( cpBody* a, cpBody* b, cpFloat phase, cpFloat ratio ) ;
FUNCTION: void cpGearJointSetRatio ( cpConstraint* constraint, cpFloat value ) ;
! cpSimpleMotor.h
FUNCTION: cpConstraintClass* cpSimpleMotorGetClass ( ) ;
STRUCT: cpSimpleMotor
{ constraint cpConstraint }
{ rate cpFloat }
{ iSum cpFloat }
{ jAcc cpFloat }
{ jMax cpFloat } ;
FUNCTION: cpSimpleMotor* cpSimpleMotorAlloc ( ) ;
FUNCTION: cpSimpleMotor* cpSimpleMotorInit ( cpSimpleMotor* joint, cpBody* a, cpBody* b, cpFloat rate ) ;
FUNCTION: cpConstraint* cpSimpleMotorNew ( cpBody* a, cpBody* b, cpFloat rate ) ;
! cpSpace.h
C-TYPE: cpSpace
CALLBACK: int cpCollisionBeginFunc ( cpArbiter* arb, cpSpace* space, void* data ) ;
CALLBACK: int cpCollisionPreSolveFunc ( cpArbiter* arb, cpSpace* space, void* data ) ;
CALLBACK: void cpCollisionPostSolveFunc ( cpArbiter* arb, cpSpace* space, void* data ) ;
CALLBACK: void cpCollisionSeparateFunc ( cpArbiter* arb, cpSpace* space, void* data ) ;
STRUCT: cpCollisionHandler
{ a cpCollisionType }
{ b cpCollisionType }
{ begin cpCollisionBeginFunc }
{ preSolve cpCollisionPreSolveFunc }
{ postSolve cpCollisionPostSolveFunc }
{ separate cpCollisionSeparateFunc }
{ data void* } ;
STRUCT: cpSpace
{ iterations int }
{ elasticIterations int }
{ gravity cpVect }
{ damping cpFloat }
{ stamp int }
{ staticShapes cpSpaceHash* }
{ activeShapes cpSpaceHash* }
{ bodies cpArray* }
{ arbiters cpArray* }
{ contactSet cpHashSet* }
{ constraints cpArray* }
{ collFuncSet cpHashSet* }
{ defaultHandler cpCollisionHandler }
{ postStepCallbacks cpHashSet* } ;
FUNCTION: cpSpace* cpSpaceAlloc ( ) ;
FUNCTION: cpSpace* cpSpaceInit ( cpSpace* space ) ;
FUNCTION: cpSpace* cpSpaceNew ( ) ;
FUNCTION: void cpSpaceDestroy ( cpSpace* space ) ;
FUNCTION: void cpSpaceFree ( cpSpace* space ) ;
FUNCTION: void cpSpaceFreeChildren ( cpSpace* space ) ;
FUNCTION: void cpSpaceSetDefaultCollisionHandler (
cpSpace* space,
cpCollisionBeginFunc begin,
cpCollisionPreSolveFunc preSolve,
cpCollisionPostSolveFunc postSolve,
cpCollisionSeparateFunc separate,
void* data ) ;
FUNCTION: void cpSpaceAddCollisionHandler (
cpSpace* space,
cpCollisionType a,
cpCollisionType b,
cpCollisionBeginFunc begin,
cpCollisionPreSolveFunc preSolve,
cpCollisionPostSolveFunc postSolve,
cpCollisionSeparateFunc separate,
void* data ) ;
FUNCTION: void cpSpaceRemoveCollisionHandler ( cpSpace* space, cpCollisionType a, cpCollisionType b ) ;
FUNCTION: cpShape* cpSpaceAddShape ( cpSpace* space, cpShape* shape ) ;
FUNCTION: cpShape* cpSpaceAddStaticShape ( cpSpace* space, cpShape* shape ) ;
FUNCTION: cpBody* cpSpaceAddBody ( cpSpace* space, cpBody* body ) ;
FUNCTION: cpConstraint* cpSpaceAddConstraint ( cpSpace* space, cpConstraint* constraint ) ;
FUNCTION: void cpSpaceRemoveShape ( cpSpace* space, cpShape* shape ) ;
FUNCTION: void cpSpaceRemoveStaticShape ( cpSpace* space, cpShape* shape ) ;
FUNCTION: void cpSpaceRemoveBody ( cpSpace* space, cpBody* body ) ;
FUNCTION: void cpSpaceRemoveConstraint ( cpSpace* space, cpConstraint* constraint ) ;
CALLBACK: void cpPostStepFunc ( cpSpace* space, void* obj, void* data ) ;
FUNCTION: void cpSpaceAddPostStepCallback ( cpSpace* space, cpPostStepFunc func, void* obj, void* data ) ;
CALLBACK: void cpSpacePointQueryFunc ( cpShape* shape, void* data ) ;
FUNCTION: void cpSpacePointQuery ( cpSpace* space, cpVect point, cpLayers layers, cpGroup group, cpSpacePointQueryFunc func, void* data ) ;
FUNCTION: cpShape* cpSpacePointQueryFirst ( cpSpace* space, cpVect point, cpLayers layers, cpGroup group ) ;
CALLBACK: void cpSpaceSegmentQueryFunc ( cpShape* shape, cpFloat t, cpVect n, void* data ) ;
FUNCTION: int cpSpaceSegmentQuery ( cpSpace* space, cpVect start, cpVect end, cpLayers layers, cpGroup group, cpSpaceSegmentQueryFunc func, void* data ) ;
FUNCTION: cpShape* cpSpaceSegmentQueryFirst ( cpSpace* space, cpVect start, cpVect end, cpLayers layers, cpGroup group, cpSegmentQueryInfo* out ) ;
CALLBACK: void cpSpaceBBQueryFunc ( cpShape* shape, void* data ) ;
FUNCTION: void cpSpaceBBQuery ( cpSpace* space, cpBB bb, cpLayers layers, cpGroup group, cpSpaceBBQueryFunc func, void* data ) ;
CALLBACK: void cpSpaceBodyIterator ( cpBody* body, void* data ) ;
FUNCTION: void cpSpaceEachBody ( cpSpace* space, cpSpaceBodyIterator func, void* data ) ;
FUNCTION: void cpSpaceResizeStaticHash ( cpSpace* space, cpFloat dim, int count ) ;
FUNCTION: void cpSpaceResizeActiveHash ( cpSpace* space, cpFloat dim, int count ) ;
FUNCTION: void cpSpaceRehashStatic ( cpSpace* space ) ;
FUNCTION: void cpSpaceStep ( cpSpace* space, cpFloat dt ) ;
! chipmunk.h
FUNCTION: void cpInitChipmunk ( ) ;
FUNCTION: cpFloat cpMomentForCircle ( cpFloat m, cpFloat r1, cpFloat r2, cpVect offset ) ;
FUNCTION: cpFloat cpMomentForSegment ( cpFloat m, cpVect a, cpVect b ) ;
FUNCTION: cpFloat cpMomentForPoly ( cpFloat m, int numVerts, cpVect* verts, cpVect offset ) ;

View File

@ -0,0 +1 @@
Erik Charlebois

View File

@ -0,0 +1,151 @@
! Copyright (C) 2010 Erik Charlebois
! See http:// factorcode.org/license.txt for BSD license.
USING: accessors chipmunk classes.struct game.loop game.worlds gpu
gpu.util.wasd kernel literals locals math method-chains opengl.gl
random sequences specialized-arrays
specialized-arrays.instances.alien.c-types.void* ui.gadgets.worlds
ui.pixel-formats ;
IN: chipmunk.demo
CONSTANT: image-width 188
CONSTANT: image-height 35
CONSTANT: image-row-length 24
CONSTANT: image-bitmap B{
15 -16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 -64 15 63 -32 -2 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 31 -64 15 127 -125 -1 -128 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 0 0 127 -64 15 127 15 -1 -64 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 -1 -64 15 -2
31 -1 -64 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 -1 -64 0 -4 63 -1 -32 0 0 0 0 0 0
0 0 0 0 0 0 0 0 0 0 1 -1 -64 15 -8 127 -1 -32 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
1 -1 -64 0 -8 -15 -1 -32 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 -31 -1 -64 15 -8 -32
-1 -32 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 -15 -1 -64 9 -15 -32 -1 -32 0 0 0 0 0
0 0 0 0 0 0 0 0 0 0 31 -15 -1 -64 0 -15 -32 -1 -32 0 0 0 0 0 0 0 0 0 0 0 0 0
0 0 63 -7 -1 -64 9 -29 -32 127 -61 -16 63 15 -61 -1 -8 31 -16 15 -8 126 7 -31
-8 31 -65 -7 -1 -64 9 -29 -32 0 7 -8 127 -97 -25 -1 -2 63 -8 31 -4 -1 15 -13
-4 63 -1 -3 -1 -64 9 -29 -32 0 7 -8 127 -97 -25 -1 -2 63 -8 31 -4 -1 15 -13
-2 63 -1 -3 -1 -64 9 -29 -32 0 7 -8 127 -97 -25 -1 -1 63 -4 63 -4 -1 15 -13
-2 63 -33 -1 -1 -32 9 -25 -32 0 7 -8 127 -97 -25 -1 -1 63 -4 63 -4 -1 15 -13
-1 63 -33 -1 -1 -16 9 -25 -32 0 7 -8 127 -97 -25 -1 -1 63 -4 63 -4 -1 15 -13
-1 63 -49 -1 -1 -8 9 -57 -32 0 7 -8 127 -97 -25 -8 -1 63 -2 127 -4 -1 15 -13
-1 -65 -49 -1 -1 -4 9 -57 -32 0 7 -8 127 -97 -25 -8 -1 63 -2 127 -4 -1 15 -13
-1 -65 -57 -1 -1 -2 9 -57 -32 0 7 -8 127 -97 -25 -8 -1 63 -2 127 -4 -1 15 -13
-1 -1 -57 -1 -1 -1 9 -57 -32 0 7 -1 -1 -97 -25 -8 -1 63 -1 -1 -4 -1 15 -13 -1
-1 -61 -1 -1 -1 -119 -57 -32 0 7 -1 -1 -97 -25 -8 -1 63 -1 -1 -4 -1 15 -13 -1
-1 -61 -1 -1 -1 -55 -49 -32 0 7 -1 -1 -97 -25 -8 -1 63 -1 -1 -4 -1 15 -13 -1
-1 -63 -1 -1 -1 -23 -49 -32 127 -57 -1 -1 -97 -25 -1 -1 63 -1 -1 -4 -1 15 -13
-1 -1 -63 -1 -1 -1 -16 -49 -32 -1 -25 -1 -1 -97 -25 -1 -1 63 -33 -5 -4 -1 15
-13 -1 -1 -64 -1 -9 -1 -7 -49 -32 -1 -25 -8 127 -97 -25 -1 -1 63 -33 -5 -4 -1
15 -13 -1 -1 -64 -1 -13 -1 -32 -49 -32 -1 -25 -8 127 -97 -25 -1 -2 63 -49 -13
-4 -1 15 -13 -1 -1 -64 127 -7 -1 -119 -17 -15 -1 -25 -8 127 -97 -25 -1 -2 63
-49 -13 -4 -1 15 -13 -3 -1 -64 127 -8 -2 15 -17 -1 -1 -25 -8 127 -97 -25 -1
-8 63 -49 -13 -4 -1 15 -13 -3 -1 -64 63 -4 120 0 -17 -1 -1 -25 -8 127 -97 -25
-8 0 63 -57 -29 -4 -1 15 -13 -4 -1 -64 63 -4 0 15 -17 -1 -1 -25 -8 127 -97
-25 -8 0 63 -57 -29 -4 -1 -1 -13 -4 -1 -64 31 -2 0 0 103 -1 -1 -57 -8 127 -97
-25 -8 0 63 -57 -29 -4 -1 -1 -13 -4 127 -64 31 -2 0 15 103 -1 -1 -57 -8 127
-97 -25 -8 0 63 -61 -61 -4 127 -1 -29 -4 127 -64 15 -8 0 0 55 -1 -1 -121 -8
127 -97 -25 -8 0 63 -61 -61 -4 127 -1 -29 -4 63 -64 15 -32 0 0 23 -1 -2 3 -16
63 15 -61 -16 0 31 -127 -127 -8 31 -1 -127 -8 31 -128 7 -128 0 0 }
:: get-pixel ( x y -- z )
x -3 shift y image-row-length * + image-bitmap nth
x bitnot 7 bitand neg shift 1 bitand 1 = ;
:: make-ball ( x y -- shape )
cpBodyAlloc 1.0 NAN: 0 cpBodyInit cpBody memory>struct
x y cpv >>p :> body
cpCircleShapeAlloc body 0.95 0 0 cpv cpCircleShapeInit cpCircleShape memory>struct
[ shape>> 0 >>e ] [ shape>> 0 >>u ] bi drop ;
TUPLE: chipmunk-world < wasd-world
space ;
AFTER: chipmunk-world tick-game-world
space>> 1.0 60.0 / cpSpaceStep ;
SPECIALIZED-ARRAY: cpContact
M:: chipmunk-world draw-world* ( world -- )
1 1 1 0 glClearColor
GL_COLOR_BUFFER_BIT glClear
GL_PROJECTION glMatrixMode
glLoadIdentity
-320 320 -240 240 -1 1 glOrtho
0.5 0.5 0 glTranslatef
GL_VERTEX_ARRAY glEnableClientState
world space>> :> space
3 glPointSize
0 0 0 glColor3f
GL_POINTS glBegin
space bodies>> cpArray memory>struct
[ num>> ] [ arr>> swap <direct-void*-array> ] bi [
cpBody memory>struct p>> [ x>> ] [ y>> ] bi glVertex2f
] each
glEnd
2 glPointSize
1 0 0 glColor3f
GL_POINTS glBegin
space arbiters>> cpArray memory>struct
[ num>> ] [ arr>> swap <direct-void*-array> ] bi [
cpArbiter memory>struct
[ numContacts>> ] [ contacts>> swap <direct-cpContact-array> ] bi [
p>> [ x>> ] [ y>> ] bi glVertex2f
] each
] each
glEnd ;
M:: chipmunk-world begin-game-world ( world -- )
cpInitChipmunk
init-gpu
world { -0.2 0.13 0.1 } 1.1 0.2 set-wasd-view drop
cpSpaceAlloc cpSpaceInit cpSpace memory>struct :> space
world space >>space drop
space 2.0 10000 cpSpaceResizeActiveHash
space 1 >>iterations drop
image-height iota [| y |
image-width iota [| x |
x y get-pixel [
x image-width 2 / - 0.05 0.0 1.0 uniform-random-float * + 2 *
image-height 2 / y - 0.05 0.0 1.0 uniform-random-float * + 2 *
make-ball :> shape
space shape body>> cpSpaceAddBody drop
space shape cpSpaceAddShape drop
] when
] each
] each
space cpBodyAlloc NAN: 0 dup cpBodyInit cpSpaceAddBody cpBody memory>struct :> body
body -1000 -10 cpv >>p drop
body 400 0 cpv >>v drop
space cpCircleShapeAlloc body 8 0 0 cpv cpCircleShapeInit cpSpaceAddShape cpCircleShape memory>struct :> shape
shape
[ shape>> 0 >>e drop ]
[ shape>> 0 >>u drop ] bi ;
M: chipmunk-world end-game-world
space>>
[ cpSpaceFreeChildren ]
[ cpSpaceFree ] bi ;
M: chipmunk-world wasd-movement-speed drop 1/160. ;
M: chipmunk-world wasd-near-plane drop 1/32. ;
M: chipmunk-world wasd-far-plane drop 256.0 ;
GAME: chipmunk-demo {
{ world-class chipmunk-world }
{ title "Chipmunk Physics Demo" }
{ pixel-format-attributes {
windowed
double-buffered
T{ depth-bits { value 24 } }
} }
{ grab-input? t }
{ use-game-input? t }
{ pref-dim { 640 480 } }
{ tick-interval-micros $[ 60 fps ] }
} ;

View File

@ -0,0 +1 @@
Demonstration of Chipmunk library bindings.

View File

@ -0,0 +1 @@
FFI bindings to the Chipmunk 2D physics library.

View File

@ -8,7 +8,7 @@ IN: fuel.remote
<PRIVATE
: start-listener ( -- )
[ [ print-error-and-restarts ] error-hook set listener ] with-scope ;
[ [ print-error-and-restarts drop ] error-hook set listener ] with-scope ;
: server ( port -- server )
utf8 <threaded-server>

View File

@ -31,7 +31,7 @@ HELP: feedback-format:
HELP: GLSL-PROGRAM:
{ $syntax "GLSL-PROGRAM: program-name shader shader ... [vertex-format vertex-format ...] [feedback-format: vertex-format] ;" }
{ $description "Defines a new " { $link program } " named " { $snippet "program-name" } ". When the program is instantiated with " { $link <program-instance> } ", it will link together instances of all of the specified " { $link shader } "s to create the program instance. If any " { $link vertex-format } "s are specified, their attributes will be pre-assigned attribute indexes at link time, to ensure that their indexes remain constant if the program is refreshed with " { $link refresh-program } ". A trasform feedback vertex format may optionally be specified with " { $link POSTPONE: feedback-format: } "; if the program is used to collect transform feedback, the given vertex format will be used for the output." }
{ $description "Defines a new " { $link program } " named " { $snippet "program-name" } ". When the program is instantiated with " { $link <program-instance> } ", it will link together instances of all of the specified " { $link shader } "s to create the program instance. If any " { $link vertex-format } "s are specified, their attributes will be pre-assigned attribute indexes at link time, to ensure that their indexes remain constant if the program is refreshed with " { $link refresh-program } ". A transform feedback vertex format may optionally be specified with " { $link POSTPONE: feedback-format: } "; if the program is used to collect transform feedback, the given vertex format will be used for the output." }
{ $notes "Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
HELP: GLSL-SHADER-FILE:

View File

@ -1,21 +1,13 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar db db.tuples grouping io
USING: accessors calendar db db.tuples db.types grouping io
io.encodings.ascii io.launcher kernel locals make
mason.release.archive mason.server namespaces sequences ;
mason.release.archive mason.config mason.platform mason.server
namespaces sequences ;
IN: mason.server.release
! Host to upload binary package to.
SYMBOL: upload-host
! Username to log in.
SYMBOL: upload-username
! Directory with binary packages.
SYMBOL: upload-directory
: platform ( builder -- string )
[ os>> ] [ cpu>> ] bi "-" glue ;
[ os>> ] [ cpu>> ] bi (platform) ;
: package-name ( builder -- string )
[ platform ] [ last-release>> ] bi "/" glue ;
@ -23,22 +15,30 @@ SYMBOL: upload-directory
: release-name ( version builder -- string )
[
"releases/" %
[ platform % "/" % ]
over % "/" %
[ "factor-" % platform % "-" % % ]
[ os>> extension % ]
tri
bi
] "" make ;
: release-command ( version builder -- command )
[
"ln -s " %
"cp " %
[ nip package-name % " " % ] [ release-name % ] 2bi
] { } make ;
] "" make ;
TUPLE: release
host-name os cpu
last-release release-git-id ;
release "RELEASES" {
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
{ "os" "OS" TEXT +user-assigned-id+ }
{ "cpu" "CPU" TEXT +user-assigned-id+ }
{ "last-release" "LAST_RELEASE" TEXT }
{ "release-git-id" "RELEASE_GIT_ID" TEXT }
} define-persistent
:: <release> ( version builder -- release )
release new
builder host-name>> >>host-name
@ -51,12 +51,13 @@ last-release release-git-id ;
[ "ssh" , upload-host get , "-l" , upload-username get , ] { } make
<process>
swap >>command
30 seconds >>timeout
5 minutes >>timeout
ascii [ write ] with-process-writer ;
: release-script ( version builders -- string )
upload-directory get "cd " "\n" surround prepend
[ release-command ] with map "\n" join ;
[ upload-directory get "cd " "\n" surround ] 2dip
[ release-command ] with map "\n" join
append ;
: create-releases ( version builders -- )
release-script execute-on-server ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,43 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image bootstrap.image.download io io.directories
io.directories.hierarchy io.files.unique io.launcher
io.pathnames kernel sequences namespaces mason.common mason.config ;
IN: mason.source
: clone-factor ( -- )
{ "git" "clone" } home "factor" append-path suffix try-process ;
: prepare-source ( -- )
"factor" [
".git" delete-tree
images [ download-image ] each
] with-directory ;
: package-name ( version -- string )
"factor-src-" ".zip" surround ;
: make-tarball ( version -- path )
[ { "zip" "-qr9" } ] dip package-name
[ suffix "factor" suffix try-process ] keep ;
: make-package ( version -- path )
unique-directory
[
clone-factor prepare-source make-tarball
"Package created: " write absolute-path dup print
] with-directory ;
: remote-location ( version -- dest )
[ upload-directory get "/releases/" ] dip 3append ;
: remote-archive-name ( version -- dest )
[ remote-location ] [ package-name ] bi "/" glue ;
: upload-package ( package version -- )
[ upload-username get upload-host get ] dip
remote-archive-name
upload-safely ;
: release-source-package ( version -- )
[ make-package ] [ upload-package ] bi ;

View File

@ -0,0 +1,29 @@
<?xml version='1.0' ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<link rel="stylesheet" href="http://factorcode.org/css/master.css" type="text/css" media="screen" title="no title" charset="utf-8" />
<title>Factor binary package for <t:label t:name="platform" /></title>
</head>
<body>
<div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
<h1>Factor binary package for <t:label t:name="platform" /></h1>
<p>Requirements:</p>
<t:xml t:name="requirements" />
<h2>Download <t:xml t:name="release" /></h2>
<p>This release was built from GIT ID <t:xml t:name="git-id" />.</p>
<p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Getting started">get started</a> with the language.</p>
</body>
</html>
</t:chloe>

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,103 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs db.tuples furnace.actions
furnace.utilities http.server.responses kernel locals
mason.server mason.server.release sequences splitting urls
webapps.mason.utils xml.syntax xml.writer ;
IN: webapps.mason.grids
: render-grid-cell ( cpu os quot -- xml )
call( cpu os -- url label )
2dup and
[ link [XML <td class="supported"><div class="bigdiv"><-></div></td> XML] ]
[ 2drop [XML <td class="doesnotexist" /> XML] ]
if ;
CONSTANT: oses
{
{ "winnt" "Windows" }
{ "macosx" "Mac OS X" }
{ "linux" "Linux" }
{ "freebsd" "FreeBSD" }
{ "netbsd" "NetBSD" }
{ "openbsd" "OpenBSD" }
}
CONSTANT: cpus
{
{ "x86.32" "x86" }
{ "x86.64" "x86-64" }
{ "ppc" "PowerPC" }
}
: render-grid-header ( -- xml )
oses values [ [XML <th align='center' scope='col'><-></th> XML] ] map ;
:: render-grid-row ( cpu quot -- xml )
cpu second oses keys [| os | cpu os quot render-grid-cell ] map
[XML <tr><th align='center' scope='row'><-></th><-></tr> XML] ;
:: render-grid ( quot -- xml )
render-grid-header
cpus [ quot render-grid-row ] map
[XML
<table id="downloads" cellspacing="0">
<tr><th class="nobg">OS/CPU</th><-></tr>
<->
</table>
XML] ;
: package-url ( builder -- url )
[ URL" $mason-app/package" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
adjust-url ;
: package-date ( filename -- date )
"." split1 drop 16 tail* 6 head* ;
: package-grid-cell ( cpu os -- url label )
builder new swap >>os swap >>cpu select-tuple [
[ package-url ]
[ last-release>> [ package-date ] [ "N/A" ] if* ] bi
] [ f f ] if* ;
: package-grid ( -- xml )
[ package-grid-cell ] render-grid ;
: <package-grid-action> ( -- action )
<action>
[
[
package-grid xml>string
"text/html" <content>
] with-mason-db
] >>display ;
: release-url ( builder -- url )
[ URL" $mason-app/release" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
adjust-url ;
: release-version ( filename -- release )
".tar.gz" ?tail drop ".zip" ?tail drop ".dmg" ?tail drop
"-" split1-last nip ;
: release-grid-cell ( cpu os -- url label )
release new swap >>os swap >>cpu select-tuple [
[ release-url ]
[ last-release>> [ release-version ] [ "N/A" ] if* ] bi
] [ f f ] if* ;
: release-grid ( -- xml )
[ release-grid-cell ] render-grid ;
: <release-grid-action> ( -- action )
<action>
[
[
release-grid xml>string
"text/html" <content>
] with-mason-db
] >>display ;

View File

@ -0,0 +1,20 @@
<?xml version='1.0' ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<title>Make release</title>
</head>
<body>
<t:form t:action="$mason-app/make-release">
Version: <t:field t:name="version" />
<button type="submit">Go</button>
</t:form>
</body>
</html>
</t:chloe>

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,16 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors furnace.actions html.forms
http.server.responses mason.server mason.server.release
validators ;
IN: webapps.mason.make-release
: <make-release-action> ( -- action )
<page-action>
[ { { "version" [ v-one-line ] } } validate-params ] >>validate
[
[
"version" value do-release
"OK" "text/html" <content>
] with-mason-db
] >>submit ;

View File

@ -1,183 +1,41 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators db db.tuples furnace.actions
http.server.responses http.server.dispatchers kernel mason.platform
mason.server mason.report math.order sequences sorting
splitting xml.syntax xml.writer io.pathnames io.encodings.utf8
io.files present validators html.forms furnace.db urls ;
FROM: assocs => at keys values ;
USING: accessors furnace.auth furnace.db
http.server.dispatchers mason.server webapps.mason.grids
webapps.mason.make-release webapps.mason.package
webapps.mason.release webapps.mason.report ;
IN: webapps.mason
TUPLE: mason-app < dispatcher ;
: link ( url label -- xml )
[XML <a href=<->><-></a> XML] ;
SYMBOL: can-make-releases?
: download-link ( builder label -- xml )
[
[ URL" http://builds.factorcode.org/download" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
] dip link ;
: download-grid-cell ( cpu os -- xml )
builder new swap >>os swap >>cpu select-tuple [
dup last-release>> dup
[ "." split1 drop 16 tail* 6 head* download-link ] [ 2drop f ] if
[XML <td class="supported"><div class="bigdiv"><-></div></td> XML]
] [
[XML <td class="doesnotexist" /> XML]
] if* ;
CONSTANT: oses
{
{ "winnt" "Windows" }
{ "macosx" "Mac OS X" }
{ "linux" "Linux" }
{ "freebsd" "FreeBSD" }
{ "netbsd" "NetBSD" }
{ "openbsd" "OpenBSD" }
}
CONSTANT: cpus
{
{ "x86.32" "x86" }
{ "x86.64" "x86-64" }
{ "ppc" "PowerPC" }
}
: download-grid ( -- xml )
oses
[ values [ [XML <th align='center' scope='col'><-></th> XML] ] map ]
[
keys
cpus [
[ nip second ] [ first ] 2bi [
swap download-grid-cell
] curry map
[XML <tr><th align='center' scope='row'><-></th><-></tr> XML]
] with map
] bi
[XML
<table id="downloads" cellspacing="0">
<tr><th class="nobg">OS/CPU</th><-></tr>
<->
</table>
XML] ;
: <download-grid-action> ( -- action )
<action>
[ download-grid xml>string "text/html" <content> ] >>display ;
: validate-os/cpu ( -- )
{
{ "os" [ v-one-line ] }
{ "cpu" [ v-one-line ] }
} validate-params ;
: current-builder ( -- builder )
builder new "os" value >>os "cpu" value >>cpu select-tuple ;
: <build-report-action> ( -- action )
<action>
[ validate-os/cpu ] >>init
[ current-builder last-report>> "text/html" <content> ] >>display ;
: building ( builder string -- xml )
swap current-git-id>> git-link
[XML <-> for <-> XML] ;
: status-string ( builder -- string )
dup status>> {
{ +dirty+ [ drop "Dirty" ] }
{ +clean+ [ drop "Clean" ] }
{ +error+ [ drop "Error" ] }
{ +starting+ [ "Starting build" building ] }
{ +make-vm+ [ "Compiling VM" building ] }
{ +boot+ [ "Bootstrapping" building ] }
{ +test+ [ "Testing" building ] }
[ 2drop "Unknown" ]
} case ;
: current-status ( builder -- xml )
[ status-string ]
[ current-timestamp>> present " (as of " ")" surround ] bi
2array ;
: build-status ( git-id timestamp -- xml )
over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
: binaries-url ( builder -- url )
[ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ;
: latest-binary-link ( builder -- xml )
[ binaries-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
: binaries-link ( builder -- link )
binaries-url dup link ;
: clean-image-url ( builder -- url )
[ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ;
: clean-image-link ( builder -- link )
clean-image-url dup link ;
: report-link ( builder -- xml )
[ URL" report" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
[XML <a href=<->>Latest build report</a> XML] ;
: requirements ( builder -- xml )
[
os>> {
{ "winnt" "Windows XP, Windows Vista or Windows 7" }
{ "macosx" "Mac OS X 10.5 Leopard" }
{ "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
{ "freebsd" "FreeBSD 7.1" }
{ "netbsd" "NetBSD 5.0" }
{ "openbsd" "OpenBSD 4.4" }
} at
] [
dup cpu>> "x86.32" = [
os>> {
{ [ dup { "winnt" "linux" "freebsd" "netbsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
{ [ dup { "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
{ [ t ] [ drop f ] }
} cond
] [ drop f ] if
] bi
2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ;
: last-build-status ( builder -- xml )
[ last-git-id>> ] [ last-timestamp>> ] bi build-status ;
: clean-build-status ( builder -- xml )
[ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ;
: <download-binary-action> ( -- action )
<page-action>
[
validate-os/cpu
"os" value "cpu" value (platform) "platform" set-value
current-builder {
[ latest-binary-link "package" set-value ]
[ release-git-id>> git-link "git-id" set-value ]
[ requirements "requirements" set-value ]
[ host-name>> "host-name" set-value ]
[ current-status "status" set-value ]
[ last-build-status "last-build" set-value ]
[ clean-build-status "last-clean-build" set-value ]
[ binaries-link "binaries" set-value ]
[ clean-image-link "clean-images" set-value ]
[ report-link "last-report" set-value ]
} cleave
] >>init
{ mason-app "download" } >>template ;
can-make-releases? define-capability
: <mason-app> ( -- dispatcher )
mason-app new-dispatcher
<build-report-action> "report" add-responder
<download-binary-action> "download" add-responder
<download-grid-action> "grid" add-responder
mason-db <db-persistence> ;
<build-report-action>
"report" add-responder
<download-package-action>
{ mason-app "download-package" } >>template
"package" add-responder
<package-grid-action>
"packages" add-responder
<download-release-action>
{ mason-app "download-release" } >>template
"release" add-responder
<release-grid-action>
"releases" add-responder
<make-release-action>
{ mason-app "make-release" } >>template
<protected>
"make releases" >>description
{ can-make-releases? } >>capabilities
"make-release" add-responder ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,73 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators furnace.actions html.forms
kernel mason.platform mason.report mason.server present
sequences webapps.mason webapps.mason.report
webapps.mason.utils xml.syntax ;
IN: webapps.mason.package
: building ( builder string -- xml )
swap current-git-id>> git-link
[XML <-> for <-> XML] ;
: status-string ( builder -- string )
dup status>> {
{ +dirty+ [ drop "Dirty" ] }
{ +clean+ [ drop "Clean" ] }
{ +error+ [ drop "Error" ] }
{ +starting+ [ "Starting build" building ] }
{ +make-vm+ [ "Compiling VM" building ] }
{ +boot+ [ "Bootstrapping" building ] }
{ +test+ [ "Testing" building ] }
[ 2drop "Unknown" ]
} case ;
: current-status ( builder -- xml )
[ status-string ]
[ current-timestamp>> present " (as of " ")" surround ] bi
2array ;
: build-status ( git-id timestamp -- xml )
over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
: packages-url ( builder -- url )
[ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ;
: package-link ( builder -- xml )
[ packages-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
: packages-link ( builder -- link )
packages-url dup link ;
: clean-image-url ( builder -- url )
[ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ;
: clean-image-link ( builder -- link )
clean-image-url dup link ;
: last-build-status ( builder -- xml )
[ last-git-id>> ] [ last-timestamp>> ] bi build-status ;
: clean-build-status ( builder -- xml )
[ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ;
: <download-package-action> ( -- action )
<page-action>
[
[
validate-os/cpu
"os" value "cpu" value (platform) "platform" set-value
current-builder {
[ package-link "package" set-value ]
[ release-git-id>> git-link "git-id" set-value ]
[ requirements "requirements" set-value ]
[ host-name>> "host-name" set-value ]
[ current-status "status" set-value ]
[ last-build-status "last-build" set-value ]
[ clean-build-status "last-clean-build" set-value ]
[ packages-link "binaries" set-value ]
[ clean-image-link "clean-images" set-value ]
[ report-link "last-report" set-value ]
} cleave
] with-mason-db
] >>init ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,24 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors furnace.actions html.forms kernel
mason.platform mason.report mason.server sequences webapps.mason
webapps.mason.utils io.pathnames ;
IN: webapps.mason.release
: release-link ( builder -- xml )
[ "http://downloads.factorcode.org/" ] dip
last-release>> [ "/" glue ] [ file-name ] bi link ;
: <download-release-action> ( -- action )
<page-action>
[
[
validate-os/cpu
"os" value "cpu" value (platform) "platform" set-value
current-release
[ release-link "release" set-value ]
[ release-git-id>> git-link "git-id" set-value ]
[ requirements "requirements" set-value ]
tri
] with-mason-db
] >>init ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,21 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors furnace.actions http.server.responses kernel
urls mason.server webapps.mason.utils xml.syntax ;
IN: webapps.mason.report
: <build-report-action> ( -- action )
<action>
[ validate-os/cpu ] >>init
[
[
current-builder last-report>>
"text/html" <content>
] with-mason-db
] >>display ;
: report-link ( builder -- xml )
[ URL" report" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
[XML <a href=<->>Latest build report</a> XML] ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,40 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs db.tuples furnace.actions
html.forms kernel mason.server mason.server.release sequences
validators xml.syntax ;
IN: webapps.mason.utils
: link ( url label -- xml )
[XML <a href=<->><-></a> XML] ;
: validate-os/cpu ( -- )
{
{ "os" [ v-one-line ] }
{ "cpu" [ v-one-line ] }
} validate-params ;
: current-builder ( -- builder )
builder new "os" value >>os "cpu" value >>cpu select-tuple ;
: current-release ( -- builder )
release new "os" value >>os "cpu" value >>cpu select-tuple ;
: requirements ( builder -- xml )
[
os>> {
{ "winnt" "Windows XP, Windows Vista or Windows 7" }
{ "macosx" "Mac OS X 10.5 Leopard" }
{ "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
{ "freebsd" "FreeBSD 7.1" }
{ "netbsd" "NetBSD 5.0" }
{ "openbsd" "OpenBSD 4.5" }
} at
] [
dup cpu>> "x86.32" = [
os>> "macosx" =
f "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2."
?
] [ drop f ] if
] bi
2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ;

View File

@ -1,4 +1,4 @@
! Copyright (c) 2008 Slava Pestov
! Copyright (c) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs io.files io.pathnames
io.sockets io.sockets.secure io.servers.connection
@ -79,6 +79,7 @@ SYMBOL: dh-file
<user-admin> <login-config> <factor-boilerplate> "user-admin" add-responder
<pastebin> <login-config> <factor-boilerplate> "pastebin" add-responder
<planet> <login-config> <factor-boilerplate> "planet" add-responder
<mason-app> <login-config> "mason" add-responder
"/tmp/docs/" <help-webapp> "docs" add-responder
test-db <alloy>
main-responder set-global ;
@ -97,9 +98,9 @@ SYMBOL: dh-file
<login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
<pastebin> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
<mason-app> <login-config> "builds.factorcode.org" add-responder
home "docs" append-path <help-webapp> "docs.factorcode.org" add-responder
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
<mason-app> "builds.factorcode.org" add-responder
main-responder set-global ;
: <factor-secure-config> ( -- config )

View File

@ -101,6 +101,8 @@
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--alien-callback-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
(,fuel-syntax--constructor-decl-regex
(1 'factor-font-lock-word)

View File

@ -46,7 +46,7 @@
'(":" "::" ";" "&:" "<<" "<PRIVATE" ">>"
"ABOUT:" "ALIAS:" "ALIEN:" "ARTICLE:"
"B" "BIN:"
"C:" "C-ENUM:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
"C:" "CALLBACK:" "C-ENUM:" "C-STRUCT:" "C-TYPE:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
"DEFER:"
"EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
"f" "FORGET:" "FROM:" "FUNCTION:"
@ -61,7 +61,7 @@
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"QUALIFIED-WITH:" "QUALIFIED:"
"read-only" "RENAME:" "REQUIRE:" "REQUIRES:"
"SINGLETON:" "SINGLETONS:" "SLOT:" "STRING:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
"SINGLETON:" "SINGLETONS:" "SLOT:" "SPECIALIZED-ARRAY:" "SPECIALIZED-ARRAYS:" "STRING:" "STRUCT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
"TUPLE:" "t" "t?" "TYPEDEF:" "TYPED:" "TYPED::"
"UNIFORM-TUPLE:" "UNION:" "USE:" "USING:"
"VARS:" "VERTEX-FORMAT:"))
@ -125,7 +125,7 @@
(defconst fuel-syntax--type-definition-regex
(fuel-syntax--second-word-regex
'("C-STRUCT:" "C-UNION:" "MIXIN:" "TUPLE:" "SINGLETON:" "UNION:")))
'("C-STRUCT:" "C-UNION:" "MIXIN:" "TUPLE:" "SINGLETON:" "SPECIALIZED-ARRAY:" "STRUCT:" "UNION:")))
(defconst fuel-syntax--tuple-decl-regex
"^TUPLE: +\\([^ \n]+\\) +< +\\([^ \n]+\\)\\_>")
@ -152,6 +152,9 @@
(defconst fuel-syntax--alien-function-regex
"\\_<FUNCTION: \\(\\w+\\) \\(\\w+\\)")
(defconst fuel-syntax--alien-callback-regex
"\\_<CALLBACK: \\(\\w+\\) \\(\\w+\\)")
(defconst fuel-syntax--indent-def-starts '("" ":"
"C-ENUM" "C-STRUCT" "C-UNION"
"FROM" "FUNCTION:"
@ -169,6 +172,7 @@
(defconst fuel-syntax--no-indent-def-starts '("ARTICLE"
"HELP"
"SINGLETONS"
"SPECIALIZED-ARRAYS"
"SYMBOLS"
"VARS"))
@ -186,7 +190,7 @@
(defconst fuel-syntax--single-liner-regex
(regexp-opt '("ABOUT:"
"ALIAS:"
"CONSTANT:" "C:"
"CONSTANT:" "C:" "C-TYPE:"
"DEFER:"
"FORGET:"
"GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:"
@ -198,7 +202,7 @@
"POSTPONE:" "PRIVATE>" "<PRIVATE"
"QUALIFIED-WITH:" "QUALIFIED:"
"RENAME:"
"SINGLETON:" "SLOT:" "SYMBOL:"
"SINGLETON:" "SLOT:" "SPECIALIZED-ARRAY:" "SYMBOL:"
"TYPEDEF:"
"USE:"
"VAR:")))
@ -271,7 +275,7 @@
("\\_<C-ENUM:\\( \\|\n\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)" (1 "<b"))
("\\_<\\(SYMBOLS\\|VARS\\|SINGLETONS\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)"
("\\_<\\(SYMBOLS\\|VARS\\|SPECIALIZED-ARRAYS\\|SINGLETONS\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)"
(2 "<b"))
("\\(\n\\| \\);\\_>" (1 ">b"))
;; Let and lambda: