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-&& ;
: 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ;
: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ;
: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ;
: 2&& ( obj1 obj2 quots -- ? ) [ 2with ] unoptimized-&& ;
: 3&& ( obj1 obj2 obj3 quots -- ? ) [ 3 nwith ] unoptimized-&& ;
MACRO: n|| ( quots n -- quot )
[
@ -51,5 +51,5 @@ PRIVATE>
: 0|| ( quots -- ? ) [ ] unoptimized-|| ;
: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ;
: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ;
: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ;
: 2|| ( obj1 obj2 quots -- ? ) [ 2with ] 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 -- )
dup successors>>
[ update-successor-predecessor ] with with each ;
[ update-successor-predecessor ] 2with each ;
: split-branch ( bb -- )
[ 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 ;
: 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 -- )
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 -- )
live-out dup assoc-empty? [ drop ] [
[ from get to get ] dip keys
[ live-interval add-range ] with with each
[ live-interval add-range ] 2with each
] if ;
! A location where all registers have to be spilled

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

@ -35,9 +35,9 @@ GENERIC: eval-generator ( singleton -- object )
: query-tuples ( exemplar-tuple statement -- seq )
[ 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 ;
: query-modify-tuple ( tuple statement -- )
[ query-results [ sql-row-typed ] with-disposal ] keep
out-params>> rot [

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." } ;
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" } ;
HELP: signal-error.

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

@ -45,7 +45,7 @@ ERROR: game-input-not-open ;
: open-game-input ( -- )
game-input-opened? [
(open-game-input)
(open-game-input)
] unless
game-input-opened [ 1 + ] change-global
reset-mouse ;
@ -55,7 +55,7 @@ ERROR: game-input-not-open ;
1 -
] change-global
game-input-opened? [
(close-game-input)
(close-game-input)
reset-game-input
] unless ;
@ -79,7 +79,7 @@ SYMBOLS:
get-controllers [
[ product-id = ]
[ instance-id = ] bi-curry bi* and
] with with find nip ;
] 2with find nip ;
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 ] }
[ 3drop ]
} case
] with with each ;
] 2with each ;
: pump-loop ( -- )
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 )
[ [ log ] [ recip ] bi* * 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

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

@ -160,7 +160,7 @@ PRIVATE>
SIMD-INTRINSIC: (simd-v+) ( a b rep -- c ) [ + ] components-2map ;
SIMD-INTRINSIC: (simd-v-) ( a b rep -- c ) [ - ] components-2map ;
SIMD-INTRINSIC: (simd-vneg) ( a rep -- c ) [ neg ] components-map ;
SIMD-INTRINSIC:: (simd-v+-) ( a b rep -- c )
SIMD-INTRINSIC:: (simd-v+-) ( a b rep -- c )
a b rep 2byte>rep-array :> ( a' b' )
rep <rep-array> :> c'
0 rep rep-length [ 1 - 2 <range> ] [ 2 /i ] bi [| n |
@ -201,7 +201,7 @@ SIMD-INTRINSIC: (simd-vmax) ( a b rep -- c ) [ max ] components-2ma
! XXX
SIMD-INTRINSIC: (simd-v.) ( a b rep -- n )
[ 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-vsad) ( a b rep -- c ) 2byte>rep-array [ - abs ] [ + ] 2map-reduce ;
SIMD-INTRINSIC: (simd-sum) ( a rep -- n ) [ + ] components-reduce ;
@ -245,7 +245,7 @@ SIMD-INTRINSIC:: (simd-vmerge-tail) ( a b rep -- c )
] unrolled-each-integer
c' underlying>> ;
SIMD-INTRINSIC: (simd-v<=) ( a b rep -- c )
dup rep-tf-values '[ <= _ _ ? ] components-2map ;
dup rep-tf-values '[ <= _ _ ? ] components-2map ;
SIMD-INTRINSIC: (simd-v<) ( a b rep -- c )
dup rep-tf-values '[ < _ _ ? ] components-2map ;
SIMD-INTRINSIC: (simd-v=) ( a b rep -- c )
@ -276,14 +276,14 @@ SIMD-INTRINSIC: (simd-vpack-unsigned) ( a b rep -- c )
[ [ 2byte>rep-array cord-append ] [ rep-length 2 * ] bi ]
[ narrow-vector-rep >uint-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
'[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
SIMD-INTRINSIC: (simd-vunpack-head) ( a rep -- c )
SIMD-INTRINSIC: (simd-vunpack-head) ( a rep -- c )
[ byte>rep-array ] [ widen-vector-rep [ rep-length ] [ '[ _ >rep-array ] ] bi ] bi
[ head-slice ] dip call( a' -- c' ) underlying>> ;
SIMD-INTRINSIC: (simd-vunpack-tail) ( a rep -- c )
[ byte>rep-array ] [ widen-vector-rep [ rep-length ] [ '[ _ >rep-array ] ] bi ] bi
[ tail-slice ] dip call( a' -- c' ) underlying>> ;
SIMD-INTRINSIC: (simd-with) ( n rep -- v )
[ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as
[ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as
underlying>> ;
SIMD-INTRINSIC: (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn-unsafe ] keep underlying>> ;
SIMD-INTRINSIC: (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn-unsafe ] keep underlying>> ;

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

@ -16,4 +16,4 @@ PRIVATE>
: insertion-sort ( ... seq quot: ( ... elt -- ... elt' ) -- ... )
! 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
[ [ execute-accessor ] each ] dip
] 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' )
swap '[ _ bi@ _ compare-slots ] sort ; inline

10
basis/typed/typed.factor
View File

@ -1,7 +1,7 @@
! (c)Joe Groff bsd license
USING: accessors arrays classes classes.tuple combinators
combinators.short-circuit definitions effects fry hints
math kernel kernel.private namespaces parser quotations
combinators.short-circuit definitions effects fry generalizations
hints math kernel kernel.private namespaces parser quotations
sequences slots words locals effects.parser
locals.parser macros stack-checker.dependencies
classes.maybe classes.algebra ;
@ -52,7 +52,7 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
compose compose ;
: make-unboxer ( error-quot word types -- quot )
dup [ unboxer ] with with with
dup [ unboxer ] 3 nwith
[ swap \ dip [ ] 2sequence prepend ] map-reduce ;
: (unboxed-types) ( type -- types )
@ -128,7 +128,7 @@ M: typed-gensym where parent-word where ;
[ 2nip ] 3tri define-declared ;
MACRO: typed ( quot word effect -- quot' )
[ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
[ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
[
nip effect-out-types dup typed-stack-effect?
[ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
@ -152,7 +152,7 @@ M: typed-word subwords
PRIVATE>
: define-typed ( word def effect -- )
[ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
[ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
[ drop "typed-def" set-word-prop ]
[ 2drop "typed-word" word-prop set-last-word ] 3tri ;

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

@ -57,7 +57,7 @@ M: ---- <menu-item>
] make-corners ;
: <commands-menu> ( target hook commands -- menu )
[ <menu-item> ] with with map <menu> ;
[ <menu-item> ] 2with map <menu> ;
: show-commands-menu ( target commands -- )
[ 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 -- ? ? ? ? )
{ primary= secondary= tertiary= quaternary= }
[ execute( a b -- ? ) ] with with map
[ execute( a b -- ? ) ] 2with map
first4 ;
[ 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 -- )
dup blocked? [ 1string , ] [
dup possible-bases dup length iota
[ ?combine ] with with any?
[ ?combine ] 2with any?
[ drop ] [ 1string , ] if
] if ;

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

@ -11,7 +11,7 @@ IN: vocabs.metadata.resources
[ dup '[ _ directory-tree-files [ append-path ] with map ] [ prefix ] bi ]
[ 1array ] if ;
: filter-resources ( vocab-files resource-globs -- resource-files )
: filter-resources ( vocab-files resource-globs -- resource-files )
'[ _ [ matches? ] with any? ] filter ;
: copy-vocab-resource ( to from file -- )
@ -19,7 +19,7 @@ IN: vocabs.metadata.resources
dup file-info directory?
[ drop make-directories ]
[ swap [ parent-directory make-directories ] [ copy-file ] bi ] if ;
PRIVATE>
: vocab-dir-in-root ( vocab -- dir )
@ -36,10 +36,9 @@ PRIVATE>
[ drop f ] [ expand-vocab-resource-files ] if-empty ;
: copy-vocab-resources ( dir vocab -- )
dup vocab-resource-files
dup vocab-resource-files
[ 2drop ] [
[ [ vocab-dir append-path ] [ vocab-dir-in-root ] bi ] dip
[ 2drop make-directories ]
[ [ copy-vocab-resource ] with with each ] 3bi
[ [ copy-vocab-resource ] 2with each ] 3bi
] if-empty ;

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

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

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

@ -75,7 +75,7 @@ C: <predicate-engine> predicate-engine
: flatten-method ( method class assoc -- )
over flatten-class keys
[ swap push-method ] with with with each ;
[ swap push-method ] 2with with each ;
: flatten-methods ( assoc -- assoc' )
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." }
{ $examples
{ $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
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
@ -951,4 +961,3 @@ ARTICLE: "assertions" "Assertions"
assert
assert=
} ;

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

@ -8,6 +8,21 @@ IN: kernel.tests
[ 0 ] [ f size ] 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
[ ] [ 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 )
swapd [ swapd call ] 2curry ; inline
: 2with ( param1 param2 obj quot -- obj curry )
with with ; inline
: prepose ( quot1 quot2 -- compose )
swap compose ; inline

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

@ -1,7 +1,7 @@
! Factor port of the raytracer benchmark from
! 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
math.vectors math.vectors.simd math.vectors.simd.cords
math.parser make sequences words combinators ;
@ -129,7 +129,7 @@ CONSTANT: create-offsets
: create-group ( level c r -- scene )
2dup create-bound [
2dup <sphere> ,
create-offsets [ create-step , ] with with with each
create-offsets [ create-step , ] 3 nwith each
] make-group ;
: create ( level c r -- scene )
@ -145,15 +145,15 @@ CONSTANT: create-offsets
ss-point v+ normalize
double-4{ 0.0 0.0 -4.0 0.0 } swap <ray>
swap cast-ray +
] with with with each
] with with each ; inline no-compile
] 3 nwith each
] 2with each ; inline no-compile
: ray-trace ( scene -- grid )
size iota <reversed> [
size iota [
[ size 0.5 * - ] bi@ swap size
0.0 double-4-boa ray-pixel
] with with map
] 2with map
] with map ;
: 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 )
over stride
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 -- )
[ 0 ] 2dip
dup y_height>> iota
[ yuv>rgb-row ] with with each
[ yuv>rgb-row ] 2with each
drop ;
: yuv-to-rgb-benchmark ( -- )

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

@ -20,7 +20,7 @@ TUPLE: boid
C: <boid> boid
: vsum ( vecs -- v )
{ 0.0 0.0 } [ v+ ] reduce ; inline
{ 0.0 0.0 } [ v+ ] reduce ; inline
: vavg ( vecs -- v )
[ vsum ] [ length ] bi v/n ; inline
@ -61,11 +61,11 @@ GENERIC: force ( neighbors boid behaviour -- force )
: wrap-pos ( pos -- pos )
width height [ 1 - ] bi@ 2array
[ [ + ] keep mod ] 2map ;
:: simulate ( boids behaviours dt -- boids )
boids [| boid |
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 pos>> vel dt v*n v+ wrap-pos :> pos
@ -98,4 +98,3 @@ M:: separation force ( neighbors boid behaviour -- force )
behaviour radius>> :> r
boid pos>> neighbors
[ 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 ;
: 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 )
[ [ 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 ;
: 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-buffers array element-array nv ni ;

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

@ -47,7 +47,7 @@ M: x-up >y-up-axis!
[ 0 swap nth ]
[ 1 swap nth neg ]
[ 2 swap nth ] tri
swap -rot
swap -rot
] [
[ 2 swap set-nth ]
[ 1 swap set-nth ]
@ -128,8 +128,8 @@ VERTEX-FORMAT: collada-vertex-format
[
[
[ data>> ] [ offset>> ] bi
rot = [ nth ] [ 2drop f ] if
] with with map sift flatten ,
rot = [ nth ] [ 2drop f ] if
] 2with map sift flatten ,
] curry each-index
] V{ } make flatten ;
@ -146,14 +146,14 @@ VERTEX-FORMAT: collada-vertex-format
group-indices
]
[
soa>aos
soa>aos
[ flatten c:float >c-array ]
[ flatten c:uint >c-array ]
bi* collada-vertex-format f model boa
] bi ;
: 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 )
[

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

@ -110,7 +110,7 @@ M: sequence selected-vectors [ selected-vectors ] map concat ;
selected selected-vertices :> ( sel-vertices sel-count )
face-vertices face-count edge-vertices edge-count sel-vertices sel-count
<b-rep-vertices> :> vertices
vertices array>>
face-indices
@ -163,11 +163,11 @@ TYPED: refresh-b-rep-view ( world: gml-viewer-world -- )
M: gml-viewer-world model-changed
nip
[ model>> value>> ]
[ b-rep<< ]
[ b-rep<< ]
[ dup viewable? [ refresh-b-rep-view ] [ drop ] if ] tri ;
: init-viewer-model ( gml-viewer-world -- )
[ dup model>> add-connection ]
[ dup model>> add-connection ]
[ dup selected>> add-connection ] bi ;
: reset-view ( gml-viewer-world -- )
@ -192,7 +192,7 @@ M: gml-viewer-world draw-world*
{ default-attachment { 0.0 0.0 0.0 1.0 } }
{ depth-attachment 1.0 }
} clear-framebuffer
[
dup view-faces?>> [
T{ depth-state { comparison cmp-less } } set-gpu-state
@ -213,7 +213,7 @@ M: gml-viewer-world draw-world*
{ "vertex-array" [ vertex-array>> ] }
} <render-set> render
] [ drop ] if
] [
] [
{
{ "primitive-mode" [ drop points-mode ] }
{ "indexes" [ point-indices>> ] }
@ -258,7 +258,7 @@ CONSTANT: edge-hitbox-radius 0.05
] [ f ] if ;
: 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 -- )
[ [ 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
drop
] with-ui ;

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

@ -59,7 +59,7 @@ IN: graphviz.notation
name>>
[ attrs-obj-=attr ] keep
graph-obj-=attr
] with with each ;
] 2with each ;
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 ;
: 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 ]
2bi ;

6
extra/koszul/koszul.factor
View File

@ -163,7 +163,7 @@ DEFER: (d)
swap call [ at 0 or ] curry map ; inline
: 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) ] op-matrix ;
@ -260,8 +260,8 @@ DEFER: (d)
: bigraded-triple ( u-deg z-deg bigraded-basis -- triple )
#! d: C(u,z) ---> C(u+2,z-1)
[ [ 2 - ] [ 1 + ] [ ] tri* ?nth ?nth ]
[ ?nth ?nth ]
[ [ 2 - ] [ 1 + ] [ ] tri* ?nth ?nth ]
[ ?nth ?nth ]
[ [ 2 + ] [ 1 - ] [ ] tri* ?nth ?nth ]
3tri
3array ;

6
extra/nurbs/nurbs.factor
View File

@ -8,7 +8,7 @@ IN: nurbs
TUPLE: nurbs-curve
{ order integer }
control-points
control-points
knots
(knot-constants) ;
@ -32,7 +32,7 @@ TUPLE: nurbs-curve
: order-knot-constants ( curve order -- knot-constants )
2dup [ knots>> length ] dip - iota
[ order-index-knot-constants ] with with map ;
[ order-index-knot-constants ] 2with map ;
: knot-constants ( curve -- knot-constants )
2 over order>> [a,b]
@ -71,5 +71,3 @@ TUPLE: nurbs-curve
: eval-nurbs ( nurbs-curve t -- value )
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 )
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 -- ? )
0xc0 bitand 0x80 = not ;

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

@ -1,6 +1,7 @@
! Copyright (c) 2010 Samuel Tardieu.
! 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
! http://projecteuler.net/index.php?section=problems&id=265
@ -51,7 +52,7 @@ CONSTANT: N 5
nip ?register
] [
[ 1 - ] dip
{ 0 1 } [ add-bit [ iterate ] [ 3drop ] if ] with with with each
{ 0 1 } [ add-bit [ iterate ] [ 3drop ] if ] 3 nwith each
] if ;
: euler265 ( -- answer )

4
extra/sudoku/sudoku.factor
View File

@ -1,5 +1,5 @@
! 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 ;
IN: sudoku
@ -17,7 +17,7 @@ SYMBOL: board
: cell-any? ( n x y i -- ? ) 3 /mod pair+ board> = ;
: 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 -- ? )
{ [ 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 )
cities [
[ name>> = ] [ state>> = ] bi-curry bi* and
] with with filter ;
] 2with filter ;
: find-zip-code ( code -- city )
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*
windows >>windows
windows push
] with with assoc-each ;
] 2with assoc-each ;
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 ;
: emit-sequence-body ( emitter event seq -- )
[ emit-object ] with with each ;
[ emit-object ] 2with each ;
: emit-assoc-body ( emitter event assoc -- )
[
@ -534,5 +534,5 @@ PRIVATE>
: >yaml-docs ( seq -- str )
[
[ 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 ;