! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar combinators generic init kernel math
namespaces sequences heaps boxes threads debugger quotations
-assocs ;
+assocs math.order ;
IN: alarms
TUPLE: alarm quot time interval entry ;
-IN: ascii.tests
USING: ascii tools.test sequences kernel math ;
+IN: ascii.tests
[ t ] [ CHAR: a letter? ] unit-test
[ f ] [ CHAR: A letter? ] unit-test
[ t ] [ CHAR: 0 digit? ] unit-test
[ f ] [ CHAR: x digit? ] unit-test
-
[ 4 ] [
0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each
! Copyright (C) 2005, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: sequences math kernel ;\r
+USING: kernel math math.order sequences ;\r
IN: ascii\r
\r
: blank? ( ch -- ? ) " \t\n\r" member? ; inline\r
M: x30 g ;
: my-classes ( -- seq )
- "benchmark.dispatch1" words [ tuple-class? ] subset ;
+ "benchmark.dispatch1" words [ tuple-class? ] filter ;
: a-bunch-of-objects ( -- seq )
my-classes [ new ] map ;
INSTANCE: x30 g\r
\r
: my-classes ( -- seq )\r
- "benchmark.dispatch5" words [ tuple-class? ] subset ;\r
+ "benchmark.dispatch5" words [ tuple-class? ] filter ;\r
\r
: a-bunch-of-objects ( -- seq )\r
my-classes [ new ] map ;\r
>r keys r> define-slots ;
: filter-pad ( slots -- slots )
- [ drop padding-name? not ] assoc-subset ;
+ [ drop padding-name? not ] assoc-filter ;
: define-bitfield ( classname slots -- )
[
<--&& ;
: cohesion-neighborhood ( self -- boids )
- boids> [ within-cohesion-neighborhood? ] with subset ;
+ boids> [ within-cohesion-neighborhood? ] with filter ;
: cohesion-force ( self -- force )
dup cohesion-neighborhood
<--&& ;
: separation-neighborhood ( self -- boids )
- boids> [ within-separation-neighborhood? ] with subset ;
+ boids> [ within-separation-neighborhood? ] with filter ;
: separation-force ( self -- force )
dup separation-neighborhood
<--&& ;
: alignment-neighborhood ( self -- boids )
-boids> [ within-alignment-neighborhood? ] with subset ;
+boids> [ within-alignment-neighborhood? ] with filter ;
: alignment-force ( self -- force )
alignment-neighborhood
[ drop ] load-vocab-hook [
vocabs
- [ vocab-docs-loaded? not ] subset
+ [ vocab-docs-loaded? not ] filter
[ load-docs ] each
] with-variable ;
IN: builder.benchmark
! : passing-benchmarks ( table -- table )
-! [ second first2 number? swap number? and ] subset ;
+! [ second first2 number? swap number? and ] filter ;
-: passing-benchmarks ( table -- table ) [ second number? ] subset ;
+: passing-benchmarks ( table -- table ) [ second number? ] filter ;
! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
[ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ]
[ <bunny-outlined> ]
- } map-call-with [ ] subset
+ } map-call-with [ ] filter
0
roll {
set-bunny-gadget-geom
IN: bunny.model
: numbers ( str -- seq )
- " " split [ string>number ] map [ ] subset ;
+ " " split [ string>number ] map [ ] filter ;
: (parse-model) ( vs is -- vs is )
readln [
USING: arrays kernel math math.functions namespaces sequences
strings system vocabs.loader calendar.backend threads
-accessors combinators locals classes.tuple ;
+accessors combinators locals classes.tuple math.order ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
USING: math math.parser kernel sequences io calendar\r
-accessors arrays io.streams.string splitting\r
+accessors arrays io.streams.string splitting math.order\r
combinators accessors debugger ;\r
IN: calendar.format\r
\r
MACRO: >tuple*< ( class -- )
all-slots
- [ slot-spec-name "*" tail? ] subset
+ [ slot-spec-name "*" tail? ] filter
reader-slots ;
} assoc-union alien>objc-types set-global
: objc-struct-type ( i string -- ctype )
- 2dup CHAR: = -rot index* swap subseq
+ 2dup CHAR: = -rot index-from swap subseq
dup c-types get key? [
"Warning: no such C type: " write dup print
drop "void*"
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }\r
{ $errors "Throws an error if one of the iterations throws an error." } ;\r
\r
-HELP: parallel-subset\r
+HELP: parallel-filter\r
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } }\r
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }\r
{ $errors "Throws an error if one of the iterations throws an error." } ;\r
\r
ARTICLE: "concurrency.combinators" "Concurrent combinators"\r
-"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link subset } ":"\r
+"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"\r
{ $subsection parallel-each }\r
{ $subsection parallel-map }\r
-{ $subsection parallel-subset } ;\r
+{ $subsection parallel-filter } ;\r
\r
ABOUT: "concurrency.combinators"\r
\r
[ [ drop ] parallel-each ] must-infer\r
[ [ ] parallel-map ] must-infer\r
-[ [ ] parallel-subset ] must-infer\r
+[ [ ] parallel-filter ] must-infer\r
\r
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test\r
\r
[ error>> "Even" = ] must-fail-with\r
\r
[ V{ 0 3 6 9 } ]\r
-[ 10 [ 3 mod zero? ] parallel-subset ] unit-test\r
+[ 10 [ 3 mod zero? ] parallel-filter ] unit-test\r
\r
[ 10 ]\r
[\r
[ [ >r curry r> spawn-stage ] 2curry each ] keep await ;\r
inline\r
\r
-: parallel-subset ( seq quot -- newseq )\r
+: parallel-filter ( seq quot -- newseq )\r
over >r pusher >r each r> r> like ; inline\r
[
event-stream-callbacks global
- [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at
+ [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at
] "core-foundation" add-init-hook
: add-event-source-callback ( quot -- id )
: with-db ( db seq quot -- )
>r make-db db-open db r>
- [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
+ [ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
inline
: default-query ( query -- result-set )
" from " 0% 0%
dupd
- [ slot-name>> swap get-slot-named ] with subset
+ [ slot-name>> swap get-slot-named ] with filter
dup empty? [ 2drop ] [ where-clause ] if ";" 0%
] query-make ;
dup number? [ number>string ] when ;
: maybe-remove-id ( specs -- obj )
- [ +native-id+? not ] subset ;
+ [ +native-id+? not ] filter ;
: remove-relations ( specs -- newcolumns )
- [ relation? not ] subset ;
+ [ relation? not ] filter ;
: remove-id ( specs -- obj )
- [ primary-key>> not ] subset ;
+ [ primary-key>> not ] filter ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
tuck offset-of-slot set-slot ;
: tuple>filled-slots ( tuple -- alist )
- <mirror> [ nip ] assoc-subset ;
+ <mirror> [ nip ] assoc-filter ;
: tuple>params ( specs tuple -- obj )
[
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io kernel math models namespaces sequences strings
-splitting combinators unicode.categories ;
+splitting combinators unicode.categories math.order ;
IN: documents
: +col ( loc n -- newloc ) >r first2 r> + 2array ;
[ >r blank? r> xor ] curry ; inline
: (prev-word) ( ? col str -- col )
- rot break-detector find-last* drop ?1+ ;
+ rot break-detector find-last-from drop ?1+ ;
: (next-word) ( ? col str -- col )
- [ rot break-detector find* drop ] keep
+ [ rot break-detector find-from drop ] keep
over not [ nip length ] [ drop ] if ;
TUPLE: one-word-elt ;
wm-root>
<- children
- [ <- mapped? ] subset
+ [ <- mapped? ] filter
[ check-window-table ] map
reverse
! wm-root>
! <- children
-! [ <- mapped? ] subset
+! [ <- mapped? ] filter
! [ check-window-table ] map
! reverse
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: manage-windows ( -- )
-dpy get $default-root <- children [ <- mapped? ] subset
+dpy get $default-root <- children [ <- mapped? ] filter
[ $id <wm-frame> new* drop ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C: <q/a> q/a
: li>q/a ( li -- q/a )
- [ "br" tag-named*? not ] subset
+ [ "br" tag-named*? not ] filter
[ "strong" tag-named*? ] find-after
>r tag-children r> <q/a> ;
: xml>question-list ( list -- question-list )
[ "title" swap at ] keep
- tag-children [ tag? ] subset [ xml>q/a ] map
+ tag-children [ tag? ] filter [ xml>q/a ] map
<question-list> ;
: question-list>xml ( question-list -- list )
: ((shallow-fry)) ( accum quot adder -- result )
>r [ ] swap (shallow-fry) r>
append swap dup empty? [ drop ] [
- [ swap compose ] curry append
+ [ prepose ] curry append
] if ; inline
: (shallow-fry) ( accum quot -- result )
[
dup callable? [
[
- [ { , namespaces:, @ } member? ] subset length
+ [ { , namespaces:, @ } member? ] filter length
\ , <repetition> %
]
[ deep-fry % ] bi
: uname ( -- seq )
65536 "char" <c-array> [ (uname) io-error ] keep
- "\0" split [ empty? not ] subset [ >string ] map
+ "\0" split [ empty? not ] filter [ >string ] map
6 "" pad-right ;
: sysname ( -- string ) uname first ;
: domainname ( -- string ) uname 5 swap nth ;
: kernel-version ( -- seq )
- release ".-" split [ ] subset 5 "" pad-right ;
+ release ".-" split [ ] filter 5 "" pad-right ;
"You can create a new array, only containing elements which satisfy some condition:"
{ $example
": negative? ( n -- ? ) 0 < ;"
- "{ -12 10 16 0 -1 -3 -9 } [ negative? ] subset ."
+ "{ -12 10 16 0 -1 -3 -9 } [ negative? ] filter ."
"{ -12 -1 -3 -9 }"
}
{ $references
{ $index [ articles get keys ] } ;
ARTICLE: "primitive-index" "Primitive index"
-{ $index [ all-words [ primitive? ] subset ] } ;
+{ $index [ all-words [ primitive? ] filter ] } ;
ARTICLE: "error-index" "Error index"
{ $index [ all-errors ] } ;
ARTICLE: "type-index" "Type index"
-{ $index [ builtins get [ ] subset ] } ;
+{ $index [ builtins get [ ] filter ] } ;
ARTICLE: "class-index" "Class index"
{ $index [ classes ] } ;
: all-articles ( -- seq )
articles get keys
- all-words [ word-help ] subset append ;
+ all-words [ word-help ] filter append ;
: xref-help ( -- )
all-articles [ xref-article ] each ;
[ dup article-title ] { } map>assoc sort-values keys ;
: all-errors ( -- seq )
- all-words [ error? ] subset sort-articles ;
+ all-words [ error? ] filter sort-articles ;
M: word article-name word-name ;
":vars - list all variables at error time" print ;
: :help ( -- )
- error get delegates [ error-help ] map [ ] subset
+ error get delegates [ error-help ] map [ ] filter
{
{ [ dup empty? ] [ (:help-none) ] }
{ [ dup length 1 = ] [ first help ] }
[ help ] with-string-writer drop ;
: all-word-help ( words -- seq )
- [ word-help ] subset ;
+ [ word-help ] filter ;
TUPLE: help-error topic ;
articles get keys "group-articles" set
child-vocabs
[ dup check-vocab ] { } map>assoc
- [ nip empty? not ] assoc-subset
+ [ nip empty? not ] assoc-filter
] with-scope ;
: typos. ( assoc -- )
: help-lint-all ( -- ) "" help-lint ;
: unlinked-words ( words -- seq )
- all-word-help [ article-parent not ] subset ;
+ all-word-help [ article-parent not ] filter ;
: linked-undocumented-words ( -- seq )
all-words
- [ word-help not ] subset
- [ article-parent ] subset
- [ "predicating" word-prop not ] subset ;
+ [ word-help not ] filter
+ [ article-parent ] filter
+ [ "predicating" word-prop not ] filter ;
MAIN: help-lint
{ $code "\"A man, a plan, a canal: Panama.\"" }
"Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:"
{ $code "[ Letter? ]" }
-"Finally, pass the string and the quotation to the " { $link subset } " word:"
-{ $code "subset" }
+"Finally, pass the string and the quotation to the " { $link filter } " word:"
+{ $code "filter" }
"Now the stack should contain the following string:"
{ "\"AmanaplanacanalPanama\"" }
"This is almost what we want; we just need to convert the string to lower case now. This can be done by calling " { $link >lower } "; the " { $snippet ">" } " prefix is a naming convention for conversion operations, and should be read as ``to'':"
"Finally, let's print the top of the stack and discard it:"
{ $code "." }
"This will output " { $snippet "amanaplanacanalpanama" } ". This string is in the form that we want, and we evaluated the following code to get it into this form:"
-{ $code "[ Letter? ] subset >lower" }
+{ $code "[ Letter? ] filter >lower" }
"This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":"
-{ $code ": normalize ( str -- newstr ) [ Letter? ] subset >lower ;" }
+{ $code ": normalize ( str -- newstr ) [ Letter? ] filter >lower ;" }
"You will need to add " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file."
$nl
"We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:"
(find-relative) ;
: (find-all) ( n seq quot -- )
- 2dup >r >r find* [
+ 2dup >r >r find-from [
dupd 2array , 1+ r> r> (find-all)
] [
r> r> 3drop
[ 0 -rot (find-all) ] { } make ;
: (find-nth) ( offset seq quot n count -- obj )
- >r >r [ find* ] 2keep 4 npick [
+ >r >r [ find-from ] 2keep 4 npick [
r> r> 1+ 2dup <= [
4drop
] [
] [
drop t
] if
- ] subset ;
+ ] filter ;
: trim-text ( vector -- vector' )
[
] map ;
: find-by-id ( id vector -- vector )
- [ tag-attributes "id" swap at = ] with subset ;
+ [ tag-attributes "id" swap at = ] with filter ;
: find-by-class ( id vector -- vector )
- [ tag-attributes "class" swap at = ] with subset ;
+ [ tag-attributes "class" swap at = ] with filter ;
: find-by-name ( str vector -- vector )
>r >lower r>
- [ tag-name = ] with subset ;
+ [ tag-name = ] with filter ;
: find-first-name ( str vector -- i/f tag/f )
>r >lower r>
: find-by-attribute-key ( key vector -- vector )
>r >lower r>
- [ tag-attributes at ] with subset
- [ ] subset ;
+ [ tag-attributes at ] with filter
+ [ ] filter ;
: find-by-attribute-key-value ( value key vector -- vector )
>r >lower r>
- [ tag-attributes at over = ] with subset nip
- [ ] subset ;
+ [ tag-attributes at over = ] with filter nip
+ [ ] filter ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f )
>r >lower r>
tag-attributes [ "href" swap at ] [ f ] if* ;
: find-links ( vector -- vector )
- [ tag-name "a" = ] subset
- [ tag-link ] subset ;
+ [ tag-name "a" = ] filter
+ [ tag-link ] filter ;
: find-by-text ( seq quot -- tag )
- [ dup tag-name text = ] swap compose find drop ;
+ [ dup tag-name text = ] prepose find drop ;
: find-opening-tags-by-name ( name seq -- seq )
[ [ tag-name = ] keep tag-closing? not and ] with find-all ;
: query>assoc* ( str -- hash )
"?" split1 nip query>assoc ;
-! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map
+! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] filter [ "=" split peek ] map
! clear "http://www.sailwx.info/shiptrack/cruiseships.phtml" http-get parse-html remove-blank-text
! "a" over find-opening-tags-by-name
-! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset
+! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-filter
! first first 8 + over nth
! tag-attributes "href" swap at query>assoc*
! "lat" over at "lon" rot at
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
: split-path ( string -- path )
- "/" split [ empty? not ] subset ;
+ "/" split [ empty? not ] filter ;
: do-request ( request -- response )
[
] unit-test
: run-template
- with-string-writer [ "\r\n\t" member? not ] subset
+ with-string-writer [ "\r\n\t" member? not ] filter
"?>" split1 nip ; inline
: test-template ( name -- template )
<form
"POST" =method
[ "action" required-attr resolve-base-path =action ]
- [ tag-attrs [ drop name-tag "action" = not ] assoc-subset print-attrs ] bi
+ [ tag-attrs [ drop name-tag "action" = not ] assoc-filter print-attrs ] bi
form>
hidden-form-field ;
! Copyright (C) 2004, 2005 Mackenzie Straight.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.buffers
USING: alien alien.accessors alien.c-types alien.syntax kernel
kernel.private libc math sequences byte-arrays strings hints
-accessors ;
+accessors math.order ;
+IN: io.buffers
TUPLE: buffer size ptr fill pos ;
: process-contents ( lines -- assoc )
[ "#" split1 drop ] map
- [ empty? not ] subset
+ [ empty? not ] filter
[ "\t" split 2 head [ 2 tail-if hex> ] map ] map ;
: byte>ch ( assoc -- array )
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel io sequences io.buffers io.timeouts generic
-byte-vectors system io.streams.duplex io.encodings
+byte-vectors system io.streams.duplex io.encodings math.order
io.backend continuations debugger classes byte-arrays namespaces
splitting dlists assocs io.encodings.binary inspector accessors ;
IN: io.nonblocking
: parse-addrinfo-list ( addrinfo -- seq )
[ addrinfo-next ] follow
[ addrinfo>addrspec ] map
- [ ] subset ;
+ [ ] filter ;
: prepare-resolve-host ( host serv passive? -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.nonblocking io.unix.backend
bit-arrays sequences assocs unix math namespaces structs
-accessors ;
+accessors math.order ;
IN: io.unix.select
TUPLE: select-mx < mx read-fdset write-fdset ;
} cond ;
: canonicalize
- [ nip zero? not ] assoc-subset ;
+ [ nip zero? not ] assoc-filter ;
SYMBOL: terms
[ natural-sort ] keep [ index ] curry map ;
: (inversions) ( n seq -- n )
- [ > ] with subset length ;
+ [ > ] with filter length ;
: inversions ( seq -- n )
0 swap [ length ] keep [
: nth-basis-elt ( generators n -- elt )
over length [
3dup bit? [ nth ] [ 2drop f ] if
- ] map [ ] subset 2nip ;
+ ] map [ ] filter 2nip ;
: basis ( generators -- seq )
natural-sort dup length 2^ [ nth-basis-elt ] with map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq )
>r [ basis graded ] bi@ tensor bigraded-triples r>
- [ [ first3 ] swap compose map ] curry map ; inline
+ [ [ first3 ] prepose map ] curry map ; inline
: bigraded-laplacian-betti ( u-generators z-generators -- seq )
[ laplacian-betti ] bigraded-laplacian ;
: naturals 0 lfrom ;
: positives 1 lfrom ;
: evens 0 [ 2 + ] lfrom-by ;
-: odds 1 lfrom [ 2 mod 1 = ] lsubset ;
+: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
: powers-of-2 1 [ 2 * ] lfrom-by ;
: ones 1 [ ] lfrom-by ;
: squares naturals [ dup * ] lmap ;
{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
{ $description "Put the head and tail of the list on the stack." } ;
-{ leach lreduce lmap lmap-with ltake lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
+{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
HELP: leach
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-HELP: lsubset
+HELP: lfilter
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link subset } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-subset> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lwhile
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
M: lazy-while nil? ( lazy-while -- bool )
[ car ] keep lazy-while-quot call not ;
-TUPLE: lazy-subset cons quot ;
+TUPLE: lazy-filter cons quot ;
-C: <lazy-subset> lazy-subset
+C: <lazy-filter> lazy-filter
-: lsubset ( list quot -- result )
- over nil? [ 2drop nil ] [ <lazy-subset> <memoized-cons> ] if ;
+: lfilter ( list quot -- result )
+ over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
-: car-subset? ( lazy-subset -- ? )
- [ lazy-subset-cons car ] keep
- lazy-subset-quot call ;
+: car-filter? ( lazy-filter -- ? )
+ [ lazy-filter-cons car ] keep
+ lazy-filter-quot call ;
-: skip ( lazy-subset -- )
- [ lazy-subset-cons cdr ] keep
- set-lazy-subset-cons ;
+: skip ( lazy-filter -- )
+ [ lazy-filter-cons cdr ] keep
+ set-lazy-filter-cons ;
-M: lazy-subset car ( lazy-subset -- car )
- dup car-subset? [ lazy-subset-cons ] [ dup skip ] if car ;
+M: lazy-filter car ( lazy-filter -- car )
+ dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ;
-M: lazy-subset cdr ( lazy-subset -- cdr )
- dup car-subset? [
- [ lazy-subset-cons cdr ] keep
- lazy-subset-quot lsubset
+M: lazy-filter cdr ( lazy-filter -- cdr )
+ dup car-filter? [
+ [ lazy-filter-cons cdr ] keep
+ lazy-filter-quot lfilter
] [
dup skip cdr
] if ;
-M: lazy-subset nil? ( lazy-subset -- bool )
- dup lazy-subset-cons nil? [
+M: lazy-filter nil? ( lazy-filter -- bool )
+ dup lazy-filter-cons nil? [
drop t
] [
- dup car-subset? [
+ dup car-filter? [
drop f
] [
dup skip nil?
[ lcartesian-product* ] dip lmap ;
: lcomp* ( list guards quot -- result )
- [ [ lcartesian-product* ] dip [ lsubset ] each ] dip lmap ;
+ [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
DEFER: lmerge
INSTANCE: lazy-zip list
INSTANCE: lazy-while list
INSTANCE: lazy-until list
-INSTANCE: lazy-subset list
+INSTANCE: lazy-filter list
>r >r dup r> r> 2curry annotate ;\r
\r
: call-logging-quot ( quot word level -- quot' )\r
- "called" -rot [ log-message ] 3curry swap compose ;\r
+ "called" -rot [ log-message ] 3curry prepose ;\r
\r
: add-logging ( word level -- )\r
[ call-logging-quot ] (define-logging) ;\r
: input# stack-effect effect-in length ;\r
\r
: input-logging-quot ( quot word level -- quot' )\r
- over input# -rot [ log-stack ] 3curry swap compose ;\r
+ over input# -rot [ log-stack ] 3curry prepose ;\r
\r
: add-input-logging ( word level -- )\r
[ input-logging-quot ] (define-logging) ;\r
write bl write ": " write print ;\r
\r
: write-message ( msg word-name level -- )\r
- rot [ empty? not ] subset {\r
+ rot [ empty? not ] filter {\r
{ [ dup empty? ] [ 3drop ] }\r
{ [ dup length 1 = ] [ first -rot f (write-message) ] }\r
[\r
-USING: kernel math math.constants math.functions tools.test
-prettyprint ;
+USING: kernel math math.constants math.functions math.order
+tools.test prettyprint ;
IN: math.complex.tests
[ 1 C{ 0 1 } rect> ] must-fail
-USING: help.markup help.syntax kernel math
+USING: help.markup help.syntax kernel math math.order
sequences quotations math.functions.private ;
IN: math.functions
-USING: kernel math math.constants math.functions math.private
-math.libm tools.test ;
+USING: kernel math math.constants math.functions math.order
+math.private math.libm tools.test ;
IN: math.functions.tests
[ t ] [ 4 4 .00000001 ~ ] unit-test
! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel math.constants math.private
-math.libm combinators ;
+math.libm combinators math.order ;
IN: math.functions
<PRIVATE
: cols ( -- n ) 0 nth-row length ;
: skip ( i seq quot -- n )
- over >r find* drop r> length or ; inline
+ over >r find-from drop r> length or ; inline
: first-col ( row# -- n )
#! First non-zero column
: echelon ( matrix -- matrix' )
[ 0 0 (echelon) ] with-matrix ;
-: nonzero-rows [ [ zero? ] all? not ] subset ;
+: nonzero-rows [ [ zero? ] all? not ] filter ;
: null/rank ( matrix -- null rank )
echelon dup length swap nonzero-rows length [ - ] keep ;
-USING: kernel layouts math namespaces sequences
+USING: kernel layouts math math.order namespaces sequences
sequences.private accessors ;
IN: math.ranges
-USING: kernel math math.parser math.ratios math.functions
-tools.test ;
+USING: kernel math math.order math.parser math.ratios
+math.functions tools.test ;
IN: math.ratios.tests
[ 1 2 ] [ 1/2 >fraction ] unit-test
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math math.functions hints
-float-arrays ;
+float-arrays math.order ;
IN: math.vectors
: vneg ( u -- v ) [ neg ] map ;
: choices ( cell -- seq )
{ { -1 0 } { 1 0 } { 0 -1 } { 0 1 } }
[ v+ ] with map
- [ unvisited? ] subset ;
+ [ unvisited? ] filter ;
: random-neighbour ( cell -- newcell ) choices random ;
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel memoize tools.test parser ;
+IN: memoize.tests
MEMO: fib ( m -- n )
dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel math sequences arrays assocs alarms
-calendar ;
+calendar math.order ;
IN: models
TUPLE: model < identity-tuple
: canonicalize-specializer-1 ( specializer -- specializer' )
[
- [ class? ] subset
+ [ class? ] filter
[ length <reversed> [ 1+ neg ] map ] keep zip
[ length args [ max ] change ] keep
]
[
- [ pair? ] subset
+ [ pair? ] filter
[ keys [ hooks get push-new ] each ] keep
] bi append ;
! Part II: Topologically sorting specializers
: maximal-element ( seq quot -- n elt )
dupd [
- swapd [ call 0 < ] 2curry subset empty?
+ swapd [ call 0 < ] 2curry filter empty?
] 2curry find [ "Topological sort failed" throw ] unless* ;
inline
: multi-predicate ( classes -- quot )
dup length <reversed>
[ picker 2array ] 2map
- [ drop object eq? not ] assoc-subset
+ [ drop object eq? not ] assoc-filter
dup empty? [ drop [ t ] ] [
[ (multi-predicate) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: subset-of ( quot seq -- seq ) swap subset ;
+: filter-of ( quot seq -- seq ) swap filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
scan drop "}" parse-tokens swap prefix
gl-function-number
[ gl-function-pointer ] 2curry swap
- ";" parse-tokens [ "()" subseq? not ] subset
+ ";" parse-tokens [ "()" subseq? not ] filter
define-indirect
; parsing
! SYMBOL: ssl
!
! : is-set ( seq -- newseq )
-! <enum> >alist [ nip ] assoc-subset >hashtable keys ;
+! <enum> >alist [ nip ] assoc-filter >hashtable keys ;
!
! ! 1234 server-socket sock set
! "127.0.0.1" 1234 <inet4> SOCK_STREAM server-fd sock set
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;\r
\r
: results\r
- [ [ second ] swap compose compare ] curry sort 20 tail*\r
+ [ [ second ] prepose compare ] curry sort 20 tail*\r
print\r
standard-table-style\r
[\r
] tabular-output ;\r
\r
: optimizer-report\r
- all-words [ compiled? ] subset\r
+ all-words [ compiled? ] filter\r
[\r
dup [\r
word-dataflow nip 1 count-optimization-passes\r
#! from the results anything where the remaining
#! input to be parsed is not empty. So ensures a
#! fully parsed input string.
- just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ;
+ just-parser-p1 parse [ parse-result-unparsed empty? ] lfilter ;
TUPLE: apply-parser p1 quot ;
GENERIC: build-locals ( code ast -- code )\r
\r
M: ebnf-sequence build-locals ( code ast -- code )\r
- elements>> dup [ ebnf-var? ] subset empty? [\r
+ elements>> dup [ ebnf-var? ] filter empty? [\r
drop \r
] [ \r
[\r
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle
- vectors arrays math.parser
+ vectors arrays math.parser math.order
unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
IN: peg
: search ( string parser -- seq )
any-char-parser [ drop f ] action 2array choice repeat0 parse dup [
- parse-result-ast [ ] subset
+ parse-result-ast [ ] filter
] [
drop { }
] if ;
: (replace) ( string parser -- seq )
- any-char-parser 2array choice repeat0 parse parse-result-ast [ ] subset ;
+ any-char-parser 2array choice repeat0 parse parse-result-ast [ ] filter ;
: replace ( string parser -- result )
[ (replace) [ tree-write ] each ] with-string-writer ;
"extra/porter-stemmer/test/voc.txt" resource-lines
[ stem ] map
"extra/porter-stemmer/test/output.txt" resource-lines
- [ 2array ] 2map [ first2 = not ] subset
+ [ 2array ] 2map [ first2 = not ] filter
] unit-test
! -------------------
: euler001a ( -- answer )
- 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] subset sum ;
+ 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ;
! [ euler001a ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
V{ 0 } clone 1 rot (fib-upto) ;
: euler002 ( -- answer )
- 1000000 fib-upto [ even? ] subset sum ;
+ 1000000 fib-upto [ even? ] filter sum ;
! [ euler002 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
1 head-slice* { 0 1 } prepend ;
: euler002a ( -- answer )
- 1000000 fib-upto* [ even? ] subset sum ;
+ 1000000 fib-upto* [ even? ] filter sum ;
! [ euler002a ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
<PRIVATE
: source-004 ( -- seq )
- 100 999 [a,b] [ 10 mod zero? not ] subset ;
+ 100 999 [a,b] [ 10 mod zero? not ] filter ;
: max-palindrome ( seq -- palindrome )
natural-sort [ palindrome? ] find-last nip ;
: source-022 ( -- seq )
"extra/project-euler/022/names.txt" resource-path
- ascii file-contents [ quotable? ] subset "," split ;
+ ascii file-contents [ quotable? ] filter "," split ;
: name-scores ( seq -- seq )
[ 1+ swap alpha-value * ] map-index ;
46 [1,b] 47 20161 2 <range> append ;
: abundants-upto ( n -- seq )
- [1,b] [ abundant? ] subset ;
+ [1,b] [ abundant? ] filter ;
: possible-sums ( seq -- seq )
dup { } -rot [
<PRIVATE
: source-026 ( -- seq )
- 1 1000 (a,b) [ prime? ] subset [ 1 swap / ] map ;
+ 1 1000 (a,b) [ prime? ] filter [ 1 swap / ] map ;
: (mult-order) ( n a m -- k )
3dup ^ swap mod 1 = [ 2nip ] [ 1+ (mult-order) ] if ;
<PRIVATE
: source-027 ( -- seq )
- 1000 [ prime? ] subset [ dup [ neg ] map append ] keep
- cartesian-product [ first2 < ] subset ;
+ 1000 [ prime? ] filter [ dup [ neg ] map append ] keep
+ cartesian-product [ first2 < ] filter ;
: quadratic ( b a n -- m )
dup sq -rot * + + ;
PRIVATE>
: euler030 ( -- answer )
- 325537 [ dup sum-fifth-powers = ] subset sum 1- ;
+ 325537 [ dup sum-fifth-powers = ] filter sum 1- ;
! [ euler030 ] 100 ave-time
! 2537 ms run / 125 ms GC ave time - 100 trials
PRIVATE>
: euler032 ( -- answer )
- source-032 [ valid? ] subset products prune sum ;
+ source-032 [ valid? ] filter products prune sum ;
! [ euler032 ] 10 ave-time
! 23922 ms run / 1505 ms GC ave time - 10 trials
PRIVATE>
: euler032a ( -- answer )
- source-032a [ mmp ] map [ pandigital? ] subset products prune sum ;
+ source-032a [ mmp ] map [ pandigital? ] filter products prune sum ;
! [ euler032a ] 100 ave-time
! 5978 ms run / 327 ms GC ave time - 100 trials
<PRIVATE
: source-033 ( -- seq )
- 10 99 [a,b] dup cartesian-product [ first2 < ] subset ;
+ 10 99 [a,b] dup cartesian-product [ first2 < ] filter ;
: safe? ( ax xb -- ? )
[ 10 /mod ] bi@ -roll = rot zero? not and nip ;
2dup / [ ax/xb ] dip = ;
: curious-fractions ( seq -- seq )
- [ first2 curious? ] subset [ first2 / ] map ;
+ [ first2 curious? ] filter [ first2 / ] map ;
PRIVATE>
PRIVATE>
: euler034 ( -- answer )
- 3 2000000 [a,b] [ factorion? ] subset sum ;
+ 3 2000000 [a,b] [ factorion? ] filter sum ;
! [ euler034 ] 10 ave-time
! 15089 ms run / 725 ms GC ave time - 10 trials
PRIVATE>
: euler035 ( -- answer )
- source-035 [ possible? ] subset [ circular? ] count ;
+ source-035 [ possible? ] filter [ circular? ] count ;
! [ euler035 ] 100 ave-time
! 904 ms run / 86 ms GC ave time - 100 trials
PRIVATE>
: euler036 ( -- answer )
- 1 1000000 2 <range> [ both-bases? ] subset sum ;
+ 1 1000000 2 <range> [ both-bases? ] filter sum ;
! [ euler036 ] 100 ave-time
! 3891 ms run / 173 ms GC ave time - 100 trials
PRIVATE>
: euler037 ( -- answer )
- 23 1000000 primes-between [ r-trunc? ] subset [ l-trunc? ] subset sum ;
+ 23 1000000 primes-between [ r-trunc? ] filter [ l-trunc? ] filter sum ;
! [ euler037 ] 100 ave-time
! 768 ms run / 9 ms GC ave time - 100 trials
PRIVATE>
: euler038 ( -- answer )
- 9123 9876 [a,b] [ concat-product ] map [ pandigital? ] subset supremum ;
+ 9123 9876 [a,b] [ concat-product ] map [ pandigital? ] filter supremum ;
! [ euler038 ] 100 ave-time
! 37 ms run / 1 ms GC ave time - 100 trials
: source-042 ( -- seq )
"extra/project-euler/042/words.txt" resource-path
- ascii file-contents [ quotable? ] subset "," split ;
+ ascii file-contents [ quotable? ] filter "," split ;
: (triangle-upto) ( limit n -- )
2dup nth-triangle > [
: euler043 ( -- answer )
1234567890 number>digits all-permutations
- [ interesting? ] subset [ 10 digits>integer ] map sum ;
+ [ interesting? ] filter [ 10 digits>integer ] map sum ;
! [ euler043 ] time
! 125196 ms run / 19548 ms GC time
<PRIVATE
: candidates ( n -- seq )
- 1000 over <range> [ number>digits 3 0 pad-left ] map [ all-unique? ] subset ;
+ 1000 over <range> [ number>digits 3 0 pad-left ] map [ all-unique? ] filter ;
: overlap? ( seq -- ? )
dup first 2 tail* swap second 2 head = ;
: clean ( seq -- seq )
- [ unclip 1 head prefix concat ] map [ all-unique? ] subset ;
+ [ unclip 1 head prefix concat ] map [ all-unique? ] filter ;
: add-missing-digit ( seq -- seq )
dup natural-sort 10 diff first prefix ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
- candidates swap cartesian-product [ overlap? ] subset clean
+ candidates swap cartesian-product [ overlap? ] filter clean
] each [ add-missing-digit ] map ;
PRIVATE>
: euler044 ( -- answer )
2500 [1,b] [ nth-pentagonal ] map dup cartesian-product
- [ first2 sum-and-diff? ] subset [ first2 - abs ] map infimum ;
+ [ first2 sum-and-diff? ] filter [ first2 - abs ] map infimum ;
! [ euler044 ] 10 ave-time
! 8924 ms run / 2872 ms GC ave time - 10 trials
dup empty? [ "Topological sort failed" throw ] [ first ] if ;
: remove-source ( seq elt -- seq )
- [ swap member? not ] curry subset ;
+ [ swap member? not ] curry filter ;
: (topological-sort) ( seq -- )
dup length 1 > [
0 0 rot [ (partial-sum-infimum) ] each drop ; inline
: generate ( n quot -- seq )
- [ drop ] swap compose map ; inline
+ [ drop ] prepose map ; inline
: map-infimum ( seq quot -- min )
[ min ] compose 0 swap reduce ; inline
: parse-regexp ( accum end -- accum )
lexer get dup skip-blank
- [ [ index* dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
+ [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
lexer get dup still-parsing-line?
[ (parse-token) parse-options ] [ drop f ] if
<regexp> parsed ;
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;\r
\r
: results\r
- [ [ second ] swap compose compare ] curry sort 20 tail*\r
+ [ [ second ] prepose compare ] curry sort 20 tail*\r
print\r
standard-table-style\r
[\r
] tabular-output ; inline\r
\r
: optimizer-measurements ( -- alist )\r
- all-words [ compiled? ] subset\r
+ all-words [ compiled? ] filter\r
[\r
dup [\r
word-dataflow nip 1 count-optimization-passes\r
{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } { "newobj" "the mapped object" } }
{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } ;
-HELP: deep-subset
+HELP: deep-filter
{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "seq" "a sequence" } }
{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } ;
[ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test
-[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find* ] unit-test
+[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find-from ] unit-test
-[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find* ] unit-test
+[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find-from ] unit-test
-[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find* ] unit-test
+[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find-from ] unit-test
: change-something ( seq -- newseq )
dup array? [ "hi" suffix ] [ "hello" append ] if ;
[ call ] keep over branch?
[ [ deep-map ] curry map ] [ drop ] if ; inline
-: deep-subset ( obj quot -- seq )
+: deep-filter ( obj quot -- seq )
over >r
pusher >r deep-each r>
r> dup branch? [ like ] [ drop ] if ; inline
-: deep-find* ( obj quot -- elt ? )
+: deep-find-from ( obj quot -- elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
- f -rot [ >r nip r> deep-find* ] curry find drop >boolean
+ f -rot [ >r nip r> deep-find-from ] curry find drop >boolean
] [ 2drop f f ] if
] if ; inline
-: deep-find ( obj quot -- elt ) deep-find* drop ; inline
+: deep-find ( obj quot -- elt ) deep-find-from drop ; inline
-: deep-contains? ( obj quot -- ? ) deep-find* nip ; inline
+: deep-contains? ( obj quot -- ? ) deep-find-from nip ; inline
: deep-all? ( obj quot -- ? )
[ not ] compose deep-contains? not ; inline
] curry change-each ] [ 2drop ] if ; inline
: flatten ( obj -- seq )
- [ branch? not ] deep-subset ;
+ [ branch? not ] deep-filter ;
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
arrays math.parser math.private sorting strings ascii macros
-assocs.lib quotations hashtables ;
+assocs.lib quotations hashtables math.order ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
>r
dup length
dup [ / ] curry
- [ 1+ ] swap compose
+ [ 1+ ] prepose
r> compose
2each ; inline
: take-while ( seq quot -- newseq )
[ not ] compose
[ find drop [ head-slice ] when* ] curry
- [ dup ] swap compose keep like ;
+ [ dup ] prepose keep like ;
: replicate ( seq quot -- newseq )
#! quot: ( -- obj )
- [ drop ] swap compose map ; inline
+ [ drop ] prepose map ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: switches ( seq1 seq -- subseq )
! seq1 is a sequence of ones and zeroes
- >r [ length ] keep [ nth 1 = ] curry subset r>
+ >r [ length ] keep [ nth 1 = ] curry filter r>
[ nth ] curry { } map-as ;
: power-set ( seq -- subsets )
>r dup length swap r>
[ = [ ] [ drop f ] if ] curry
2map
- [ ] subset ;
+ [ ] filter ;
<PRIVATE
: (attempt-each-integer) ( i n quot -- result )
USING: shufflers tools.test ;
+IN: shufflers.tests
SHUFFLE: abcd 4
[ ] [ 1 2 3 4 abcd- ] unit-test
prepare
dup headers>> >alist sort-keys [
drop { "Date" "Message-Id" } member? not
- ] assoc-subset
+ ] assoc-filter
over to>>
rot from>>
] unit-test
] if ;
: remove-full-rows ( board -- )
- dup board-rows [ row-not-full? ] subset swap set-board-rows ;
+ dup board-rows [ row-not-full? ] filter swap set-board-rows ;
: check-rows ( board -- n )
#! remove full rows, then add blank ones at the top, returning the number
"--- Entering: " write swap .
"--- Variable values:" print
[ dup get ] H{ } map>assoc describe
- ] 2curry swap compose ;
+ ] 2curry prepose ;
: watch-vars ( word vars -- )
dupd [ (watch-vars) ] 2curry annotate ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: tools.completion
USING: kernel arrays sequences math namespaces strings io
vectors words assocs combinators sorting unicode.case
-unicode.categories ;
+unicode.categories math.order ;
+IN: tools.completion
: (fuzzy) ( accum ch i full -- accum i ? )
- index*
+ index-from
[
[ swap push ] 2keep 1+ t
] [
: rank-completions ( results -- newresults )
sort-keys <reversed>
[ 0 [ first max ] reduce 3 /f ] keep
- [ first < ] with subset
+ [ first < ] with filter
[ second ] map ;
: complete ( full short -- score )
[
[
word-props swap
- '[ , nip member? ] assoc-subset
+ '[ , nip member? ] assoc-filter
f assoc-like
] keep set-word-props
] with each ;
strip-globals? [
"Stripping globals" show
global swap
- '[ drop , member? not ] assoc-subset
- [ drop string? not ] assoc-subset ! strip CLI args
+ '[ drop , member? not ] assoc-filter
+ [ drop string? not ] assoc-filter ! strip CLI args
dup keys unparse show
21 setenv
] [ drop ] if ;
"You can query memory status:"
{ $subsection data-room }
{ $subsection code-room }
-"There are a pair of combinators, analogous to " { $link each } " and " { $link subset } ", which operate on the entire collection of objects in the object heap:"
+"There are a pair of combinators, analogous to " { $link each } " and " { $link filter } ", which operate on the entire collection of objects in the object heap:"
{ $subsection each-object }
{ $subsection instances }
"You can check an object's the heap memory usage:"
] with-row ;
: counters. ( assoc -- )
- [ second 0 > ] subset sort-values
+ [ second 0 > ] filter sort-values
standard-table-style [
[ counter. ] assoc-each
] tabular-output ;
"Call counts for words which call " write
dup pprint
":" print
- usage [ word? ] subset counters counters. ;
+ usage [ word? ] filter counters counters. ;
: vocabs-profile. ( -- )
"Call counts for all vocabularies:" print
vocabs [
dup words
- [ "predicating" word-prop not ] subset
+ [ "predicating" word-prop not ] filter
[ profile-counter ] map sum
] { } map>assoc counters. ;
: run-tests ( prefix -- failures )
child-vocabs dup empty? [ drop f ] [
[ dup run-test ] { } map>assoc
- [ second empty? not ] subset
+ [ second empty? not ] filter
] if ;
: test ( prefix -- )
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-IN: tools.threads\r
USING: threads kernel prettyprint prettyprint.config\r
io io.styles sequences assocs namespaces sorting boxes\r
-heaps.private system math math.parser ;\r
+heaps.private system math math.parser math.order ;\r
+IN: tools.threads\r
\r
: thread. ( thread -- )\r
dup thread-id pprint-cell\r
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words r> map
- [ [ word? ] subset [ word-vocabulary ] map ] map>set
- remove [ ] subset [ vocab ] map ; inline
+ [ [ word? ] filter [ word-vocabulary ] map ] map>set
+ remove [ ] filter [ vocab ] map ; inline
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
: keyed-vocabs ( str quot -- seq )
all-vocabs [
swap >r
- [ >r 2dup r> swap call member? ] subset
+ [ >r 2dup r> swap call member? ] filter
r> swap
] assoc-map 2nip ; inline
dup vocab-dir "tests" append-path vocab-append-path dup [\r
dup exists? [\r
dup directory keys\r
- [ ".factor" tail? ] subset\r
+ [ ".factor" tail? ] filter\r
[ append-path ] with map\r
] [ drop f ] if\r
] [ drop f ] if ;\r
changed-vocabs get dup [ key? ] [ 2drop t ] if ;\r
\r
: filter-changed ( vocabs -- vocabs' )\r
- [ changed-vocab? ] subset ;\r
+ [ changed-vocab? ] filter ;\r
\r
SYMBOL: modified-sources\r
SYMBOL: modified-docs\r
dup vocab-authors-path set-vocab-file-contents ;\r
\r
: subdirs ( dir -- dirs )\r
- directory [ second ] subset keys natural-sort ;\r
+ directory [ second ] filter keys natural-sort ;\r
\r
: (all-child-vocabs) ( root name -- vocabs )\r
[ vocab-dir append-path subdirs ] keep\r
} cond nip ;\r
\r
: filter-dangerous ( seq -- seq' )\r
- [ vocab-name dangerous? not ] subset ;\r
+ [ vocab-name dangerous? not ] filter ;\r
\r
: try-everything ( -- failures )\r
all-vocabs-seq\r
: unrooted-child-vocabs ( prefix -- seq )\r
dup empty? [ CHAR: . suffix ] unless\r
vocabs\r
- [ find-vocab-root not ] subset\r
+ [ find-vocab-root not ] filter\r
[\r
vocab-name swap ?head CHAR: . rot member? not and\r
- ] with subset\r
+ ] with filter\r
[ vocab ] map ;\r
\r
: all-child-vocabs ( prefix -- assoc )\r
: all-child-vocabs-seq ( prefix -- assoc )\r
vocab-roots get swap [\r
dupd (all-child-vocabs)\r
- [ vocab-dir? ] with subset\r
+ [ vocab-dir? ] with filter\r
] curry map concat ;\r
\r
: map>set ( seq quot -- )\r
: command-gestures ( class -- hash )
commands values [
[
- [ first ] subset
+ [ first ] filter
[ [ invoke-command ] curry swap set ] assoc-each
] each
] H{ } make-assoc ;
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
kernel math models namespaces opengl opengl.gl sequences strings
-io.styles math.vectors sorting colors combinators assocs ;
+io.styles math.vectors sorting colors combinators assocs
+math.order ;
IN: ui.gadgets.editors
TUPLE: editor
! See http://factorcode.org/license.txt for BSD license.
USING: ui.commands ui.gestures ui.render ui.gadgets
ui.gadgets.labels ui.gadgets.scrollers
-kernel sequences models opengl math namespaces
+kernel sequences models opengl math math.order namespaces
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
math.vectors classes.tuple ;
IN: ui.gadgets.lists
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences ui.gadgets kernel math math.functions
-math.vectors namespaces ;
+math.vectors namespaces math.order ;
IN: ui.gadgets.packs
TUPLE: pack align fill gap ;
! Copyright (C) 2005, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math
-namespaces sequences ;
+namespaces sequences math.order ;
IN: ui.gadgets.paragraphs
! A word break gadget
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gestures ui.gadgets ui.gadgets.buttons
-ui.gadgets.frames ui.gadgets.grids
+ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences
vectors models math.vectors math.functions quotations colors ;
IN: ui.gadgets.sliders
: normalized-sizes ( track -- seq )
track-sizes
- [ [ ] subset sum ] keep [ dup [ over / ] when ] map nip ;
+ [ [ ] filter sum ] keep [ dup [ over / ] when ] map nip ;
: <track> ( orientation -- track )
<pack> V{ } clone
] if ;
: modifier ( mod modifiers -- seq )
- [ second swap bitand 0 > ] with subset
+ [ second swap bitand 0 > ] with filter
0 <column> prune dup empty? [ drop f ] [ >array ] if ;
: drag-loc ( -- loc )
SYMBOL: operations
: object-operations ( obj -- operations )
- operations get [ operation-predicate call ] with subset ;
+ operations get [ operation-predicate call ] with filter ;
: find-operation ( obj quot -- command )
>r object-operations r> find-last nip ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays hashtables io kernel math namespaces opengl
opengl.gl opengl.glu sequences strings io.styles vectors
-combinators math.vectors ui.gadgets colors ;
+combinators math.vectors ui.gadgets colors math.order ;
IN: ui.render
SYMBOL: clip
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions boxes calendar concurrency.flags ui.tools.workspace
-accessors ;
+accessors math.order ;
IN: ui.tools.interactor
TUPLE: interactor history output flag thread help ;
[ ] [ "w" get com-scroll-down ] unit-test
[ t ] [
"w" get workspace-book gadget-children
- [ tool-scroller ] map [ ] subset [ scroller? ] all?
+ [ tool-scroller ] map [ ] filter [ scroller? ] all?
] unit-test
[ ] [ "w" get hide-popup ] unit-test
[ ] [ <gadget> "w" get show-popup ] unit-test
[ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
- windows global [ [ first = not ] with subset ] change-at ;
+ windows global [ [ first = not ] with filter ] change-at ;
: raised-window ( world -- )
windows get-global [ second eq? ] with find drop
: process-other-extend ( lines -- set )
[ "#" split1 drop ";" split1 drop trim-blank ] map
- [ empty? not ] subset
+ [ empty? not ] filter
[ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
concat [ dup ] H{ } map>assoc ;
USING: assocs math kernel sequences io.files hashtables
-quotations splitting arrays math.parser hash2
-byte-arrays words namespaces words compiler.units parser io.encodings.ascii ;
+quotations splitting arrays math.parser hash2 math.order
+byte-arrays words namespaces words compiler.units parser
+io.encodings.ascii ;
IN: unicode.data
<<
: (process-data) ( index data -- newdata )
[ [ nth ] keep first swap 2array ] with map
- [ second empty? not ] subset
+ [ second empty? not ] filter
[ >r hex> r> ] assoc-map ;
: process-data ( index data -- hash )
[ " " split [ hex> ] map ] assoc-map ;
: process-canonical ( data -- hash2 hash )
- (process-decomposed) [ first* ] subset
+ (process-decomposed) [ first* ] filter
[
- [ second length 2 = ] subset
+ [ second length 2 = ] filter
! using 1009 as the size, the maximum load is 4
[ first2 first2 rot 3array ] map 1009 alist>hash2
] keep
: process-combining ( data -- hash )
3 swap (process-data)
[ string>number ] assoc-map
- [ nip zero? not ] assoc-subset
+ [ nip zero? not ] assoc-filter
>hashtable ;
: categories ( -- names )
] assoc-map >hashtable ;
: multihex ( hexstring -- string )
- " " split [ hex> ] map [ ] subset ;
+ " " split [ hex> ] map [ ] filter ;
TUPLE: code-point lower title upper ;
! Special casing data
: load-special-casing ( -- special-casing )
"extra/unicode/SpecialCasing.txt" resource-path data
- [ length 5 = ] subset
+ [ length 5 = ] filter
[ [ set-code-point ] each ] H{ } make-assoc ;
load-data
[ >r >r 2dup r> r> insert ] 2each 2drop ; inline
: reorder-slice ( string start -- slice done? )
- 2dup swap [ non-starter? not ] find* drop
+ 2dup swap [ non-starter? not ] find-from drop
[ [ over length ] unless* rot <slice> ] keep not ;
: reorder-next ( string i -- new-i done? )
- over [ non-starter? ] find* drop [
+ over [ non-starter? ] find-from drop [
reorder-slice
>r dup [ combining-class ] insertion-sort slice-to r>
] [ length t ] if* ;
0 reorder-loop ;
: reorder-back ( string i -- )
- over [ non-starter? not ] find-last* drop ?1+ reorder-next 2drop ;
+ over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ;
: decompose ( string quot -- decomposed )
! When there are 8 and 32-bit strings, this'll be
-USING: unicode.data kernel math sequences parser bit-arrays namespaces
-sequences.private arrays quotations classes.predicate assocs ;
+USING: unicode.data kernel math sequences parser bit-arrays
+namespaces sequences.private arrays quotations assocs
+classes.predicate math.order ;
IN: unicode.syntax
! Character classes (categories)
: [category] ( categories -- quot )
[
- [ [ categories member? not ] subset as-string ] keep
- [ categories member? ] subset >category-array
+ [ [ categories member? not ] filter as-string ] keep
+ [ categories member? ] filter >category-array
[ dup category# ] % , [ nth-unsafe [ drop t ] ] %
\ member? 2array >quotation ,
\ if ,
CREATE ";" parse-tokens define-category ; parsing
: seq-minus ( seq1 seq2 -- diff )
- [ member? not ] curry subset ;
+ [ member? not ] curry filter ;
: CATEGORY-NOT:
CREATE ";" parse-tokens
\r
: parse-com-functions ( -- functions )\r
";" parse-tokens { ")" } split\r
- [ empty? not ] subset\r
+ [ empty? not ] filter\r
[ (parse-com-function) ] map ;\r
\r
: (iid-word) ( definition -- word )\r
SYMBOL: windows-messages
"windows.messages" words
-[ word-name "windows-message" head? not ] subset
+[ word-name "windows-message" head? not ] filter
[ dup execute swap ] { } map>assoc
windows-messages set-global
SYMBOL: width
: line-chunks ( string -- words-lines )
- "\n" split [ " \t" split [ empty? not ] subset ] map ;
+ "\n" split [ " \t" split [ empty? not ] filter ] map ;
: (split-chunk) ( words -- )
-1 over [ length + 1+ dup width get > ] find drop nip
: circulate-focus ( -- )
dpy get $default-root <- children
-[ find-in-table ] map [ <- mapped? ] subset dup length 1 >
+[ find-in-table ] map [ <- mapped? ] filter dup length 1 >
[ reverse dup first <- lower drop
second <- raise
dup <wm-frame> is? [ $child ] [ ] if
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: managed? ( id -- ? )
-dpy get $window-table values [ <wm-child> is? ] subset [ $id ] map member? ;
+dpy get $window-table values [ <wm-child> is? ] filter [ $id ] map member? ;
: event>keyname ( event -- keyname ) lookup-keysym keysym>name ;
: unmapped-frames ( -- seq )
dpy get $window-table values
-[ <wm-frame> is? ] subset [ <- mapped? not ] subset ;
+[ <wm-frame> is? ] filter [ <- mapped? not ] filter ;
<unmapped-frames-menu> {
: add-workspace ( -- ) { } clone <workspace> workspaces> push ;
: mapped-windows ( -- seq )
-dpy get $default-root <- children [ <- mapped? ] subset ;
+dpy get $default-root <- children [ <- mapped? ] filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
] unit-test
[ "abcd" ] [
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
- [ string? ] deep-subset concat
+ [ string? ] deep-filter concat
] unit-test
[ "foo" ] [
"<a><b id='c'>foo</b><d id='e'/></a>" string>xml
concat ;
: children-tags ( tag -- sequence )
- tag-children [ tag? ] subset ;
+ tag-children [ tag? ] filter ;
: first-child-tag ( tag -- tag )
tag-children [ tag? ] find nip ;
assure-name [ swap tag-named? ] curry deep-find ;
: deep-tags-named ( tag name/string -- tags-seq )
- tags@ [ swap tag-named? ] curry deep-subset ;
+ tags@ [ swap tag-named? ] curry deep-filter ;
: tag-named ( tag name/string -- matching-tag )
! like get-name-tag but only looks at direct children,
assure-name swap [ tag-named? ] with find nip ;
: tags-named ( tag name/string -- tags-seq )
- tags@ swap [ tag-named? ] with subset ;
+ tags@ swap [ tag-named? ] with filter ;
: tag-with-attr? ( elem attr-value attr-name -- ? )
rot dup tag? [ at = ] [ 3drop f ] if ;
assure-name [ tag-with-attr? ] 2curry find nip ;
: tags-with-attr ( tag attr-value attr-name -- tags-seq )
- tags@ [ tag-with-attr? ] 2curry subset tag-children ;
+ tags@ [ tag-with-attr? ] 2curry filter tag-children ;
: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
assure-name [ tag-with-attr? ] 2curry deep-find ;
: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
- tags@ [ tag-with-attr? ] 2curry deep-subset ;
+ tags@ [ tag-with-attr? ] 2curry deep-filter ;
: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
"id" deep-tag-with-attr ;
: ?filter-children ( children -- no-whitespace )\r
xml-pprint? get [\r
[ dup string? [ trim-whitespace ] when ] map\r
- [ dup empty? swap string? and not ] subset\r
+ [ dup empty? swap string? and not ] filter\r
] when ;\r
\r
: print-name ( name -- )\r
reset-prolog init-xml-stack init-ns-stack ;
: assert-blanks ( seq pre? -- )
- swap [ string? ] subset
+ swap [ string? ] filter
[
dup [ blank? ] all?
[ drop ] [ swap <pre/post-content> throw ] if
M: keyword-map >alist delegate >alist ;
: (keyword-map-no-word-sep)
- keys concat [ alpha? not ] subset prune natural-sort ;
+ keys concat [ alpha? not ] filter prune natural-sort ;
: keyword-map-no-word-sep* ( keyword-map -- str )
dup keyword-map-no-word-sep [ ] [
{ { "type" >upper set-company-type } }
init-from-tag dup
] keep
- tag-children [ tag? ] subset
+ tag-children [ tag? ] filter
[ parse-employee-tag ] with each ;
[
: implies >r not r> or ; inline
-: child-tags ( tag -- seq ) tag-children [ tag? ] subset ;
+: child-tags ( tag -- seq ) tag-children [ tag? ] filter ;
: map-find ( seq quot -- result elt )
f -rot
: tag-init-form ( spec -- quot )
{
- { [ dup quotation? ] [ [ object get tag get ] swap compose ] }
+ { [ dup quotation? ] [ [ object get tag get ] prepose ] }
{ [ dup length 2 = ] [
first2 [
>r >r tag get children>string
} cond ;
: with-tag-initializer ( tag obj quot -- )
- [ object set tag set ] swap compose with-scope ; inline
+ [ object set tag set ] prepose with-scope ; inline
MACRO: (init-from-tag) ( specs -- )
[ tag-init-form ] map concat [ ] like
projects / factor.git / commitdiff