] with each ; inline
: encode-pad ( seq n -- )
- [ 3 0 pad-right binary [ encode3 ] with-byte-writer ]
- [ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline
+ [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
+ [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
ERROR: malformed-base64 ;
bootstrap-cell <groups> native> emit-seq ;
: pad-bytes ( seq -- newseq )
- dup length bootstrap-cell align 0 pad-right ;
+ dup length bootstrap-cell align 0 pad-tail ;
: extended-part ( str -- str' )
dup [ 128 < ] all? [ drop f ] [
combinators accessors calendar calendar.format.macros present ;\r
IN: calendar.format\r
\r
-: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;\r
+: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;\r
\r
-: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;\r
+: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;\r
\r
-: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;\r
+: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;\r
\r
: write-00 ( n -- ) pad-00 write ;\r
\r
[ zip concat ] keep like ;
: sha1-interleave ( string -- seq )
- [ zero? ] trim-left
+ [ zero? ] trim-head
dup length odd? [ rest ] when
seq>2seq [ sha1 checksum-bytes ] bi@
2seq>seq ;
[ + + w+ ] 2dip swap set-nth ; inline
: prepare-message-schedule ( seq -- w-seq )
- word-size get group [ be> ] map block-size get 0 pad-right
+ word-size get group [ be> ] map block-size get 0 pad-tail
dup 16 64 dup <slice> [
process-M-256
] with each ;
##box-float
##box-alien
} memq?
- ] contains? ;
+ ] any? ;
: linearize-basic-block ( bb -- )
[ number>> _label ]
: check-dlsym ( symbols dll -- )
dup dll-valid? [
- dupd '[ _ dlsym ] contains?
+ dupd '[ _ dlsym ] any?
[ drop ] [ no-such-symbol ] if
] [
dll-path no-such-library drop
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
-: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ;
+: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ;
[ t ] [
- [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
+ [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
] unit-test
[ t f ] [
[ { "hi" } bleh ] ignore-errors
- \ + stack-trace-contains?
- \ > stack-trace-contains?
+ \ + stack-trace-any?
+ \ > stack-trace-any?
] unit-test
: inline-recursive ( -- ) inline-recursive ; inline recursive
-[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test
+[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? nip ] unit-test
branch-out get [ ] find nip swap head* >vector datastack set ;
M: #phi check-stack-flow*
- branch-out get [ ] contains? [
+ branch-out get [ ] any? [
[ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
] [ drop terminated? on ] if ;
[ t ] [
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
- [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
+ [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
] unit-test
[ ] [
dup dup '[
_ keep swap [ drop t ] [
dup #branch? [
- children>> [ _ contains-node? ] contains?
+ children>> [ _ contains-node? ] any?
] [
dup #recursive? [
child>> _ contains-node?
] [ drop f ] if
] if
] if
- ] contains? ; inline recursive
+ ] any? ; inline recursive
: select-children ( seq flags -- seq' )
[ [ drop f ] unless ] 2map ;
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
: some-outputs-dead? ( #call -- ? )
- out-d>> [ live-value? not ] contains? ;
+ out-d>> [ live-value? not ] any? ;
: maybe-drop-dead-outputs ( node -- nodes )
dup some-outputs-dead? [
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
[
[ nip ] [
- dup [ +bottom+ eq? ] trim-left
+ dup [ +bottom+ eq? ] trim-head
[ [ length ] bi@ - tail* ] keep append
] if
] 3map ;
[ class-types length 1 = ]
[ union-class? not ]
bi and
- ] contains? ;
+ ] any? ;
: node-count-bias ( -- n )
45 node-count get [-] 8 /i ;
! These nodes never participate in unboxing
: assert-not-unboxed ( values -- )
dup array?
- [ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if
+ [ [ unboxed-allocation ] any? ] [ unboxed-allocation ] if
[ "Unboxing wrong value" throw ] when ;
M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
\r
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )\r
mailbox check-disposed\r
- mailbox data>> pred dlist-contains? [\r
+ mailbox data>> pred dlist-any? [\r
mailbox timeout wait-for-mailbox\r
mailbox timeout pred block-unless-pred\r
] unless ; inline recursive\r
delimiter swap with-variable ; inline
: needs-escaping? ( cell -- ? )
- [ [ "\n\"" member? ] [ delimiter get = ] bi or ] contains? ; inline ! "
+ [ [ "\n\"" member? ] [ delimiter get = ] bi or ] any? ; inline
: escape-quotes ( cell -- cell' )
[ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
] if ;
: maybe-make-retryable ( statement -- statement )
- dup in-params>> [ generator-bind? ] contains?
+ dup in-params>> [ generator-bind? ] any?
[ make-retryable ] when ;
: regenerate-params ( statement -- statement )
] with-string-writer ;
: can-be-null? ( -- ? )
- "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
+ "sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
: delete-cascade? ( -- ? )
"sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
primary-key>> +primary-key+? ;
: db-assigned-id-spec? ( specs -- ? )
- [ primary-key>> +db-assigned-id+? ] contains? ;
+ [ primary-key>> +db-assigned-id+? ] any? ;
: user-assigned-id-spec? ( specs -- ? )
- [ primary-key>> +user-assigned-id+? ] contains? ;
+ [ primary-key>> +user-assigned-id+? ] any? ;
: normalize-spec ( spec -- )
dup type>> dup +primary-key+? [
dup normalize-spec ;
: spec>tuple ( class spec -- tuple )
- 3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
+ 3 f pad-tail [ first3 ] keep 3 tail <sql-spec> ;
: number>string* ( n/string -- string )
dup number? [ number>string ] when ;
"Iterating over elements:"
{ $subsection dlist-each }
{ $subsection dlist-find }
-{ $subsection dlist-contains? }
+{ $subsection dlist-any? }
"Deleting a node matching a predicate:"
{ $subsection delete-node-if* }
{ $subsection delete-node-if }
"This operation is O(n)."
} ;
-HELP: dlist-contains?
+HELP: dlist-any?
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ;
[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
[ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
-[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
+[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-any? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-any? ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test
: dlist-find ( dlist quot -- obj/f ? )
'[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
-: dlist-contains? ( dlist quot -- ? )
+: dlist-any? ( dlist quot -- ? )
dlist-find nip ; inline
M: dlist deque-member? ( value dlist -- ? )
- [ = ] with dlist-contains? ;
+ [ = ] with dlist-any? ;
M: dlist delete-node ( dlist-node dlist -- )
{
TUPLE: line-break ;
: absolute-url? ( string -- ? )
- { "http://" "https://" "ftp://" } [ head? ] with contains? ;
+ { "http://" "https://" "ftp://" } [ head? ] with any? ;
: simple-link-title ( string -- string' )
dup absolute-url? [ "/" split1-last swap or ] unless ;
: check-url ( href -- href' )
{
{ [ dup empty? ] [ drop invalid-url ] }
- { [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
+ { [ dup [ 127 > ] any? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
[ relative-link-prefix get prepend "" like ]
"string. For example:\n"
{ $list
"\"%.3s\" formats a string to truncate at 3 characters (from the left)."
- "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
+ "\"%.10f\" formats a float to pad-tail with zeros up to 10 digits beyond the decimal point."
"\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
}
}
[ 0 ] [ string>number ] if-empty ;
: pad-digits ( string digits -- string' )
- [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
+ [ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
: max-digits ( n digits -- n' )
10 swap ^ [ * round ] keep / ; inline
[ max-digits ] keep -rot
[
[ 0 < "-" "+" ? ]
- [ abs number>string 2 CHAR: 0 pad-left ] bi
+ [ abs number>string 2 CHAR: 0 pad-head ] bi
"e" -rot 3append
]
[ number>string ] bi*
char = "'" (.) => [[ second ]]
pad-char = (zero|char)? => [[ CHAR: \s or ]]
-pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]]
+pad-align = ("-")? => [[ \ pad-tail \ pad-head ? ]]
pad-width = ([0-9])* => [[ >digits ]]
pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
<PRIVATE
-: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-left ; inline
+: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
-: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-left ; inline
+: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-head ; inline
: >time ( timestamp -- string )
[ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
: parse-list-11 ( lines -- seq )
[
- 11 f pad-right
+ 11 f pad-tail
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
} validate-params
{ "password" "new-password" "verify-password" }
- [ value empty? not ] contains? [
+ [ value empty? not ] any? [
"password" value username check-login
[ "incorrect password" validation-error ] unless
SYMBOL: permit-id\r
\r
: permit-id-key ( realm -- string )\r
- [ >hex 2 CHAR: 0 pad-left ] { } map-as concat\r
+ [ >hex 2 CHAR: 0 pad-head ] { } map-as concat\r
"__p_" prepend ;\r
\r
: client-permit-id ( realm -- id/f )\r
: base-path ( string -- pair )
dup responder-nesting get
- [ second class superclasses [ name>> = ] with contains? ] with find nip
+ [ second class superclasses [ name>> = ] with any? ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
$predicate
$class-description
$error-description
- } swap '[ _ elements empty? not ] contains? ;
+ } swap '[ _ elements empty? not ] any? ;
: don't-check-word? ( word -- ? )
{
[ "Missing whitespace between strings" throw ] unless ;
: check-bogus-nl ( element -- )
- { { $nl } { { $nl } } } [ head? ] with contains?
+ { { $nl } { { $nl } } } [ head? ] with any?
[ "Simple element should not begin with a paragraph break" throw ] when ;
: check-elements ( element -- )
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
- [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
+ [ 255 * >fixnum >hex 2 CHAR: 0 pad-head % ] tri@ ;
: fg-css, ( color -- )
"color: #" % hex-color, "; " % ;
] [ too-many-redirects ] if ; inline recursive
: read-chunk-size ( -- n )
- read-crlf ";" split1 drop [ blank? ] trim-right
+ read-crlf ";" split1 drop [ blank? ] trim-tail
hex> [ "Bad chunk size" throw ] unless* ;
: read-chunked ( quot: ( chunk -- ) -- )
[ file-responder get hook>> call ] [ 2drop <304> ] if ;\r
\r
: serving-path ( filename -- filename )\r
- file-responder get root>> trim-right-separators\r
+ file-responder get root>> trim-tail-separators\r
"/"\r
- rot "" or trim-left-separators 3append ;\r
+ rot "" or trim-head-separators 3append ;\r
\r
: serve-file ( filename -- response )\r
dup mime-type\r
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
- normalize-path trim-right-separators {
+ normalize-path trim-tail-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
{
{ [ os unix? ] [ "io.directories.unix" require ] }
{ [ os windows? ] [ "io.directories.windows" require ] }
-} cond
\ No newline at end of file
+} cond
[ t ] [ "\\\\" root-directory? ] unit-test
[ t ] [ "/" root-directory? ] unit-test
[ t ] [ "//" root-directory? ] unit-test
-[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test
-[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test
+[ t ] [ "c:\\" trim-tail-separators root-directory? ] unit-test
+[ t ] [ "Z:\\" trim-tail-separators root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
{
{ [ dup empty? ] [ drop f ] }
{ [ dup [ path-separator? ] all? ] [ drop t ] }
- { [ dup trim-right-separators { [ length 2 = ]
+ { [ dup trim-tail-separators { [ length 2 = ]
[ second CHAR: : = ] } 1&& ] [ drop t ] }
{ [ dup unicode-prefix head? ]
- [ trim-right-separators length unicode-prefix length 2 + = ] }
+ [ trim-tail-separators length unicode-prefix length 2 + = ] }
[ drop f ]
} cond ;
"m" get next-change path>>
dup print flush
dup parent-directory
- [ trim-right-separators "xyz" tail? ] either? not
+ [ trim-tail-separators "xyz" tail? ] either? not
] loop
"c1" get count-down
"m" get next-change path>>
dup print flush
dup parent-directory
- [ trim-right-separators "yxy" tail? ] either? not
+ [ trim-tail-separators "yxy" tail? ] either? not
] loop
"c2" get count-down
: format-column ( seq ? -- seq )
[
[ 0 [ length max ] reduce ] keep
- swap [ CHAR: \s pad-right ] curry map
+ swap [ CHAR: \s pad-tail ] curry map
] unless ;
: map-last ( seq quot -- seq )
! We special-case all the :> at the start of a quotation
: load-locals-quot ( args -- quot )
[ [ ] ] [
- dup [ local-reader? ] contains? [
+ dup [ local-reader? ] any? [
dup [ local-reader? [ 1array ] [ ] ? ] map
spread>quot
] [ [ ] ] if swap length [ load-locals ] curry append
M: special rewrite-literal? drop t ;
-M: array rewrite-literal? [ rewrite-literal? ] contains? ;
+M: array rewrite-literal? [ rewrite-literal? ] any? ;
-M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
+M: quotation rewrite-literal? [ rewrite-literal? ] any? ;
M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
reverse 1 cut [ (>permutation) ] each ;
: permutation-indices ( n seq -- permutation )
- length [ factoradic ] dip 0 pad-left >permutation ;
+ length [ factoradic ] dip 0 pad-head >permutation ;
PRIVATE>
[ from>> ] [ to>> ] bi ;
: points>interval ( seq -- interval )
- dup [ first fp-nan? ] contains?
+ dup [ first fp-nan? ] any?
[ drop [-inf,inf] ] [
dup first
[ [ endpoint-min ] reduce ]
<PRIVATE
-: 2pad-left ( p q n -- p q ) [ 0 pad-left ] curry bi@ ;
-: 2pad-right ( p q n -- p q ) [ 0 pad-right ] curry bi@ ;
-: pextend ( p q -- p q ) 2dup [ length ] bi@ max 2pad-right ;
-: pextend-left ( p q -- p q ) 2dup [ length ] bi@ max 2pad-left ;
+: 2pad-head ( p q n -- p q ) [ 0 pad-head ] curry bi@ ;
+: 2pad-tail ( p q n -- p q ) [ 0 pad-tail ] curry bi@ ;
+: pextend ( p q -- p q ) 2dup [ length ] bi@ max 2pad-tail ;
+: pextend-left ( p q -- p q ) 2dup [ length ] bi@ max 2pad-head ;
: unempty ( seq -- seq ) [ { 0 } ] when-empty ;
: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
: p= ( p q -- ? ) pextend = ;
: ptrim ( p -- p )
- dup length 1 = [ [ zero? ] trim-right ] unless ;
+ dup length 1 = [ [ zero? ] trim-tail ] unless ;
: 2ptrim ( p q -- p q ) [ ptrim ] bi@ ;
: p+ ( p q -- r ) pextend v+ ;
: n*p ( n p -- n*p ) n*v ;
: pextend-conv ( p q -- p q )
- 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
+ 2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ;
: p* ( p q -- r )
2unempty pextend-conv <reversed> dup length
2ptrim
2dup [ length ] bi@ -
dup 1 < [ drop 1 ] when
- [ over length + 0 pad-left pextend ] keep 1+ ;
+ [ over length + 0 pad-head pextend ] keep 1+ ;
: /-last ( seq seq -- a )
#! divide the last two numbers in the sequences
M: sp-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[
- input-slice [ blank? ] trim-left-slice input-from pos set @
+ input-slice [ blank? ] trim-head-slice input-from pos set @
] ;
TUPLE: delay-parser quot ;
: char>quoted ( ch -- str )
dup printable? [ 1string ] [
assure-small >hex >upper
- 2 CHAR: 0 pad-left
+ 2 CHAR: 0 pad-head
CHAR: = prefix
] if ;
{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." }
{ $see-also find } ;
-HELP: deep-contains?
+HELP: deep-any?
{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests whether the given object or any subnode satisfies the given quotation." }
-{ $see-also contains? } ;
+{ $see-also any? } ;
HELP: flatten
{ $values { "obj" object } { "seq" "a sequence" } }
{ $subsection deep-map }
{ $subsection deep-filter }
{ $subsection deep-find }
-{ $subsection deep-contains? }
+{ $subsection deep-any? }
{ $subsection deep-change-each }
"A utility word to collapse nested subsequences:"
{ $subsection flatten } ;
[ { { "heyhello" "hihello" } } ]
[ "hey" 1array 1array [ [ change-something ] deep-change-each ] keep ] unit-test
-[ t ] [ "foo" [ string? ] deep-contains? ] unit-test
+[ t ] [ "foo" [ string? ] deep-any? ] unit-test
[ "foo" ] [ "foo" [ string? ] deep-find ] unit-test
: deep-find ( obj quot -- elt ) (deep-find) drop ; inline
-: deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline
+: deep-any? ( obj quot -- ? ) (deep-find) nip ; inline
: deep-all? ( obj quot -- ? )
- '[ @ not ] deep-contains? not ; inline
+ '[ @ not ] deep-any? not ; inline
: deep-member? ( obj seq -- ? )
swap '[
[ 2 <clumps> [ = not ] assoc-filter values ] [ first ] bi prefix ;
: first>upper ( seq -- seq' ) 1 head >upper ;
-: trim-first ( seq -- seq' ) dup first [ = ] curry trim-left ;
+: trim-first ( seq -- seq' ) dup first [ = ] curry trim-head ;
: remove-zeroes ( seq -- seq' ) CHAR: 0 swap remove ;
: remove-non-alpha ( seq -- seq' ) [ alpha? ] filter ;
: pad-4 ( first seq -- seq' ) "000" 3append 4 head ;
{
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
- [ def>> [ word? ] contains? ]
+ [ def>> [ word? ] any? ]
} cond ;
: ?missing-effect ( word -- )
: pad-with-bottom ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
- '[ _ +bottom+ pad-left ] map
+ '[ _ +bottom+ pad-head ] map
] unless ;
: phi-inputs ( max-d-in pairs -- newseq )
(infer-if)
] [
drop 2 consume-d
- dup [ known [ curried? ] [ composed? ] bi or ] contains? [
+ dup [ known [ curried? ] [ composed? ] bi or ] any? [
output-d
[ rot [ drop call ] [ nip call ] if ]
infer-quot-here
#! Can we use a fast byte array test here?
{
{ [ dup length 8 < ] [ f ] }
- { [ dup [ integer? not ] contains? ] [ f ] }
- { [ dup [ 0 < ] contains? ] [ f ] }
- { [ dup [ bit-member-n >= ] contains? ] [ f ] }
+ { [ dup [ integer? not ] any? ] [ f ] }
+ { [ dup [ 0 < ] any? ] [ f ] }
+ { [ dup [ bit-member-n >= ] any? ] [ f ] }
[ t ]
} cond nip ;
[ atom-entry-link >>url ]
[
{ "content" "summary" } any-tag-named
- dup children>> [ string? not ] contains?
+ dup children>> [ string? not ] any?
[ children>> xml>string ]
[ children>string ] if >>description
]
"resource:basis/tools/crossref/test/foo.factor" run-file
[ t ] [ integer \ foo method \ + usage member? ] unit-test
-[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test
+[ t ] [ \ foo usage [ pathname? ] any? ] unit-test
dup [ second length ] map supremum
'[
[
- [ first >hex cell 2 * CHAR: 0 pad-left % ": " % ]
- [ second _ CHAR: \s pad-right % " " % ]
+ [ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]
+ [ second _ CHAR: \s pad-tail % " " % ]
[ third % ]
tri
] "" make
: dir-or-size ( file-info -- str )
dup directory? [
- drop "<DIR>" 20 CHAR: \s pad-right
+ drop "<DIR>" 20 CHAR: \s pad-tail
] [
- size>> number>string 20 CHAR: \s pad-left
+ size>> number>string 20 CHAR: \s pad-head
] if ;
: listing-time ( timestamp -- string )
[ hour>> ] [ minute>> ] bi
- [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
+ [ number>string 2 CHAR: 0 pad-head ] bi@ ":" glue ;
: listing-date ( timestamp -- string )
[ month>> month-abbreviation ]
- [ day>> number>string 2 CHAR: \s pad-left ]
+ [ day>> number>string 2 CHAR: \s pad-head ]
[
dup year>> dup now year>> =
[ drop listing-time ] [ nip number>string ] if
- 5 CHAR: \s pad-left
+ 5 CHAR: \s pad-head
] tri 3array " " join ;
: read>string ( ? -- string ) "r" "-" ? ; inline
[ >hex write "h" write nl ] bi ;
: write-offset ( lineno -- )
- 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
+ 16 * >hex 8 CHAR: 0 pad-head write "h: " write ;
: >hex-digit ( digit -- str )
- >hex 2 CHAR: 0 pad-left " " append ;
+ >hex 2 CHAR: 0 pad-head " " append ;
: >hex-digits ( bytes -- str )
- [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
+ [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ;
: >ascii ( bytes -- str )
[ [ printable? ] keep CHAR: . ? ] "" map-as ;
: contains-dot? ( string -- ? ) ".." swap subseq? ;
-: contains-separator? ( string -- ? ) [ path-separator? ] contains? ;
+: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
: check-vocab-name ( string -- string )
dup contains-dot? [ vocab-name-contains-dot ] when
] if ;
: lookup-type ( string -- object/string ? )
- "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-right
+ "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-tail
H{
{ "object" object } { "obj" object }
{ "quot" quotation }
TR: convert-separators "/\\" ".." ;\r
\r
: vocab-dir>vocab-name ( path -- vocab )\r
- trim-left-separators\r
- trim-right-separators\r
+ trim-head-separators\r
+ trim-tail-separators\r
convert-separators ;\r
\r
: path>vocab-name ( path -- vocab )\r
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }
- [ x-atom = ] with contains? ;
+ [ x-atom = ] with any? ;
: clipboard-for-atom ( atom -- clipboard )
{
: add ( char -- )\r
dup blocked? [ 1string , ] [\r
dup possible-bases dup length\r
- [ ?combine ] with with contains?\r
+ [ ?combine ] with with any?\r
[ drop ] [ 1string , ] if\r
] if ;\r
\r
: insensitive= ( str1 str2 levels-removed -- ? )\r
[\r
[ collation-key ] dip\r
- [ [ 0 = not ] trim-right but-last ] times\r
+ [ [ 0 = not ] trim-tail but-last ] times\r
] curry bi@ = ;\r
PRIVATE>\r
\r
: exclusions ( -- set )
exclusions-file utf8 file-lines
- [ "#" split1 drop [ blank? ] trim-right hex> ] map harvest ;
+ [ "#" split1 drop [ blank? ] trim-tail hex> ] map harvest ;
: remove-exclusions ( alist -- alist )
exclusions [ dup ] H{ } map>assoc assoc-diff ;
HOOK: utmpx>utmpx-record os ( utmpx -- utmpx-record )
: memory>string ( alien n -- string )
- memory>byte-array utf8 decode [ 0 = ] trim-right ;
+ memory>byte-array utf8 decode [ 0 = ] trim-tail ;
M: unix new-utmpx-record
utmpx-record new ;
: push-utf8 ( ch -- )
1string utf8 encode
- [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+ [ CHAR: % , >hex 2 CHAR: 0 pad-head % ] each ;
PRIVATE>
] dip 76 shift bitor ;
: uuid>string ( n -- string )
- >hex 32 CHAR: 0 pad-left
+ >hex 32 CHAR: 0 pad-head
[ CHAR: - 20 ] dip insert-nth
[ CHAR: - 16 ] dip insert-nth
[ CHAR: - 12 ] dip insert-nth
] keep ;
: (guid-section%) ( guid quot len -- )
- [ call >hex ] dip CHAR: 0 pad-left % ; inline
+ [ call >hex ] dip CHAR: 0 pad-head % ; inline
: (guid-byte%) ( guid byte -- )
- swap nth >hex 2 CHAR: 0 pad-left % ; inline
+ swap nth >hex 2 CHAR: 0 pad-head % ; inline
: guid>string ( guid -- string )
[
: children>string ( tag -- string )
children>> {
{ [ dup empty? ] [ drop "" ] }
- { [ dup [ string? not ] contains? ]
+ { [ dup [ string? not ] any? ]
[ "XML tag unexpectedly contains non-text children" throw ] }
[ concat ]
} cond ;
SYMBOL: indentation\r
\r
: sensitive? ( tag -- ? )\r
- sensitive-tags get swap '[ _ names-match? ] contains? ;\r
+ sensitive-tags get swap '[ _ names-match? ] any? ;\r
\r
: indent-string ( -- string )\r
xml-pprint? get\r
: before-main? ( -- ? )
xml-stack get {
[ length 1 = ]
- [ first second [ tag? ] contains? not ]
+ [ first second [ tag? ] any? not ]
} 1&& ;
M: directive process
: no-post-tags ( post -- post/* )
! this does *not* affect the contents of the stack
- dup [ tag? ] contains? [ multitags ] when ;
+ dup [ tag? ] any? [ multitags ] when ;
: assure-tags ( seq -- seq )
! this does *not* affect the contents of the stack
: keyword-number? ( keyword -- ? )
{
[ current-rule-set highlight-digits?>> ]
- [ dup [ digit? ] contains? ]
+ [ dup [ digit? ] any? ]
[
dup [ digit? ] all? [
current-rule-set digit-re>>
{ $subsection substitute }
{ $subsection substitute-here }
{ $subsection extract-keys }
-{ $see-also key? assoc-contains? assoc-all? "sets" } ;
+{ $see-also key? assoc-any? assoc-all? "sets" } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection assoc-map }
{ $subsection assoc-filter }
{ $subsection assoc-filter-as }
-{ $subsection assoc-contains? }
+{ $subsection assoc-any? }
{ $subsection assoc-all? }
"Additional combinators:"
{ $subsection cache }
{ assoc-filter assoc-filter-as } related-words
-HELP: assoc-contains?
+HELP: assoc-any?
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
[ (assoc-each) partition ] [ drop ] 2bi
tuck [ assoc-like ] 2bi@ ; inline
-: assoc-contains? ( assoc quot -- ? )
+: assoc-any? ( assoc quot -- ? )
assoc-find 2nip ; inline
: assoc-all? ( assoc quot -- ? )
- [ not ] compose assoc-contains? not ; inline
+ [ not ] compose assoc-any? not ; inline
: at ( key assoc -- value/f )
at* drop ; inline
[ normalize-path (file-reader) ] dip checksum-stream ;
: hex-string ( seq -- str )
- [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;
+ [ >hex 2 CHAR: 0 pad-head ] { } map-as concat ;
[ members>> ] dip [ class<= ] curry all? ;\r
\r
: right-anonymous-union<= ( first second -- ? )\r
- members>> [ class<= ] with contains? ;\r
+ members>> [ class<= ] with any? ;\r
\r
: left-anonymous-intersection<= ( first second -- ? )\r
- [ participants>> ] dip [ class<= ] curry contains? ;\r
+ [ participants>> ] dip [ class<= ] curry any? ;\r
\r
: right-anonymous-intersection<= ( first second -- ? )\r
participants>> [ class<= ] with all? ;\r
] if ;\r
\r
M: anonymous-union (classes-intersect?)\r
- members>> [ classes-intersect? ] with contains? ;\r
+ members>> [ classes-intersect? ] with any? ;\r
\r
M: anonymous-intersection (classes-intersect?)\r
participants>> [ classes-intersect? ] with all? ;\r
[ class<= ] [ swap class<= ] 2bi and ;\r
\r
: largest-class ( seq -- n elt )\r
- dup [ [ class< ] with contains? not ] curry find-last\r
+ dup [ [ class< ] with any? not ] curry find-last\r
[ "Topological sort failed" throw ] unless* ;\r
\r
: sort-classes ( seq -- newseq )\r
[
[ name>> "f?" = ]
[ vocabulary>> "syntax" = ] bi and
- ] contains?
+ ] any?
] unit-test
: tuple-prototype ( class -- prototype )
[ initial-values ] keep
- over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
+ over [ ] any? [ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
M: union-class rank-class drop 2 ;
M: union-class instance?
- "members" word-prop [ instance? ] with contains? ;
+ "members" word-prop [ instance? ] with any? ;
M: union-class (flatten-class)
members <anonymous-union> (flatten-class) ;
: case>quot ( default assoc -- quot )
dup keys {
{ [ dup empty? ] [ 2drop ] }
- { [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] }
+ { [ dup [ length 4 <= ] [ [ word? ] any? ] bi or ] [ drop linear-case-quot ] }
{ [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
- { [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] }
+ { [ dup [ wrapper? ] any? not ] [ drop hash-case-quot ] }
{ [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] }
[ drop linear-case-quot ]
} cond ;
[ t ] [
\ / usage [ word? ] filter
- [ name>> "integer=>generic-forget-test-1" = ] contains?
+ [ name>> "integer=>generic-forget-test-1" = ] any?
] unit-test
[ ] [
[ f ] [
\ / usage [ word? ] filter
- [ name>> "integer=>generic-forget-test-1" = ] contains?
+ [ name>> "integer=>generic-forget-test-1" = ] any?
] unit-test
GENERIC: generic-forget-test-2 ( a b -- c )
[ t ] [
\ = usage [ word? ] filter
- [ name>> "sequence=>generic-forget-test-2" = ] contains?
+ [ name>> "sequence=>generic-forget-test-2" = ] any?
] unit-test
[ ] [
[ f ] [
\ = usage [ word? ] filter
- [ name>> "sequence=>generic-forget-test-2" = ] contains?
+ [ name>> "sequence=>generic-forget-test-2" = ] any?
] unit-test
GENERIC: generic-forget-test-3 ( a -- b )
: path-separator ( -- string ) os windows? "\\" "/" ? ;
-: trim-right-separators ( str -- newstr )
- [ path-separator? ] trim-right ;
+: trim-tail-separators ( str -- newstr )
+ [ path-separator? ] trim-tail ;
-: trim-left-separators ( str -- newstr )
- [ path-separator? ] trim-left ;
+: trim-head-separators ( str -- newstr )
+ [ path-separator? ] trim-head ;
: last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last-from ;
: parent-directory ( path -- parent )
dup root-directory? [
- trim-right-separators
+ trim-tail-separators
dup last-path-separator [
1+ cut
] [
: append-path-empty ( path1 path2 -- path' )
{
{ [ dup head.? ] [
- rest trim-left-separators append-path-empty
+ rest trim-head-separators append-path-empty
] }
{ [ dup head..? ] [ drop no-parent-directory ] }
[ nip ]
{
{ [ over empty? ] [ append-path-empty ] }
{ [ dup empty? ] [ drop ] }
- { [ over trim-right-separators "." = ] [ nip ] }
+ { [ over trim-tail-separators "." = ] [ nip ] }
{ [ dup absolute-path? ] [ nip ] }
- { [ dup head.? ] [ rest trim-left-separators append-path ] }
+ { [ dup head.? ] [ rest trim-head-separators append-path ] }
{ [ dup head..? ] [
- 2 tail trim-left-separators
+ 2 tail trim-head-separators
[ parent-directory ] dip append-path
] }
{ [ over absolute-path? over first path-separator? and ] [
[ 2 head ] dip append
] }
[
- [ trim-right-separators "/" ] dip
- trim-left-separators 3append
+ [ trim-tail-separators "/" ] dip
+ trim-head-separators 3append
]
} cond ;
: file-name ( path -- string )
dup root-directory? [
- trim-right-separators
+ trim-tail-separators
dup last-path-separator [ 1+ tail ] [
drop "resource:" ?head [ file-name ] when
] if
M: string (normalize-path)
"resource:" ?head [
- trim-left-separators resource-path
+ trim-head-separators resource-path
(normalize-path)
] [
current-directory get prepend-path
HOOK: home io-backend ( -- dir )
-M: object home "" resource-path ;
\ No newline at end of file
+M: object home "" resource-path ;
{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
-HELP: contains?
+HELP: any?
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the sequence contains an element satisfying the predicate, by applying the predicate to each element in turn until a true value is found. If the sequence is empty or if the end of the sequence is reached, outputs " { $link f } "." } ;
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
-HELP: pad-left
+HELP: pad-head
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } }
{ $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the left with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." }
-{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ;
+{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-head print ] each" "---ab\n-quux" } } ;
-HELP: pad-right
+HELP: pad-tail
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } }
{ $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the right with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." }
-{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ;
+{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-tail print ] each" "ab---\nquux-" } } ;
HELP: sequence=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
}
{ $notes "Used to implement the " { $link filter } " word." } ;
-HELP: trim-left
+HELP: trim-head
{ $values
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
{ $example "" "USING: prettyprint math sequences ;"
- "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left ."
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-head ."
"{ 1 2 3 0 0 }"
} ;
-HELP: trim-left-slice
+HELP: trim-head-slice
{ $values
{ "seq" sequence } { "quot" quotation }
{ "slice" slice } }
{ $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice" }
{ $example "" "USING: prettyprint math sequences ;"
- "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left-slice ."
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-head-slice ."
"T{ slice { from 2 } { to 7 } { seq { 0 0 1 2 3 0 0 } } }"
} ;
-HELP: trim-right
+HELP: trim-tail
{ $values
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
{ $example "" "USING: prettyprint math sequences ;"
- "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right ."
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-tail ."
"{ 0 0 1 2 3 }"
} ;
-HELP: trim-right-slice
+HELP: trim-tail-slice
{ $values
{ "seq" sequence } { "quot" quotation }
{ "slice" slice } }
{ $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice." }
{ $example "" "USING: prettyprint math sequences ;"
- "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right-slice ."
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-tail-slice ."
"T{ slice { from 0 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }"
} ;
"T{ slice { from 2 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }"
} ;
-{ trim trim-slice trim-left trim-left-slice trim-right trim-right-slice } related-words
+{ trim trim-slice trim-head trim-head-slice trim-tail trim-tail-slice } related-words
HELP: sift
{ $values
{ $subsection concat }
{ $subsection join }
"A pair of words useful for aligning strings:"
-{ $subsection pad-left }
-{ $subsection pad-right } ;
+{ $subsection pad-head }
+{ $subsection pad-tail } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
"Extracting a subsequence:"
{ $subsection push-if }
{ $subsection filter }
"Testing if a sequence contains elements satisfying a predicate:"
-{ $subsection contains? }
+{ $subsection any? }
{ $subsection all? }
{ $subsection "sequence-2combinators" }
{ $subsection "sequence-3combinators" } ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
{ $subsection trim }
-{ $subsection trim-left }
-{ $subsection trim-right }
+{ $subsection trim-head }
+{ $subsection trim-tail }
"Potentially more efficient trim:"
{ $subsection trim-slice }
-{ $subsection trim-left-slice }
-{ $subsection trim-right-slice } ;
+{ $subsection trim-head-slice }
+{ $subsection trim-tail-slice } ;
ARTICLE: "sequences-destructive-discussion" "When to use destructive operations"
"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:"
[ -1./0. 0 delete-nth ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
-[ "" ] [ "" [ CHAR: \s = ] trim-left ] unit-test
-[ "" ] [ "" [ CHAR: \s = ] trim-right ] unit-test
-[ "" ] [ " " [ CHAR: \s = ] trim-left ] unit-test
-[ "" ] [ " " [ CHAR: \s = ] trim-right ] unit-test
+[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test
+[ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test
+[ "" ] [ " " [ CHAR: \s = ] trim-head ] unit-test
+[ "" ] [ " " [ CHAR: \s = ] trim-tail ] unit-test
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
-[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-left ] unit-test
-[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-right ] unit-test
+[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-head ] unit-test
+[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-tail ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
: nths ( indices seq -- seq' )
[ nth ] curry map ;
-: contains? ( seq quot -- ? )
+: any? ( seq quot -- ? )
find drop >boolean ; inline
: member? ( elt seq -- ? )
- [ = ] with contains? ;
+ [ = ] with any? ;
: memq? ( elt seq -- ? )
- [ eq? ] with contains? ;
+ [ eq? ] with any? ;
: remove ( elt seq -- newseq )
[ = not ] with filter ;
[ <repetition> ] curry
] dip compose if ; inline
-: pad-left ( seq n elt -- padded )
+: pad-head ( seq n elt -- padded )
[ swap dup append-as ] padding ;
-: pad-right ( seq n elt -- padded )
+: pad-tail ( seq n elt -- padded )
[ append ] padding ;
: shorter? ( seq1 seq2 -- ? ) [ length ] bi@ < ;
dup slice? [ { } like ] when 0 over length rot <slice> ;
inline
-: trim-left-slice ( seq quot -- slice )
+: trim-head-slice ( seq quot -- slice )
over [ [ not ] compose find drop ] dip swap
[ tail-slice ] [ dup length tail-slice ] if* ; inline
-: trim-left ( seq quot -- newseq )
- over [ trim-left-slice ] dip like ; inline
+: trim-head ( seq quot -- newseq )
+ over [ trim-head-slice ] dip like ; inline
-: trim-right-slice ( seq quot -- slice )
+: trim-tail-slice ( seq quot -- slice )
over [ [ not ] compose find-last drop ] dip swap
[ 1+ head-slice ] [ 0 head-slice ] if* ; inline
-: trim-right ( seq quot -- newseq )
- over [ trim-right-slice ] dip like ; inline
+: trim-tail ( seq quot -- newseq )
+ over [ trim-tail-slice ] dip like ; inline
: trim-slice ( seq quot -- slice )
- [ trim-left-slice ] [ trim-right-slice ] bi ; inline
+ [ trim-head-slice ] [ trim-tail-slice ] bi ; inline
: trim ( seq quot -- newseq )
over [ trim-slice ] dip like ; inline
"Adding elements to sets:"
{ $subsection adjoin }
{ $subsection conjoin }
-{ $see-also member? memq? contains? all? "assocs-sets" } ;
+{ $see-also member? memq? any? all? "assocs-sets" } ;
ABOUT: "sets"
tester filter ;
: intersects? ( seq1 seq2 -- ? )
- tester contains? ;
+ tester any? ;
: diff ( seq1 seq2 -- newseq )
tester [ not ] compose filter ;
]
unit-test
-[ "05" ] [ "5" 2 CHAR: 0 pad-left ] unit-test
-[ "666" ] [ "666" 2 CHAR: 0 pad-left ] unit-test
+[ "05" ] [ "5" 2 CHAR: 0 pad-head ] unit-test
+[ "666" ] [ "666" 2 CHAR: 0 pad-head ] unit-test
[ 1 "" nth ] must-fail
[ -6 "hello" nth ] must-fail
[
all-words [
"compiled-uses" word-prop
- keys [ "forgotten" word-prop ] contains?
+ keys [ "forgotten" word-prop ] any?
] filter
] unit-test
crossref get at keys
[ word? ] filter
[
- [ reset-on-redefine [ word-prop ] with contains? ]
+ [ reset-on-redefine [ word-prop ] with any? ]
[ inline? ]
bi or
] filter
{ 0 0 1 }
{ 0 0 0 } } ;
-: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ;
+: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-head string>digits ;
: set-rule ( n -- )
dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
] if
] [ f ] if
]
- ] contains? ; inline recursive
+ ] any? ; inline recursive
:: count-numbers ( max listener -- )
- 10 [ 1+ 1 1 0 max listener (count-numbers) ] contains? drop ;
+ 10 [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ;
inline
:: beust ( -- )
swap >float number>string
"." split1 rot
over length over <
- [ CHAR: 0 pad-right ]
+ [ CHAR: 0 pad-tail ]
[ head ] if "." glue ;
: discard-lines ( -- )
[ \ ¬ instance? ] partition [ x>> ] map intersect empty? ;
METHOD: satisfiable? { □ }
- cnf [ (satisfiable?) ] contains? ;
+ cnf [ (satisfiable?) ] any? ;
GENERIC: (expr.) ( expr -- )
MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: init-hmac ( K -- o i )
- 64 0 pad-right
+ 64 0 pad-tail
[ opad seq-bitxor ] keep
ipad seq-bitxor ;
string-lines
1 tail
[ dup " " head? [ 4 tail ] [ ] if ] map
- [ " " split1 [ " " first = ] trim-left 2array ] map
+ [ " " split1 [ " " first = ] trim-head 2array ] map
\ $values prefix
parsed
: flattenable? ( object -- ? )
{ [ word? ] [ primitive? not ] [
{ "inverse" "math-inverse" "pop-inverse" }
- [ word-prop ] with contains? not
+ [ word-prop ] with any? not
] } 1&& ;
: flatten ( quot -- expanded )
: empty-inverse ( class -- quot )
deconstruct-pred
- [ tuple>array rest [ ] contains? [ fail ] when ]
+ [ tuple>array rest [ ] any? [ fail ] when ]
compose ;
\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
[
drop {
- [ [ wrapper? ] deep-contains? ]
- [ [ hashtable? ] deep-contains? ]
+ [ [ wrapper? ] deep-any? ]
+ [ [ hashtable? ] deep-any? ]
} 1|| not
] assoc-filter
: double. ( double -- )
double>bits
[ (double-sign) .b ]
- [ (double-exponent-bits) >bin 11 CHAR: 0 pad-left bl print ]
+ [ (double-exponent-bits) >bin 11 CHAR: 0 pad-head bl print ]
[
- (double-mantissa-bits) >bin 52 CHAR: 0 pad-left
+ (double-mantissa-bits) >bin 52 CHAR: 0 pad-head
11 [ bl ] times print
] tri ;
: (money>string) ( dollars cents -- string )
[ number>string ] bi@
[ <reversed> 3 group "," join <reversed> ]
- [ 2 CHAR: 0 pad-left ] bi* "." glue ;
+ [ 2 CHAR: 0 pad-head ] bi* "." glue ;
: money>string ( object -- string )
dollars/cents (money>string) currency-token get prefix ;
parsers>> 0 swap seq>list
[ parse ] lazy-map-with lconcat ;
-: trim-left-slice ( string -- string )
+: trim-head-slice ( string -- string )
#! Return a new string without any leading whitespace
#! from the original string.
dup empty? [
- dup first blank? [ rest-slice trim-left-slice ] when
+ dup first blank? [ rest-slice trim-head-slice ] when
] unless ;
TUPLE: sp-parser p1 ;
M: sp-parser parse ( input parser -- list )
#! Skip all leading whitespace from the input then call
#! the parser on the remaining input.
- [ trim-left-slice ] dip p1>> parse ;
+ [ trim-head-slice ] dip p1>> parse ;
TUPLE: just-parser p1 ;
<PRIVATE
: candidates ( n -- seq )
- 1000 over <range> [ number>digits 3 0 pad-left ] map [ all-unique? ] filter ;
+ 1000 over <range> [ number>digits 3 0 pad-head ] map [ all-unique? ] filter ;
: overlap? ( seq -- ? )
[ first 2 tail* ] [ second 2 head ] bi = ;
2 /i sqrt >integer [1,b] [ sq ] map ;
: fits-conjecture? ( n -- ? )
- dup perfect-squares [ 2 * - ] with map [ prime? ] contains? ;
+ dup perfect-squares [ 2 * - ] with map [ prime? ] any? ;
: next-odd-composite ( n -- m )
dup odd? [ 2 + ] [ 1+ ] if dup prime? [ next-odd-composite ] when ;
: source-059 ( -- seq )
"resource:extra/project-euler/059/cipher1.txt"
- ascii file-contents [ blank? ] trim-right "," split
+ ascii file-contents [ blank? ] trim-tail "," split
[ string>number ] map ;
TUPLE: rollover seq n ;
print readln string>number ;
: number>euler ( n -- str )
- number>string 3 CHAR: 0 pad-left ;
+ number>string 3 CHAR: 0 pad-head ;
: solution-path ( n -- str/f )
number>euler "project-euler." prepend
: >board ( row m n -- ) row set-nth ;
: f>board ( m n -- ) f -rot >board ;
-: row-contains? ( n y -- ? ) row member? ;
-: col-contains? ( n x -- ? ) board get swap <column> member? ;
-: cell-contains? ( n x y i -- ? ) 3 /mod pair+ board> = ;
+: row-any? ( n y -- ? ) row member? ;
+: col-any? ( n x -- ? ) board get swap <column> member? ;
+: cell-any? ( n x y i -- ? ) 3 /mod pair+ board> = ;
-: box-contains? ( n x y -- ? )
+: box-any? ( n x y -- ? )
[ 3 /i 3 * ] bi@
- 9 [ [ 3dup ] dip cell-contains? ] contains?
+ 9 [ [ 3dup ] dip cell-any? ] any?
[ 3drop ] dip ;
DEFER: search
: attempt ( n x y -- )
{
- { [ 3dup nip row-contains? ] [ 3drop ] }
- { [ 3dup drop col-contains? ] [ 3drop ] }
- { [ 3dup box-contains? ] [ 3drop ] }
+ { [ 3dup nip row-any? ] [ 3drop ] }
+ { [ 3dup drop col-any? ] [ 3drop ] }
+ { [ 3dup box-any? ] [ 3drop ] }
[ assume ]
} cond ;
: uname ( -- seq )
65536 "char" <c-array> [ (uname) io-error ] keep
"\0" split harvest [ >string ] map
- 6 "" pad-right ;
+ 6 "" pad-tail ;
: sysname ( -- string ) uname first ;
: nodename ( -- string ) uname second ;
: domainname ( -- string ) uname 5 swap nth ;
: kernel-version ( -- seq )
- release ".-" split harvest 5 "" pad-right ;
+ release ".-" split harvest 5 "" pad-tail ;
: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
: read-c-string* ( n -- str/f )
- read [ zero? ] trim-right [ f ] when-empty ;
+ read [ zero? ] trim-tail [ f ] when-empty ;
: read-tar-header ( -- obj )
\ tar-header new
: typeflag-L ( header -- )
drop ;
! <string-writer> [ read-data-blocks ] keep
- ! >string [ zero? ] trim-right filename set
+ ! >string [ zero? ] trim-tail filename set
! filename get tar-prepend-path make-directories ;
! Multi volume continuation entry
" kernel vocab keywords
syn keyword factorKeyword or construct-delegate set-slots tuck 2bi 2tri while wrapper nip bi* wrapper? hashcode callstack>array both? die set-delegate dupd callstack callstack? 3dup tri@ pick curry build prepose 3bi >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep construct clear 2dup when not tuple? 3compose dup 2bi* call object bi@ wrapped unless* if* >r curry-quot drop when* retainstack -rot 2bi@ delegate boa with 3slip slip compose-first compose-second 3drop either? bi curry? datastack curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if 3tri unless compose? tuple keep 2curry equal? set-datastack 2slip tri 2drop most <wrapper> identity-tuple? null r> new set-callstack dip xor rot -roll identity-tuple
-syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-contains? <enum> assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys
+syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-any? <enum> assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys
syn keyword factorKeyword case dispatch-case-quot with-datastack <buckets> no-cond no-case? 3cleave>quot (distribute-buckets) contiguous-range? 2cleave cond>quot no-cond? cleave>quot no-case recursive-hashcode case>quot 3cleave alist>quot dispatch-case hash-case-table hash-case-quot case-find cond cleave distribute-buckets 2cleave>quot linear-case-quot spread spread>quot hash-dispatch-quot
syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 ?1+ imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum (all-integers?) times denominator find-last-integer (each-integer) bit? * + power-of-2? - / >= bitand find-integer complex < real > log2 integer? number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift float 1+ 1- fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator /f
-syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? <slice> tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth <flat-slice> second change-each join set-repetition-len <reversed> all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index <repetition> unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch
+syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? <slice> tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek any? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth <flat-slice> second change-each join set-repetition-len <reversed> all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index <repetition> unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch
syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc
syn keyword factorKeyword <array> 3array >array 4array pair? array pair 2array 1array resize-array array?
syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln
projects / factor.git / commitdiff