tuple-arrays: completely rewritten to use functors, 10x faster on benchmark

basis/inverse/inverse.factor

@@ -12,7 +12,7 @@ IN: inverse
 ERROR: fail ;
 M: fail summary drop "Matching failed" ;
 
-: assure ( ? -- ) [ fail ] unless ;
+: assure ( ? -- ) [ fail ] unless ; inline
 
 : =/fail ( obj1 obj2 -- ) = assure ;
 

basis/tuple-arrays/authors.txt

@@ -1 +1 @@
-Daniel Ehrenberg
+Slava Pestov

basis/tuple-arrays/summary.txt

@@ -1 +0,0 @@
-Packed homogeneous tuple arrays

basis/tuple-arrays/tags.txt

@@ -1 +0,0 @@
-collections

basis/tuple-arrays/tuple-arrays-docs.factor

@@ -1,13 +0,0 @@
-USING: help.syntax help.markup splitting kernel sequences ;
-IN: tuple-arrays
-
-HELP: tuple-array
-{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ;
-
-HELP: <tuple-array>
-{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
-{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class." } ;
-
-HELP: >tuple-array
-{ $values { "seq" sequence } { "tuple-array" tuple-array } }
-{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ;

basis/tuple-arrays/tuple-arrays-tests.factor

@@ -5,17 +5,21 @@ IN: tuple-arrays.tests
 SYMBOL: mat
 TUPLE: foo bar ;
 C: <foo> foo
-[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
+TUPLE-ARRAY: foo
+
+[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
 [ T{ foo } ] [ mat get first ] unit-test
 [ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test
-[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
+[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >foo-array dup mat set foo-array? ] unit-test
 [ T{ foo f 3 } t ] 
-[ mat get [ bar>> 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
+[ mat get [ bar>> 2 + <foo> ] map [ first ] keep foo-array? ] unit-test
 
-[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
+[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
 [ T{ foo } ] [ mat get first ] unit-test
 [ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
 
 TUPLE: baz { bing integer } bong ;
-[ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test
-[ f ] [ 1 baz <tuple-array> first bong>> ] unit-test
+TUPLE-ARRAY: baz
+
+[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
+[ f ] [ 1 <baz-array> first bong>> ] unit-test

basis/tuple-arrays/tuple-arrays.factor

@@ -1,34 +1,68 @@
-! Copyright (C) 2007 Daniel Ehrenberg.
+! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: splitting grouping classes.tuple classes math kernel
-sequences arrays accessors ;
+USING: accessors arrays combinators.smart fry functors grouping
+kernel macros sequences sequences.private stack-checker
+parser ;
+FROM: inverse => undo ;
 IN: tuple-arrays
 
-TUPLE: tuple-array { seq read-only } { class read-only } ;
+<PRIVATE
 
-: <tuple-array> ( length class -- tuple-array )
-    [
-        new tuple>array 1 tail
-        [ <repetition> concat ] [ length ] bi <sliced-groups>
-    ] [ ] bi tuple-array boa ;
+MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
 
-M: tuple-array nth
-    [ seq>> nth ] [ class>> ] bi prefix >tuple ;
+: smart-tuple>array ( tuple class -- array )
+    '[ [ _ boa ] undo ] output>array ; inline
 
-M: tuple-array set-nth ( elt n seq -- )
-    [ tuple>array 1 tail ] 2dip seq>> set-nth ;
+: smart-array>tuple ( array class -- tuple )
+    '[ _ boa ] input<sequence ; inline
 
-M: tuple-array new-sequence
-    class>> <tuple-array> ;
+: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
 
-: >tuple-array ( seq -- tuple-array )
+: tuple-prototype ( class -- array )
+    [ new ] [ smart-tuple>array ] bi ; inline
+
+PRIVATE>
+
+FUNCTOR: define-tuple-array ( CLASS -- )
+
+CLASS IS ${CLASS}
+
+CLASS-array DEFINES-CLASS ${CLASS}-array
+CLASS-array? IS ${CLASS-array}?
+
+<CLASS-array> DEFINES <${CLASS}-array>
+>CLASS-array DEFINES >${CLASS}-array
+
+WHERE
+
+TUPLE: CLASS-array { seq sliced-groups read-only } ;
+
+: <CLASS-array> ( length -- tuple-array )
+    CLASS tuple-prototype <repetition> concat
+    CLASS tuple-arity <sliced-groups>
+    CLASS-array boa ;
+
+M: CLASS-array nth-unsafe
+    seq>> nth-unsafe CLASS smart-array>tuple ;
+
+M: CLASS-array set-nth-unsafe
+    [ CLASS smart-tuple>array ] 2dip seq>> set-nth-unsafe ;
+
+M: CLASS-array new-sequence
+    drop <CLASS-array> ;
+
+: >CLASS-array ( seq -- tuple-array )
     dup empty? [
-        0 over first class <tuple-array> clone-like
+        0 <CLASS-array> clone-like
     ] unless ;
 
-M: tuple-array like 
-    drop dup tuple-array? [ >tuple-array ] unless ;
+M: CLASS-array like 
+    drop dup CLASS-array? [ >CLASS-array ] unless ;
 
-M: tuple-array length seq>> length ;
+M: CLASS-array length seq>> length ;
 
-INSTANCE: tuple-array sequence
+INSTANCE: CLASS-array sequence
+
+;FUNCTOR
+
+SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ;

extra/benchmark/tuple-arrays/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/benchmark/tuple-arrays/tuple-arrays.factor

@@ -0,0 +1,20 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions tuple-arrays accessors fry sequences
+prettyprint ;
+IN: benchmark.tuple-arrays
+
+TUPLE: point { x float } { y float } { z float } ;
+
+TUPLE-ARRAY: point
+
+: tuple-array-benchmark ( -- )
+    100 [
+        drop 5000 <point-array> [
+            [ 1+ ] change-x
+            [ 1- ] change-y
+            [ 1+ 2 / ] change-z
+        ] map [ z>> ] sigma
+    ] sigma . ;
+
+MAIN: tuple-array-benchmark