Paste: multiarrays

To use this vocabulary, you have to apply the following patch:


diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 2155f14..ea8a64f 100644
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -50,7 +50,8 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
 
 : push ( elt seq -- ) [ length ] [ set-nth ] bi ;
 
-: bounds-check? ( n seq -- ? )
+GENERIC: bounds-check? ( n seq -- ? )
+M: sequence bounds-check?
     dupd length < [ 0 >= ] [ drop f ] if ; inline
 
 ERROR: bounds-error index seq ;


! Copyright (C) 2010 Jon Harper.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences tools.test multiarrays kernel combinators.short-circuit 
memoize math prettyprint io.streams.string ;
IN: multiarrays.tests


[ 12 { 3 1 } ] [ { 4 3 } index-multiplicator ] unit-test 
[ 5 ] [ { 1 2 } { 3 1 } calc-index ] unit-test 
[ t ] [ { 4 3 } <multiarray> {
        [ underlying>> length 12 = ]
        [ lengths>> { 4 3 } = ]
        [ multiplicators>> { 3 1 } = ]
      } 1&& ] unit-test 

MEMO: test-array ( -- narray )
    { 2 5 3 } <multiarray> ;

[ { 1 5 2 } test-array nth ] [ bounds-error? ] must-fail-with
[ { 1 -1 2 } test-array nth ] [ bounds-error? ] must-fail-with
[ { 2 } test-array nth ] [ bounds-error? ] must-fail-with


[ f ] [ { 1 3 2 } test-array nth ] unit-test
[ ] [ t { 1 3 2 } test-array set-nth ] unit-test
[ t ] [ { 1 3 2 } test-array nth ] unit-test

[ ] [ test-array [ drop t ] map
      [ [ "Map didn't work" throw ] unless ] each ] unit-test


[ { 0 0 0 } 
  { 0 0 1 }
  { 0 0 2 }
  { 0 0 3 }
  { 1 0 0 }
  { 1 0 1 }
  { 1 0 2 }
  { 1 0 3 }
  +overflow+ ] [ { 0 0 0 } 8 [ dup { 2 1 4 } increment-index  ] times ] unit-test

[ "{ 0 0 0 }{ 0 0 1 }{ 0 0 2 }{ 0 1 0 }{ 0 1 1 }{ 0 1 2 }{ 0 2 0 }{ 0 2 1 }{ 0 2 2 }{ 0 3 0 }{ 0 3 1 }{ 0 3 2 }{ 0 4 0 }{ 0 4 1 }{ 0 4 2 }{ 1 0 0 }{ 1 0 1 }{ 1 0 2 }{ 1 1 0 }{ 1 1 1 }{ 1 1 2 }{ 1 2 0 }{ 1 2 1 }{ 1 2 2 }{ 1 3 0 }{ 1 3 1 }{ 1 3 2 }{ 1 4 0 }{ 1 4 1 }{ 1 4 2 }" ]
[ test-array [ nip ] mmap-index [ [ pprint ] each ] with-string-writer ] unit-test


! Copyright (C) 2010 Jon Harper.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences sequences.private arrays math kernel combinators.short-circuit 
delegate make generalizations ;
IN: multiarrays


TUPLE: multiarray underlying lengths multiplicators ;
INSTANCE: multiarray sequence
: index-multiplicator ( lengths -- total-length multiplicators )
    <reversed> 1 [ * ] accumulate reverse ;
: <multiarray> ( lengths -- array )
    multiarray new swap >>lengths
    dup lengths>> index-multiplicator 
    [ f <array> >>underlying ] [ >>multiplicators ] bi* ;

M: multiarray length underlying>> length ;
GENERIC# multiarray-bounds-check? 1 ( index seq -- ? )
M: integer multiarray-bounds-check?
   underlying>> bounds-check? ; 
M: array multiarray-bounds-check? 
    { [ lengths>> [ length ] bi@ = ] [ lengths>> [ < ] 2all? ] [ drop [ 0 >= ] all? ] } 2&& ;
M: multiarray bounds-check? multiarray-bounds-check? ;

: calc-index ( {i1,..,in} memory-sizes -- i )
    0 [ * + ] 2reduce ;
: restore-index ( i memory-sizes -- {i1,..,in} )
    swap [ [ /mod swap , ] reduce drop ] { } make ;
GENERIC# delegate-multiarray 1 ( index array -- index array )
M: integer delegate-multiarray
    underlying>> ;
M: array delegate-multiarray 
    [ multiplicators>> calc-index ] keep delegate-multiarray ;
PROTOCOL: multi-index-protocol nth-unsafe set-nth-unsafe ;
CONSULT: multi-index-protocol multiarray
    delegate-multiarray ;

M: multiarray like
    swap >array >>underlying ;
: 2unclip-last-slice ( seq1 seq2 -- head-slice1 head-slice2 last1 last2 )
    [ unclip-last-slice ] bi@ swapd ;
SYMBOL: +overflow+
: increment-index ( index dims -- index' )
    [ drop +overflow+ ] [
    2unclip-last-slice 1 - over > [
        1 + nip
    ] [
        drop increment-index 0 ] if
    over +overflow+ = [ drop ] [ suffix ] if ] if-empty ;
: prepare-meach-index ( multiarray -- first-index multiarray dims )
    [ lengths>> dup length 0 <array> ] keep rot ;
: meach-index ( multiarray quot -- )
    [ prepare-meach-index ] dip
    [ { [ nip swapd call ] [ drop nip increment-index ] } 4 ncleave ] 2curry each drop ; inline
: mmap-index ( multiarray quot -- )
    [ prepare-meach-index ] dip
    [ { [ nip swapd call ] [ drop nip swap [ increment-index ] dip ] } 4 ncleave ] 2curry map nip ; inline