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

kernel: new combinator 2with = with with

db4
Björn Lindqvist 2014-07-22 15:09:26 +02:00 committed by John Benediktsson
parent 8c8f58dfee
commit 60ffe0680e
38 changed files with 105 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/combinators/short-circuit/short-circuit.factor
View File

@ -29,8 +29,8 @@ PRIVATE>
: 0&& ( quots -- ? ) [ ] unoptimized-&& ; : 0&& ( quots -- ? ) [ ] unoptimized-&& ;
: 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ; : 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ;
: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ; : 2&& ( obj1 obj2 quots -- ? ) [ 2with ] unoptimized-&& ;
: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ; : 3&& ( obj1 obj2 obj3 quots -- ? ) [ 3 nwith ] unoptimized-&& ;
MACRO: n|| ( quots n -- quot ) MACRO: n|| ( quots n -- quot )
[ [
@ -51,5 +51,5 @@ PRIVATE>
: 0|| ( quots -- ? ) [ ] unoptimized-|| ; : 0|| ( quots -- ? ) [ ] unoptimized-|| ;
: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ; : 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ;
: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ; : 2|| ( obj1 obj2 quots -- ? ) [ 2with ] unoptimized-|| ;
: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ; : 3|| ( obj1 obj2 obj3 quots -- ? ) [ 3 nwith ] unoptimized-|| ;

2
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -44,7 +44,7 @@ IN: compiler.cfg.branch-splitting
: update-successor-predecessors ( copies old-bb -- ) : update-successor-predecessors ( copies old-bb -- )
dup successors>> dup successors>>
[ update-successor-predecessor ] with with each ; [ update-successor-predecessor ] 2with each ;
: split-branch ( bb -- ) : split-branch ( bb -- )
[ new-blocks ] keep [ new-blocks ] keep

2
basis/compiler/cfg/def-use/def-use.factor
View File

@ -109,7 +109,7 @@ SYMBOLS: defs insns ;
: insn-of ( vreg -- insn ) insns get at ; : insn-of ( vreg -- insn ) insns get at ;
: set-def-of ( obj insn assoc -- ) : set-def-of ( obj insn assoc -- )
swap defs-vregs [ swap set-at ] with with each ; swap defs-vregs [ swap set-at ] 2with each ;
: compute-defs ( cfg -- ) : compute-defs ( cfg -- )
H{ } clone [ H{ } clone [

2
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -162,7 +162,7 @@ M: hairy-clobber-insn compute-live-intervals* ( insn -- )
: handle-live-out ( bb -- ) : handle-live-out ( bb -- )
live-out dup assoc-empty? [ drop ] [ live-out dup assoc-empty? [ drop ] [
[ from get to get ] dip keys [ from get to get ] dip keys
[ live-interval add-range ] with with each [ live-interval add-range ] 2with each
] if ; ] if ;
! A location where all registers have to be spilled ! A location where all registers have to be spilled

2
basis/db/tuples/tuples.factor
View File

@ -35,7 +35,7 @@ GENERIC: eval-generator ( singleton -- object )
: query-tuples ( exemplar-tuple statement -- seq ) : query-tuples ( exemplar-tuple statement -- seq )
[ out-params>> ] keep query-results [ [ out-params>> ] keep query-results [
[ sql-row-typed swap resulting-tuple ] with with query-map [ sql-row-typed swap resulting-tuple ] 2with query-map
] with-disposal ; ] with-disposal ;
: query-modify-tuple ( tuple statement -- ) : query-modify-tuple ( tuple statement -- )

2
basis/debugger/debugger-docs.factor
View File

@ -105,7 +105,7 @@ HELP: type-check-error.
{ $error-description "Thrown by various primitives if one of the inputs does not have the expected type. Generic words throw " { $link no-method } " and " { $link no-math-method } " errors in such cases instead." } ; { $error-description "Thrown by various primitives if one of the inputs does not have the expected type. Generic words throw " { $link no-method } " and " { $link no-math-method } " errors in such cases instead." } ;
HELP: divide-by-zero-error. HELP: divide-by-zero-error.
{ $error-description "This error is thrown when " { $link / } " or " { $link /i } " is called with with a zero denominator." } { $error-description "This error is thrown when " { $link / } " or " { $link /i } " is called with a zero denominator." }
{ $see-also "division-by-zero" } ; { $see-also "division-by-zero" } ;
HELP: signal-error. HELP: signal-error.

2
basis/game/input/input.factor
View File

@ -79,7 +79,7 @@ SYMBOLS:
get-controllers [ get-controllers [
[ product-id = ] [ product-id = ]
[ instance-id = ] bi-curry bi* and [ instance-id = ] bi-curry bi* and
] with with find nip ; ] 2with find nip ;
TUPLE: keyboard-state keys ; TUPLE: keyboard-state keys ;

2
basis/io/monitors/recursive/recursive.factor
View File

@ -69,7 +69,7 @@ M: recursive-monitor dispose*
{ +rename-file-new+ [ child-added ] } { +rename-file-new+ [ child-added ] }
[ 3drop ] [ 3drop ]
} case } case
] with with each ; ] 2with each ;
: pump-loop ( -- ) : pump-loop ( -- )
receive { receive {

2
basis/math/functions/functions.factor
View File

@ -410,7 +410,7 @@ M: float round dup sgn 2 /f + truncate ;
: roots ( x t -- seq ) : roots ( x t -- seq )
[ [ log ] [ recip ] bi* * e^ ] [ [ log ] [ recip ] bi* * e^ ]
[ recip 2pi * 0 swap complex boa e^ ] [ recip 2pi * 0 swap complex boa e^ ]
[ iota [ ^ * ] with with map ] tri ; [ iota [ ^ * ] 2with map ] tri ;
: sigmoid ( x -- y ) neg e^ 1 + recip ; inline : sigmoid ( x -- y ) neg e^ 1 + recip ; inline

2
basis/math/vectors/simd/intrinsics/intrinsics.factor
View File

@ -201,7 +201,7 @@ SIMD-INTRINSIC: (simd-vmax) ( a b rep -- c ) [ max ] components-2ma
! XXX ! XXX
SIMD-INTRINSIC: (simd-v.) ( a b rep -- n ) SIMD-INTRINSIC: (simd-v.) ( a b rep -- n )
[ 2byte>rep-array [ [ first ] bi@ * ] 2keep ] keep [ 2byte>rep-array [ [ first ] bi@ * ] 2keep ] keep
1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] with with each ; 1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] 2with each ;
SIMD-INTRINSIC: (simd-vsqrt) ( a rep -- c ) [ fsqrt ] components-map ; SIMD-INTRINSIC: (simd-vsqrt) ( a rep -- c ) [ fsqrt ] components-map ;
SIMD-INTRINSIC: (simd-vsad) ( a b rep -- c ) 2byte>rep-array [ - abs ] [ + ] 2map-reduce ; SIMD-INTRINSIC: (simd-vsad) ( a b rep -- c ) 2byte>rep-array [ - abs ] [ + ] 2map-reduce ;
SIMD-INTRINSIC: (simd-sum) ( a rep -- n ) [ + ] components-reduce ; SIMD-INTRINSIC: (simd-sum) ( a rep -- n ) [ + ] components-reduce ;

2
basis/sorting/insertion/insertion.factor
View File

@ -16,4 +16,4 @@ PRIVATE>
: insertion-sort ( ... seq quot: ( ... elt -- ... elt' ) -- ... ) : insertion-sort ( ... seq quot: ( ... elt -- ... elt' ) -- ... )
! quot is a transformation on elements ! quot is a transformation on elements
over length [ insert ] with with 1 -rot (each-integer) ; inline over length [ insert ] 2with 1 -rot (each-integer) ; inline

2
basis/sorting/slots/slots.factor
View File

@ -16,7 +16,7 @@ IN: sorting.slots
unclip-last-slice unclip-last-slice
[ [ execute-accessor ] each ] dip [ [ execute-accessor ] each ] dip
] when execute-comparator ] when execute-comparator
] with with map-find drop +eq+ or ; ] 2with map-find drop +eq+ or ;
: sort-by-with ( seq sort-specs quot: ( obj -- key ) -- seq' ) : sort-by-with ( seq sort-specs quot: ( obj -- key ) -- seq' )
swap '[ _ bi@ _ compare-slots ] sort ; inline swap '[ _ bi@ _ compare-slots ] sort ; inline

6
basis/typed/typed.factor
View File

@ -1,7 +1,7 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors arrays classes classes.tuple combinators USING: accessors arrays classes classes.tuple combinators
combinators.short-circuit definitions effects fry hints combinators.short-circuit definitions effects fry generalizations
math kernel kernel.private namespaces parser quotations hints math kernel kernel.private namespaces parser quotations
sequences slots words locals effects.parser sequences slots words locals effects.parser
locals.parser macros stack-checker.dependencies locals.parser macros stack-checker.dependencies
classes.maybe classes.algebra ; classes.maybe classes.algebra ;
@ -52,7 +52,7 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
compose compose ; compose compose ;
: make-unboxer ( error-quot word types -- quot ) : make-unboxer ( error-quot word types -- quot )
dup [ unboxer ] with with with dup [ unboxer ] 3 nwith
[ swap \ dip [ ] 2sequence prepend ] map-reduce ; [ swap \ dip [ ] 2sequence prepend ] map-reduce ;
: (unboxed-types) ( type -- types ) : (unboxed-types) ( type -- types )

2
basis/ui/gadgets/menus/menus.factor
View File

@ -57,7 +57,7 @@ M: ---- <menu-item>
] make-corners ; ] make-corners ;
: <commands-menu> ( target hook commands -- menu ) : <commands-menu> ( target hook commands -- menu )
[ <menu-item> ] with with map <menu> ; [ <menu-item> ] 2with map <menu> ;
: show-commands-menu ( target commands -- ) : show-commands-menu ( target commands -- )
[ dup [ ] ] dip <commands-menu> show-menu ; [ dup [ ] ] dip <commands-menu> show-menu ;

2
basis/unicode/collation/collation-tests.factor
View File

@ -13,7 +13,7 @@ IN: unicode.collation.tests
: test-equality ( str1 str2 -- ? ? ? ? ) : test-equality ( str1 str2 -- ? ? ? ? )
{ primary= secondary= tertiary= quaternary= } { primary= secondary= tertiary= quaternary= }
[ execute( a b -- ? ) ] with with map [ execute( a b -- ? ) ] 2with map
first4 ; first4 ;
[ f f f f ] [ "hello" "hi" test-equality ] unit-test [ f f f f ] [ "hello" "hi" test-equality ] unit-test

2
basis/unicode/collation/collation.factor
View File

@ -83,7 +83,7 @@ ducet get-global insert-helpers
: add ( char -- ) : add ( char -- )
dup blocked? [ 1string , ] [ dup blocked? [ 1string , ] [
dup possible-bases dup length iota dup possible-bases dup length iota
[ ?combine ] with with any? [ ?combine ] 2with any?
[ drop ] [ 1string , ] if [ drop ] [ 1string , ] if
] if ; ] if ;

3
basis/vocabs/metadata/resources/resources.factor
View File

@ -40,6 +40,5 @@ PRIVATE>
[ 2drop ] [ [ 2drop ] [
[ [ vocab-dir append-path ] [ vocab-dir-in-root ] bi ] dip [ [ vocab-dir append-path ] [ vocab-dir-in-root ] bi ] dip
[ 2drop make-directories ] [ 2drop make-directories ]
[ [ copy-vocab-resource ] with with each ] 3bi [ [ copy-vocab-resource ] 2with each ] 3bi
] if-empty ; ] if-empty ;

2
core/generic/math/math.factor
View File

@ -118,7 +118,7 @@ M: math-combination perform-combination
drop dup generic-word [ drop dup generic-word [
dup [ over ] [ dup [ over ] [
dup math-class? [ dup math-class? [
[ dup ] [ math-method ] with with math-dispatch-step [ dup ] [ math-method ] 2with math-dispatch-step
] [ ] [
drop object-method drop object-method
] if ] if

2
core/generic/single/single.factor
View File

@ -75,7 +75,7 @@ C: <predicate-engine> predicate-engine
: flatten-method ( method class assoc -- ) : flatten-method ( method class assoc -- )
over flatten-class keys over flatten-class keys
[ swap push-method ] with with with each ; [ swap push-method ] 2with with each ;
: flatten-methods ( assoc -- assoc' ) : flatten-methods ( assoc -- assoc' )
H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ; H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ;

13
core/kernel/kernel-docs.factor
View File

@ -777,9 +777,19 @@ HELP: with
{ $notes "This operation is efficient and does not copy the quotation." } { $notes "This operation is efficient and does not copy the quotation." }
{ $examples { $examples
{ $example "USING: kernel math prettyprint sequences ;" "1 { 1 2 3 } [ / ] with map ." "{ 1 1/2 1/3 }" } { $example "USING: kernel math prettyprint sequences ;" "1 { 1 2 3 } [ / ] with map ." "{ 1 1/2 1/3 }" }
{ $example "USING: kernel math prettyprint sequences ;" "1000 100 5 iota [ sq + + ] with with map ." "{ 1100 1101 1104 1109 1116 }" } { $example "USING: kernel math prettyprint sequences ;" "1000 100 5 iota [ sq + + ] 2with map ." "{ 1100 1101 1104 1109 1116 }" }
} ; } ;
HELP: 2with
{ $values
{ "param1" object }
{ "param1" object }
{ "obj" object }
{ "quot" { $quotation ( param1 param2 elt -- ... ) } }
{ "curry" curry }
}
{ $description "Partial application on the left of two parameters." } ;
HELP: compose HELP: compose
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } } { $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
@ -951,4 +961,3 @@ ARTICLE: "assertions" "Assertions"
assert assert
assert= assert=
} ; } ;

15
core/kernel/kernel-tests.factor
View File

@ -8,6 +8,21 @@ IN: kernel.tests
[ 0 ] [ f size ] unit-test [ 0 ] [ f size ] unit-test
[ t ] [ [ \ = \ = ] all-equal? ] unit-test [ t ] [ [ \ = \ = ] all-equal? ] unit-test
[
{
{ 1 2 0 }
{ 1 2 1 }
{ 1 2 2 }
{ 1 2 3 }
{ 1 2 4 }
{ 1 2 5 }
{ 1 2 6 }
{ 1 2 7 }
{ 1 2 8 }
{ 1 2 9 }
}
] [ 1 2 10 iota [ 3array ] 2with map ] unit-test
! Don't leak extra roots if error is thrown ! Don't leak extra roots if error is thrown
[ ] [ 1000 [ [ 3 throw ] ignore-errors ] times ] unit-test [ ] [ 1000 [ [ 3 throw ] ignore-errors ] times ] unit-test

3
core/kernel/kernel.factor
View File

@ -135,6 +135,9 @@ DEFER: if
: with ( param obj quot -- obj curry ) : with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline swapd [ swapd call ] 2curry ; inline
: 2with ( param1 param2 obj quot -- obj curry )
with with ; inline
: prepose ( quot1 quot2 -- compose ) : prepose ( quot1 quot2 -- compose )
swap compose ; inline swap compose ; inline

10
extra/benchmark/raytracer-simd/raytracer-simd.factor
View File

@ -1,7 +1,7 @@
! Factor port of the raytracer benchmark from ! Factor port of the raytracer benchmark from
! http://www.ffconsultancy.com/languages/ray_tracer/index.html ! http://www.ffconsultancy.com/languages/ray_tracer/index.html
USING: arrays accessors io io.files io.files.temp USING: arrays accessors generalizations io io.files io.files.temp
io.encodings.binary kernel math math.constants math.functions io.encodings.binary kernel math math.constants math.functions
math.vectors math.vectors.simd math.vectors.simd.cords math.vectors math.vectors.simd math.vectors.simd.cords
math.parser make sequences words combinators ; math.parser make sequences words combinators ;
@ -129,7 +129,7 @@ CONSTANT: create-offsets
: create-group ( level c r -- scene ) : create-group ( level c r -- scene )
2dup create-bound [ 2dup create-bound [
2dup <sphere> , 2dup <sphere> ,
create-offsets [ create-step , ] with with with each create-offsets [ create-step , ] 3 nwith each
] make-group ; ] make-group ;
: create ( level c r -- scene ) : create ( level c r -- scene )
@ -145,15 +145,15 @@ CONSTANT: create-offsets
ss-point v+ normalize ss-point v+ normalize
double-4{ 0.0 0.0 -4.0 0.0 } swap <ray> double-4{ 0.0 0.0 -4.0 0.0 } swap <ray>
swap cast-ray + swap cast-ray +
] with with with each ] 3 nwith each
] with with each ; inline no-compile ] 2with each ; inline no-compile
: ray-trace ( scene -- grid ) : ray-trace ( scene -- grid )
size iota <reversed> [ size iota <reversed> [
size iota [ size iota [
[ size 0.5 * - ] bi@ swap size [ size 0.5 * - ] bi@ swap size
0.0 double-4-boa ray-pixel 0.0 double-4-boa ray-pixel
] with with map ] 2with map
] with map ; ] with map ;
: pgm-header ( w h -- ) : pgm-header ( w h -- )

4
extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor
View File

@ -78,12 +78,12 @@ STRUCT: yuv-buffer
: yuv>rgb-row ( index rgb yuv y -- index ) : yuv>rgb-row ( index rgb yuv y -- index )
over stride over stride
pick y_width>> iota pick y_width>> iota
[ yuv>rgb-pixel ] with with with with each ; inline [ yuv>rgb-pixel ] 4 nwith each ; inline
TYPED: yuv>rgb ( rgb: byte-array yuv: yuv-buffer -- ) TYPED: yuv>rgb ( rgb: byte-array yuv: yuv-buffer -- )
[ 0 ] 2dip [ 0 ] 2dip
dup y_height>> iota dup y_height>> iota
[ yuv>rgb-row ] with with each [ yuv>rgb-row ] 2with each
drop ; drop ;
: yuv-to-rgb-benchmark ( -- ) : yuv-to-rgb-benchmark ( -- )

3
extra/boids/simulation/simulation.factor
View File

@ -65,7 +65,7 @@ GENERIC: force ( neighbors boid behaviour -- force )
:: simulate ( boids behaviours dt -- boids ) :: simulate ( boids behaviours dt -- boids )
boids [| boid | boids [| boid |
boid boids behaviours boid boids behaviours
[ [ (force) ] keep weight>> v*n ] with with map vsum :> a [ [ (force) ] keep weight>> v*n ] 2with map vsum :> a
boid vel>> a dt v*n v+ normalize :> vel boid vel>> a dt v*n v+ normalize :> vel
boid pos>> vel dt v*n v+ wrap-pos :> pos boid pos>> vel dt v*n v+ wrap-pos :> pos
@ -98,4 +98,3 @@ M:: separation force ( neighbors boid behaviour -- force )
behaviour radius>> :> r behaviour radius>> :> r
boid pos>> neighbors boid pos>> neighbors
[ pos>> v- [ normalize ] [ r v/n ] bi v- ] with map vsum ; [ pos>> v- [ normalize ] [ r v/n ] bi v- ] with map vsum ;

4
extra/bunny/model/model.factor
View File

@ -30,7 +30,7 @@ IN: bunny.model
vneg normalize ; vneg normalize ;
: normal ( ns vs triple -- ) : normal ( ns vs triple -- )
[ n ] keep [ rot [ v+ ] change-nth ] with with each ; [ n ] keep [ rot [ v+ ] change-nth ] 2with each ;
: normals ( vs is -- ns ) : normals ( vs is -- ns )
[ [ length { 0.0 0.0 0.0 } <array> ] keep ] dip [ [ length { 0.0 0.0 0.0 } <array> ] keep ] dip
@ -55,7 +55,7 @@ CONSTANT: model-url "http://duriansoftware.com/joe/media/bun_zipper.ply"
] each ; ] each ;
: draw-triangles ( ns vs is -- ) : draw-triangles ( ns vs is -- )
GL_TRIANGLES [ [ (draw-triangle) ] with with each ] do-state ; GL_TRIANGLES [ [ (draw-triangle) ] 2with each ] do-state ;
TUPLE: bunny-dlist list ; TUPLE: bunny-dlist list ;
TUPLE: bunny-buffers array element-array nv ni ; TUPLE: bunny-buffers array element-array nv ni ;

4
extra/game/models/collada/collada.factor
View File

@ -129,7 +129,7 @@ VERTEX-FORMAT: collada-vertex-format
[ [
[ data>> ] [ offset>> ] bi [ data>> ] [ offset>> ] bi
rot = [ nth ] [ 2drop f ] if rot = [ nth ] [ 2drop f ] if
] with with map sift flatten , ] 2with map sift flatten ,
] curry each-index ] curry each-index
] V{ } make flatten ; ] V{ } make flatten ;
@ -153,7 +153,7 @@ VERTEX-FORMAT: collada-vertex-format
] bi ; ] bi ;
: mesh>triangles ( sources vertices mesh-tag -- models ) : mesh>triangles ( sources vertices mesh-tag -- models )
"triangles" tags-named [ triangles>model ] with with map ; "triangles" tags-named [ triangles>model ] 2with map ;
: mesh>models ( mesh-tag -- models ) : mesh>models ( mesh-tag -- models )
[ [

3
extra/gml/viewer/viewer.factor
View File

@ -258,7 +258,7 @@ CONSTANT: edge-hitbox-radius 0.05
] [ f ] if ; ] [ f ] if ;
: intersecting-edge-node ( source direction b-rep -- edge/f ) : intersecting-edge-node ( source direction b-rep -- edge/f )
edges>> [ intersects-edge-node? ] with with find nip ; edges>> [ intersects-edge-node? ] 2with find nip ;
: select-edge ( world -- ) : select-edge ( world -- )
[ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ] [ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ]
@ -311,4 +311,3 @@ M: gml-viewer-world wasd-mouse-scale drag?>> -1/600. 0.0 ? ;
_ >>selected _ >>selected
drop drop
] with-ui ; ] with-ui ;

2
extra/graphviz/notation/notation.factor
View File

@ -59,7 +59,7 @@ IN: graphviz.notation
name>> name>>
[ attrs-obj-=attr ] keep [ attrs-obj-=attr ] keep
graph-obj-=attr graph-obj-=attr
] with with each ; ] 2with each ;
PRIVATE> PRIVATE>

2
extra/irc/client/participants/participants.factor
View File

@ -28,7 +28,7 @@ M: irc-channel-chat has-participant? participants>> key? ;
dup participant-chats [ part-participant ] with each ; dup participant-chats [ part-participant ] with each ;
: rename-participant* ( new old -- ) : rename-participant* ( new old -- )
[ dup participant-chats [ rename-participant ] with with each ] [ dup participant-chats [ rename-participant ] 2with each ]
[ dup chat> [ rename-nick-chat ] [ 2drop ] if ] [ dup chat> [ rename-nick-chat ] [ 2drop ] if ]
2bi ; 2bi ;

2
extra/koszul/koszul.factor
View File

@ -163,7 +163,7 @@ DEFER: (d)
swap call [ at 0 or ] curry map ; inline swap call [ at 0 or ] curry map ; inline
: op-matrix ( domain range quot -- matrix ) : op-matrix ( domain range quot -- matrix )
rot [ (op-matrix) ] with with map ; inline rot [ (op-matrix) ] 2with map ; inline
: d-matrix ( domain range -- matrix ) : d-matrix ( domain range -- matrix )
[ (d) ] op-matrix ; [ (d) ] op-matrix ;

4
extra/nurbs/nurbs.factor
View File

@ -32,7 +32,7 @@ TUPLE: nurbs-curve
: order-knot-constants ( curve order -- knot-constants ) : order-knot-constants ( curve order -- knot-constants )
2dup [ knots>> length ] dip - iota 2dup [ knots>> length ] dip - iota
[ order-index-knot-constants ] with with map ; [ order-index-knot-constants ] 2with map ;
: knot-constants ( curve -- knot-constants ) : knot-constants ( curve -- knot-constants )
2 over order>> [a,b] 2 over order>> [a,b]
@ -71,5 +71,3 @@ TUPLE: nurbs-curve
: eval-nurbs ( nurbs-curve t -- value ) : eval-nurbs ( nurbs-curve t -- value )
2dup knot-interval 1 - { 1.0 } 2 (eval-bases) ; 2dup knot-interval 1 - { 1.0 } 2 (eval-bases) ;

3
extra/pcre/pcre.factor
View File

@ -22,9 +22,6 @@ ERROR: pcre-error value ;
: split-subseqs ( seq subseqs -- seqs ) : split-subseqs ( seq subseqs -- seqs )
dup first [ replace-all ] keep split-subseq [ >string ] map harvest ; dup first [ replace-all ] keep split-subseq [ >string ] map harvest ;
: 2with ( param1 param2 obj quot -- obj curry )
[ -rot ] dip [ [ rot ] dip call ] 3curry ; inline
: utf8-start-byte? ( byte -- ? ) : utf8-start-byte? ( byte -- ? )
0xc0 bitand 0x80 = not ; 0xc0 bitand 0x80 = not ;

5
extra/project-euler/265/265.factor
View File

@ -1,6 +1,7 @@
! Copyright (c) 2010 Samuel Tardieu. ! Copyright (c) 2010 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions project-euler.common sequences sets ; USING: generalizations kernel math math.functions project-euler.common
sequences sets ;
IN: project-euler.265 IN: project-euler.265
! http://projecteuler.net/index.php?section=problems&id=265 ! http://projecteuler.net/index.php?section=problems&id=265
@ -51,7 +52,7 @@ CONSTANT: N 5
nip ?register nip ?register
] [ ] [
[ 1 - ] dip [ 1 - ] dip
{ 0 1 } [ add-bit [ iterate ] [ 3drop ] if ] with with with each { 0 1 } [ add-bit [ iterate ] [ 3drop ] if ] 3 nwith each
] if ; ] if ;
: euler265 ( -- answer ) : euler265 ( -- answer )

4
extra/sudoku/sudoku.factor
View File

@ -1,5 +1,5 @@
! Based on http://www.ffconsultancy.com/ocaml/sudoku/index.html ! Based on http://www.ffconsultancy.com/ocaml/sudoku/index.html
USING: columns combinators combinators.short-circuit io USING: columns combinators combinators.short-circuit generalizations io
io.styles kernel math math.parser namespaces sequences ; io.styles kernel math math.parser namespaces sequences ;
IN: sudoku IN: sudoku
@ -17,7 +17,7 @@ SYMBOL: board
: cell-any? ( n x y i -- ? ) 3 /mod pair+ board> = ; : cell-any? ( n x y i -- ? ) 3 /mod pair+ board> = ;
: box-any? ( n x y -- ? ) : box-any? ( n x y -- ? )
[ 3 /i 3 * ] bi@ 9 iota [ cell-any? ] with with with any? ; [ 3 /i 3 * ] bi@ 9 iota [ cell-any? ] 3 nwith any? ;
: board-any? ( n x y -- ? ) : board-any? ( n x y -- ? )
{ [ nip row-any? ] [ drop col-any? ] [ box-any? ] } 3|| ; { [ nip row-any? ] [ drop col-any? ] [ box-any? ] } 3|| ;

2
extra/usa-cities/usa-cities.factor
View File

@ -49,7 +49,7 @@ MEMO: cities-named ( name -- cities )
MEMO: cities-named-in ( name state -- cities ) MEMO: cities-named-in ( name state -- cities )
cities [ cities [
[ name>> = ] [ state>> = ] bi-curry bi* and [ name>> = ] [ state>> = ] bi-curry bi* and
] with with filter ; ] 2with filter ;
: find-zip-code ( code -- city ) : find-zip-code ( code -- city )
cities [ first-zip>> <=> ] with search nip ; cities [ first-zip>> <=> ] with search nip ;

2
extra/window-controls-demo/window-controls-demo.factor
View File

@ -39,6 +39,6 @@ M: window-controls-demo-world pref-dim*
open-window* open-window*
windows >>windows windows >>windows
windows push windows push
] with with assoc-each ; ] 2with assoc-each ;
MAIN: window-controls-demo MAIN: window-controls-demo

4
extra/yaml/yaml.factor
View File

@ -426,7 +426,7 @@ M:: yaml-alias emit-value ( emitter event unused obj -- )
yaml_emitter_emit_asserted ; yaml_emitter_emit_asserted ;
: emit-sequence-body ( emitter event seq -- ) : emit-sequence-body ( emitter event seq -- )
[ emit-object ] with with each ; [ emit-object ] 2with each ;
: emit-assoc-body ( emitter event assoc -- ) : emit-assoc-body ( emitter event assoc -- )
[ [
@ -534,5 +534,5 @@ PRIVATE>
: >yaml-docs ( seq -- str ) : >yaml-docs ( seq -- str )
[ [
[ init-emitter ] dip [ init-emitter ] dip
[ [ replace-identities emit-doc ] with with each ] [ drop flush-emitter ] 3bi [ [ replace-identities emit-doc ] 2with each ] [ drop flush-emitter ] 3bi
] with-destructors ; ] with-destructors ;