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

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 ] }
+        { [ dup "void" =         ] [ drop void ] }
-        { [ CHAR: ] over member?    ] [ parse-array-type parse-c-type-name prefix ] }
+        { [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
-        { [ dup search c-type-word? ] [ parse-c-type-name ] }
+        { [ dup search           ] [ parse-c-type-name ] }
-        { [ "**" ?tail              ] [ drop void* ] }
+        { [ "**" ?tail           ] [ drop void* ] }
-        { [ "*" ?tail               ] [ parse-c-type-name resolve-pointer-type ] }
+        { [ "*" ?tail            ] [ parse-c-type-name resolve-pointer-type ] }
-        [ dup search [ no-c-type ] [ no-word ] ?if ]
+        [ 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 ]

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

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 ]

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 ;

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 )
+: ?inconsistent ( bool branch -- ?/inconsistent )
-    2dup = [ drop ] [ 2drop !!inconsistent!! ] if ;
+    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

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
+classes.tuple.private math vectors math.vectors quotations
-combinators byte-arrays specialized-arrays ;
+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 ;

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 }

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 ;
-
 <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 )
+: c-type-count ( in/out -- c-type count )
-    dup array? [ unclip swap array-length >fixnum ] [ 1 ] if
+    dup array? [ unclip swap array-length >fixnum ] [ 1 ] if ; inline
-    2dup swap heap-size * >fixnum ; inline
 
-MACRO: >param ( in -- quot: ( array -- param ) )
+: c-type-iter-length ( c-type count -- iter-length )
-    c-type-count '[
+    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 ) )
+: [>object-param] ( class count -- quot )
-    c-type-count dup '[
+    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 ]
+    [ in>>  [ (parse-c-type) ] map parsed ]
-    [ out>> [ parse-c-type ] map parsed ] bi ;
+    [ out>> [ (parse-c-type) ] map parsed ] bi ;
 
 PRIVATE>
 

extra/grid-meshes/grid-meshes.factor

@@ -1,31 +1,26 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors arrays destructors kernel math opengl
+USING: accessors alien.data.map arrays destructors fry grouping
-opengl.gl sequences sequences.product specialized-arrays ;
+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 )
+: vertex-array-row ( range z0 z1 -- vertices )
-    [ swap first /f ]
+    '[ _ _ [ 0.0 swap 1.0 float-4-boa ] bi-curry@ bi ]
-    [ swap second /f ] bi-curry* bi
+    data-map( object -- float-4[2] ) ; inline
-    [ 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 ( dim -- vertices )
-    dup second iota
+    first2 [ [ 0.0 1.0 1.0 ] dip /f <range> ] bi@
-    [ vertex-array-row ] with map concat ;
+    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

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 -- )
     [ <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
+        swap >>dim
-        floats scale bias float-map>byte-map >>bitmap
+        swap >>bitmap
         L >>component-order
         ubyte-components >>component-type ;
 
-TYPED: uniform-noise-map ( seed: integer dim -- map: float-array )
+:: 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
-        _ product 4 / [ 0.0 1.0 uniform-random-float-4 ]
-        float-4-array{ } replicate-as
-        byte-array>float-array
-    ] with-seed ;
 
 : 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 )
+CONSTANT: normal-noise-pow 2
-    swap '[
+CONSTANT: normal-noise-count 4
-        _ product 4 / [ 0.5 _ normal-random-float-4 ]
-        float-4-array{ } replicate-as
-        byte-array>float-array
-    ] with-seed ;
 
-: normal-noise-image ( seed sigma dim -- image )
+TYPED: normal-noise-map ( seed: integer dim -- bytes )
-    [ normal-noise-map ] [ 1.0 0.0 float-map>image ] bi ; inline
+    '[ _ 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

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 <repetition> >byte-array ; inline