reverse args for assoc-diff, diff

fix lots of usings
fix help lint
db4
Doug Coleman 2008-04-26 02:01:43 -05:00
parent e264537a1a
commit 4d0ba8c3c1
60 changed files with 74 additions and 123 deletions

View File

@ -12,7 +12,7 @@ IN: bunny.model
readln [ readln [
numbers { numbers {
{ [ dup length 5 = ] [ 3 head pick push ] } { [ dup length 5 = ] [ 3 head pick push ] }
{ [ dup first 3 = ] [ 1 tail over push ] } { [ dup first 3 = ] [ rest over push ] }
[ drop ] [ drop ]
} cond (parse-model) } cond (parse-model)
] when* ; ] when* ;

View File

@ -1,5 +1,5 @@
USING: arrays calendar kernel math sequences tools.test USING: arrays calendar kernel math sequences tools.test
continuations system ; continuations system math.order ;
IN: calendar.tests IN: calendar.tests
\ time+ must-infer \ time+ must-infer

View File

@ -6,6 +6,7 @@ HELP: >tuple<
{ $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." } { $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." }
{ $example { $example
"USING: kernel prettyprint classes.tuple.lib ;" "USING: kernel prettyprint classes.tuple.lib ;"
"IN: scratchpad"
"TUPLE: foo a b c ;" "TUPLE: foo a b c ;"
"1 2 3 \\ foo boa \\ foo >tuple< .s" "1 2 3 \\ foo boa \\ foo >tuple< .s"
"1\n2\n3" "1\n2\n3"
@ -18,6 +19,7 @@ HELP: >tuple*<
{ $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." } { $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." }
{ $example { $example
"USING: kernel prettyprint classes.tuple.lib ;" "USING: kernel prettyprint classes.tuple.lib ;"
"IN: scratchpad"
"TUPLE: foo a bb* ccc dddd* ;" "TUPLE: foo a bb* ccc dddd* ;"
"1 2 3 4 \\ foo boa \\ foo >tuple*< .s" "1 2 3 4 \\ foo boa \\ foo >tuple*< .s"
"2\n4" "2\n4"

View File

@ -7,7 +7,7 @@ IN: classes.tuple.lib
[ slot-spec-reader ] map [ get-slots ] curry ; [ slot-spec-reader ] map [ get-slots ] curry ;
MACRO: >tuple< ( class -- ) MACRO: >tuple< ( class -- )
all-slots 1 tail-slice reader-slots ; all-slots rest-slice reader-slots ;
MACRO: >tuple*< ( class -- ) MACRO: >tuple*< ( class -- )
all-slots all-slots

View File

@ -573,7 +573,7 @@ SYMBOL: $4
#! $1, $2, etc with the relevant item from the #! $1, $2, etc with the relevant item from the
#! given index. #! given index.
dup quotation? over [ ] = not and [ ! vector tree dup quotation? over [ ] = not and [ ! vector tree
dup first swap 1 tail ! vector car cdr dup first swap rest ! vector car cdr
>r dupd replace-patterns ! vector v R: cdr >r dupd replace-patterns ! vector v R: cdr
swap r> replace-patterns >r 1quotation r> append swap r> replace-patterns >r 1quotation r> append
] [ ! vector value ] [ ! vector value

View File

@ -123,6 +123,6 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
: byte-array>sha1-interleave ( string -- seq ) : byte-array>sha1-interleave ( string -- seq )
[ zero? ] left-trim [ zero? ] left-trim
dup length odd? [ 1 tail ] when dup length odd? [ rest ] when
seq>2seq [ byte-array>sha1 ] bi@ seq>2seq [ byte-array>sha1 ] bi@
2seq>seq ; 2seq>seq ;

View File

@ -23,7 +23,7 @@ IN: delegate
: forget-old-definitions ( protocol new-wordlist -- ) : forget-old-definitions ( protocol new-wordlist -- )
>r users-and-words r> >r users-and-words r>
diff forget-all-methods ; swap diff forget-all-methods ;
: define-protocol ( protocol wordlist -- ) : define-protocol ( protocol wordlist -- )
! 2dup forget-old-definitions ! 2dup forget-old-definitions

View File

@ -85,7 +85,7 @@ C: <faq> faq
: toc, ( faq -- ) : toc, ( faq -- )
"div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [ "div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
"strong" [ "The big questions" , ] tag, br, "strong" [ "The big questions" , ] tag, br,
faq-lists 1 tail dup length [ toc-link, ] 2each faq-lists rest dup length [ toc-link, ] 2each
] tag*, ; ] tag*, ;
: faq-sections, ( question-lists -- ) : faq-sections, ( question-lists -- )

View File

@ -14,7 +14,7 @@ M: link uses
collect-elements [ \ f or ] map ; collect-elements [ \ f or ] map ;
: help-path ( topic -- seq ) : help-path ( topic -- seq )
[ article-parent ] follow 1 tail ; [ article-parent ] follow rest ;
: set-article-parents ( parent article -- ) : set-article-parents ( parent article -- )
article-children [ set-article-parent ] with each ; article-children [ set-article-parent ] with each ;

View File

@ -9,7 +9,7 @@ macros combinators.lib sequences.lib math sets ;
IN: help.lint IN: help.lint
: check-example ( element -- ) : check-example ( element -- )
1 tail [ rest [
1 head* "\n" join 1vector 1 head* "\n" join 1vector
[ [
use [ clone ] change use [ clone ] change
@ -23,7 +23,7 @@ IN: help.lint
: extract-values ( element -- seq ) : extract-values ( element -- seq )
\ $values swap elements dup empty? [ \ $values swap elements dup empty? [
first 1 tail [ first ] map prune natural-sort first rest [ first ] map prune natural-sort
] unless ; ] unless ;
: effect-values ( word -- seq ) : effect-values ( word -- seq )
@ -59,7 +59,7 @@ IN: help.lint
: check-see-also ( word element -- ) : check-see-also ( word element -- )
nip \ $see-also swap elements [ nip \ $see-also swap elements [
1 tail dup prune [ length ] bi@ assert= rest dup prune [ length ] bi@ assert=
] each ; ] each ;
: vocab-exists? ( name -- ? ) : vocab-exists? ( name -- ? )

View File

@ -311,7 +311,7 @@ M: array elements*
[ [
swap [ swap [
elements [ elements [
1 tail [ dup set ] each rest [ dup set ] each
] each ] each
] curry each ] curry each
] H{ } make-assoc keys ; ] H{ } make-assoc keys ;

View File

@ -99,7 +99,7 @@ IN: html.parser.analyzer
: find-between ( i/f tag/f vector -- vector ) : find-between ( i/f tag/f vector -- vector )
find-between* dup length 3 >= [ find-between* dup length 3 >= [
[ 1 tail-slice 1 head-slice* ] keep like [ rest-slice 1 head-slice* ] keep like
] when ; ] when ;
: find-between-first ( string vector -- vector' ) : find-between-first ( string vector -- vector' )

View File

@ -36,7 +36,7 @@ IN: html.parser.utils
dup quoted? [ quote ] unless ; dup quoted? [ quote ] unless ;
: unquote ( str -- newstr ) : unquote ( str -- newstr )
dup quoted? [ 1 head-slice* 1 tail-slice >string ] when ; dup quoted? [ 1 head-slice* rest-slice >string ] when ;
: quote? ( ch -- ? ) "'\"" member? ; : quote? ( ch -- ? ) "'\"" member? ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors splitting calendar continuations accessors vectors math.order
io.encodings.8-bit io.encodings.binary fry debugger inspector ; io.encodings.8-bit io.encodings.binary fry debugger inspector ;
IN: http.client IN: http.client

View File

@ -149,7 +149,7 @@ TUPLE: dispatcher default responders ;
[ nip ] [ drop default>> ] if [ nip ] [ drop default>> ] if
] [ ] [
over first over responders>> at* over first over responders>> at*
[ >r drop 1 tail-slice r> ] [ drop default>> ] if [ >r drop rest-slice r> ] [ drop default>> ] if
] if ; ] if ;
M: dispatcher call-responder ( path dispatcher -- response ) M: dispatcher call-responder ( path dispatcher -- response )

View File

@ -204,7 +204,7 @@ DEFER: _
"predicate" word-prop [ dupd call assure ] curry ; "predicate" word-prop [ dupd call assure ] curry ;
: slot-readers ( class -- quot ) : slot-readers ( class -- quot )
all-slots 1 tail ! tail gets rid of delegate all-slots rest ! tail gets rid of delegate
[ slot-spec-reader 1quotation [ keep ] curry ] map concat [ slot-spec-reader 1quotation [ keep ] curry ] map concat
[ ] like [ drop ] compose ; [ ] like [ drop ] compose ;
@ -218,7 +218,7 @@ DEFER: _
: empty-inverse ( class -- quot ) : empty-inverse ( class -- quot )
deconstruct-pred deconstruct-pred
[ tuple>array 1 tail [ ] contains? [ fail ] when ] [ tuple>array rest [ ] contains? [ fail ] when ]
compose ; compose ;
\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse

View File

@ -9,7 +9,7 @@ IN: irc
! utils ! utils
: split-at-first ( seq separators -- before after ) : split-at-first ( seq separators -- before after )
dupd '[ , member? ] find dupd '[ , member? ] find
[ cut 1 tail ] [ cut rest ]
[ swap ] [ swap ]
if ; if ;
@ -101,7 +101,7 @@ SYMBOL: irc-client
: irc-client> ( -- irc-client ) irc-client get ; : irc-client> ( -- irc-client ) irc-client get ;
: irc-stream> ( -- stream ) irc-client> stream>> ; : irc-stream> ( -- stream ) irc-client> stream>> ;
: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ; : remove-heading-: ( seq -- seq ) dup ":" head? [ rest ] when ;
: parse-name ( string -- string ) : parse-name ( string -- string )
remove-heading-: "!" split-at-first drop ; remove-heading-: "!" split-at-first drop ;

View File

@ -84,7 +84,7 @@ TUPLE: segment number color radius ;
pick >r nearer-segment dup r> = ; pick >r nearer-segment dup r> = ;
: find-nearest-segment ( oint segments -- segment ) : find-nearest-segment ( oint segments -- segment )
dup first swap 1 tail-slice rot [ (find-nearest-segment) ] curry dup first swap rest-slice rot [ (find-nearest-segment) ] curry
find 2drop ; find 2drop ;
: nearest-segment-forward ( segments oint start -- segment ) : nearest-segment-forward ( segments oint start -- segment )

View File

@ -203,7 +203,7 @@ DEFER: (d)
[ basis graded ] bi@ tensor bigraded-ker/im-d [ basis graded ] bi@ tensor bigraded-ker/im-d
[ [ [ first ] map ] map ] keep [ [ [ first ] map ] map ] keep
[ [ second ] map 2 head* { 0 0 } prepend ] map [ [ second ] map 2 head* { 0 0 } prepend ] map
1 tail dup first length 0 <array> suffix rest dup first length 0 <array> suffix
[ v- ] 2map ; [ v- ] 2map ;
! Laplacian ! Laplacian

View File

@ -16,6 +16,7 @@ HELP: [|
{ $examples { $examples
{ $example { $example
"USING: kernel locals math prettyprint ;" "USING: kernel locals math prettyprint ;"
"IN: scratchpad"
":: adder ( n -- quot ) [| m | m n + ] ;" ":: adder ( n -- quot ) [| m | m n + ] ;"
"3 5 adder call ." "3 5 adder call ."
"8" "8"
@ -29,6 +30,7 @@ HELP: [let
{ $examples { $examples
{ $example { $example
"USING: kernel locals math math.functions prettyprint sequences ;" "USING: kernel locals math math.functions prettyprint sequences ;"
"IN: scratchpad"
":: frobnicate ( n seq -- newseq )" ":: frobnicate ( n seq -- newseq )"
" [let | n' [ n 6 * ] |" " [let | n' [ n 6 * ] |"
" seq [ n' gcd nip ] map ] ;" " seq [ n' gcd nip ] map ] ;"
@ -44,6 +46,7 @@ HELP: [let*
{ $examples { $examples
{ $example { $example
"USING: kernel locals math math.functions prettyprint sequences ;" "USING: kernel locals math math.functions prettyprint sequences ;"
"IN: scratchpad"
":: frobnicate ( n seq -- newseq )" ":: frobnicate ( n seq -- newseq )"
" [let* | a [ n 3 + ]" " [let* | a [ n 3 + ]"
" b [ a 4 * ] |" " b [ a 4 * ] |"
@ -62,6 +65,7 @@ HELP: [wlet
{ $examples { $examples
{ $example { $example
"USING: locals math prettyprint sequences ;" "USING: locals math prettyprint sequences ;"
"IN: scratchpad"
":: quuxify ( n seq -- newseq )" ":: quuxify ( n seq -- newseq )"
" [wlet | add-n [| m | m n + ] |" " [wlet | add-n [| m | m n + ] |"
" seq [ add-n ] map ] ;" " seq [ add-n ] map ] ;"

View File

@ -130,7 +130,7 @@ M: object free-vars* drop ;
M: quotation free-vars* [ add-if-free ] each ; M: quotation free-vars* [ add-if-free ] each ;
M: lambda free-vars* M: lambda free-vars*
[ vars>> ] [ body>> ] bi free-vars diff % ; [ vars>> ] [ body>> ] bi free-vars swap diff % ;
GENERIC: lambda-rewrite* ( obj -- ) GENERIC: lambda-rewrite* ( obj -- )

View File

@ -14,7 +14,7 @@ SYMBOL: message-histogram
dup second CRITICAL eq? [ dup errors get push ] when dup second CRITICAL eq? [ dup errors get push ] when
1 over third word-histogram get at+ 1 over third word-histogram get at+
dup third word-names get member? [ dup third word-names get member? [
1 over 1 tail message-histogram get at+ 1 over rest message-histogram get at+
] when ] when
drop ; drop ;

View File

@ -42,7 +42,7 @@ SYMBOL: log-files
{ [ dup length 1 = ] [ first -rot f (write-message) ] } { [ dup length 1 = ] [ first -rot f (write-message) ] }
[ [
[ first -rot f (write-message) ] 3keep [ first -rot f (write-message) ] 3keep
1 tail -rot [ t (write-message) ] 2curry each rest -rot [ t (write-message) ] 2curry each
] ]
} cond ; } cond ;

View File

@ -42,6 +42,7 @@ HELP: match-replace
{ $examples { $examples
{ $example { $example
"USING: match prettyprint ;" "USING: match prettyprint ;"
"IN: scratchpad"
"MATCH-VARS: ?a ?b ;" "MATCH-VARS: ?a ?b ;"
"{ 1 2 } { ?a ?b } { ?b ?a } match-replace ." "{ 1 2 } { ?a ?b } { ?b ?a } match-replace ."
"{ 2 1 }" "{ 2 1 }"

View File

@ -67,13 +67,13 @@ MACRO: match-cond ( assoc -- )
[ replace-patterns ] bind ; [ replace-patterns ] bind ;
: ?1-tail ( seq -- tail/f ) : ?1-tail ( seq -- tail/f )
dup length zero? not [ 1 tail ] [ drop f ] if ; dup length zero? not [ rest ] [ drop f ] if ;
: (match-first) ( seq pattern-seq -- bindings leftover/f ) : (match-first) ( seq pattern-seq -- bindings leftover/f )
2dup [ length ] bi@ < [ 2drop f f ] 2dup [ length ] bi@ < [ 2drop f f ]
[ [
2dup length head over match 2dup length head over match
[ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if* [ nip swap ?1-tail ] [ >r rest r> (match-first) ] if*
] if ; ] if ;
: match-first ( seq pattern-seq -- bindings ) : match-first ( seq pattern-seq -- bindings )

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math math.functions USING: arrays kernel sequences math math.functions
math.vectors ; math.vectors math.order ;
IN: math.matrices IN: math.matrices
! Matrices ! Matrices

View File

@ -58,7 +58,7 @@ PRIVATE>
2dup /-last 2dup /-last
2dup , n*p swapd 2dup , n*p swapd
p- >vector p- >vector
dup pop* swap 1 tail-slice ; dup pop* swap rest-slice ;
PRIVATE> PRIVATE>

View File

@ -8,4 +8,4 @@ MEMO: fib ( m -- n )
[ 89 ] [ 10 fib ] unit-test [ 89 ] [ 10 fib ] unit-test
[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail [ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail

View File

@ -34,7 +34,7 @@ IN: multiline
[ [
lexer get lexer-column swap (parse-multiline-string) lexer get lexer-column swap (parse-multiline-string)
lexer get set-lexer-column lexer get set-lexer-column
] "" make 1 tail 1 head* ; ] "" make rest 1 head* ;
: <" : <"
"\">" parse-multiline-string parsed ; parsing "\">" parse-multiline-string parsed ; parsing

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Joe Groff. ! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting opengl.gl USING: kernel namespaces sequences splitting opengl.gl
continuations math.parser math arrays sets ; continuations math.parser math arrays sets math.order ;
IN: opengl.capabilities IN: opengl.capabilities
: (require-gl) ( thing require-quot make-error-quot -- ) : (require-gl) ( thing require-quot make-error-quot -- )
@ -15,7 +15,7 @@ IN: opengl.capabilities
: has-gl-extensions? ( extensions -- ? ) : has-gl-extensions? ( extensions -- ? )
gl-extensions swap [ over member? ] all? nip ; gl-extensions swap [ over member? ] all? nip ;
: (make-gl-extensions-error) ( required-extensions -- ) : (make-gl-extensions-error) ( required-extensions -- )
gl-extensions swap diff gl-extensions diff
"Required OpenGL extensions not supported:\n" % "Required OpenGL extensions not supported:\n" %
[ " " % % "\n" % ] each ; [ " " % % "\n" % ] each ;
: require-gl-extensions ( extensions -- ) : require-gl-extensions ( extensions -- )

View File

@ -1,5 +1,6 @@
USING: arrays combinators.lib kernel math math.functions math.vectors namespaces USING: arrays combinators.lib kernel math math.functions
opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; math.order math.vectors namespaces opengl opengl.gl sequences ui
ui.gadgets ui.gestures ui.render ;
IN: opengl.demo-support IN: opengl.demo-support
: NEAR-PLANE 1.0 64.0 / ; inline : NEAR-PLANE 1.0 64.0 / ; inline

View File

@ -38,7 +38,7 @@ M: comment pprint*
" --" % " --" %
" " over node-out-d values% " " over node-out-d values%
" r: " swap node-out-r values% " r: " swap node-out-r values%
] "" make 1 tail ; ] "" make rest ;
MACRO: match-choose ( alist -- ) MACRO: match-choose ( alist -- )
[ [ ] curry ] assoc-map [ match-cond ] curry ; [ [ ] curry ] assoc-map [ match-cond ] curry ;

View File

@ -177,7 +177,7 @@ M: or-parser parse ( input parser1 -- list )
#! Return a new string without any leading whitespace #! Return a new string without any leading whitespace
#! from the original string. #! from the original string.
dup empty? [ dup empty? [
dup first blank? [ 1 tail-slice left-trim-slice ] when dup first blank? [ rest-slice left-trim-slice ] when
] unless ; ] unless ;
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;

View File

@ -107,7 +107,7 @@ MEMO: pack ( begin body end -- parser )
#! range of characters from the first to the second, #! range of characters from the first to the second,
#! inclusive. #! inclusive.
dup first CHAR: ^ = [ dup first CHAR: ^ = [
1 tail (range-pattern) [ member? not ] curry satisfy rest (range-pattern) [ member? not ] curry satisfy
] [ ] [
(range-pattern) [ member? ] curry satisfy (range-pattern) [ member? ] curry satisfy
] if ; ] if ;

View File

@ -448,7 +448,7 @@ M: action-parser (compile) ( parser -- quot )
#! Return a new string without any leading whitespace #! Return a new string without any leading whitespace
#! from the original string. #! from the original string.
dup empty? [ dup empty? [
dup first blank? [ 1 tail-slice left-trim-slice ] when dup first blank? [ rest-slice left-trim-slice ] when
] unless ; ] unless ;
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;

View File

@ -45,13 +45,14 @@ IN: project-euler.023
: possible-sums ( seq -- seq ) : possible-sums ( seq -- seq )
dup { } -rot [ dup { } -rot [
dupd [ + ] curry map dupd [ + ] curry map
rot append prune swap 1 tail rot append prune swap rest
] each drop natural-sort ; ] each drop natural-sort ;
PRIVATE> PRIVATE>
: euler023 ( -- answer ) : euler023 ( -- answer )
20161 abundants-upto possible-sums source-023 diff sum ; source-023
20161 abundants-upto possible-sums diff sum ;
! TODO: solution is still too slow, although it takes under 1 minute ! TODO: solution is still too slow, although it takes under 1 minute

View File

@ -28,7 +28,7 @@ IN: project-euler.035
: possible? ( seq -- ? ) : possible? ( seq -- ? )
dup length 1 > [ dup length 1 > [
dup { 0 2 4 5 6 8 } swap diff = dup { 0 2 4 5 6 8 } diff =
] [ ] [
drop t drop t
] if ; ] if ;

View File

@ -79,7 +79,7 @@ PRIVATE>
[ unclip 1 head prefix concat ] map [ all-unique? ] filter ; [ unclip 1 head prefix concat ] map [ all-unique? ] filter ;
: add-missing-digit ( seq -- seq ) : add-missing-digit ( seq -- seq )
dup natural-sort 10 diff first prefix ; dup natural-sort 10 swap diff first prefix ;
: interesting-pandigitals ( -- seq ) : interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [ 17 candidates { 13 11 7 5 3 2 } [

View File

@ -35,7 +35,7 @@ IN: project-euler.079
] { } make ; ] { } make ;
: find-source ( seq -- elt ) : find-source ( seq -- elt )
dup values swap keys [ prune ] bi@ diff [ keys ] [ values ] bi diff prune
dup empty? [ "Topological sort failed" throw ] [ first ] if ; dup empty? [ "Topological sort failed" throw ] [ first ] if ;
: remove-source ( seq elt -- seq ) : remove-source ( seq elt -- seq )
@ -52,7 +52,7 @@ PRIVATE>
: topological-sort ( seq -- seq ) : topological-sort ( seq -- seq )
[ [ (topological-sort) ] { } make ] keep [ [ (topological-sort) ] { } make ] keep
concat prune dupd diff append ; concat prune over diff append ;
: euler079 ( -- answer ) : euler079 ( -- answer )
source-079 >edges topological-sort 10 digits>integer ; source-079 >edges topological-sort 10 digits>integer ;

View File

@ -40,10 +40,10 @@ IN: project-euler.common
! Propagate one row into the upper one ! Propagate one row into the upper one
: propagate ( bottom top -- newtop ) : propagate ( bottom top -- newtop )
[ over 1 tail rot first2 max rot + ] map nip ; [ over rest rot first2 max rot + ] map nip ;
: shift-3rd ( seq obj obj -- seq obj obj ) : shift-3rd ( seq obj obj -- seq obj obj )
rot 1 tail -rot ; rot rest -rot ;
: (sum-divisors) ( n -- sum ) : (sum-divisors) ( n -- sum )
dup sqrt >fixnum [1,b] [ dup sqrt >fixnum [1,b] [
@ -95,7 +95,7 @@ PRIVATE>
! Not strictly needed, but it is nice to be able to dump the triangle after the ! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation ! propagation
: propagate-all ( triangle -- newtriangle ) : propagate-all ( triangle -- newtriangle )
reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap suffix ; reverse [ first dup ] keep rest [ propagate dup ] map nip reverse swap suffix ;
: sum-divisors ( n -- sum ) : sum-divisors ( n -- sum )
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ; dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;

View File

@ -23,7 +23,7 @@ IN: qualified
] curry map zip ; ] curry map zip ;
: partial-vocab-ignoring ( words name -- assoc ) : partial-vocab-ignoring ( words name -- assoc )
[ vocab-words keys diff ] keep partial-vocab ; [ vocab-words keys swap diff ] keep partial-vocab ;
: EXCLUDE: : EXCLUDE:
#! Syntax: EXCLUDE: vocab => words ... ; #! Syntax: EXCLUDE: vocab => words ... ;

View File

@ -7,7 +7,7 @@ IN: random-weighted
: probabilities ( weights -- probabilities ) dup sum v/n ; : probabilities ( weights -- probabilities ) dup sum v/n ;
: layers ( probabilities -- layers ) : layers ( probabilities -- layers )
dup length 1+ [ head ] with map 1 tail [ sum ] map ; dup length 1+ [ head ] with map rest [ sum ] map ;
: random-weighted ( weights -- elt ) : random-weighted ( weights -- elt )
probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ; probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;

View File

@ -1,5 +1,5 @@
USING: kernel math random namespaces random.mersenne-twister USING: kernel math random namespaces random.mersenne-twister
sequences tools.test ; sequences tools.test math.order ;
IN: random.mersenne-twister.tests IN: random.mersenne-twister.tests
: check-random ( max -- ? ) : check-random ( max -- ? )

View File

@ -117,7 +117,7 @@ MACRO: firstn ( n -- )
: split-around ( seq quot -- before elem after ) : split-around ( seq quot -- before elem after )
dupd find over [ "Element not found" throw ] unless dupd find over [ "Element not found" throw ] unless
>r cut 1 tail r> swap ; inline >r cut rest r> swap ; inline
: (map-until) ( quot pred -- quot ) : (map-until) ( quot pred -- quot )
[ dup ] swap 3compose [ dup ] swap 3compose
@ -239,7 +239,7 @@ PRIVATE>
zip >hashtable substitute ; zip >hashtable substitute ;
: remove-nth ( seq n -- seq' ) : remove-nth ( seq n -- seq' )
cut-slice 1 tail-slice append ; cut-slice rest-slice append ;
: short ( seq n -- seq n' ) : short ( seq n -- seq n' )
over length min ; inline over length min ; inline

View File

@ -111,7 +111,7 @@ M: tuple (serialize) ( obj -- )
CHAR: T write1 CHAR: T write1
[ class (serialize) ] [ class (serialize) ]
[ add-object ] [ add-object ]
[ tuple>array 1 tail (serialize) ] [ tuple>array rest (serialize) ]
tri tri
] serialize-shared ; ] serialize-shared ;

View File

@ -1 +0,0 @@
Daniel Ehrenberg

View File

@ -1,13 +0,0 @@
USING: help.syntax help.markup ;
IN: shufflers
HELP: SHUFFLE:
{ $syntax "SHUFFLE: alphabet #" }
{ $values { "alphabet" "an alphabet of unique letters" } { "#" "the maximum length" } }
{ $description "Defines stack shufflers of the form abc-bcba where 'abc' describes the inputs and 'bcba' describes the outputs. Given a stack of 1 2 3, this returns 2 3 2 1. The stack shufflers defined are put in the current vocab with the suffix '.shuffle' appended." }
{ $examples
"SHUFFLE: abcd 6\n"
": 4drop abcd- ;\n"
": 2over abcd-abcdab ;\n"
": 2swap abcd-cdab ;\n"
": 3dup abc-abcabc ;\n" } ;

View File

@ -1,8 +0,0 @@
USING: shufflers tools.test ;
IN: shufflers.tests
SHUFFLE: abcd 4
[ ] [ 1 2 3 4 abcd- ] unit-test
[ 1 2 1 2 ] [ 1 2 3 abc-abab ] unit-test
[ 4 3 2 1 ] [ 1 2 3 4 abcd-dcba ] unit-test
[ 1 1 1 1 ] [ 1 a-aaaa ] unit-test

View File

@ -1,36 +0,0 @@
USING: kernel sequences words math math.functions arrays
shuffle quotations parser math.parser strings namespaces
splitting effects sequences.lib ;
IN: shufflers
: shuffle>string ( names shuffle -- string )
swap [ [ nth ] curry map ] curry map
first2 "-" swap 3append >string ;
: make-shuffles ( max-out max-in -- shuffles )
[ 1+ dup rot strings [ 2array ] with map ]
with map concat ;
: shuffle>quot ( shuffle -- quot )
[
first2 2dup [ - ] with map
reverse [ , \ npick , \ >r , ] each
swap , \ ndrop , length [ \ r> , ] times
] [ ] make ;
: put-effect ( word -- )
dup word-name "-" split1
[ >array [ 1string ] map ] bi@
<effect> "declared-effect" set-word-prop ;
: in-shuffle ( -- ) in get ".shuffle" append set-in ;
: out-shuffle ( -- ) in get ".shuffle" ?tail drop set-in ;
: define-shuffles ( names max-out -- )
in-shuffle over length make-shuffles [
[ shuffle>string create-in ] keep
shuffle>quot dupd define put-effect
] with each out-shuffle ;
: SHUFFLE:
scan scan string>number define-shuffles ; parsing

View File

@ -1 +0,0 @@
Arbitrary stack shuffling operators of the form abc-cbab

View File

@ -1 +0,0 @@
extensions

View File

@ -5,5 +5,5 @@ HELP: SYMBOLS:
{ $syntax "SYMBOLS: words... ;" } { $syntax "SYMBOLS: words... ;" }
{ $values { "words" "a sequence of new words to define" } } { $values { "words" "a sequence of new words to define" } }
{ $description "Creates a new word for every token until the ';'." } { $description "Creates a new word for every token until the ';'." }
{ $examples { $example "USING: prettyprint symbols ;" "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } } { $examples { $example "USING: prettyprint symbols ;" "IN: scratchpad" "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } }
{ $see-also POSTPONE: SYMBOL: } ; { $see-also POSTPONE: SYMBOL: } ;

View File

@ -104,7 +104,7 @@ IN: tools.deploy.shaker
set-global ; set-global ;
: strip-vocab-globals ( except names -- words ) : strip-vocab-globals ( except names -- words )
[ child-vocabs [ words ] map concat ] map concat diff ; [ child-vocabs [ words ] map concat ] map concat swap diff ;
: stripped-globals ( -- seq ) : stripped-globals ( -- seq )
[ [

View File

@ -127,7 +127,7 @@ SYMBOL: modified-docs
modified-sources get modified-sources get
modified-docs get modified-docs get
] ]
[ modified-sources get modified-docs get append swap diff ] bi [ modified-docs get modified-sources get append diff ] bi
] with-scope ; ] with-scope ;
: do-refresh ( modified-sources modified-docs unchanged -- ) : do-refresh ( modified-sources modified-docs unchanged -- )

View File

@ -47,6 +47,7 @@ HELP: command-name
{ $examples { $examples
{ $example { $example
"USING: io ui.commands ;" "USING: io ui.commands ;"
"IN: scratchpad"
": com-my-command ;" ": com-my-command ;"
"\\ com-my-command command-name write" "\\ com-my-command command-name write"
"My Command" "My Command"
@ -105,6 +106,7 @@ HELP: command-string
{ $examples { $examples
{ $example { $example
"USING: io ui.commands ui.gestures ;" "USING: io ui.commands ui.gestures ;"
"IN: scratchpad"
": com-my-command ;" ": com-my-command ;"
"T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write" "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write"
"My Command (C+s)" "My Command (C+s)"

View File

@ -56,7 +56,7 @@ GENERIC: command-word ( command -- word )
M: word command-name ( word -- str ) M: word command-name ( word -- str )
word-name word-name
"com-" ?head drop "com-" ?head drop
dup first Letter? [ 1 tail ] unless dup first Letter? [ rest ] unless
(command-name) ; (command-name) ;
M: word command-description ( word -- str ) M: word command-description ( word -- str )

View File

@ -60,7 +60,7 @@ DEFER: (gadget-subtree)
: traverse-child ( frompath topath gadget -- ) : traverse-child ( frompath topath gadget -- )
dup -roll [ dup -roll [
>r >r 1 tail-slice r> r> traverse-step (gadget-subtree) >r >r rest-slice r> r> traverse-step (gadget-subtree)
] make-node ; ] make-node ;
: (gadget-subtree) ( frompath topath gadget -- ) : (gadget-subtree) ( frompath topath gadget -- )

View File

@ -59,7 +59,7 @@ IN: unicode.data
: process-compat ( data -- hash ) : process-compat ( data -- hash )
(process-decomposed) (process-decomposed)
[ dup first* [ first2 1 tail 2array ] unless ] map [ dup first* [ first2 rest 2array ] unless ] map
>hashtable chain-decomposed ; >hashtable chain-decomposed ;
: process-combining ( data -- hash ) : process-combining ( data -- hash )

View File

@ -162,7 +162,7 @@ SYMBOL: ns-stack
T{ name f "" "version" f } T{ name f "" "version" f }
T{ name f "" "encoding" f } T{ name f "" "encoding" f }
T{ name f "" "standalone" f } T{ name f "" "standalone" f }
} swap diff } diff
dup empty? [ drop ] [ <extra-attrs> throw ] if ; dup empty? [ drop ] [ <extra-attrs> throw ] if ;
: good-version ( version -- version ) : good-version ( version -- version )

View File

@ -12,7 +12,7 @@ IN: xml
SYMBOL: xml-stack SYMBOL: xml-stack
: <unclosed> ( -- unclosed ) : <unclosed> ( -- unclosed )
xml-stack get 1 tail-slice [ first opener-name ] map xml-stack get rest-slice [ first opener-name ] map
{ set-unclosed-tags } unclosed construct ; { set-unclosed-tags } unclosed construct ;
: add-child ( object -- ) : add-child ( object -- )
@ -93,7 +93,7 @@ M: closer process
: make-xml-doc ( prolog seq -- xml-doc ) : make-xml-doc ( prolog seq -- xml-doc )
dup [ tag? ] find dup [ tag? ] find
>r assure-tags cut 1 tail >r assure-tags cut rest
no-pre/post no-post-tags no-pre/post no-post-tags
r> swap <xml> ; r> swap <xml> ;