steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2008-07-03 15:18:15 -05:00
parent f864d51255 4238657a26
commit a3c3527655
13 changed files with 171 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/bootstrap/stage2.factor
View File

@ -28,7 +28,7 @@ SYMBOL: bootstrap-time
[ "bootstrap." prepend require ] each ;
: count-words ( pred -- )
all-words swap filter length number>string write ;
all-words swap count number>string write ;
: print-report ( time -- )
1000 /i

2
core/classes/tuple/tuple.factor
View File

@ -103,7 +103,7 @@ ERROR: bad-superclass class ;
: superclass-size ( class -- n )
superclasses but-last-slice
[ slot-names length ] map sum ;
[ slot-names length ] sigma ;
: generate-tuple-slots ( class slots -- slot-specs )
over superclass-size 2 + simple-slots ;

2
core/optimizer/inlining/inlining.factor
View File

@ -48,7 +48,7 @@ DEFER: (flat-length)
{ [ dup word? ] [ word-flat-length ] }
[ drop 1 ]
} cond
] map sum ;
] sigma ;
: flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ;

22
core/sequences/sequences-docs.factor
View File

@ -1,5 +1,5 @@
USING: arrays bit-arrays help.markup help.syntax math
sequences.private vectors strings sbufs kernel math.order ;
sequences.private vectors strings quotations sbufs kernel math.order ;
IN: sequences
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
@ -957,3 +957,23 @@ HELP: unfold
"The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:"
{ $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" }
} ;
HELP: sigma
{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
{ $description "Like map sum, but without creating an intermediate sequence." }
{ $example
"! Find the sum of the squares [0,99]"
"USING: math math.ranges sequences.lib prettyprint ;"
"100 [1,b] [ sq ] sigma ."
"338350"
} ;
HELP: count
{ $values { "seq" sequence } { "quot" quotation } { "n" integer } }
{ $description "Efficiently returns the number of elements that the predicate quotation matches." }
{ $example
"USING: math math.ranges sequences.lib prettyprint ;"
"100 [1,b] [ even? ] count ."
"50"
} ;

5
core/sequences/sequences-tests.factor
View File

@ -243,3 +243,8 @@ unit-test
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test

5
core/sequences/sequences.factor
View File

@ -722,3 +722,8 @@ PRIVATE>
dup [ length ] map infimum
swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
] unless ;
: sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline

34
extra/bake/bake-tests.factor Normal file
View File

@ -0,0 +1,34 @@
USING: kernel tools.test bake ;
IN: bake.tests
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: unit-test* ( input output -- ) swap unit-test ;
: must-be-t ( in -- ) [ t ] swap unit-test ;
: must-be-f ( in -- ) [ f ] swap unit-test ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ 10 20 30 `{ , , , } ] [ { 10 20 30 } ] unit-test*
[ 10 20 30 `{ , { , } , } ] [ { 10 { 20 } 30 } ] unit-test*
[ 10 { 20 21 22 } 30 `{ , , , } ] [ { 10 { 20 21 22 } 30 } ] unit-test*
[ 10 { 20 21 22 } 30 `{ , @ , } ] [ { 10 20 21 22 30 } ] unit-test*
[ { 1 2 3 } `{ @ } ] [ { 1 2 3 } ] unit-test*
[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `{ @ @ @ } ]
[ { 1 2 3 4 5 6 7 8 9 } ]
unit-test*
[ 10 20 30 40 `[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `[ , { V{ @ } { , } } ] ]
[ [ { 1 2 3 } { V{ 4 5 6 } { { 7 8 9 } } } ] ]
unit-test*

70
extra/bake/bake.factor
View File

@ -1,6 +1,7 @@
USING: kernel parser combinators sequences splitting quotations arrays macros
arrays.lib combinators.cleave combinators.conditional newfx ;
USING: kernel parser namespaces sequences quotations arrays vectors splitting
math
macros arrays.lib combinators.lib combinators.conditional newfx ;
IN: bake
@ -14,46 +15,79 @@ SYMBOL: @
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: [bake-array]
DEFER: [bake]
: broil-element ( obj -- quot )
{
{ [ comma? ] [ drop [ >r ] ] }
{ [ array? ] [ [bake-array] [ >r ] append ] }
{ [ drop t ] [ [ >r ] prefix-on ] }
{ [ comma? ] [ drop [ >r ] ] }
{ [ integer? ] [ [ >r ] prefix-on ] }
{ [ sequence? ] [ [bake] [ >r ] append ] }
{ [ drop t ] [ [ >r ] prefix-on ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [broil] ( array -- quot )
: constructor ( seq -- quot )
{
{ [ array? ] [ length [ narray ] prefix-on ] }
{ [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] }
{ [ vector? ] [ length [ narray >vector ] prefix-on ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [broil] ( seq -- quot )
[ reverse [ broil-element ] map concat ]
[ length [ drop [ r> ] ] map concat ]
[ length [ narray ] prefix-on ]
[ length [ drop [ r> ] ] map concat ]
[ constructor ]
tri append append
>quotation ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [simmer] ( array -- quot )
SYMBOL: saved-sequence
: [connector] ( -- quot )
saved-sequence get quotation? [ [ compose ] ] [ [ append ] ] if ;
: [starter] ( -- quot )
saved-sequence get
{
{ [ quotation? ] [ drop [ [ ] ] ] }
{ [ array? ] [ drop [ { } ] ] }
{ [ vector? ] [ drop [ V{ } ] ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [simmer] ( seq -- quot )
dup saved-sequence set
{ @ } split reverse
[ [ [bake-array] [ append ] append [ >r ] append ] map concat ]
[ length [ drop [ r> append ] ] map concat ]
[ [ [bake] [connector] append [ >r ] append ] map concat ]
[ length [ drop [ r> ] [connector] append ] map concat ]
bi
>r 2 head* [ >r ] append r> ! remove the last append
>r 1 invert-index pluck r> ! remove the last append/compose
[ { } ] swap append
[starter] prepend
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [bake-array] ( array -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
MACRO: bake-array ( array -- quot ) [bake-array] ;
: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing
MACRO: bake ( seq -- quot ) [bake] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing

29
extra/fry/fry.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators parser splitting
USING: kernel sequences combinators parser splitting math
quotations arrays namespaces qualified ;
QUALIFIED: namespaces
IN: fry
@ -10,9 +10,10 @@ IN: fry
: _ ( -- * ) "Only valid inside a fry" throw ;
DEFER: (shallow-fry)
DEFER: shallow-fry
: ((shallow-fry)) ( accum quot adder -- result )
>r [ ] swap (shallow-fry) r>
>r shallow-fry r>
append swap dup empty? [ drop ] [
[ prepose ] curry append
] if ; inline
@ -34,29 +35,25 @@ DEFER: (shallow-fry)
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
: deep-fry ( quot -- quot' )
{ _ } last-split1 [
[
shallow-fry %
[ >r ] %
deep-fry %
[ [ dip ] curry r> compose ] %
] [ ] make
: deep-fry ( quot -- quot )
{ _ } last-split1 dup [
shallow-fry [ >r ] rot
deep-fry [ [ dip ] curry r> compose ] 4array concat
] [
shallow-fry
] if* ;
drop shallow-fry
] if ;
: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
: count-inputs ( quot -- n )
[
{
{ [ dup callable? ] [ count-inputs ] }
{ [ dup fry-specifier? ] [ drop 1 ] }
[ drop 0 ]
{ [ dup callable? ] [ count-inputs ] }
{ [ dup fry-specifier? ] [ drop 1 ] }
[ drop 0 ]
} cond
] map sum ;
: fry ( quot -- quot' )
[
[

39
extra/newfx/newfx.factor
View File

@ -159,6 +159,11 @@ METHOD: as-mutate { object object assoc } set-at ;
: prefix-on ( elt seq -- seq ) swap prefix ;
: suffix-on ( elt seq -- seq ) swap suffix ;
: suffix! ( seq elt -- seq ) over sequences:push ;
: suffix-on! ( elt seq -- seq ) tuck sequences:push ;
: suffixed! ( seq elt -- ) swap sequences:push ;
: suffixed-on! ( elt seq -- ) sequences:push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: subseq ( seq from to -- subseq ) rot sequences:subseq ;
@ -199,4 +204,36 @@ METHOD: as-mutate { object object assoc } set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start ( seq subseq -- i ) swap sequences:start ;
: start ( seq subseq -- i ) swap sequences:start ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: pluck ( seq i -- seq ) cut-slice rest-slice append ;
: pluck-from ( i seq -- seq ) swap pluck ;
: pluck! ( seq i -- seq ) over delete-nth ;
: pluck-from! ( i seq -- seq ) tuck delete-nth ;
: plucked! ( seq i -- ) swap delete-nth ;
: plucked-from! ( i seq -- ) delete-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: snip ( seq a b -- seq ) >r over r> [ head ] [ tail ] 2bi* append ;
: snip-this ( a b seq -- seq ) -rot snip ;
: snip! ( seq a b -- seq ) pick delete-slice ;
: snip-this! ( a b seq -- seq ) -rot pick delete-slice ;
: snipped! ( seq a b -- ) rot delete-slice ;
: snipped-from! ( a b seq -- ) delete-slice ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: invert-index ( seq i -- seq i ) >r dup length 1 - r> - ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: append! ( a b -- ab ) over sequences:push-all ;
: append-to! ( b a -- ab ) swap over sequences:push-all ;
: appended! ( a b -- ) swap sequences:push-all ;
: appended-to! ( b a -- ) sequences:push-all ;
: prepend! ( a b -- ba ) over append 0 pick copy ;
: prepended! ( a b -- ) over append 0 rot copy ;

19
extra/sequences/lib/lib-docs.factor
View File

@ -19,25 +19,6 @@ HELP: each-withn
}
{ $see-also map-withn } ;
HELP: sigma
{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
{ $description "Like map sum, but without creating an intermediate sequence." }
{ $example
"! Find the sum of the squares [0,99]"
"USING: math math.ranges sequences.lib prettyprint ;"
"100 [1,b] [ sq ] sigma ."
"338350"
} ;
HELP: count
{ $values { "seq" sequence } { "quot" quotation } { "n" integer } }
{ $description "Efficiently returns the number of elements that the predicate quotation matches." }
{ $example
"USING: math math.ranges sequences.lib prettyprint ;"
"100 [1,b] [ even? ] count ."
"50"
} ;
HELP: if-seq
{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
{ $description "Makes an implicit check if the sequence is empty. If the sequence has any elements, " { $snippet "quot1" } " is called on it. Otherwise, the empty sequence is dropped and " { $snippet "quot2" } " is called." }

8
extra/sequences/lib/lib-tests.factor
View File

@ -2,10 +2,6 @@ USING: arrays kernel sequences sequences.lib math math.functions math.ranges
tools.test strings ;
IN: sequences.lib.tests
[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
@ -64,10 +60,6 @@ IN: sequences.lib.tests
[ 3 ] [ { 1 2 3 } ?third ] unit-test
[ f ] [ { 1 2 3 } ?fourth ] unit-test
[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test

8
extra/sequences/lib/lib.factor
View File

@ -51,14 +51,6 @@ MACRO: firstn ( n -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sigma ( seq quot -- n )
[ + ] compose 0 swap reduce ; inline
: count ( seq quot -- n )
[ 1 0 ? ] compose sigma ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: map-reduce ( seq map-quot reduce-quot -- result )
>r [ unclip ] dip [ call ] keep r> compose reduce ; inline