steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2009-10-16 16:39:19 -05:00
parent 65a2419134 dd6308ead5
commit 1d9c62ae7c
11 changed files with 139 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
basis/alien/parser/parser.factor
View File

@ -10,16 +10,22 @@ IN: alien.parser
: parse-c-type-name ( name -- word )
dup search [ ] [ no-word ] ?if ;
: parse-c-type ( string -- type )
: (parse-c-type) ( string -- type )
{
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ dup search c-type-word? ] [ parse-c-type-name ] }
{ [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ dup search [ no-c-type ] [ no-word ] ?if ]
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ dup search ] [ parse-c-type-name ] }
{ [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ dup search [ ] [ no-word ] ?if ]
} cond ;
: valid-c-type? ( c-type -- ? )
{ [ array? ] [ c-type-name? ] } 1|| ;
: parse-c-type ( string -- type )
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
: scan-c-type ( -- c-type )
scan dup "{" =
[ drop \ } parse-until >array ]

14
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -183,6 +183,13 @@ MACRO: if-literals-match ( quots -- )
[ rep %unpack-vector-head-reps member? ]
[ src rep ^^unpack-vector-head ]
}
{
[ rep unsigned-int-vector-rep? ]
[
rep ^^zero-vector :> zero
src zero rep ^^merge-vector-head
]
}
[
rep ^^zero-vector :> zero
zero src rep cc> ^^compare-vector :> sign
@ -203,6 +210,13 @@ MACRO: if-literals-match ( quots -- )
tail rep ^^unpack-vector-head
]
}
{
[ rep unsigned-int-vector-rep? ]
[
rep ^^zero-vector :> zero
src zero rep ^^merge-vector-tail
]
}
[
rep ^^zero-vector :> zero
zero src rep cc> ^^compare-vector :> sign

6
basis/math/vectors/conversion/conversion-tests.factor
View File

@ -91,6 +91,12 @@ MACRO:: test-vconvert ( from-type to-type -- )
[ uint-4{ -1 2 3 -40000 } uint-4{ 5 60000 -7 80000 } uint-4 short-8 test-vconvert ]
[ error>> bad-vconvert? ] must-fail-with
[ ushort-8{ 0 1 2 3 128 129 130 131 } ushort-8{ 4 5 6 7 132 133 134 135 } ]
[
uchar-16{ 0 1 2 3 128 129 130 131 4 5 6 7 132 133 134 135 }
uchar-16 ushort-8 test-vconvert
] unit-test
! TODO we should be able to do 256->128 pack
! [ float-4{ -1.25 2.0 3.0 -4.0 } ]
[ double-4{ -1.25 2.0 3.0 -4.0 } double-4 float-4 test-vconvert ]

6
basis/math/vectors/simd/intrinsics/intrinsics.factor
View File

@ -8,7 +8,7 @@ sequences sets effects accessors namespaces
lexer parser vocabs.parser words arrays math.vectors ;
IN: math.vectors.simd.intrinsics
ERROR: bad-simd-call ;
ERROR: bad-simd-call word ;
<<
@ -24,7 +24,7 @@ V{ } clone simd-ops set-global
: (SIMD-OP:) ( accum quot -- accum )
[
scan-word dup name>> "(simd-" ")" surround create-in
[ nip [ bad-simd-call ] define ]
[ nip dup '[ _ bad-simd-call ] define ]
] dip
'[ _ dip set-stack-effect ]
[ 2array simd-ops get push ]
@ -147,7 +147,7 @@ GENERIC# supported-simd-op? 1 ( rep intrinsic -- ? )
cc> %compare-vector-reps [ int-vector-rep? ] filter
%xor-vector-reps [ float-vector-rep? ] filter
union
{ uchar-16-rep ushort-8-rep uint-4-rep ulonglong-2-rep } union ;
[ { } ] [ { uchar-16-rep ushort-8-rep uint-4-rep ulonglong-2-rep } union ] if-empty ;
: (%shuffle-imm-reps) ( -- reps )
%shuffle-vector-reps %shuffle-vector-imm-reps union ;

6
basis/math/vectors/simd/simd-tests.factor
View File

@ -394,10 +394,10 @@ simd-classes [
[ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ]
[ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri ; inline
SYMBOL: !!inconsistent!!
TUPLE: inconsistent-vector-test bool branch ;
: ?inconsistent ( a b -- ab/inconsistent )
2dup = [ drop ] [ 2drop !!inconsistent!! ] if ;
: ?inconsistent ( bool branch -- ?/inconsistent )
2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
:: test-vector-tests ( vector decl -- none? any? all? )
vector decl test-vector-tests-bool :> bool-all :> bool-any :> bool-none

6
basis/mirrors/mirrors.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple
classes.tuple.private math vectors quotations accessors
combinators byte-arrays specialized-arrays ;
classes.tuple.private math vectors math.vectors quotations
accessors combinators byte-arrays specialized-arrays ;
IN: mirrors
TUPLE: mirror { object read-only } ;
@ -54,6 +54,8 @@ INSTANCE: vector enumerated-sequence
INSTANCE: callable enumerated-sequence
INSTANCE: byte-array enumerated-sequence
INSTANCE: specialized-array enumerated-sequence
INSTANCE: simd-128 enumerated-sequence
INSTANCE: simd-256 enumerated-sequence
GENERIC: make-mirror ( obj -- assoc )
M: hashtable make-mirror ;

24
extra/alien/data/map/map-tests.factor
View File

@ -1,6 +1,6 @@
! (c)Joe Groff bsd license
USING: alien.data.map fry generalizations kernel locals math.vectors
math.vectors.conversion math math.vectors.simd
math.vectors.conversion math math.vectors.simd sequences
specialized-arrays tools.test ;
FROM: alien.c-types => uchar short int float ;
SIMDS: float int short uchar ;
@ -13,6 +13,28 @@ IN: alien.data.map.tests
byte-array>float-array
] unit-test
[
float-4-array{
float-4{ 0.0 0.0 0.0 0.0 }
float-4{ 1.0 1.0 1.0 1.0 }
float-4{ 2.0 2.0 2.0 2.0 }
}
] [
3 iota [ float-4-with ] data-map( object -- float-4 )
byte-array>float-4-array
] unit-test
[
float-4-array{
float-4{ 0.0 1.0 2.0 3.0 }
float-4{ 4.0 5.0 6.0 7.0 }
float-4{ 8.0 9.0 10.0 11.0 }
}
] [
12 iota [ float-4-boa ] data-map( object[4] -- float-4 )
byte-array>float-4-array
] unit-test
[ float-array{ 1.0 1.0 3.0 3.0 5.0 5.0 0.0 0.0 } ]
[
int-array{ 1 3 5 } float-array{ 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 }

50
extra/alien/data/map/map.factor
View File

@ -1,12 +1,10 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data alien.parser arrays
byte-arrays combinators effects.parser fry generalizations kernel
byte-arrays combinators effects.parser fry generalizations grouping kernel
lexer locals macros make math math.ranges parser sequences sequences.private ;
FROM: alien.arrays => array-length ;
IN: alien.data.map
ERROR: bad-data-map-input-length byte-length iter-size remainder ;
<PRIVATE
: <displaced-direct-array> ( displacement bytes length type -- direct-array )
@ -21,8 +19,6 @@ TUPLE: data-map-param
{ iter-length fixnum read-only }
{ iter-count fixnum read-only } ;
ERROR: bad-data-map-param param remainder ;
M: data-map-param length
iter-count>> ; inline
@ -36,12 +32,14 @@ M: data-map-param nth-unsafe
INSTANCE: data-map-param immutable-sequence
: c-type-count ( in/out -- c-type count iter-length )
dup array? [ unclip swap array-length >fixnum ] [ 1 ] if
2dup swap heap-size * >fixnum ; inline
: c-type-count ( in/out -- c-type count )
dup array? [ unclip swap array-length >fixnum ] [ 1 ] if ; inline
MACRO: >param ( in -- quot: ( array -- param ) )
c-type-count '[
: c-type-iter-length ( c-type count -- iter-length )
swap heap-size * >fixnum ; inline
: [>c-type-param] ( c-type count -- quot )
2dup c-type-iter-length '[
[ _ _ ] dip
[ ]
[ >c-ptr ]
@ -51,8 +49,18 @@ MACRO: >param ( in -- quot: ( array -- param ) )
data-map-param boa
] ;
MACRO: alloc-param ( out -- quot: ( len -- param ) )
c-type-count dup '[
: [>object-param] ( class count -- quot )
nip '[ _ <sliced-groups> ] ;
: [>param] ( type -- quot )
c-type-count over c-type-name?
[ [>c-type-param] ] [ [>object-param] ] if ;
MACRO: >param ( in -- quot: ( array -- param ) )
[>param] ;
: [alloc-c-type-param] ( c-type count -- quot )
2dup c-type-iter-length dup '[
[ _ _ ] dip
[
_ * >fixnum [ (byte-array) dup ] keep
@ -61,11 +69,21 @@ MACRO: alloc-param ( out -- quot: ( len -- param ) )
data-map-param boa
] ;
: [alloc-object-param] ( type count -- quot )
"Factor sequences as data-map outputs not supported" throw ;
: [alloc-param] ( type -- quot )
c-type-count over c-type-name?
[ [alloc-c-type-param] ] [ [alloc-object-param] ] if ;
MACRO: alloc-param ( out -- quot: ( len -- param ) )
[alloc-param] ;
MACRO: unpack-params ( ins -- )
[ c-type-count drop nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
[ c-type-count nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
MACRO: pack-params ( outs -- )
[ ] [ c-type-count drop nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
[ ] [ c-type-count nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
fry [ call ] compose ;
:: [data-map] ( ins outs param-quot -- quot )
@ -99,8 +117,8 @@ MACRO: data-map! ( ins outs -- )
: parse-data-map-effect ( accum -- accum )
")" parse-effect
[ in>> [ parse-c-type ] map parsed ]
[ out>> [ parse-c-type ] map parsed ] bi ;
[ in>> [ (parse-c-type) ] map parsed ]
[ out>> [ (parse-c-type) ] map parsed ] bi ;
PRIVATE>

34
extra/grid-meshes/grid-meshes.factor
View File

@ -1,31 +1,26 @@
! (c)2009 Joe Groff bsd license
USING: accessors arrays destructors kernel math opengl
opengl.gl sequences sequences.product specialized-arrays ;
USING: accessors alien.data.map arrays destructors fry grouping
kernel math math.ranges math.vectors.simd opengl opengl.gl sequences
sequences.product specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SIMD: float
SPECIALIZED-ARRAY: float-4
IN: grid-meshes
TUPLE: grid-mesh dim buffer row-length ;
<PRIVATE
: vertex-array-vertex ( dim x z -- vertex )
[ swap first /f ]
[ swap second /f ] bi-curry* bi
[ 0 ] dip float-array{ } 3sequence ;
: vertex-array-row ( dim z -- vertices )
dup 1 + 2array
over first 1 + iota
2array [ first2 swap vertex-array-vertex ] with product-map
concat ;
: vertex-array-row ( range z0 z1 -- vertices )
'[ _ _ [ 0.0 swap 1.0 float-4-boa ] bi-curry@ bi ]
data-map( object -- float-4[2] ) ; inline
: vertex-array ( dim -- vertices )
dup second iota
[ vertex-array-row ] with map concat ;
first2 [ [ 0.0 1.0 1.0 ] dip /f <range> ] bi@
2 <sliced-clumps> [ first2 vertex-array-row ] with map concat ;
: >vertex-buffer ( bytes -- buffer )
[ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
[ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ; inline
: draw-vertex-buffer-row ( grid-mesh i -- )
swap [ GL_TRIANGLE_STRIP ] 2dip
@ -36,13 +31,16 @@ PRIVATE>
: draw-grid-mesh ( grid-mesh -- )
GL_ARRAY_BUFFER over buffer>> [
[ 3 GL_FLOAT 0 f glVertexPointer ] dip
[ 4 GL_FLOAT 0 f glVertexPointer ] dip
dup dim>> second iota [ draw-vertex-buffer-row ] with each
] with-gl-buffer ;
USE: tools.time
: <grid-mesh> ( dim -- grid-mesh )
[
[ ] [ vertex-array >vertex-buffer ] [ first 1 + 2 * ] tri
grid-mesh boa ;
grid-mesh boa
] time ;
M: grid-mesh dispose
[ [ delete-gl-buffer ] when* f ] change-buffer

61
extra/noise/noise.factor
View File

@ -4,32 +4,13 @@ math.libm math.matrices.simd math.vectors math.vectors.conversion math.vectors.s
memoize random random.mersenne-twister sequences sequences.private specialized-arrays
typed ;
QUALIFIED-WITH: alien.c-types c
SIMDS: c:float c:int c:short c:uchar ;
SIMDS: c:float c:int c:short c:ushort c:uchar ;
SPECIALIZED-ARRAYS: c:float c:uchar float-4 uchar-16 ;
IN: noise
: with-seed ( seed quot -- )
[ <mersenne-twister> ] dip with-random ; inline
: random-int-4 ( -- v )
16 random-bytes underlying>> int-4 boa ; inline
: (random-float-4) ( -- v )
random-int-4 int-4 float-4 vconvert ; inline
! XXX redundant add
: uniform-random-float-4 ( min max -- n )
(random-float-4) (random-float-4)
2.0 31 ^ v+n 2.0 32 ^ v*n v+
[ over - 2.0 -64 ^ * ] dip n*v n+v ; inline
: normal-random-float-4 ( mean sigma -- n )
0.0 1.0 uniform-random-float-4
0.0 1.0 uniform-random-float-4
[ 2 pi * v*n [ fcos ] map ]
[ 1.0 swap n-v [ flog ] map -2.0 v*n vsqrt ]
bi* v* n*v n+v ; inline
: float-map>byte-map ( floats: float-array scale: float bias: float -- bytes: byte-array )
'[
[ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply
@ -37,32 +18,34 @@ IN: noise
short-8 uchar-16 vconvert
] data-map( float-4[4] -- uchar-16 ) ; inline
TYPED:: float-map>image ( floats: float-array dim scale: float bias: float -- image: image )
TYPED: byte-map>image ( bytes: byte-array dim -- image: image )
image new
dim >>dim
floats scale bias float-map>byte-map >>bitmap
swap >>dim
swap >>bitmap
L >>component-order
ubyte-components >>component-type ;
TYPED: uniform-noise-map ( seed: integer dim -- map: float-array )
'[
_ product 4 / [ 0.0 1.0 uniform-random-float-4 ]
float-4-array{ } replicate-as
byte-array>float-array
] with-seed ;
:: float-map>image ( floats: float-array dim scale: float bias: float -- image: image )
floats scale bias float-map>byte-map dim byte-map>image ; inline
: uniform-noise-image ( seed dim -- image )
[ uniform-noise-map ] [ 1.0 0.0 float-map>image ] bi ; inline
[ '[ _ product random-bytes >byte-array ] with-seed ]
[ byte-map>image ] bi ; inline
TYPED: normal-noise-map ( seed: integer sigma: float dim -- map: float-array )
swap '[
_ product 4 / [ 0.5 _ normal-random-float-4 ]
float-4-array{ } replicate-as
byte-array>float-array
] with-seed ;
CONSTANT: normal-noise-pow 2
CONSTANT: normal-noise-count 4
: normal-noise-image ( seed sigma dim -- image )
[ normal-noise-map ] [ 1.0 0.0 float-map>image ] bi ; inline
TYPED: normal-noise-map ( seed: integer dim -- bytes )
'[ _ product normal-noise-count * random-bytes >byte-array ] with-seed
[
[ ushort-8{ 0 0 0 0 0 0 0 0 } ushort-8{ 0 0 0 0 0 0 0 0 } ] normal-noise-count ndip
[ uchar-16 ushort-8 vconvert [ v+ ] bi-curry@ bi* ] normal-noise-count napply
[ normal-noise-pow vrshift ] bi@
ushort-8 uchar-16 vconvert
] data-map( uchar-16[normal-noise-count] -- uchar-16 ) ; inline
: normal-noise-image ( seed dim -- image )
[ normal-noise-map ] [ byte-map>image ] bi ; inline
ERROR: invalid-perlin-noise-table table ;
@ -73,7 +56,7 @@ ERROR: invalid-perlin-noise-table table ;
dup { [ byte-array? ] [ length 512 >= ] } 1&&
[ invalid-perlin-noise-table ] unless ;
! XXX doesn't work for NaNs or very large floats
! XXX doesn't work for NaNs or floats > 2^31
: floor-vector ( v -- v' )
[ float-4 int-4 vconvert int-4 float-4 vconvert ]
[ [ v> -1.0 float-4-with vand ] curry keep v+ ] bi ; inline

2
extra/terrain/generation/generation.factor
View File

@ -32,7 +32,7 @@ TUPLE: terrain
terrain-segment-size-vector v* translation-matrix4 m4.
terrain-segment-size perlin-noise-image bitmap>> ; inline
: tiny-noise-segment ( terrain at -- bytes )
[ tiny-noise-seed>> ] dip seed-at 0.1
[ tiny-noise-seed>> ] dip seed-at
terrain-segment-size normal-noise-image bitmap>> ; inline
: padding ( terrain at -- padding )
2drop terrain-segment-size product 255 <repetition> >byte-array ; inline