data>> first ; inline
: data-exchange ( m n heap -- )
- [ tuck data-nth [ data-nth ] dip ] 3keep
- tuck [ data-set-nth ] 2dip data-set-nth ; inline
+ [ [ data-nth ] curry bi@ ]
+ [ [ data-set-nth ] curry bi@ ] 3bi ; inline
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
: heap-pop-all ( heap -- alist )
[ dup heap-empty? not ]
[ dup heap-pop swap 2array ]
- [ ] produce nip ;
+ produce nip ;
: slurp-heap ( heap quot: ( elt -- ) -- )
over heap-empty? [ 2drop ] [
--- /dev/null
- [ "a" ] [ 1 SBUF" cba" stream-read ] unit-test
- [ "ab" ] [ 2 SBUF" cba" stream-read ] unit-test
- [ "abc" ] [ 3 SBUF" cba" stream-read ] unit-test
- [ "abc" ] [ 4 SBUF" cba" stream-read ] unit-test
+USING: io.streams.string io kernel arrays namespaces make
+tools.test ;
+IN: io.streams.string.tests
+
+[ "line 1" CHAR: l ]
+[
+ "line 1\nline 2\nline 3" <string-reader>
+ dup stream-readln swap stream-read1
+]
+unit-test
+
+[ f ]
+[ "" <string-reader> stream-readln ]
+unit-test
+
+[ "xyzzy" ] [ [ "xyzzy" write ] with-string-writer ] unit-test
+
- 3 SBUF" cba" [ stream-read ] keep stream-read1
++[ "a" ] [ 1 "abc" <string-reader> stream-read ] unit-test
++[ "ab" ] [ 2 "abc" <string-reader> stream-read ] unit-test
++[ "abc" ] [ 3 "abc" <string-reader> stream-read ] unit-test
++[ "abc" ] [ 4 "abc" <string-reader> stream-read ] unit-test
+[ "abc" f ] [
++ 3 "abc" <string-reader> [ stream-read ] keep stream-read1
+] unit-test
+
+[
+ {
+ { "It seems " CHAR: J }
+ { "obs has lost h" CHAR: i }
+ { "s grasp on reality again.\n" f }
+ }
+] [
+ [
+ "It seems Jobs has lost his grasp on reality again.\n"
+ <string-reader> [
+ "J" read-until 2array ,
+ "i" read-until 2array ,
+ "X" read-until 2array ,
+ ] with-input-stream
+ ] { } make
+] unit-test
+
+[ "hello" "hi" ] [
+ "hello\nhi" <string-reader>
+ dup stream-readln
+ 2 rot stream-read
+] unit-test
+
+[ "hello" "hi" ] [
+ "hello\r\nhi" <string-reader>
+ dup stream-readln
+ 2 rot stream-read
+] unit-test
+
+[ "hello" "hi" ] [
+ "hello\rhi" <string-reader>
+ dup stream-readln
+ 2 rot stream-read
+] unit-test
--- /dev/null
- ! Copyright (C) 2003, 2009 Slava Pestov.
++! Copyright (C) 2003, 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io kernel math namespaces sequences sbufs
- strings generic splitting continuations destructors
- io.streams.plain io.encodings math.order growable ;
++strings generic splitting continuations destructors sequences.private
++io.streams.plain io.encodings math.order growable io.streams.sequence ;
+IN: io.streams.string
+
+<PRIVATE
+
- : harden-as ( seq growble-exemplar -- newseq )
- underlying>> like ;
-
- : growable-read-until ( growable n -- str )
- >fixnum dupd tail-slice swap harden-as dup reverse-here ;
-
+SINGLETON: null-encoding
+
+M: null-encoding decode-char drop stream-read1 ;
+
+PRIVATE>
+
+M: growable dispose drop ;
+
+M: growable stream-write1 push ;
+M: growable stream-write push-all ;
+M: growable stream-flush drop ;
+
+: <string-writer> ( -- stream )
+ 512 <sbuf> ;
+
+: with-string-writer ( quot -- str )
+ <string-writer> swap [ output-stream get ] compose with-output-stream*
+ >string ; inline
+
- M: growable stream-read1 [ f ] [ pop ] if-empty ;
-
- : find-last-sep ( seq seps -- n )
- swap [ memq? ] curry find-last drop ;
-
- M: growable stream-read-until
- [ find-last-sep ] keep over [
- [ swap 1+ growable-read-until ] 2keep [ nth ] 2keep
- set-length
- ] [
- [ swap drop 0 growable-read-until f like f ] keep
- delete-all
- ] if ;
++! New implementation
+
- M: growable stream-read
- [
- drop f
- ] [
- [ length swap - 0 max ] keep
- [ swap growable-read-until ] 2keep
- set-length
- ] if-empty ;
++TUPLE: string-reader { underlying string read-only } { i array-capacity } ;
+
- M: growable stream-read-partial
- stream-read ;
++M: string-reader stream-read-partial stream-read ;
++M: string-reader stream-read sequence-read ;
++M: string-reader stream-read1 sequence-read1 ;
++M: string-reader stream-read-until sequence-read-until ;
++M: string-reader dispose drop ;
+
+: <string-reader> ( str -- stream )
- >sbuf dup reverse-here null-encoding <decoder> ;
++ 0 string-reader boa null-encoding <decoder> ;
+
+: with-string-reader ( str quot -- )
+ [ <string-reader> ] dip with-input-stream ; inline
+
+INSTANCE: growable plain-writer
: factor-2s ( n -- r s )
#! factor an integer into 2^r * s
dup 0 = [ 1 ] [
- 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while
+ 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while
] if ; inline
<PRIVATE
[ factor-2s ] dip [ (^n) ] keep rot * shift ;
M: ratio ^n
- [ >fraction ] dip tuck [ ^n ] 2bi@ / ;
+ [ >fraction ] dip [ ^n ] curry bi@ / ;
M: float ^n
(^n) ;
GENERIC: random-bytes* ( n tuple -- byte-array )
M: object random-bytes* ( n tuple -- byte-array )
- [ [ <byte-vector> ] keep 4 /mod ] dip tuck
+ [ [ <byte-vector> ] keep 4 /mod ] dip
[ pick '[ _ random-32* 4 >le _ push-all ] times ]
[
over zero?
[ 2drop ] [ random-32* 4 >le swap head over push-all ] if
- ] 2bi* ;
+ ] bi-curry bi* ;
M: object random-32* ( tuple -- r ) 4 random-bytes* le> ;
: randomize ( seq -- seq )
dup length [ dup 1 > ]
[ [ random ] [ 1- ] bi [ pick exchange ] keep ]
- [ ] while drop ;
+ while drop ;
: delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep delete-nth ;
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models models.filter arrays accessors
+sequences.private assocs models models.arrow arrays accessors
generic generic.standard definitions make sbufs ;
IN: tools.walker
]
} case
] handle-synchronous
- ] [ ] while ;
+ ] while ;
: step-back-msg ( continuation -- continuation' )
walker-history tget
{ step-into-all [ step-into-all-loop ] }
{ abandon [ drop f keep-running ] }
! Pass quotation to debugged thread
- { call-in [ nip keep-running ] }
+ { call-in [ keep-running ] }
! Pass previous continuation to debugged thread
{ step-back [ step-back-msg ] }
} case f
] handle-synchronous
- ] [ ] while ;
+ ] while ;
: walker-loop ( -- )
+running+ set-status
[ walker-suspended ]
} case
] handle-synchronous
- ] [ ] until ;
+ ] until ;
: associate-thread ( walker -- )
walker-thread tset
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs io kernel math models namespaces make
-dlists deques sequences threads sequences words ui.gadgets
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend
-ui.render continuations init combinators hashtables
-concurrency.flags sets accessors calendar call ;
+USING: arrays assocs io kernel math models namespaces make dlists
+deques sequences threads sequences words continuations init call
+combinators hashtables concurrency.flags sets accessors calendar fry
+destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text
+ui.text.private ;
IN: ui
+<PRIVATE
+
! Assoc mapping aliens to gadgets
SYMBOL: windows
: focus-gestures ( new old -- )
drop-prefix <reversed>
- T{ lose-focus } swap each-gesture
- T{ gain-focus } swap each-gesture ;
+ lose-focus swap each-gesture
+ gain-focus swap each-gesture ;
: focus-world ( world -- )
t >>focused?
: reset-world ( world -- )
#! This is used when a window is being closed, but also
#! when restoring saved worlds on image startup.
- [ fonts>> clear-assoc ]
- [ unfocus-world ]
- [ f >>handle drop ] tri ;
+ f >>handle unfocus-world ;
: (ungraft-world) ( world -- )
- [ free-fonts ]
- [ hand-clicked close-global ]
- [ hand-gadget close-global ] tri ;
+ {
+ [ handle>> select-gl-context ]
+ [ text-handle>> dispose ]
+ [ images>> [ dispose ] when* ]
+ [ hand-clicked close-global ]
+ [ hand-gadget close-global ]
+ } cleave ;
M: world ungraft*
[ (ungraft-world) ]
[ handle>> (close-window) ]
[ reset-world ] tri ;
-: find-window ( quot -- world )
- windows get values
- [ gadget-child swap call ] with find-last nip ; inline
-
-SYMBOL: ui-hook
-
: init-ui ( -- )
<dlist> \ graft-queue set-global
<dlist> \ layout-queue set-global
children>> [ restore-gadget ] each ;
: restore-world ( world -- )
- dup reset-world restore-gadget ;
-
-: restore-windows ( -- )
- windows get [ values ] keep delete-all
- [ restore-world ] each
- forget-rollover ;
-
-: restore-windows? ( -- ? )
- windows get empty? not ;
+ {
+ [ reset-world ]
+ [ init-text-rendering ]
+ [ f >>images drop ]
+ [ restore-gadget ]
+ } cleave ;
: update-hand ( world -- )
dup hand-world get-global eq?
: redraw-worlds ( seq -- )
[ dup update-hand draw-world ] each ;
-: notify ( gadget -- )
- dup graft-state>>
- [ first { f f } { t t } ? >>graft-state ] keep
- {
- { { f t } [ dup activate-control graft* ] }
- { { t f } [ dup deactivate-control ungraft* ] }
- } case ;
-
-: notify-queued ( -- )
- graft-queue [ notify ] slurp-deque ;
-
: send-queued-gestures ( -- )
gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
: update-ui ( -- )
[
- [
- notify-queued
- layout-queued
- redraw-worlds
- send-queued-gestures
- ] call( -- )
+ notify-queued
+ layout-queued
+ redraw-worlds
+ send-queued-gestures
] [ ui-error ] recover ;
SYMBOL: ui-thread
t \ ui-running set-global
[ f \ ui-running set-global ] [ ] cleanup ; inline
+PRIVATE>
+
+: find-window ( quot -- world )
+ windows get values
+ [ gadget-child swap call ] with find-last nip ; inline
+
: ui-running? ( -- ? )
\ ui-running get-global ;
+<PRIVATE
+
: update-ui-loop ( -- )
[ ui-running? ui-thread get-global self eq? and ]
[ ui-notify-flag get lower-flag update-ui ]
- [ ] while ;
+ while ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]
"UI update" spawn drop ;
+: start-ui ( quot -- )
+ call notify-ui-thread start-ui-thread ;
+
+: restore-windows ( -- )
+ [
+ windows get [ values ] [ delete-all ] bi
+ [ restore-world ] each
+ forget-rollover
+ ] (with-ui) ;
+
+: restore-windows? ( -- ? )
+ windows get empty? not ;
+
+PRIVATE>
+
: open-world-window ( world -- )
dup pref-dim >>dim dup relayout graft ;
M: object close-window
find-world [ ungraft ] when* ;
-: start-ui ( -- )
- restore-windows? [
- restore-windows
- ] [
- init-ui ui-hook get call
- ] if
- notify-ui-thread start-ui-thread ;
-
[
f \ ui-running set-global
<flag> ui-notify-flag set-global
] "ui" add-init-hook
-HOOK: ui ui-backend ( -- )
-
-MAIN: ui
-
: with-ui ( quot -- )
- ui-running? [
- call
- ] [
- f windows set-global
- [
- ui-hook set
- ui
- ] with-scope
- ] if ;
+ ui-running? [ call ] [ '[ init-ui @ ] (with-ui) ] if ;
+
+HOOK: beep ui-backend ( -- )
}
} ;
+HELP: bi-curry
+{ $values { "x" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( x -- ... )" } } { "p'" { $snippet "[ x p ]" } } { "q'" { $snippet "[ x q ]" } } }
+{ $description "Partially applies " { $snippet "p" } " and " { $snippet "q" } " to " { $snippet "x" } "." }
+{ $notes
+ "The following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] bi-curry [ call ] bi@"
+ "[ p ] [ q ] bi"
+ }
+ "Higher-arity variants of " { $link bi } " can be built from " { $link bi-curry } ":"
+ { $code
+ "[ p ] [ q ] bi-curry bi == [ p ] [ q ] 2bi"
+ "[ p ] [ q ] bi-curry bi-curry bi == [ p ] [ q ] 3bi"
+ }
+ "The combination " { $snippet "bi-curry bi*" } " cannot be expressed with the non-currying dataflow combinators alone; it is equivalent to a stack shuffle preceding " { $link 2bi* } ":"
+ { $code
+ "[ p ] [ q ] bi-curry bi*"
+ "[ swap ] keep [ p ] [ q ] 2bi*"
+ }
+ "To put it another way, " { $snippet "bi-curry bi*" } " handles the case where you have three values " { $snippet "a b c" } " on the stack, and you wish to apply " { $snippet "p" } " to " { $snippet "a c" } " and " { $snippet "q" } " to " { $snippet "b c" } "."
+} ;
+
+HELP: tri-curry
+{ $values
+ { "x" object }
+ { "p" { $quotation "( x -- ... )" } }
+ { "q" { $quotation "( x -- ... )" } }
+ { "r" { $quotation "( x -- ... )" } }
+ { "p'" { $snippet "[ x p ]" } }
+ { "q'" { $snippet "[ x q ]" } }
+ { "r'" { $snippet "[ x r ]" } }
+}
+{ $description "Partially applies " { $snippet "p" } ", " { $snippet "q" } " and " { $snippet "r" } " to " { $snippet "x" } "." }
+{ $notes
+ "The following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] tri-curry [ call ] tri@"
+ "[ p ] [ q ] [ r ] tri"
+ }
+ "Higher-arity variants of " { $link tri } " can be built from " { $link tri-curry } ":"
+ { $code
+ "[ p ] [ q ] [ r ] tri-curry tri == [ p ] [ q ] [ r ] 2tri"
+ "[ p ] [ q ] [ r ] tri-curry tri-curry bi == [ p ] [ q ] [ r ] 3tri"
+ }
+ "The combination " { $snippet "tri-curry tri*" } " cannot be expressed with the non-currying dataflow combinators alone; it handles the case where you have four values " { $snippet "a b c d" } " on the stack, and you wish to apply " { $snippet "p" } " to " { $snippet "a d" } ", " { $snippet "q" } " to " { $snippet "b d" } " and " { $snippet "r" } " to " { $snippet "c d" } "." } ;
+
+HELP: bi-curry*
+{ $values { "x" object } { "y" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( y -- ... )" } } { "p'" { $snippet "[ x p ]" } } { "q'" { $snippet "[ y q ]" } } }
+{ $description "Partially applies " { $snippet "p" } " to " { $snippet "x" } ", and " { $snippet "q" } " to " { $snippet "y" } "." }
+{ $notes
+ "The following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] bi-curry* [ call ] bi@"
+ "[ p ] [ q ] bi*"
+ }
+ "The combination " { $snippet "bi-curry* bi" } " is equivalent to a stack shuffle preceding " { $link 2bi* } ":"
+ { $code
+ "[ p ] [ q ] bi-curry* bi"
+ "[ over ] dip [ p ] [ q ] 2bi*"
+ }
+ "In other words, " { $snippet "bi-curry* bi" } " handles the case where you have the three values " { $snippet "a b c" } " on the stack, and you wish to apply " { $snippet "p" } " to " { $snippet "a b" } " and " { $snippet "q" } " to " { $snippet "a c" } "."
+ $nl
+ "The combination " { $snippet "bi-curry* bi*" } " is equivalent to a stack shuffle preceding " { $link 2bi* } ":"
+ { $code
+ "[ p ] [ q ] bi-curry* bi*"
+ "[ swap ] dip [ p ] [ q ] 2bi*"
+ }
+ "In other words, " { $snippet "bi-curry* bi*" } " handles the case where you have the four values " { $snippet "a b c d" } " on the stack, and you wish to apply " { $snippet "p" } " to " { $snippet "a c" } " and " { $snippet "q" } " to " { $snippet "b d" } "."
+
+} ;
+
+HELP: tri-curry*
+{ $values
+ { "x" object }
+ { "y" object }
+ { "z" object }
+ { "p" { $quotation "( x -- ... )" } }
+ { "q" { $quotation "( y -- ... )" } }
+ { "r" { $quotation "( z -- ... )" } }
+ { "p'" { $snippet "[ x p ]" } }
+ { "q'" { $snippet "[ y q ]" } }
+ { "r'" { $snippet "[ z r ]" } }
+}
+{ $description "Partially applies " { $snippet "p" } " to " { $snippet "x" } ", " { $snippet "q" } " to " { $snippet "y" } " and " { $snippet "r" } " to " { $snippet "z" } "." }
+{ $notes
+ "The following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] tri-curry* [ call ] tri@"
+ "[ p ] [ q ] [ r ] tri*"
+ }
+ "The combination " { $snippet "tri-curry* tri" } " is equivalent to a stack shuffle preceding " { $link 2tri* } ":"
+ { $code
+ "[ p ] [ q ] [ r ] tri-curry* tri"
+ "[ [ over ] dip over ] dip [ p ] [ q ] [ r ] 2tri*"
+ }
+} ;
+
+HELP: bi-curry@
+{ $values { "x" object } { "y" object } { "q" { $quotation "( obj -- ... )" } } { "p'" { $snippet "[ x q ]" } } { "q'" { $snippet "[ y q ]" } } }
+{ $description "Partially applies " { $snippet "q" } " to " { $snippet "x" } " and " { $snippet "y" } "." }
+{ $notes
+ "The following two lines are equivalent:"
+ { $code
+ "[ q ] bi-curry@"
+ "[ q ] [ q ] bi-curry*"
+ }
+} ;
+
+HELP: tri-curry@
+{ $values
+ { "x" object }
+ { "y" object }
+ { "z" object }
+ { "q" { $quotation "( obj -- ... )" } }
+ { "p'" { $snippet "[ x q ]" } }
+ { "q'" { $snippet "[ y q ]" } }
+ { "r'" { $snippet "[ z q ]" } }
+}
+{ $description "Partially applies " { $snippet "q" } " to " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } "." }
+{ $notes
+ "The following two lines are equivalent:"
+ { $code
+ "[ q ] tri-curry@"
+ "[ q ] [ q ] [ q ] tri-curry*"
+ }
+} ;
+
HELP: if
{ $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } }
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation."
} ;
HELP: while
- { $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+ { $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ;
HELP: until
- { $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+ { $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link t } "." } ;
HELP: do
- { $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+ { $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
{ $description "Executes one iteration of a " { $link while } " or " { $link until } " loop." } ;
HELP: loop
"In most cases, loops should be written using high-level combinators (such as " { $link "sequences-combinators" } ") or tail recursion. However, sometimes, the best way to express intent is with a loop."
{ $subsection while }
{ $subsection until }
- "The above two combinators take a " { $snippet "tail" } " quotation. Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
- { $code
- "[ P ] [ Q ] [ T ] while"
- "[ P ] [ Q ] [ ] while T"
- }
- "However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference."
- $nl
"To execute one iteration of a loop, use the following word:"
{ $subsection do }
"This word is intended as a modifier. The normal " { $link while } " loop never executes the body if the predicate returns first on the first iteration. To ensure the body executes at least once, use " { $link do } ":"
{ $code
- "[ P ] [ Q ] [ T ] do while"
+ "[ P ] [ Q ] do while"
}
"A simpler looping combinator which executes a single quotation until it returns " { $link f } ":"
{ $subsection loop } ;
{ $subsection 2keep }
{ $subsection 3keep } ;
+ARTICLE: "curried-dataflow" "Curried dataflow combinators"
+"Curried cleave combinators:"
+{ $subsection bi-curry }
+{ $subsection tri-curry }
+"Curried spread combinators:"
+{ $subsection bi-curry* }
+{ $subsection tri-curry* }
+"Curried apply combinators:"
+{ $subsection bi-curry@ }
+{ $subsection tri-curry@ }
+{ $see-also "dataflow-combinators" } ;
+
+ARTICLE: "compositional-examples" "Examples of compositional combinator usage"
+"Consider printing the same message ten times:"
+{ $code ": print-10 ( -- ) 10 [ \"Hello, world.\" print ] times ;" }
+"if we wanted to abstract out the message into a parameter, we could keep it on the stack between iterations:"
+{ $code ": print-10 ( message -- ) 10 [ dup print ] times drop ;" }
+"However, keeping loop-invariant values on the stack doesn't always work out nicely. For example, a word to subtract a value from each element of a sequence:"
+{ $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" }
+"Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":"
+{ $example
+ "USING: kernel math prettyprint sequences ;"
+ ": subtract-n ( seq n -- seq' ) [ - ] curry map ;"
+ "{ 10 20 30 } 5 subtract-n ."
+ "{ 5 15 25 }"
+}
+"Now consider the word that is dual to the one above; instead of subtracting " { $snippet "n" } " from each stack element, it subtracts each element from " { $snippet "n" } "."
+$nl
+"One way to write this is with a pair of " { $link swap } "s:"
+{ $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" }
+"Since this pattern comes up often, " { $link with } " encapsulates it:"
+{ $example
+ "USING: kernel math prettyprint sequences ;"
+ ": n-subtract ( n seq -- seq' ) [ - ] with map ;"
+ "30 { 10 20 30 } n-subtract ."
+ "{ 20 10 0 }"
+}
+{ $see-also "fry.examples" } ;
+
ARTICLE: "compositional-combinators" "Compositional combinators"
-"Quotations can be composed using efficient quotation-specific operations:"
+"Certain combinators transform quotations to produce a new quotation."
+{ $subsection "compositional-examples" }
+"Fundamental operations:"
{ $subsection curry }
+{ $subsection compose }
+"Derived operations:"
{ $subsection 2curry }
{ $subsection 3curry }
{ $subsection with }
-{ $subsection compose }
{ $subsection prepose }
-"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
+"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words."
+$nl
+"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways."
+{ $subsection "curried-dataflow" }
+"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ;
ARTICLE: "implementing-combinators" "Implementing combinators"
"The following pair of words invoke words and quotations reflectively:"
{ $subsection "slip-keep-combinators" }
{ $subsection "cleave-combinators" }
{ $subsection "spread-combinators" }
-{ $subsection "apply-combinators" } ;
+{ $subsection "apply-combinators" }
+{ $see-also "curried-dataflow" } ;
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
M: fixnum bit? neg shift 1 bitand 0 > ;
: fixnum-log2 ( x -- n )
- 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] until drop ;
+ 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] until drop ;
M: fixnum (log2) fixnum-log2 ;
: pre-scale ( num den -- scale shifted-num scaled-den )
2dup [ log2 ] bi@ -
- tuck [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] 2bi*
+ [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] bi-curry bi*
-rot ; inline
! Second step: loop
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ]
[ [ shift-mantissa ] dip ]
- [ ] while /mod ; inline
+ while /mod ; inline
! Third step: post-scaling
: unscaled-float ( mantissa -- n )
{ $side-effects "seq" } ;
HELP: replace-slice
-{ $values { "new" sequence } { "seq" "a mutable sequence" } { "from" "a non-negative integer" } { "to" "a non-negative integer" } }
+{ $values { "new" sequence } { "seq" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq'" sequence } }
{ $description "Replaces a range of elements beginning at index " { $snippet "from" } " and ending before index " { $snippet "to" } " with a new sequence." }
-{ $notes "If the " { $snippet "to - from" } " is equal to the length of " { $snippet "new" } ", the sequence remains the same size, and does not have to support resizing. However, if " { $snippet "to - from" } " is not equal to the length of " { $snippet "new" } ", the " { $link set-length } " word is called on " { $snippet "seq" } ", so fixed-size sequences should not be passed in this case." }
-{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." }
-{ $side-effects "seq" } ;
+{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." } ;
{ push prefix suffix } related-words
{ $errors "Throws an error if the sequence is empty." } ;
HELP: produce
- { $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } }
+ { $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
{ $examples
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
- { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] produce nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
- "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link produce } " call:"
- { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] produce ." "{ 8 2 2 9 }" }
+ { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] produce nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
+ "The following example collects random numbers as long as they are greater than 1:"
+ { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] produce nip ." "{ 8 2 2 9 }" }
} ;
HELP: produce-as
- { $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "tail" "a quotation" } { "exemplar" sequence } { "seq" "a sequence" } }
+ { $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "exemplar" sequence } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence of type " { $snippet "exemplar" } " at the end." }
- { $examples
- "The following example divides a number by two until we reach zero, and accumulates intermediate results:"
- { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] V{ } produce-as nip ." "V{ 668 334 167 83 41 20 10 5 2 1 0 }" }
- "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link produce } " call:"
- { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] B{ } produce-as ." "B{ 8 2 2 9 }" }
- } ;
+ { $examples "See " { $link produce } " for examples." } ;
HELP: sigma
{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
{ $subsection unclip-last-slice }
{ $subsection cut-slice }
"A utility for words which use slices as iterators:"
-{ $subsection <flat-slice> } ;
+{ $subsection <flat-slice> }
+"Replacing slices with new elements:"
+{ $subsection replace-slice } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
"Iteration:"
{ $subsection move }
{ $subsection exchange }
{ $subsection copy }
-{ $subsection replace-slice }
"Many operations have constructive and destructive variants:"
{ $table
{ "Constructive" "Destructive" }
[ first3-unsafe ] [ 3 swap nth-unsafe ] bi ; inline
: exchange-unsafe ( m n seq -- )
- [ tuck [ nth-unsafe ] 2bi@ ]
- [ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline
+ [ [ nth-unsafe ] curry bi@ ]
+ [ [ set-nth-unsafe ] curry bi@ ] 3bi ; inline
: (head) ( seq n -- from to seq ) [ 0 ] 2dip swap ; inline
{ seq read-only } ;
: collapse-slice ( m n slice -- m' n' seq )
- [ from>> ] [ seq>> ] bi [ tuck [ + ] 2bi@ ] dip ; inline
+ [ from>> ] [ seq>> ] bi [ [ + ] curry bi@ ] dip ; inline
ERROR: slice-error from to seq reason ;
PRIVATE>
: subseq ( from to seq -- subseq )
- [ check-slice prepare-subseq (copy) ] [ like ] bi ;
+ [ check-slice prepare-subseq (copy) ] keep like ;
: head ( seq n -- headseq ) (head) subseq ;
[ (each) ] dip collect ; inline
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
- [ over ] dip [ nth-unsafe ] 2bi@ ; inline
+ [ nth-unsafe ] bi-curry@ bi ; inline
: (2each) ( seq1 seq2 quot -- n quot' )
[
] dip compose ; inline
: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 )
- [ over ] 2dip [ over ] dip [ nth-unsafe ] 2tri@ ; inline
+ [ nth-unsafe ] tri-curry@ tri ; inline
: (3each) ( seq1 seq2 seq3 quot -- n quot' )
[
- [ [ length ] tri@ min min ] 3keep
- [ 3nth-unsafe ] 3curry
+ [ [ length ] tri@ min min ]
+ [ [ 3nth-unsafe ] 3curry ] 3bi
] dip compose ; inline
: finish-find ( i seq -- i elt )
[ 2drop f f ]
if ; inline
-: (interleave) ( n elt between quot -- )
- roll 0 = [ nip ] [ swapd 2slip ] if call ; inline
-
PRIVATE>
: each ( seq quot -- )
over map-into ; inline
: accumulate ( seq identity quot -- final newseq )
- swapd [ pick slip ] curry map ; inline
+ swapd [ [ call ] [ 2drop ] 3bi ] curry map ; inline
: 2each ( seq1 seq2 quot -- )
(2each) each-integer ; inline
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
: partition ( seq quot -- trueseq falseseq )
- over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline
-
-: interleave ( seq between quot -- )
- [ (interleave) ] 2curry [ [ length ] keep ] dip 2each ; inline
+ over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline
: accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
- : produce-as ( pred quot tail exemplar -- seq )
- [ swap accumulator [ swap while ] dip ] dip like ; inline
+ : produce-as ( pred quot exemplar -- seq )
+ [ accumulator [ while ] dip ] dip like ; inline
- : produce ( pred quot tail -- seq )
+ : produce ( pred quot -- seq )
{ } produce-as ; inline
: follow ( obj quot -- seq )
- [ dup ] swap [ keep ] curry [ ] produce nip ; inline
+ [ dup ] swap [ keep ] curry produce nip ; inline
: prepare-index ( seq quot -- seq n quot )
[ dup length ] dip ; inline
: each-index ( seq quot -- )
prepare-index 2each ; inline
+: interleave ( seq between quot -- )
+ swap [ drop ] [ [ 2dip call ] 2curry ] 2bi
+ [ [ 0 = ] 2dip if ] 2curry
+ each-index ; inline
+
: map-index ( seq quot -- )
prepare-index 2map ; inline
[ over - ] 2dip move-backward
] if ;
-PRIVATE>
-
: open-slice ( shift from seq -- )
pick 0 = [
3drop
set-length
] if ;
+PRIVATE>
+
: delete-slice ( from to seq -- )
check-slice [ over [ - ] dip ] dip open-slice ;
: delete-nth ( n seq -- )
[ dup 1+ ] dip delete-slice ;
-: replace-slice ( new from to seq -- )
- [ [ [ dup pick length + ] dip - over ] dip open-slice ] keep
- copy ;
+: snip ( from to seq -- head tail )
+ [ swap head ] [ swap tail ] bi-curry bi* ; inline
+
+: snip-slice ( from to seq -- head tail )
+ [ swap head-slice ] [ swap tail-slice ] bi-curry bi* ; inline
+
+: replace-slice ( new from to seq -- seq' )
+ snip-slice surround ;
: remove-nth ( n seq -- seq' )
- [ swap head-slice ] [ swap 1+ tail-slice ] 2bi append ;
+ [ [ { } ] dip dup 1+ ] dip replace-slice ;
: pop ( seq -- elt )
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
: exchange ( m n seq -- )
- pick over bounds-check 2drop 2dup bounds-check 2drop
- exchange-unsafe ;
+ [ nip bounds-check 2drop ]
+ [ bounds-check 3drop ]
+ [ exchange-unsafe ]
+ 3tri ;
: reverse-here ( seq -- )
- dup length dup 2/ [
- [ 2dup ] dip
- tuck - 1- rot exchange-unsafe
- ] each 2drop ;
+ [ length 2/ ] [ length ] [ ] tri
+ [ [ over - 1- ] dip exchange-unsafe ] 2curry each ;
: reverse ( seq -- newseq )
[
: join ( seq glue -- newseq )
[
- 2dup joined-length over new-resizable spin
- [ dup pick push-all ] [ pick push-all ] interleave drop
+ 2dup joined-length over new-resizable [
+ [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
+ interleave
+ ] keep
] keep like ;
: padding ( seq n elt quot -- newseq )
: drop-prefix ( seq1 seq2 -- slice1 slice2 )
2dup mismatch [ 2dup min-length ] unless*
- tuck [ tail-slice ] 2bi@ ;
+ [ tail-slice ] curry bi@ ;
: unclip ( seq -- rest first )
[ rest ] [ first-unsafe ] bi ;
[ but-last-slice ] [ peek ] bi ; inline
: <flat-slice> ( seq -- slice )
- dup slice? [ { } like ] when 0 over length rot <slice> ;
+ dup slice? [ { } like ] when
+ [ drop 0 ] [ length ] [ ] tri <slice> ;
inline
-: trim-head-slice ( seq quot -- slice )
- over [ [ not ] compose find drop ] dip swap
- [ tail-slice ] [ dup length tail-slice ] if* ; inline
+<PRIVATE
+: (trim-head) ( seq quot -- seq n )
+ over [ [ not ] compose find drop ] dip
+ [ length or ] keep swap ; inline
+
+: (trim-tail) ( seq quot -- seq n )
+ over [ [ not ] compose find-last drop ?1+ ] dip
+ swap ; inline
+
+PRIVATE>
+
+: trim-head-slice ( seq quot -- slice )
+ (trim-head) tail-slice ; inline
+
: trim-head ( seq quot -- newseq )
- over [ trim-head-slice ] dip like ; inline
+ (trim-head) tail ; inline
: trim-tail-slice ( seq quot -- slice )
- over [ [ not ] compose find-last drop ] dip swap
- [ 1+ head-slice ] [ 0 head-slice ] if* ; inline
+ (trim-tail) head-slice ; inline
: trim-tail ( seq quot -- newseq )
- over [ trim-tail-slice ] dip like ; inline
+ (trim-tail) head ; inline
: trim-slice ( seq quot -- slice )
[ trim-head-slice ] [ trim-tail-slice ] bi ; inline
: trim ( seq quot -- newseq )
- over [ trim-slice ] dip like ; inline
+ [ trim-slice ] [ drop ] 2bi like ; inline
: sum ( seq -- n ) 0 [ + ] binary-reduce ;
: product ( seq -- n ) 1 [ * ] binary-reduce ;
-: infimum ( seq -- n ) dup first [ min ] reduce ;
+: infimum ( seq -- n ) [ ] [ min ] map-reduce ;
-: supremum ( seq -- n ) dup first [ max ] reduce ;
+: supremum ( seq -- n ) [ ] [ max ] map-reduce ;
-: sigma ( seq quot -- n ) [ 0 ] 2dip [ rot slip + ] curry each ; inline
+: sigma ( seq quot -- n )
+ [ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
: sort-loop ( merge quot -- )
[ 2 [ over seq>> length over > ] ] dip
[ [ 1 shift 2dup ] dip sort-pass ] curry
- [ ] while 2drop ; inline
+ while 2drop ; inline
: each-pair ( seq quot -- )
[ [ length 1+ 2/ ] keep ] dip
[ drop nip nth ] dip push
] [
[
- [ tuck [ nth-unsafe ] 2bi@ 2dup ] dip call +gt+ eq?
+ [ [ nth-unsafe ] curry bi@ 2dup ] dip call +gt+ eq?
[ swap ] when
- ] dip tuck [ push ] 2bi@
+ ] dip [ push ] curry bi@
] if ; inline
: sort-pairs ( merge quot -- )
USING: alien.syntax alien.c-types core-foundation
-core-foundation.bundles system combinators kernel sequences
-debugger io accessors ;
+core-foundation.bundles core-foundation.dictionaries system
+combinators kernel sequences debugger io accessors ;
IN: iokit
<<
IOObjectRelease mach-error ;
: io-objects-from-iterator* ( i -- i array )
- [ dup IOIteratorNext dup MACH_PORT_NULL = not ]
- [ ]
- [ drop ] produce ;
+ [ dup IOIteratorNext dup MACH_PORT_NULL = not ] [ ] produce nip ;
: io-objects-from-iterator ( i -- array )
io-objects-from-iterator* [ release-io-object ] dip ;
projects / factor.git / commitdiff