diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index e4ff5789d2..abda8539e9 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -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 ] diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index bd851199ca..73f880a102 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -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 diff --git a/basis/math/vectors/conversion/conversion-tests.factor b/basis/math/vectors/conversion/conversion-tests.factor index d6c16c8518..0f48b47756 100644 --- a/basis/math/vectors/conversion/conversion-tests.factor +++ b/basis/math/vectors/conversion/conversion-tests.factor @@ -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 ] diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index fab55949b4..1bd5834f2c 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -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 ; diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index 8766056a96..e48826d00b 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -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 diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor index 6ec6a9fbb2..b9f9019245 100644 --- a/basis/mirrors/mirrors.factor +++ b/basis/mirrors/mirrors.factor @@ -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 ; diff --git a/extra/alien/data/map/map-tests.factor b/extra/alien/data/map/map-tests.factor index eb47d3675c..7a492ab0c5 100644 --- a/extra/alien/data/map/map-tests.factor +++ b/extra/alien/data/map/map-tests.factor @@ -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 } diff --git a/extra/alien/data/map/map.factor b/extra/alien/data/map/map.factor index 48fcbcd97b..72f5cb5517 100644 --- a/extra/alien/data/map/map.factor +++ b/extra/alien/data/map/map.factor @@ -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 ; - ( 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 '[ _ ] ; + +: [>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> diff --git a/extra/grid-meshes/grid-meshes.factor b/extra/grid-meshes/grid-meshes.factor index 4eaa702468..b63b3d791c 100644 --- a/extra/grid-meshes/grid-meshes.factor +++ b/extra/grid-meshes/grid-meshes.factor @@ -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 ; ] bi@ + 2 [ first2 vertex-array-row ] with map concat ; : >vertex-buffer ( bytes -- buffer ) - [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW ; + [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW ; 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 : ( 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 diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index 032090cae3..5d32ed4502 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -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 -- ) [ ] 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 diff --git a/extra/terrain/generation/generation.factor b/extra/terrain/generation/generation.factor index d1b6dededa..e41d107871 100644 --- a/extra/terrain/generation/generation.factor +++ b/extra/terrain/generation/generation.factor @@ -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 >byte-array ; inline