read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
: read-ignoring ( ignoring n -- str )
- [ drop read1-ignoring ] with map harvest
+ [ drop read1-ignoring ] with { } map-integers
+ [ { f 0 } member? not ] filter
[ f ] [ >string ] if-empty ;
: ch>base64 ( ch -- ch )
[ write1-lines ] each ;
: encode3 ( seq -- )
- be> 4 <reversed> [
+ be> 4 iota <reversed> [
-6 * shift HEX: 3f bitand ch>base64 write1-lines
] with each ; inline
-USING: binary-search math.order vectors kernel tools.test ;
+USING: binary-search math.order sequences kernel tools.test ;
IN: binary-search.tests
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
-[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
+[ 10 ] [ 10 20 iota [ <=> ] with search drop ] unit-test
[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
[ t ] [
100 [
- drop 100 [ 2 random zero? ] replicate
+ drop 100 [ 2 iota random zero? ] replicate
dup >bit-array >array =
- ] all?
+ ] all-integers?
] unit-test
[ ?{ f } ] [
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data accessors math alien.accessors kernel
kernel.private sequences sequences.private byte-arrays
: (set-bits) ( bit-array n -- )
[ [ length bits>cells ] keep ] dip swap underlying>>
- '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
+ '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline
: clean-up ( bit-array -- )
! Zero bits after the end.
] if ;
: bit-array>integer ( bit-array -- n )
- 0 swap underlying>> dup length <reversed> [
+ 0 swap underlying>> dup length iota <reversed> [
alien-unsigned-1 swap 8 shift bitor
] with each ;
[ 0 ] [ 123 <bit-vector> length ] unit-test\r
\r
: do-it ( seq -- )\r
- 1234 swap [ [ even? ] dip push ] curry each ;\r
+ 1234 swap [ [ even? ] dip push ] curry each-integer ;\r
\r
[ t ] [\r
3 <bit-vector> dup do-it\r
[ t ] [ 1325376000 unix-time>timestamp 2012 <year-gmt> = ] unit-test
[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
-[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
+[ t ] [ 1500000000 iota random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: math math.order math.parser math.functions kernel\r
sequences io accessors arrays io.streams.string splitting\r
[\r
[ 1 + day. ] keep\r
1 + + 7 mod zero? [ nl ] [ bl ] if\r
- ] with each nl ;\r
+ ] with each-integer nl ;\r
\r
M: timestamp month. ( timestamp -- )\r
[ year>> ] [ month>> ] bi 2array month. ;\r
GENERIC: year. ( obj -- )\r
\r
M: integer year. ( n -- )\r
- 12 [ 1 + 2array month. nl ] with each ;\r
+ 12 [ 1 + 2array month. nl ] with each-integer ;\r
\r
M: timestamp year. ( timestamp -- )\r
year>> year. ;\r
M cloned-H sha2 T1-256
cloned-H T2-256
cloned-H update-H
- ] each
+ ] each-integer
sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
M: sha2-short checksum-block
b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
a H nth-unsafe b H set-nth-unsafe
a H set-nth-unsafe
- ] each
+ ] each-integer
state [ H [ w+ ] 2map ] change-H drop ; inline
M:: sha1-state checksum-block ( bytes state -- )
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ;
+USING: classes.struct.bit-accessors tools.test effects kernel
+sequences random stack-checker ;
IN: classes.struct.bit-accessors.test
-[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test
-[ t ] [ 20 random 20 random bit-writer infer (( n alien -- )) effect= ] unit-test
+[ t ] [ 20 iota random 20 iota random bit-reader infer (( alien -- n )) effect= ] unit-test
+[ t ] [ 20 iota random 20 iota random bit-writer infer (( n alien -- )) effect= ] unit-test
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
classes.struct continuations combinators compiler compiler.alien
(free) ;
: method-arg-types ( method -- args )
- dup method_getNumberOfArguments
+ dup method_getNumberOfArguments iota
[ method-arg-type ] with map ;
: method-return-type ( method -- ctype )
[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
[ ] [ "seq" get 1 <column> [ sq ] map! drop ] unit-test
[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
+
+[ { { 1 3 } { 2 4 } } ] [ { { 1 2 } { 3 4 } } <flipped> [ >array ] map ] unit-test
-! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2005, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel accessors ;
IN: columns
INSTANCE: column virtual-sequence
: <flipped> ( seq -- seq' )
- dup empty? [ dup first length [ <column> ] with map ] unless ;
+ dup empty? [ dup first length [ <column> ] with { } map-integers ] unless ;
stack-checker math sequences ;
IN: combinators.smart
+<PRIVATE
+
+: inputs ( quot -- n ) infer in>> length ;
+
+: outputs ( quot -- n ) infer out>> length ;
+
+PRIVATE>
+
MACRO: drop-outputs ( quot -- quot' )
- dup infer out>> '[ @ _ ndrop ] ;
+ dup outputs '[ @ _ ndrop ] ;
MACRO: keep-inputs ( quot -- quot' )
- dup infer in>> '[ _ _ nkeep ] ;
+ dup inputs '[ _ _ nkeep ] ;
MACRO: output>sequence ( quot exemplar -- newquot )
- [ dup infer out>> ] dip
+ [ dup outputs ] dip
'[ @ _ _ nsequence ] ;
MACRO: output>array ( quot -- newquot )
'[ _ { } output>sequence ] ;
MACRO: input<sequence ( quot -- newquot )
- [ infer in>> ] keep
+ [ inputs ] keep
'[ _ firstn @ ] ;
MACRO: input<sequence-unsafe ( quot -- newquot )
- [ infer in>> ] keep
+ [ inputs ] keep
'[ _ firstn-unsafe @ ] ;
MACRO: reduce-outputs ( quot operation -- newquot )
- [ dup infer out>> 1 [-] ] dip n*quot compose ;
+ [ dup outputs 1 [-] ] dip n*quot compose ;
MACRO: sum-outputs ( quot -- n )
'[ _ [ + ] reduce-outputs ] ;
MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
- [ dup infer out>> ] 2dip
+ [ dup outputs ] 2dip
[ swap '[ _ _ napply ] ]
[ [ 1 [-] ] dip n*quot ] bi-curry* bi
'[ @ @ @ ] ;
MACRO: append-outputs-as ( quot exemplar -- newquot )
- [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
+ [ dup outputs ] dip '[ @ _ _ nappend-as ] ;
MACRO: append-outputs ( quot -- seq )
'[ _ { } append-outputs-as ] ;
MACRO: preserving ( quot -- )
- [ infer in>> length ] keep '[ _ ndup @ ] ;
+ [ inputs ] keep '[ _ ndup @ ] ;
MACRO: nullary ( quot -- quot' )
- dup infer out>> length '[ @ _ ndrop ] ;
+ dup outputs '[ @ _ ndrop ] ;
MACRO: smart-if ( pred true false -- )
'[ _ preserving _ _ if ] ; inline
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
make fry sequences parser accessors effects namespaces
"pure-insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
- boa-effect in>> but-last f <effect> ;
+ boa-effect in>> but-last { } <effect> ;
: define-insn-tuple ( class superclass specs -- )
[ name>> ] map "insn#" suffix define-tuple-class ;
: define-insn-ctor ( class specs -- )
[ dup '[ _ ] [ f ] [ boa , ] surround ] dip
- [ name>> ] map f <effect> define-declared ;
+ [ name>> ] map { } <effect> define-declared ;
: define-insn ( class superclass specs -- )
parse-insn-slot-specs {
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences accessors arrays
byte-arrays layouts classes.tuple.private fry locals
[ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
:: store-initial-element ( len reg elt class -- )
- len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ;
+ len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each-integer ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math sequences kernel namespaces accessors biassocs compiler.cfg
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
: ds-load ( n -- vregs )
dup 0 =
[ drop f ]
- [ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
+ [ [ iota <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
: ds-store ( vregs -- )
[
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences byte-arrays namespaces accessors classes math
math.order fry arrays combinators compiler.cfg.registers
2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
: (uninitialized-locs) ( seq quot -- seq' )
- [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
+ [ [ drop 0 = ] pusher [ each-index ] dip ] dip map ; inline
PRIVATE>
[ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
: prepare-unbox-parameters ( parameters -- offsets types indices )
- [ parameter-offsets nip ] [ ] [ length iota reverse ] tri ;
+ [ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
: unbox-parameters ( offset node -- )
parameters>> swap
{ int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
alien-invoke gc 3 ;
-[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+[ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
float
{ float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
alien-invoke ;
-[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
+[ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;
: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
-[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
+[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
[ t ] [ callback-1 alien? ] unit-test
1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
[ t ] [
- 10000000 [ drop try-breaking-dispatch-2 ] all?
+ 10000000 [ drop try-breaking-dispatch-2 ] all-integers?
] unit-test
! Regression
! Bug with ##return node construction
: return-recursive-bug ( nodes -- ? )
- { fixnum } declare [
+ { fixnum } declare iota [
dup 3 bitand 1 = [ drop t ] [
dup 3 bitand 2 = [
return-recursive-bug
[ ] [
10000 [
- 5 random [ drop 32 random-bits ] map product >bignum
+ 5 iota random iota [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if
] times
: double-label-2 ( a -- b )
dup array? [ ] [ ] if 0 t double-label-1 ;
-[ 0 ] [ 10 double-label-2 ] unit-test
+[ 0 ] [ 10 iota double-label-2 ] unit-test
! regression
GENERIC: void-generic ( obj -- * )
] if ; inline recursive
[ 10 ] [
- 10 20 >vector <flat-slice>
+ 10 20 iota <flat-slice>
[ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test
[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
-[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 iota [ ] B{ } map-as ] compile-call ] unit-test
[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
] unit-test
[ t ] [
- [ { fixnum } declare length [ drop ] each-integer ]
+ [ { fixnum } declare iota [ drop ] each ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
- [ { fixnum } declare [ drop ] each ]
- { < <-integer-fixnum +-integer-fixnum + } inlined?
-] unit-test
-
-[ t ] [
- [ { fixnum } declare 0 [ + ] reduce ]
+ [ { fixnum } declare iota 0 [ + ] reduce ]
{ < <-integer-fixnum nth-unsafe } inlined?
] unit-test
[ f ] [
- [ { fixnum } declare 0 [ + ] reduce ]
+ [ { fixnum } declare iota 0 [ + ] reduce ]
\ +-integer-fixnum inlined?
] unit-test
[ f ] [
[
- { integer } declare [ ] map
+ { integer } declare iota [ ] map
] \ >fixnum inlined?
] unit-test
[ t ] [
[
- { integer } declare [ 0 >= ] map
+ { integer } declare iota [ 0 >= ] map
] { >= fixnum>= } inlined?
] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences namespaces kernel accessors assocs sets fry
arrays combinators columns stack-checker.backend
: drop-indexed-values ( values indices -- node )
[ drop filter-live ] [ swap nths ] 2bi
- [ make-values ] keep
+ [ length make-values ] keep
[ drop ] [ zip ] 2bi
#data-shuffle ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs sequences kernel locals fry
combinators stack-checker.backend
:: drop-dead-inputs ( inputs outputs -- #shuffle )
inputs filter-live
- outputs inputs filter-corresponding make-values
+ outputs inputs filter-corresponding length make-values
outputs
inputs
drop-values ;
2bi ;
:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
- inputs outputs filter-corresponding make-values :> new-live-outputs
+ inputs outputs filter-corresponding length make-values :> new-live-outputs
outputs filter-live :> live-outputs
new-live-outputs
live-outputs
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors words assocs sequences arrays namespaces
fry locals definitions classes classes.algebra generic
filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle )
- outputs make-values :> new-outputs
+ outputs length make-values :> new-outputs
outputs filter-live :> live-outputs
new-outputs
live-outputs
M: shuffle-node pprint* effect>> effect>string text ;
: (shuffle-effect) ( in out #shuffle -- effect )
- mapping>> '[ _ at ] map <effect> ;
+ mapping>> '[ _ at ] map [ >array ] bi@ <effect> ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
-USING: kernel tools.test namespaces sequences
+USING: kernel tools.test namespaces sequences math
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.recursive.tests
H{ } clone allocations set
<escaping-values> escaping-values set
-[ ] [ 8 [ introduce-value ] each ] unit-test
+[ ] [ 8 [ introduce-value ] each-integer ] unit-test
[ ] [ { 1 2 } 3 record-allocation ] unit-test
[ t ] [
[
- { fixnum } declare 0 swap
+ { fixnum } declare iota 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
[ t ] [
[
- { integer } declare [ 256 mod ] map
+ { integer } declare iota [ 256 mod ] map
] { mod fixnum-mod } inlined?
] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math math.order accessors kernel arrays
combinators assocs
] with-variable ;
M: #recursive normalize*
- dup label>> introductions>>
- [ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
- [ make-values '[ _ (normalize) ] change-child ]
- 2bi ;
+ [ [ child>> first ] [ in-d>> ] bi >>in-d drop ]
+ [ dup label>> introductions>> make-values '[ _ (normalize) ] change-child ]
+ bi ;
M: #enter-recursive normalize*
[ introduction-stack get prepend ] change-out-d
-! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2009, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.private effects fry
-kernel kernel.private make sequences continuations quotations
-words math stack-checker combinators.short-circuit
+USING: accessors arrays combinators combinators.private effects
+fry kernel kernel.private make sequences continuations
+quotations words math stack-checker combinators.short-circuit
stack-checker.transforms compiler.tree.propagation.info
compiler.tree.propagation.inlining compiler.units ;
IN: compiler.tree.propagation.call-effect
M: effect curry-effect
[ in>> length ] [ out>> length ] [ terminated?>> ] tri
pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
- effect boa ;
+ [ [ "x" <array> ] bi@ ] dip effect boa ;
M: curry cached-effect
quot>> cached-effect curry-effect ;
[ f ] [ 0.0 -0.0 eql? ] unit-test
-[ t ] [
- number <class-info>
- sequence <class-info>
- value-info-intersect
- class>> integer class=
-] unit-test
-
[ t t ] [
0 10 [a,b] <interval-info>
5 20 [a,b] <interval-info>
] final-literals
] unit-test
-[ V{ 27 } ] [
- [
- dup number? over sequence? and [
- dup 10 < over 8 <= not and [ 3 * ] [ "A" throw ] if
- ] [ "B" throw ] if
- ] final-literals
-] unit-test
-
[ V{ string string } ] [
[
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
] unit-test
[ V{ fixnum } ] [
- [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
+ [ { fixnum fixnum } declare iota [ nth-unsafe ] curry call ] final-classes
] unit-test
[ V{ f } ] [
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
'[ _ _ with-datastack [ <literal-info> ] map nip ]
- [ drop [ object-info ] replicate ]
+ [ drop length [ object-info ] replicate ]
recover ;
: fold-call ( #call word -- )
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel sequences words fry generic accessors
classes.tuple classes classes.algebra definitions
\ index [
dup sequence? [
dup length 4 >= [
- dup length zip >hashtable '[ _ at ]
+ dup length iota zip >hashtable '[ _ at ]
] [ drop f ] if
] [ drop f ] if
] 1 define-partial-eval
} 1&& ;
: lookup-table-seq ( assoc -- table )
- [ keys supremum 1 + ] keep '[ _ at ] { } map-as ;
+ [ keys supremum 1 + iota ] keep '[ _ at ] { } map-as ;
: lookup-table-quot ( seq -- newquot )
lookup-table-seq
5 bitstream bs:read 1 +
4 bitstream bs:read 4 + clen-shuffle swap head
- dup length iota [ 3 bitstream bs:read ] replicate
+ dup length [ 3 bitstream bs:read ] replicate
get-table
bitstream swap <huffman-decoder>
[ 2dup + ] dip swap :> k!
MEMO: static-huffman-tables ( -- obj )
[
- 0 143 [a,b] [ 8 ] replicate
- 144 255 [a,b] [ 9 ] replicate append
- 256 279 [a,b] [ 7 ] replicate append
- 280 287 [a,b] [ 8 ] replicate append
+ 0 143 [a,b] length [ 8 ] replicate
+ 144 255 [a,b] length [ 9 ] replicate append
+ 256 279 [a,b] length [ 7 ] replicate append
+ 280 287 [a,b] length [ 8 ] replicate append
] append-outputs
- 0 31 [a,b] [ 5 ] replicate 2array
+ 0 31 [a,b] length [ 5 ] replicate 2array
[ [ length>> [0,b) ] [ ] bi get-table ] map ;
CONSTANT: length-table
\r
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test\r
\r
-[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 random sleep sq ] parallel-map ] unit-test\r
+[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 iota random sleep sq ] parallel-map ] unit-test\r
\r
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]\r
[ error>> "Even" = ] must-fail-with\r
\r
[ V{ 0 3 6 9 } ]\r
-[ 10 [ 3 mod zero? ] parallel-filter ] unit-test\r
+[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test\r
\r
[ 10 ]\r
[\r
V{ } clone\r
- 10 over [ push ] curry parallel-each\r
+ 10 iota over [ push ] curry parallel-each\r
length\r
] unit-test\r
\r
[ 20 ]\r
[\r
V{ } clone\r
- 10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each\r
+ 10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each\r
length\r
] unit-test\r
\r
t >>bound? drop ;
: sql-row ( result-set -- seq )
- dup #columns [ row-column ] with map ;
+ dup #columns [ row-column ] with { } map-integers ;
: sql-row-typed ( result-set -- seq )
- dup #columns [ row-column-typed ] with map ;
+ dup #columns [ row-column-typed ] with { } map-integers ;
: query-each ( statement quot: ( statement -- ) -- )
over more-rows? [
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
- drop [ retries>> ] [
+ drop [ retries>> iota ] [
[
nip
[ query-results dispose t ]
} define-persistent
: test-1-tuple ( -- tuple )
- f 100 random 100 random 100 random [ number>string ] tri@
+ f 100 iota random 100 iota random 100 iota random [ number>string ] tri@
test-1 boa ;
: db-tester ( test-db -- )
test-2 ensure-table
] with-db
] [
- 10 [
+ 10 iota [
drop
10 [
dup [
] with-db
] [
<db-pool> [
- 10 [
+ 10 iota [
10 [
test-1-tuple insert-tuple yield
] times
: random-markup ( -- string )
10 [
- 2 random 1 = [
+ 2 iota random 1 = [
{
"[["
"*"
100 [
drop random-markup
[ convert-farkup drop t ] [ drop print f ] recover
- ] all?
+ ] all-integers?
] unit-test
[ "<p><a href=\"http://foo.com/~foo\">http://foo.com/~foo</a></p>" ] [ "[[http://foo.com/~foo]]" convert-farkup ] unit-test
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
[ { 1 2 3 } ] [
- 3 1 '[ _ [ _ + ] map ] call
+ 3 1 '[ _ iota [ _ + ] map ] call
] unit-test
[ { 1 { 2 { 3 } } } ] [
{ 3 5 } [ 2 nweave ] must-infer-as\r
\r
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]\r
-[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test\r
+[ 9 [ ] each-integer { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test\r
\r
[ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test\r
\r
<min-heap> [ heap-push-all ] keep heap-pop-all ;
: random-alist ( n -- alist )
- [
+ iota [
drop 32 random-bits dup number>string
] H{ } map>assoc ;
14 [
[ t ] swap [ 2^ test-heap-sort ] curry unit-test
-] each
+] each-integer
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ heap-push-all ] keep
- data>> dup length swap [ index>> ] map sequence= ;
+ data>> dup length iota swap [ index>> ] map sequence= ;
14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
-] each
+] each-integer
: sort-entries ( entries -- entries' )
[ key>> ] sort-with ;
11 [
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
-] each
+] each-integer
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays byte-vectors classes
combinators definitions effects fry generic generic.single
"specializer" word-prop ;
: make-specializer ( specs -- quot )
- dup length <reversed>
+ dup length iota <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
[ [ t ] ] [
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic hashtables io kernel assocs math
namespaces prettyprint prettyprint.custom prettyprint.sections
M: enum add-numbers ;
M: assoc add-numbers
- +number-rows+ get [
- dup length [ prefix ] 2map
- ] when ;
+ +number-rows+ get [ [ prefix ] map-index ] when ;
TUPLE: slot-name name ;
: enough? ( stack word -- ? )
dup deferred? [ 2drop f ] [
- [ [ length ] [ 1quotation infer in>> ] bi* >= ]
+ [ [ length ] [ 1quotation infer in>> length ] bi* >= ]
[ 3drop f ] recover
] if ;
] recover ; inline
: true-out ( quot effect -- quot' )
- out>> '[ @ _ ndrop t ] ;
+ out>> length '[ @ _ ndrop t ] ;
: false-recover ( effect -- quot )
- in>> [ ndrop f ] curry [ recover-fail ] curry ;
+ in>> length [ ndrop f ] curry [ recover-fail ] curry ;
: [matches?] ( quot -- undoes?-quot )
[undo] dup infer [ true-out ] [ false-recover ] bi curry ;
"vocab:io/encodings/iso2022/212.txt" flat-file>biassoc to: jis212
VALUE: ascii
-128 unique >biassoc to: ascii
+128 iota unique >biassoc to: ascii
TUPLE: iso2022-state type ;
IN: io.files.links.unix.tests
: make-test-links ( n path -- )
- [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each ]
+ [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each-integer ]
[ [ number>string ] dip prepend touch-file ] 2bi ; inline
[ t ] [
<PRIVATE
: random-letter ( -- ch )
- 26 random { CHAR: a CHAR: A } random + ;
+ 26 iota random { CHAR: a CHAR: A } random + ;
: random-ch ( -- ch )
{ t f } random
- [ 10 random CHAR: 0 + ] [ random-letter ] if ;
+ [ 10 iota random CHAR: 0 + ] [ random-letter ] if ;
: random-name ( -- string )
unique-length get [ random-ch ] "" replicate-as ;
-: retry ( quot: ( -- ? ) n -- )
- swap [ drop ] prepose attempt-all ; inline
+: retry ( quot: ( -- ? ) n -- )
+ iota swap [ drop ] prepose attempt-all ; inline
: (make-unique-file) ( path prefix suffix -- path )
'[
USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ;
IN: lcs.diff2html.tests
-[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml>string drop ] unit-test
+[ ] [ "hello" "heyo" [ [ 1string ] { } map-as ] bi@ diff htmlize-diff xml>string drop ] unit-test
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: lcs xml.syntax xml.writer kernel strings ;
FROM: accessors => item>> ;
i 1 + j 1 + matrix nth set-nth ; inline\r
\r
: lcs-initialize ( |str1| |str2| -- matrix )\r
- [ drop 0 <array> ] with map ;\r
+
iota [ drop 0 <array> ] with map ;
\r \r
: levenshtein-initialize ( |str1| |str2| -- matrix )\r
- [ [ + ] curry map ] with map ;\r
+ [ iota ] bi@ [ [ + ] curry map ] with map ;\r
\r
:: run-lcs ( old new init step -- matrix )\r
old length 1 + new length 1 + init call :> matrix\r
- old length [| i |\r
- new length\r
+ old length iota [| i |\r
+ new length iota\r
[| j | i j matrix old new step loop-step ] each\r
] each matrix ; inline\r
PRIVATE>\r
stack get pop end
[ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
[
- length [ <reversed> ] keep
+ length iota [ <reversed> ] keep
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
] bi ;
[ 0 ] [ 9 5 iota 3 <combo> dual-index ] unit-test
[ 179 ] [ 72 10 iota 5 <combo> dual-index ] unit-test
-[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
+[ { 5 3 2 1 } ] [ 7 iota 4 <combo> 8 combinadic ] unit-test
[ { 4 3 2 1 0 } ] [ 10 iota 5 <combo> 0 combinadic ] unit-test
[ { 8 6 3 1 0 } ] [ 10 iota 5 <combo> 72 combinadic ] unit-test
[ { 9 8 7 6 5 } ] [ 10 iota 5 <combo> 251 combinadic ] unit-test
-! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
+! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs binary-search fry kernel locals math math.order
math.ranges namespaces sequences sorting ;
PRIVATE>
: factorial ( n -- n! )
- 1 [ 1 + * ] reduce ;
+ iota 1 [ 1 + * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
[ permutation-indices ] keep nths ;
: all-permutations ( seq -- seq )
- [ length factorial ] keep
+ [ length factorial iota ] keep
'[ _ permutation ] map ;
: each-permutation ( seq quot -- )
- [ [ length factorial ] keep ] dip
+ [ [ length factorial iota ] keep ] dip
'[ _ permutation @ ] each ; inline
: reduce-permutations ( seq identity quot -- result )
dup full-interval eq? [
drop 32 random-bits 31 2^ -
] [
- [ ] [ from>> first ] [ to>> first ] tri over - random +
+ [ ] [ from>> first ] [ to>> first ] tri over - iota random +
2dup swap interval-contains? [
nip
] [
] if ;
: random-interval ( -- interval )
- 10 random 0 = [ full-interval ] [
- 2000 random 1000 - dup 2 1000 random + +
- 1 random zero? [ [ neg ] bi@ swap ] when
- 4 random {
+ 10 iota random 0 = [ full-interval ] [
+ 2000 iota random 1000 - dup 2 1000 iota random + +
+ 1 iota random zero? [ [ neg ] bi@ swap ] when
+ 4 iota random {
{ 0 [ [a,b] ] }
{ 1 [ [a,b) ] }
{ 2 [ (a,b) ] }
] if ;
unary-ops [
- [ [ t ] ] dip '[ 8000 iota [ drop _ unary-test ] all? ] unit-test
+ [ [ t ] ] dip '[ 8000 [ drop _ unary-test ] all-integers? ] unit-test
] each
: binary-ops ( -- alist )
! Test that commutative interval ops really are
: random-interval-or-empty ( -- obj )
- 10 random 0 = [ empty-interval ] [ random-interval ] if ;
+ 10 iota random 0 = [ empty-interval ] [ random-interval ] if ;
: commutative-ops ( -- seq )
{
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel locals math math.vectors math.matrices
namespaces sequences fry sorting ;
[ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
: rows-from ( row# -- slice )
- rows dup <slice> ;
+ rows dup iota <slice> ;
: clear-col ( col# row# rows -- )
[ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
: reduced ( matrix' -- matrix'' )
[
- rows <reversed> [
+ rows iota <reversed> [
dup nth-row leading drop
- dup [ swap dup clear-col ] [ 2drop ] if
+ dup [ swap dup iota clear-col ] [ 2drop ] if
] each
] with-matrix ;
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays columns kernel locals math math.bits
math.functions math.order math.vectors sequences
: identity-matrix ( n -- matrix )
#! Make a nxn identity matrix.
- dup [ [ = 1 0 ? ] with map ] curry map ;
+ iota dup [ [ = 1 0 ? ] with map ] curry map ;
:: rotation-matrix3 ( axis theta -- matrix )
theta cos :> c
2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
: p* ( p q -- r )
- 2unempty pextend-conv <reversed> dup length
+ 2unempty pextend-conv <reversed> dup length iota
[ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
: p-sq ( p -- p^2 )
[ t ] [ 37 miller-rabin ] unit-test
[ t ] [ 2135623355842621559 miller-rabin ] unit-test
-[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
+[ f ] [ 1000 iota [ drop 15 miller-rabin ] any? ] unit-test
n 1 - :> n-1
n-1 factor-2s :> ( r s )
0 :> a!
- trials [
+ trials iota [
drop
2 n 2 - [a,b] random a!
a s n ^mod 1 = [
>odd (find-relative-prime) ;
: find-relative-prime ( n -- p )
- dup random find-relative-prime* ;
+ dup iota random find-relative-prime* ;
ERROR: too-few-primes n numbits ;
A{ DEFINES ${A}{
N [ A-rep rep-length ]
-BOA-EFFECT [ N 2 * "n" <repetition> >array { "v" } <effect> ]
+BOA-EFFECT [ N 2 * "n" <array> { "v" } <effect> ]
WHERE
[ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
[ tail-slice ] dip call( a' -- c' ) underlying>> ;
: (simd-with) ( n rep -- v )
- [ rep-length iota swap '[ _ ] ] [ <rep-array> ] bi replicate-as
+ [ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as
underlying>> ;
: (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ;
: (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ;
[ { } ] [
with-ctors [
- [ 1000 random '[ _ ] ] dip '[ _ execute ]
+ [ 1000 iota random '[ _ ] ] dip '[ _ execute ]
] [ = ] check-optimizer
] unit-test
[ { } ] [
boa-ctors [
- [ stack-effect in>> length [ 1000 random ] [ ] replicate-as ] keep
+ [ stack-effect in>> length [ 1000 iota random ] [ ] replicate-as ] keep
'[ _ execute ]
] [ = ] check-optimizer
] unit-test
"== Checking vector operations" print
: random-int-vector ( class -- vec )
- new [ drop 1,000 random ] map ;
+ new [ drop 1000 iota random ] map ;
+
: random-float-vector ( class -- vec )
new [
drop
- 1000 random
+ 1000 iota random
10 swap <array> 0/0. suffix random
] map ;
inputs [
{
{ +vector+ [ class elt-class random-vector ] }
- { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
+ { +scalar+ [ 1000 iota random elt-class float = [ >float ] when ] }
} case
] [ ] map-as
word '[ _ execute ] ;
"== Checking boolean operations" print
: random-boolean-vector ( class -- vec )
- new [ drop 2 random zero? ] map ;
+ new [ drop 2 iota random zero? ] map ;
:: check-boolean-op ( word inputs class elt-class -- inputs quot )
inputs [
{
{ +vector+ [ class random-boolean-vector ] }
- { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
+ { +scalar+ [ 1000 iota random elt-class float = [ >float ] when ] }
} case
] [ ] map-as
word '[ _ execute ] ;
[ [ 4 + ] map ] map
[ append ] 2map
] }
- [ dup '[ _ random ] replicate 1array ]
+ [ dup '[ _ iota random ] replicate 1array ]
} case ;
simd-classes [
"== Checking variable shuffles" print
: random-shift-vector ( class -- vec )
- new [ drop 16 random ] map ;
+ new [ drop 16 iota random ] map ;
:: test-shift-vector ( class -- ? )
[
! Test element access -- it should box bignums for int-4 on x86
: test-accesses ( seq -- failures )
- [ length >array ] keep
+ [ length iota >array ] keep
'[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
"== Checking broadcast" print
: test-broadcast ( seq -- failures )
- [ length >array ] keep
+ [ length iota >array ] keep
'[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ;
[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
SET-NTH [ ELT dup c:c-setter c:array-accessor ]
-BOA-EFFECT [ N "n" <repetition> >array { "v" } <effect> ]
+BOA-EFFECT [ N "n" <array> { "v" } <effect> ]
WHERE
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: models.arrow models.product stack-checker accessors fry
-generalizations macros kernel ;
+generalizations combinators.smart combinators.smart.private
+macros kernel ;
IN: models.arrow.smart
MACRO: <smart-arrow> ( quot -- quot' )
- [ infer in>> dup ] keep
+ [ inputs dup ] keep
'[ _ narray <product> [ _ firstn @ ] <arrow> ] ;
\ No newline at end of file
USING: nibble-arrays tools.test sequences kernel math ;
IN: nibble-arrays.tests
-[ t ] [ 16 dup >nibble-array sequence= ] unit-test
+[ t ] [ 16 iota dup >nibble-array sequence= ] unit-test
[ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test
[ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test
] [ \r
[\r
"FROM: locals => [let :> ; FROM: sequences => nth ; [let " %\r
- dup length [\r
+ [\r
over ebnf-var? [\r
" " % # " over nth :> " %\r
name>> % \r
] [\r
2drop\r
] if\r
- ] 2each\r
+ ] each-index\r
" " %\r
% \r
" nip ]" % \r
] unit-test
: random-string ( -- str )
- 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
+ 1000000 iota random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
: random-assocs ( n -- hash phash )
[ random-string ] replicate
] unit-test
{ 100 1060 2000 10000 100000 1000000 } [
- [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
+ [ t ] swap [ iota dup >persistent-vector sequence= ] curry unit-test
] each
[ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test
[ ] [ "1" get >vector "2" set ] unit-test
[ t ] [
- 3000 [
+ 3000 iota [
drop
- 16 random-bits 10000 random
+ 16 random-bits 10000 iota random
[ "1" [ new-nth ] change ]
[ "2" [ new-nth ] change ] 2bi
"1" get "2" get sequence=
] unit-test
[ t ] [
- 10000 >persistent-vector 752 [ ppop ] times dup length sequence=
+ 10000 iota >persistent-vector 752 [ ppop ] times dup length iota sequence=
] unit-test
[ t ] [
- 100 [
+ 100 iota [
drop
- 100 random [
+ 100 iota random [
16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi
] times
- 100 random "1" get length min [
+ 100 iota random "1" get length min [
"1" [ ppop ] change
"2" get pop*
] times
] if ;
: consonant-seq ( str -- n )
- 0 0 rot skip-consonants (consonant-seq) ;
+ [ 0 0 ] dip skip-consonants (consonant-seq) ;
: stem-vowel? ( str -- ? )
- [ length ] keep [ consonant? ] curry all? not ;
+ [ length iota ] keep [ consonant? ] curry all? not ;
: double-consonant? ( i str -- ? )
over 1 < [
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables io kernel math assocs
namespaces make sequences strings io.styles vectors words
: group-flow ( seq -- newseq )
[
- dup length [
+ dup length iota [
2dup 1 - swap ?nth prev set
2dup 1 + swap ?nth next set
swap nth dup split-before dup , split-after
IN: random.mersenne-twister.tests
: check-random ( max -- ? )
- [ random 0 ] keep between? ;
+ [ iota random 0 ] keep between? ;
-[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test
+[ t ] [ 100 [ drop 674 check-random ] all-integers? ] unit-test
: randoms ( -- seq )
- 100 [ 100 random ] replicate ;
+ 100 [ 100 iota random ] replicate ;
: test-rng ( seed quot -- )
[ <mersenne-twister> ] dip with-random ; inline
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
[ 1333075495 ] [
- 0 [ 1000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng
+ 0 [ 1000 [ drop random-generator get random-32* drop ] each-integer random-generator get random-32* ] test-rng
] unit-test
[ 1575309035 ] [
- 0 [ 10000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng
+ 0 [ 10000 [ drop random-generator get random-32* drop ] each-integer random-generator get random-32* ] test-rng
] unit-test
: mt-generate ( mt -- )
[
seq>>
- [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
- [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
+ [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each-integer ]
+ [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each-integer ]
bi
] [ 0 >>i drop ] bi ; inline
: init-mt-rest ( seq -- )
n 1 - swap '[
_ [ init-mt-formula ] [ [ 1 + ] dip set-nth ] 2bi
- ] each ; inline
+ ] each-integer ; inline
: init-mt-seq ( seed -- seq )
32 bits n <uint-array>
[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
[ V{ } [ delete-random drop ] keep length ] must-fail
-[ t ] [ 10000 [ 0 [ drop 187 random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test
-[ t ] [ 10000 [ 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test
+[ t ] [ 10000 [ iota 0 [ drop 187 iota random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test
+[ t ] [ 10000 [ iota 0 [ drop 400 iota random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test
-[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
+[ t ] [ 1000 [ 400 iota random ] replicate prune length 256 > ] unit-test
-[ f ] [ 0 random ] unit-test
+[ f ] [ 0 iota random ] unit-test
[ { } ] [ { } randomize ] unit-test
[ { 1 } ] [ { 1 } randomize ] unit-test
zip [ first ] partition [ values ] bi@ parts boa ;
: powerset-partition ( sequence -- partitions )
- [ length [ 2^ ] keep ] keep '[
- _ <bits> _ make-partition
- ] map rest ;
+ [ length [ 2^ iota ] keep ] keep '[ _ <bits> _ make-partition ] map rest ;
: partition>class ( parts -- class )
[ out>> [ <not-class> ] map ]
<PRIVATE
MACRO: binary-roman-op ( quot -- quot' )
- [ infer in>> ] [ ] [ infer out>> ] tri
+ [ infer in>> length ] [ ] [ infer out>> length ] tri
'[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
PRIVATE>
SYNTAX: ROMAN-OP:
scan-word [ name>> "roman" prepend create-in ] keep
1quotation '[ _ binary-roman-op ]
- dup infer [ in>> ] [ out>> ] bi
- [ "string" <repetition> ] bi@ <effect> define-declared ;
+ dup infer define-declared ;
>>
IN: serialize.tests
: test-serialize-cell ( a -- ? )
- 2^ random dup
+ 2^ iota random dup
binary [ serialize-cell ] with-byte-writer
binary [ deserialize-cell ] with-byte-reader = ;
[ t ] [
100 [
drop
- 40 [ test-serialize-cell ] all?
- 4 [ 40 * test-serialize-cell ] all?
- 4 [ 400 * test-serialize-cell ] all?
- 4 [ 4000 * test-serialize-cell ] all?
+ 40 [ test-serialize-cell ] all-integers?
+ 4 [ 40 * test-serialize-cell ] all-integers?
+ 4 [ 400 * test-serialize-cell ] all-integers?
+ 4 [ 4000 * test-serialize-cell ] all-integers?
and and and
- ] all?
+ ] all-integers?
] unit-test
TUPLE: serialize-test a b ;
[ ] tri ;
: copy-seq-to-tuple ( seq tuple -- )
- [ dup length ] dip [ set-array-nth ] curry 2each ;
+ [ set-array-nth ] curry each-index ;
: deserialize-tuple ( -- array )
#! Ugly because we have to intern the tuple before reading
<PRIVATE
: >index-assoc ( sequence -- assoc )
- dup length zip >hashtable ;
+ dup length iota zip >hashtable ;
PRIVATE>
: insertion-sort ( seq quot -- )
! quot is a transformation on elements
- over length [ insert ] with with each ; inline
+ over length [ insert ] with with each-integer ; inline
: (monotonic-slice) ( seq quot class -- slices )
[
dupd '[
- [ length ] [ ] [ <circular> 1 over change-circular-start ] tri
+ [ length iota ] [ ] [ <circular> 1 over change-circular-start ] tri
[ @ not [ , ] [ drop ] if ] 3each
] { } make
dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel prettyprint io debugger
+USING: accessors arrays kernel prettyprint io debugger
sequences assocs stack-checker.errors summary effects ;
IN: stack-checker.errors.prettyprint
M: unbalanced-branches-error error.
dup summary print
- [ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
+ [ quots>> ] [ branches>> [ length "x" <array> <effect> ] { } assoc>map ] bi zip
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
M: too-many->r summary
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces assocs kernel sequences words accessors
definitions math math.order effects classes arrays combinators
: make-copies ( values effect-in -- values' )
[ length cut* ] keep
[ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map
- [ make-values ] dip append ;
+ [ length make-values ] dip append ;
SYMBOL: enter-in
SYMBOL: enter-out
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
- peek-d literal value>> second 1 + { tuple } <effect>
+ peek-d literal value>> second 1 + "obj" <array> { tuple } <effect>
apply-word/effect ;
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
ERROR: custom-error ;
-[ T{ effect f 0 0 t } ] [
+[ T{ effect f { } { } t } ] [
[ custom-error ] infer
] unit-test
: funny-throw ( a -- * ) throw ; inline
-[ T{ effect f 0 0 t } ] [
+[ T{ effect f { } { } t } ] [
[ 3 funny-throw ] infer
] unit-test
-[ T{ effect f 0 0 t } ] [
+[ T{ effect f { } { } t } ] [
[ custom-error inference-error ] infer
] unit-test
-[ T{ effect f 1 2 t } ] [
+[ T{ effect f { "x" } { "x" "x" } t } ] [
[ dup [ 3 throw ] dip ] infer
] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs arrays namespaces sequences kernel definitions
math effects accessors words fry classes.algebra
: current-stack-height ( -- n ) meta-d length input-count get - ;
: current-effect ( -- effect )
- input-count get meta-d length terminated? get effect boa ;
+ input-count get "x" <array>
+ meta-d length "x" <array>
+ terminated? get effect boa ;
: init-inference ( -- )
terminated? off
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences fry math.order splitting ;
IN: strings.tables
<PRIVATE
: map-last ( seq quot -- seq )
- [ dup length <reversed> ] dip '[ 0 = @ ] 2map ; inline
+ [ dup length iota <reversed> ] dip '[ 0 = @ ] 2map ; inline
: max-length ( seq -- n )
[ length ] [ max ] map-reduce ;
<PRIVATE
: suffixes ( string -- suffixes-seq )
- dup length [ tail-slice ] with map ;
+ dup length iota [ tail-slice ] with map ;
: prefix<=> ( begin seq -- <=> )
[ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ;
USING: namespaces io tools.test threads kernel
concurrency.combinators concurrency.promises locals math
-words calendar ;
+words calendar sequences ;
IN: threads.tests
3 "x" set
[ f ] [ f get-global ] unit-test
{ { 0 3 6 9 12 15 18 21 24 27 } } [
- 10 [
+ 10 iota [
0 "i" tset
[
"i" [ yield 3 + ] tchange
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays strings sequences sequences.private ascii
fry kernel words parser lexer assocs math math.order summary ;
[ [ ascii? ] all? ] both? [ bad-tr ] unless ;
: compute-tr ( quot from to -- mapping )
- [ 128 ] 3dip zip
+ [ 128 iota ] 3dip zip
'[ [ _ call( x -- y ) _ at ] keep or ] B{ } map-as ; inline
: tr-hints ( word -- )
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
-MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
+MACRO: infer-in ( class -- quot ) infer in>> length '[ _ ] ;
: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
MACRO: write-tuple ( class -- quot )
[ '[ [ _ boa ] undo ] ]
- [ tuple-arity <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
+ [ tuple-arity iota <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
bi '[ _ dip @ ] ;
PRIVATE>
<mock-gadget> over <model> >>model
"g" get over add-gadget drop
swap 1 + number>string set
- ] each ;
+ ] each-integer ;
: status-flags ( -- seq )
{ "g" "1" "2" "3" } [ get graft-state>> ] map prune ;
USING: ui.gadgets.packs ui.gadgets.packs.private
ui.gadgets.labels ui.gadgets ui.gadgets.debug ui.render
ui.baseline-alignment kernel namespaces tools.test math.parser
-sequences math.rectangles accessors ;
+sequences math.rectangles accessors math ;
IN: ui.gadgets.packs.tests
[ t ] [
{ 0 0 } { 100 100 } <rect> clip set
<pile>
- 100 [ number>string <label> add-gadget ] each
+ 100 [ number>string <label> add-gadget ] each-integer
dup layout
visible-children [ label? ] all?
[ ] [ #children "num-children" set ] unit-test
[ ] [
- "pane" get <pane-stream> [ 100 [ . ] each ] with-output-stream*
+ "pane" get <pane-stream> [ 100 [ . ] each-integer ] with-output-stream*
] unit-test
[ t ] [ #children "num-children" get = ] unit-test
"s" set
[ t ] [
- 10 [
+ 10 iota [
drop
"g2" get scroll>gadget
"s" get layout
IN: ui.gadgets.slots.tests
USING: assocs ui.gadgets.slots tools.test refs ;
-[ t ] [ [ ] [ ] { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
+[ t ] [ [ ] [ ] { { 1 1 } { 2 2 } { 3 3 } } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
utf8 file-lines
[ "#" split1 drop ] map harvest [
"÷" split
- [ "×" split [ [ blank? ] trim hex> ] map harvest >string ] map
+ [
+ "×" split
+ [ [ blank? ] trim hex> ] map
+ [ { f 0 } member? not ] filter
+ >string
+ ] map
harvest
] map ;
grapheme-break-test parse-test-file [ >graphemes ] test
word-break-test parse-test-file [ >words ] test
-[ { t f t t f t } ] [ 6 [ "as df" word-break-at? ] map ] unit-test
+[ { t f t t f t } ] [ 6 iota [ "as df" word-break-at? ] map ] unit-test
: make-grapheme-table ( -- )
{ CR } { LF } connect
- { Control CR LF } graphemes disconnect
- graphemes { Control CR LF } disconnect
+ { Control CR LF } graphemes iota disconnect
+ graphemes iota { Control CR LF } disconnect
{ L } { L V LV LVT } connect
{ LV V } { V T } connect
{ LVT T } { T } connect
- graphemes { Extend } connect
- graphemes { SpacingMark } connect
- { Prepend } graphemes connect ;
+ graphemes iota { Extend } connect
+ graphemes iota { SpacingMark } connect
+ { Prepend } graphemes iota connect ;
VALUE: grapheme-table
: make-word-table ( -- )
{ wCR } { wLF } connect
- { wNewline wCR wLF } words disconnect
- words { wNewline wCR wLF } disconnect
+ { wNewline wCR wLF } words iota disconnect
+ words iota { wNewline wCR wLF } disconnect
{ wALetter } { wMidLetter wMidNumLet } check-letter-after set-table
{ wMidLetter wMidNumLet } { wALetter } check-letter-before set-table
{ wNumeric wALetter } { wNumeric wALetter } connect
over tail-slice first-word + ;
: last-word ( str -- i )
- [ length ] keep '[ _ word-break-at? ] find-last drop 0 or ;
+ [ length iota ] keep '[ _ word-break-at? ] find-last drop 0 or ;
: last-word-from ( end str -- i )
swap head-slice last-word ;
\r
: add ( char -- )\r
dup blocked? [ 1string , ] [\r
- dup possible-bases dup length\r
+ dup possible-bases dup length iota\r
[ ?combine ] with with any?\r
[ drop ] [ 1string , ] if\r
] if ;\r
: exclusions ( -- set )
exclusions-file utf8 file-lines
- [ "#" split1 drop [ blank? ] trim-tail hex> ] map harvest ;
+ [ "#" split1 drop [ blank? ] trim-tail hex> ] map
+ [ 0 = not ] filter ;
: remove-exclusions ( alist -- alist )
exclusions [ dup ] H{ } map>assoc assoc-diff ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax kernel libc
-sequences continuations byte-arrays strings math namespaces
-system combinators vocabs.loader accessors
-stack-checker macros locals generalizations unix.types
-io vocabs classes.struct unix.time alien.libraries ;
+USING: alien alien.c-types alien.syntax kernel libc sequences
+continuations byte-arrays strings math namespaces system
+combinators combinators.smart combinators.smart.private
+vocabs.loader accessors stack-checker macros locals
+generalizations unix.types io vocabs classes.struct unix.time
+alien.libraries ;
IN: unix
CONSTANT: PROT_NONE 0
ERROR: unix-system-call-error args errno message word ;
MACRO:: unix-system-call ( quot -- )
- quot infer in>> :> n
+ quot inputs :> n
quot first :> word
[
n ndup quot call dup 0 < [
USING: unrolled-lists tools.test deques kernel sequences
-random prettyprint grouping ;
+random prettyprint grouping math ;
IN: unrolled-lists.tests
[ 1 ] [ <unrolled-list> 1 over push-front pop-front ] unit-test
[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
<unrolled-list>
- 32 [ over push-front ] each
+ 32 [ over push-front ] each-integer
32 [ dup pop-back ] replicate
nip
] unit-test
[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
<unrolled-list>
- 32 [ over push-front ] each
+ 32 [ over push-front ] each-integer
32 [ dup pop-front ] replicate reverse
nip
] unit-test
[ t ] [
<unrolled-list>
- 1000 [ 1000 random ] replicate
+ 1000 [ 1000 iota random ] replicate
[ [ over push-front ] each ]
- [ [ dup pop-back ] replicate ]
+ [ length [ dup pop-back ] replicate ]
[ ]
tri
=
[ t ] [
<unrolled-list>
- 1000 [ 1000 random ] replicate
+ 1000 [ 1000 iota random ] replicate
[
10 group [
[ [ over push-front ] each ]
- [ [ dup pop-back ] replicate ]
+ [ length [ dup pop-back ] replicate ]
bi
] map concat
] keep
-USING: accessors assocs combinators continuations fry generalizations
-io.pathnames kernel macros sequences stack-checker tools.test xml
-xml.traversal xml.writer arrays xml.data ;
+USING: accessors assocs combinators combinators.smart
+continuations fry generalizations io.pathnames kernel macros
+sequences stack-checker tools.test xml xml.traversal xml.writer
+arrays xml.data ;
IN: xml.tests.suite
TUPLE: xml-test id uri sections description type ;
CONSTANT: base "vocab:xml/tests/xmltest/"
-MACRO: drop-output ( quot -- newquot )
- dup infer out>> '[ @ _ ndrop ] ;
-
-MACRO: drop-input ( quot -- newquot )
- infer in>> '[ _ ndrop ] ;
+MACRO: drop-inputs ( quot -- newquot )
+ infer in>> length '[ _ ndrop ] ;
: fails? ( quot -- ? )
- [ drop-output f ] [ nip drop-input t ] bi-curry recover ; inline
+ [ drop-outputs f ] [ nip drop-inputs t ] bi-curry recover ; inline
: well-formed? ( uri -- answer )
[ file>xml ] fails? "not-wf" "valid" ? ;
get-char [ missing-close ] unless next ;
: expect ( string -- )
- dup spot get '[ _ [ char>> ] keep next* ] replicate
+ dup length spot get '[ _ [ char>> ] keep next* ] "" replicate-as
2dup = [ 2drop ] [ expected ] if ;
! Suddenly XML-specific
-! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov
+! Copyright (C) 2007, 2010 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays math sequences.private vectors
accessors ;
M: enum delete-at seq>> remove-nth! drop ; inline
M: enum >alist ( enum -- alist )
- seq>> [ length ] keep zip ; inline
+ seq>> [ length iota ] keep zip ; inline
M: enum assoc-size seq>> length ; inline
USING: tools.test byte-vectors vectors sequences kernel\r
-prettyprint ;\r
+prettyprint math ;\r
IN: byte-vectors.tests\r
\r
[ 0 ] [ 123 <byte-vector> length ] unit-test\r
\r
: do-it ( seq -- seq )\r
- 123 [ over push ] each ;\r
+ 123 [ over push ] each-integer ;\r
\r
[ t ] [\r
3 <byte-vector> do-it\r
\r
! class<=>\r
\r
-[ +lt+ ] [ integer sequence class<=> ] unit-test\r
[ +lt+ ] [ sequence object class<=> ] unit-test\r
[ +gt+ ] [ object sequence class<=> ] unit-test\r
[ +eq+ ] [ integer integer class<=> ] unit-test\r
10 [\r
[ ] [\r
20 [ random-op ] [ ] replicate-as\r
- [ infer in>> [ random-class ] times ] keep\r
+ [ infer in>> length [ random-class ] times ] keep\r
call\r
drop\r
] unit-test\r
20 [\r
[ t ] [\r
20 [ random-boolean-op ] [ ] replicate-as dup .\r
- [ infer in>> [ random-boolean ] replicate dup . ] keep\r
+ [ infer in>> length [ random-boolean ] replicate dup . ] keep\r
\r
[ [ [ ] each ] dip call ] 2keep\r
\r
] with-scope
] callcc0 "x" get 5 = ;
-[ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test
+[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test
[ t ] [ callcc-namespace-test ] unit-test
[ 5 throw ] [ 5 = ] must-fail-with
{ $values { "obj" object } { "str" string } }
{ $description "Turns a stack effect object into a string mnemonic." }
{ $examples
- { $example "USING: effects io ;" "1 2 <effect> effect>string print" "( object -- object object )" }
+ { $example "USING: effects io ;" "{ \"x\" } { \"y\" \"z\" } <effect> effect>string print" "( x -- y z )" }
} ;
HELP: stack-effect
quotations sequences ;
IN: effects.tests
-[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
-[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
-[ t ] [ 2 2 <effect> 2 2 <effect> effect<= ] unit-test
-[ f ] [ 3 3 <effect> 2 2 <effect> effect<= ] unit-test
-[ f ] [ 2 3 <effect> 2 2 <effect> effect<= ] unit-test
+[ t ] [ { "a" } { "a" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ f ] [ { "a" } { } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ t ] [ { "a" "b" } { "a" "b" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ f ] [ { "a" "b" "c" } { "a" "b" "c" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ f ] [ { "a" "b" } { "a" "b" "c" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
[ 2 ] [ (( a b -- c )) in>> length ] unit-test
[ 1 ] [ (( a b -- c )) out>> length ] unit-test
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser math.order namespaces make sequences strings
words assocs combinators accessors arrays quotations ;
IN: effects
-TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
-
-GENERIC: effect-length ( obj -- n )
-M: sequence effect-length length ;
-M: integer effect-length ;
+TUPLE: effect
+{ in array read-only }
+{ out array read-only }
+{ terminated? read-only } ;
: <effect> ( in out -- effect )
- dup { "*" } sequence= [ drop { } t ] [ f ] if
+ dup { "*" } = [ drop { } t ] [ f ] if
effect boa ;
: effect-height ( effect -- n )
- [ out>> effect-length ] [ in>> effect-length ] bi - ; inline
+ [ out>> length ] [ in>> length ] bi - ; inline
: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
- { [ 2dup [ in>> effect-length ] bi@ > ] [ f ] }
+ { [ 2dup [ in>> length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ; inline
: effect= ( effect1 effect2 -- ? )
- [ [ in>> effect-length ] bi@ = ]
- [ [ out>> effect-length ] bi@ = ]
+ [ [ in>> length ] bi@ = ]
+ [ [ out>> length ] bi@ = ]
[ [ terminated?>> ] bi@ = ]
2tri and and ;
M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
: stack-picture ( seq -- string )
- dup integer? [ "object" <repetition> ] when
[ [ effect>string % CHAR: \s , ] each ] "" make ;
M: effect effect>string ( effect -- string )
GENERIC: effect>type ( obj -- type )
M: object effect>type drop object ;
M: word effect>type ;
-! attempting to specialize on callable breaks compiling
-! M: effect effect>type drop callable ;
M: pair effect>type second effect>type ;
+: effect-in-types ( effect -- input-types )
+ in>> [ effect>type ] map ;
+
+: effect-out-types ( effect -- input-types )
+ out>> [ effect>type ] map ;
+
GENERIC: stack-effect ( word -- effect/f )
M: word stack-effect "declared-effect" word-prop ;
stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
- in>> effect-length cut* ;
+ in>> length cut* ;
: shuffle-mapping ( effect -- mapping )
[ out>> ] [ in>> ] bi [ index ] curry map ;
over terminated?>> [
drop
] [
- [ [ [ in>> effect-length ] [ out>> effect-length ] bi ] [ in>> effect-length ] bi* swap [-] + ]
- [ [ out>> effect-length ] [ [ in>> effect-length ] [ out>> effect-length ] bi ] bi* [ [-] ] dip + ]
+ [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
+ [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
- [ [ [ "obj" ] replicate ] bi@ ] dip
+ [ [ "x" <array> ] bi@ ] dip
effect boa
] if ; inline
-
-: effect-in-types ( effect -- input-types )
- in>> [ effect>type ] map ;
-: effect-out-types ( effect -- input-types )
- out>> [ effect>type ] map ;
continuations ;
IN: hashtables.tests
-[ f ] [ "hi" V{ 1 2 3 } at ] unit-test
-
[ H{ } ] [ { } [ dup ] H{ } map>assoc ] unit-test
-[ ] [ 1000 [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
+[ ] [ 1000 iota [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
[ V{ } ]
-[ 1000 [ dup sq swap "testhash" get at = not ] filter ]
+[ 1000 iota [ dup sq swap "testhash" get at = not ] filter ]
unit-test
[ t ]
! Resource leak...
H{ } "x" set
-100 [ drop "x" get clear-assoc ] each
+100 [ drop "x" get clear-assoc ] each-integer
! Crash discovered by erg
[ t ] [ 0.75 <hashtable> dup clone = ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test
! Random test case
-[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
+[ "A" ] [ 100 iota [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
[ 3 ] [ 2 "lápis" >utf8-index ] unit-test
-[ V{ } ] [ 100000 [ [ code-point-length ] [ 1string utf8 encode length ] bi = not ] filter ] unit-test
+[ V{ } ] [ 100000 iota [ [ code-point-length ] [ 1string utf8 encode length ] bi = not ] filter ] unit-test
[ 0 ] [ 1/0. >bignum ] unit-test
-[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
+[ t ] [ 64 iota [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
[ 5 ] [ 10.5 1.9 /i ] unit-test
: random-integer ( -- n )
32 random-bits
- 1 random zero? [ neg ] when
- 1 random zero? [ >bignum ] when ;
+ 1 iota random zero? [ neg ] when
+ 1 iota random zero? [ >bignum ] when ;
[ t ] [
1000 [
random-integer
random-integer
[ >float / ] [ /f ] 2bi 0.1 ~
- ] all?
+ ] all-integers?
] unit-test
! Ensure that /f is accurate for fixnums > 2^53 on 64-bit platforms
[ fixnum ] [ 1 >bignum SBUF" " new-sequence length class ] unit-test
-[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test
+[ fixnum ] [ 1 >bignum iota [ ] SBUF" " map-as length class ] unit-test
HELP: replicate
{ $values
- { "seq" sequence } { "quot" { $quotation "( -- elt )" } }
+ { "len" integer } { "quot" { $quotation "( -- elt )" } }
{ "newseq" sequence } }
-{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the input sequence." }
+ { $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new array." }
{ $examples
{ $unchecked-example "USING: kernel prettyprint random sequences ;"
"5 [ 100 random ] replicate ."
HELP: replicate-as
{ $values
- { "seq" sequence } { "quot" quotation } { "exemplar" sequence }
+ { "len" integer } { "quot" quotation } { "exemplar" sequence }
{ "newseq" sequence } }
-{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the exemplar sequence." }
+ { $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new sequence of the same type as the exemplar sequence." }
{ $examples
{ $unchecked-example "USING: prettyprint kernel sequences ;"
"5 [ 100 random ] B{ } replicate-as ."
"B{ 44 8 2 33 18 }"
}
} ;
+
{ replicate replicate-as } related-words
HELP: partition
[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test
[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test
-[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
-[ 3 ] [ 1 4 dup <slice> length ] unit-test
+[ V{ 1 2 3 4 } ] [ 1 5 dup iota <slice> >vector ] unit-test
+[ 3 ] [ 1 4 dup iota <slice> length ] unit-test
[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test
[ V{ 2 3 } ] [ 1 3 { 1 2 3 4 } <slice> >vector ] unit-test
[ V{ 4 5 } ] [ { 1 2 3 4 5 } 2 tail-slice* >vector ] unit-test
-[ V{ 3 4 } ] [ 2 4 1 10 dup <slice> subseq >vector ] unit-test
-[ V{ 3 4 } ] [ 0 2 2 4 1 10 dup <slice> <slice> subseq >vector ] unit-test
+[ V{ 3 4 } ] [ 2 4 1 10 dup iota <slice> subseq >vector ] unit-test
+[ V{ 3 4 } ] [ 0 2 2 4 1 10 dup iota <slice> <slice> subseq >vector ] unit-test
[ 0 10 "hello" <slice> ] must-fail
[ -10 3 "hello" <slice> ] must-fail
[ 2 1 "hello" <slice> ] must-fail
[ { 1 3 2 4 } ] [ { 1 2 3 4 } clone 1 2 pick exchange ] unit-test
[ { "" "a" "aa" "aaa" } ]
-[ 4 [ CHAR: a <string> ] map ]
+[ 4 [ CHAR: a <string> ] { } map-integers ]
unit-test
[ V{ } ] [ "f" V{ } clone remove! ] unit-test
[ V{ "x" } ] [ "f" V{ "f" "x" "f" } clone remove! ] unit-test
[ V{ "y" "x" } ] [ "f" V{ "y" "f" "x" "f" } clone remove! ] unit-test
-[ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test
+[ V{ 0 1 4 5 } ] [ 6 iota >vector 2 4 pick delete-slice ] unit-test
[ 6 >vector 2 8 pick delete-slice ] must-fail
-[ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test
+[ V{ } ] [ 6 iota >vector 0 6 pick delete-slice ] unit-test
[ { 1 2 "a" "b" 5 6 7 } ] [
{ "a" "b" } 2 4 { 1 2 3 4 5 6 7 }
[ 0 ] [ f length ] unit-test
[ f first ] must-fail
-[ 3 ] [ 3 10 nth ] unit-test
-[ 3 ] [ 3 10 nth-unsafe ] unit-test
-[ -3 10 nth ] must-fail
-[ 11 10 nth ] must-fail
+[ 3 ] [ 3 10 iota nth ] unit-test
+[ 3 ] [ 3 10 iota nth-unsafe ] unit-test
+[ -3 10 iota nth ] must-fail
+[ 11 10 iota nth ] must-fail
[ -1/0. 0 remove-nth! ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-head ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-tail ] unit-test
-[ 328350 ] [ 100 [ sq ] map-sum ] unit-test
+[ 328350 ] [ 100 iota [ sq ] map-sum ] unit-test
-[ 50 ] [ 100 [ even? ] count ] unit-test
-[ 50 ] [ 100 [ odd? ] count ] unit-test
+[ 50 ] [ 100 iota [ even? ] count ] unit-test
+[ 50 ] [ 100 iota [ odd? ] count ] unit-test
[ { "b" "d" } ] [ { 1 3 } { "a" "b" "c" "d" } nths ] unit-test
[ { "a" "b" "c" "d" } ] [ { 0 1 2 3 } { "a" "b" "c" "d" } nths ] unit-test
-! Copyright (C) 2005, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2005, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private slots.private math
math.private math.order ;
INSTANCE: f immutable-sequence
-! Integers used to support the sequence protocol
-M: integer length ; inline
-M: integer nth-unsafe drop ; inline
-
-INSTANCE: integer immutable-sequence
-
PRIVATE>
! In the future, this will replace integer sequences
: map ( seq quot -- newseq )
over map-as ; inline
-: replicate ( seq quot -- newseq )
- [ drop ] prepose map ; inline
+: replicate-as ( len quot exemplar -- newseq )
+ [ [ drop ] prepose ] dip map-integers ; inline
-: replicate-as ( seq quot exemplar -- newseq )
- [ [ drop ] prepose ] dip map-as ; inline
+: replicate ( len quot -- newseq )
+ { } replicate-as ; inline
: map! ( seq quot -- seq )
over [ map-into ] keep ; inline
(2each) all-integers? ; inline
: 3each ( seq1 seq2 seq3 quot -- )
- (3each) each ; inline
+ (3each) each-integer ; inline
: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
[ (3each) ] dip map-integers ; inline
[ { } ] [ { } natural-sort ] unit-test
[ { 270000000 270000001 } ]
-[ T{ slice f 270000000 270000002 270000002 } natural-sort ]
+[ T{ slice f 270000000 270000002 T{ iota f 270000002 } } natural-sort ]
unit-test
[ t ] [
100 [
drop
- 100 [ 20 random [ 1000 random ] replicate ] replicate
+ 100 [ 20 iota random [ 1000 iota random ] replicate ] replicate
dup natural-sort
[ set= ] [ nip [ before=? ] monotonic? ] 2bi and
- ] all?
+ ] all-integers?
] unit-test
[ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test
M: source-file-error compute-restarts error>> compute-restarts ;
: sort-errors ( errors -- alist )
- [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
+ [ [ line#>> 0 or ] sort-with ] { } assoc-map-as sort-keys ;
: group-by-source-file ( errors -- assoc )
H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
drop
300 100 CHAR: \u123456
[ <string> clone resize-string first ] keep =
- ] all?
+ ] all-integers?
] unit-test
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
[ t ] [
- 100 [ 100 random ] V{ } replicate-as
+ 100 [ 100 iota random ] V{ } replicate-as
dup >array >vector =
] unit-test
[ 4 ] [ 5 V{ 1 2 3 4 5 } index ] unit-test
[ t ] [
- 100 >array dup >vector <reversed> >array [ reverse ] dip =
+ 100 iota >array dup >vector <reversed> >array [ reverse ] dip =
] unit-test
[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
-[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
+[ fixnum ] [ 1 >bignum iota [ ] V{ } map-as length class ] unit-test
[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test
USING: sequences vectors arrays strings sbufs math math.vectors
kernel ;
-: <range> ( from to -- seq ) dup <slice> ; inline
+: <range> ( from to -- seq ) dup iota <slice> ; inline
: vector-iter ( -- ) 100 [ 0 100000 <range> >vector [ ] map drop ] times ;
: array-iter ( -- ) 100 [ 0 100000 <range> >array [ ] map drop ] times ;
] unit-test
! We shouldn't have more than 0.01 false-positive rate.
-[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map
+[ t ] [ 1000 iota [ drop most-positive-fixnum iota random 1000 + ] map
full-bloom-filter
[ bloom-filter-member? ] curry map
- [ ] filter
+ [ ] count
! TODO: This should be 10, but the false positive rate is currently very
! high. 300 is large enough not to prevent builds from succeeding.
- length 300 <=
+ 300 <=
] unit-test
: inv-sbox ( -- array )
256 0 <array>
- dup 256 [ dup sbox nth rot set-nth ] with each ;
+ dup 256 [ dup sbox nth rot set-nth ] with each-integer ;
: rcon ( -- array )
{
MEMO:: t-table ( -- array )
1024 0 <array>
- dup 256 [ set-t ] with each ;
+ dup 256 [ set-t ] with each-integer ;
:: set-d ( D i -- )
i inv-sbox nth :> a1
MEMO:: d-table ( -- array )
1024 0 <array>
- dup 256 [ set-d ] with each ;
+ dup 256 [ set-d ] with each-integer ;
USE: multiline
] unit-test
: random-test-int ( -- n )
- 10 random 2 random 0 = [ neg ] when ;
+ 10 iota random 2 iota random 0 = [ neg ] when ;
: random-test-decimal ( -- decimal )
random-test-int random-test-int <decimal> ;
: test-decimal-op ( quot1 quot2 -- ? )
[ random-test-decimal random-test-decimal ] 2dip (test-decimal-op) ; inline
-[ t ] [ 1000 [ drop [ D+ ] [ + ] test-decimal-op ] all? ] unit-test
-[ t ] [ 1000 [ drop [ D- ] [ - ] test-decimal-op ] all? ] unit-test
-[ t ] [ 1000 [ drop [ D* ] [ * ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D+ ] [ + ] test-decimal-op ] all-integers? ] unit-test
+[ t ] [ 1000 [ drop [ D- ] [ - ] test-decimal-op ] all-integers? ] unit-test
+[ t ] [ 1000 [ drop [ D* ] [ * ] test-decimal-op ] all-integers? ] unit-test
[ t ] [
1000 [
drop
[ [ 100 D/ ] [ /f ] test-decimal-op ]
[ { "kernel-error" 4 f f } = ] recover
- ] all?
+ ] all-integers?
] unit-test
[ t ] [
] map ;
: find-by-id ( vector id -- vector' elt/f )
- '[ attributes>> "id" at _ = ] find ;
+ '[ attributes>> "id" swap at _ = ] find ;
: find-by-class ( vector id -- vector' elt/f )
- '[ attributes>> "class" at _ = ] find ;
+ '[ attributes>> "class" swap at _ = ] find ;
: find-by-name ( vector string -- vector elt/f )
>lower '[ name>> _ = ] find ;
[ t ]
-[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
+[ 10000 iota [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
0 swap length clamp ;
: random-color ( -- color )
- { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
+ { 100 100 100 } [ iota random 100 / >float ] map first3 1.0 <rgba> ;
CONSTANT: tunnel-segment-distance 0.4
CONSTANT: random-rotation-angle $[ pi 20 / ]
[ natural-sort ] keep [ index ] curry map ;
: (inversions) ( n seq -- n )
- [ > ] with filter length ;
+ [ > ] with count ;
: inversions ( seq -- n )
- 0 swap [ length ] keep [
+ 0 swap [ length iota ] keep [
[ nth ] 2keep swap 1 + tail-slice (inversions) +
] curry each ;
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )
- over length [
+ over length iota [
3dup bit? [ nth ] [ 2drop f ] if
] map sift 2nip ;
: basis ( generators -- seq )
- natural-sort dup length 2^ [ nth-basis-elt ] with map ;
+ natural-sort dup length 2^ iota [ nth-basis-elt ] with map ;
: (tensor) ( seq1 seq2 -- seq )
[
dim-im/ker-d ;
: graded-ker/im-d ( graded-basis -- seq )
- [ length ] keep [ (graded-ker/im-d) ] curry map ;
+ [ length iota ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
basis graded graded-ker/im-d unzip but-last 0 prefix v- ;
3array ;
:: bigraded-triples ( grid -- triples )
- grid length [| z |
- grid first length [| u |
+ grid length iota [| z |
+ grid first length iota [| u |
u z grid bigraded-triple
] map
] map ;
}
: gamma-z ( x n -- seq )
- [ + recip ] with map 1.0 0 pick set-nth ;
+ [ + recip ] with { } map-integers 1.0 0 pick set-nth ;
: (gamma-lanczos6) ( x -- log[gamma[x+1]] )
#! log(gamma(x+1)
first 3digits>text
] [
[ set-conjunction "" ] [ length ] [ ] tri
- [ (recombine) ] curry each
+ [ (recombine) ] curry each-integer
] if ;
: (number>text) ( n -- str )
! (c)2009 Joe Groff bsd license
USING: accessors arrays bit-arrays classes
-classes.tuple.private fry kernel locals parser
+classes.tuple.private fry kernel locals math parser
sequences sequences.private vectors words ;
IN: memory.pools
: <pool> ( size class -- pool )
[ nip new ]
- [ [ iota ] dip '[ _ new ] V{ } replicate-as ] 2bi
+ [ '[ _ new ] V{ } replicate-as ] 2bi
pool boa ;
: pool-size ( pool -- size )
:: copy-tuple ( from to -- to )
from tuple-size :> size
- size [| n | n from array-nth n to set-array-nth ] each
+ size [| n | n from array-nth n to set-array-nth ] each-integer
to ; inline
: (pool-new) ( pool -- object )
: canonicalize-specializer-1 ( specializer -- specializer' )
[
[ class? ] filter
- [ length <reversed> [ 1 + neg ] map ] keep zip
+ [ length iota <reversed> [ 1 + neg ] map ] keep zip
[ length args [ max ] change ] keep
]
[
swap "predicate" word-prop append ;
: multi-predicate ( classes -- quot )
- dup length <reversed>
+ dup length iota <reversed>
[ picker 2array ] 2map
[ drop object eq? not ] assoc-filter
[ [ t ] ] [
: range ( r from to -- n )
over - 1 + rot [
- '[ over + @ drop ] each drop f
+ '[ over + @ drop ] each-integer drop f
] bshift 2nip ; inline
[ 55 ] [
: pad-front ( matrix -- matrix )
[
- length [ 0 <repetition> ] map
+ length iota [ 0 <repetition> ] map
] keep [ append ] 2map ;
: pad-back ( matrix -- matrix )
<reversed> [
- length [ 0 <repetition> ] map
+ length iota [ 0 <repetition> ] map
] keep [ <reversed> append ] 2map ;
: diagonal/ ( -- matrix )
[ [ dup 1 > ] [ dup , next-collatz ] while , ] { } make ;
: euler014 ( -- answer )
- 1000000 [1,b] 0 [ collatz longest ] reduce first ;
+ 1000000 [1,b] { } [ collatz longest ] reduce first ;
! [ euler014 ] time
! 52868 ms run / 483 ms GC time
PRIVATE>
: euler014a ( -- answer )
- 500000 1000000 [a,b] 1 [
+ 500000 1000000 [a,b] { 1 } [
dup worth-calculating? [ collatz longest ] [ drop ] if
] reduce first ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.combinatorics math.parser project-euler.common ;
+USING: kernel math.combinatorics math.parser project-euler.common
+sequences ;
IN: project-euler.024
! http://projecteuler.net/index.php?section=problems&id=24
! --------
: euler024 ( -- answer )
- 999999 10 permutation 10 digits>integer ;
+ 999999 10 iota permutation 10 digits>integer ;
! [ euler024 ] 100 ave-time
! 0 ms ave run time - 0.27 SD (100 trials)
: source-032 ( -- seq )
9 factorial iota [
- 9 permutation [ 1 + ] map 10 digits>integer
+ 9 iota permutation [ 1 + ] map 10 digits>integer
] map ;
: 1and4 ( n -- ? )
: interesting? ( seq -- ? )
{
- [ 17 8 rot subseq-divisible? ]
- [ 13 7 rot subseq-divisible? ]
- [ 11 6 rot subseq-divisible? ]
- [ 7 5 rot subseq-divisible? ]
- [ 5 4 rot subseq-divisible? ]
- [ 3 3 rot subseq-divisible? ]
- [ 2 2 rot subseq-divisible? ]
+ [ [ 17 8 ] dip subseq-divisible? ]
+ [ [ 13 7 ] dip subseq-divisible? ]
+ [ [ 11 6 ] dip subseq-divisible? ]
+ [ [ 7 5 ] dip subseq-divisible? ]
+ [ [ 5 4 ] dip subseq-divisible? ]
+ [ [ 3 3 ] dip subseq-divisible? ]
+ [ [ 2 2 ] dip subseq-divisible? ]
} 1&& ;
PRIVATE>
[ unclip 1 head prefix concat ] map [ all-unique? ] filter ;
: add-missing-digit ( seq -- seq )
- dup natural-sort 10 swap diff prepend ;
+ dup natural-sort 10 iota swap diff prepend ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
<PRIVATE
: map-nx ( n x -- seq )
- [ 1 + * ] with map ; inline
+ iota [ 1 + * ] with map ; inline
: all-same-digits? ( seq -- ? )
[ number>digits natural-sort ] map all-equal? ;
! --------
: euler053 ( -- answer )
- 23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] map-sum ;
+ 23 100 [a,b] [ dup iota [ nCk 1000000 > ] with count ] map-sum ;
! [ euler053 ] 100 ave-time
! 52 ms ave run time - 4.44 SD (100 trials)
:: (euler150) ( m -- n )
sums-triangle :> table
- m [| x |
- x 1 + [| y |
- m x - [0,b) [| z |
+ m iota [| x |
+ x 1 + iota [| y |
+ m x - iota [| z |
x z + table nth-unsafe
[ y z + 1 + swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
{ { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1 + ] }
{ { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1 + ] }
{ { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1 + ] }
- [ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
+ [ [ dup length iota [ pick-sheet ] with map sum ] [ sum ] bi / ]
} case ] cache ;
: euler151 ( -- answer )
<PRIVATE
: next-keys ( key -- keys )
- [ last ] [ 10 swap sum - ] bi [ 2array ] with map ;
+ [ last ] [ 10 swap sum - iota ] bi [ 2array ] with map ;
: next-table ( assoc -- assoc )
H{ } clone swap
<PRIVATE
: max-children ( seq -- seq )
- [ dup length 1 - [ nth-pair max , ] with each ] { } make ;
+ [ dup length 1 - iota [ nth-pair max , ] with each ] { } make ;
! Propagate one row into the upper one
: propagate ( bottom top -- newtop )
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables help.markup help.stylesheet io
io.styles kernel math models namespaces sequences ui ui.gadgets
[ first3 ] dip head 3array ;
: strip-tease ( data -- seq )
- dup third length 1 - [
+ dup third length 1 - iota [
2 + (strip-tease)
] with map ;
] with-compilation-unit ;
: test-inference ( ast -- in# out# )
- test-compilation infer [ in>> ] [ out>> ] bi ;
+ test-compilation infer [ in>> ] [ out>> ] bi [ length ] bi@ ;
[ 2 1 ] [
T{ ast-block f
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators effects generic generic.standard
+USING: arrays combinators effects generic generic.standard
kernel sequences words lexer ;
IN: smalltalk.selectors
: selector>effect ( selector -- effect )
dup selector-type {
- { unary [ drop 0 ] }
- { binary [ drop 1 ] }
- { keyword [ [ CHAR: : = ] count ] }
+ { unary [ drop { } ] }
+ { binary [ drop { "x" } ] }
+ { keyword [ [ CHAR: : = ] count "x" <array> ] }
} case "receiver" suffix { "result" } <effect> ;
: selector>generic ( selector -- generic )
TUPLE: board { width integer } { height integer } rows ;
: make-rows ( width height -- rows )
- [ drop f <array> ] with map ;
+
iota [ drop f <array> ] with map ;
: <board> ( width height -- board )
2dup make-rows board boa ;
: block-free? ( board block -- ? ) block not ;
: block-in-bounds? ( board block -- ? )
- [ first swap width>> bounds-check? ] 2keep
- second swap height>> bounds-check? and ;
+ [ first swap width>> iota bounds-check? ]
+ [ second swap height>> iota bounds-check? ] 2bi and ;
: location-valid? ( board block -- ? )
2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;
IN: trees.splay.tests
: randomize-numeric-splay-tree ( splay-tree -- )
- 100 [ drop 100 random swap at drop ] with each ;
+ 100 iota [ drop 100 iota random swap at drop ] with each ;
: make-numeric-splay-tree ( n -- splay-tree )
- <splay> [ [ conjoin ] curry each ] keep ;
+ iota <splay> [ [ conjoin ] curry each ] keep ;
[ t ] [
100 make-numeric-splay-tree dup randomize-numeric-splay-tree
projects / factor.git / commitdiff