From 60ffe0680e2aeaca5faba2e503bb24d738e9a7eb Mon Sep 17 00:00:00 2001 From: =?utf8?q?Bj=C3=B6rn=20Lindqvist?= Date: Tue, 22 Jul 2014 15:09:26 +0200 Subject: [PATCH] kernel: new combinator 2with = with with --- .../short-circuit/short-circuit.factor | 8 ++++---- .../cfg/branch-splitting/branch-splitting.factor | 2 +- basis/compiler/cfg/def-use/def-use.factor | 2 +- .../live-intervals/live-intervals.factor | 2 +- basis/db/tuples/tuples.factor | 4 ++-- basis/debugger/debugger-docs.factor | 2 +- basis/game/input/input.factor | 6 +++--- basis/io/monitors/recursive/recursive.factor | 2 +- basis/math/functions/functions.factor | 2 +- .../vectors/simd/intrinsics/intrinsics.factor | 10 +++++----- basis/sorting/insertion/insertion.factor | 2 +- basis/sorting/slots/slots.factor | 2 +- basis/typed/typed.factor | 10 +++++----- basis/ui/gadgets/menus/menus.factor | 2 +- basis/unicode/collation/collation-tests.factor | 2 +- basis/unicode/collation/collation.factor | 2 +- basis/vocabs/metadata/resources/resources.factor | 9 ++++----- core/generic/math/math.factor | 2 +- core/generic/single/single.factor | 2 +- core/kernel/kernel-docs.factor | 13 +++++++++++-- core/kernel/kernel-tests.factor | 15 +++++++++++++++ core/kernel/kernel.factor | 3 +++ .../raytracer-simd/raytracer-simd.factor | 10 +++++----- extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor | 4 ++-- extra/boids/simulation/simulation.factor | 7 +++---- extra/bunny/model/model.factor | 4 ++-- extra/game/models/collada/collada.factor | 12 ++++++------ extra/gml/viewer/viewer.factor | 13 ++++++------- extra/graphviz/notation/notation.factor | 2 +- extra/irc/client/participants/participants.factor | 2 +- extra/koszul/koszul.factor | 6 +++--- extra/nurbs/nurbs.factor | 6 ++---- extra/pcre/pcre.factor | 3 --- extra/project-euler/265/265.factor | 5 +++-- extra/sudoku/sudoku.factor | 4 ++-- extra/usa-cities/usa-cities.factor | 2 +- .../window-controls-demo.factor | 2 +- extra/yaml/yaml.factor | 4 ++-- 38 files changed, 105 insertions(+), 85 deletions(-) diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index f775c2f24c..9e59d5ee9e 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -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-|| ; diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index 0222df9ad0..157fd355cd 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -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 diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 36e6bdd46e..9f750f16dc 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -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 [ diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 5a9da37d03..ad4ab4fe16 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -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 diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index fcb7df53cc..0bdb2978ee 100644 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -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 [ diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index a1bfdcc9c6..e673fb0b2f 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -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. diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index edd30b89fa..51e1b84ec9 100644 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -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 ; diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor index 39701fef01..b0c86a215f 100755 --- a/basis/io/monitors/recursive/recursive.factor +++ b/basis/io/monitors/recursive/recursive.factor @@ -69,7 +69,7 @@ M: recursive-monitor dispose* { +rename-file-new+ [ child-added ] } [ 3drop ] } case - ] with with each ; + ] 2with each ; : pump-loop ( -- ) receive { diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 3ba6bfd324..5dd3877e7d 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -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 diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 03529a0f36..a784a77449 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -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 :> c' 0 rep rep-length [ 1 - 2 ] [ 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-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 '[ _ ] ] [ ] bi replicate-as + [ rep-length swap '[ _ ] ] [ ] bi replicate-as underlying>> ; SIMD-INTRINSIC: (simd-gather-2) ( m n rep -- v ) [ 2 set-firstn-unsafe ] keep underlying>> ; SIMD-INTRINSIC: (simd-gather-4) ( m n o p rep -- v ) [ 4 set-firstn-unsafe ] keep underlying>> ; diff --git a/basis/sorting/insertion/insertion.factor b/basis/sorting/insertion/insertion.factor index d6681be8cc..2a2ac4134a 100644 --- a/basis/sorting/insertion/insertion.factor +++ b/basis/sorting/insertion/insertion.factor @@ -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 diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 959fd8bfd5..43c05ee207 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -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 diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index 1a368c9446..a492a9b567 100644 --- a/basis/typed/typed.factor +++ b/basis/typed/typed.factor @@ -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 ; diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor index 70cc0bc971..15569dbc1a 100644 --- a/basis/ui/gadgets/menus/menus.factor +++ b/basis/ui/gadgets/menus/menus.factor @@ -57,7 +57,7 @@ M: ---- ] make-corners ; : ( target hook commands -- menu ) - [ ] with with map ; + [ ] 2with map ; : show-commands-menu ( target commands -- ) [ dup [ ] ] dip show-menu ; diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor index fdeb721e65..add0cbe677 100644 --- a/basis/unicode/collation/collation-tests.factor +++ b/basis/unicode/collation/collation-tests.factor @@ -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 diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor index 38b5e9c9bf..b907d33eba 100644 --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -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 ; diff --git a/basis/vocabs/metadata/resources/resources.factor b/basis/vocabs/metadata/resources/resources.factor index 1ff002d13a..7db83144a7 100644 --- a/basis/vocabs/metadata/resources/resources.factor +++ b/basis/vocabs/metadata/resources/resources.factor @@ -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 ; - diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 5c074cea21..96a3edf9c6 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -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 diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 1ef45e2e76..207dd5807c 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -75,7 +75,7 @@ C: 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 ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 37b60d45b2..e18d9f27cb 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -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= } ; - diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index c2fc444510..0385342970 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -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 diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 72b1c59d1b..a397331bcf 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -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 diff --git a/extra/benchmark/raytracer-simd/raytracer-simd.factor b/extra/benchmark/raytracer-simd/raytracer-simd.factor index 866891dd31..13716b27c6 100644 --- a/extra/benchmark/raytracer-simd/raytracer-simd.factor +++ b/extra/benchmark/raytracer-simd/raytracer-simd.factor @@ -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 , - 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 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 [ 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 -- ) diff --git a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor index e6dce0061a..cf4719490a 100644 --- a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor +++ b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor @@ -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 ( -- ) diff --git a/extra/boids/simulation/simulation.factor b/extra/boids/simulation/simulation.factor index 5119837be8..62fb1d8e98 100644 --- a/extra/boids/simulation/simulation.factor +++ b/extra/boids/simulation/simulation.factor @@ -20,7 +20,7 @@ TUPLE: boid C: 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 ; - diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index c1ec085dc2..5aaf61d9dc 100644 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -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 } ] 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 ; diff --git a/extra/game/models/collada/collada.factor b/extra/game/models/collada/collada.factor index 2d3192279c..18773e79a4 100644 --- a/extra/game/models/collada/collada.factor +++ b/extra/game/models/collada/collada.factor @@ -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 ) [ diff --git a/extra/gml/viewer/viewer.factor b/extra/gml/viewer/viewer.factor index a39b8ac9b8..ce1bd4b971 100644 --- a/extra/gml/viewer/viewer.factor +++ b/extra/gml/viewer/viewer.factor @@ -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 :> 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 ] [ 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 ; - diff --git a/extra/graphviz/notation/notation.factor b/extra/graphviz/notation/notation.factor index 3066f7b721..0168289455 100644 --- a/extra/graphviz/notation/notation.factor +++ b/extra/graphviz/notation/notation.factor @@ -59,7 +59,7 @@ IN: graphviz.notation name>> [ attrs-obj-=attr ] keep graph-obj-=attr - ] with with each ; + ] 2with each ; PRIVATE> diff --git a/extra/irc/client/participants/participants.factor b/extra/irc/client/participants/participants.factor index d2b2e15999..f3440725bf 100644 --- a/extra/irc/client/participants/participants.factor +++ b/extra/irc/client/participants/participants.factor @@ -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 ; diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index ead78200fd..662162f532 100644 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -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 ; diff --git a/extra/nurbs/nurbs.factor b/extra/nurbs/nurbs.factor index 38ab0c31da..858e1f7401 100644 --- a/extra/nurbs/nurbs.factor +++ b/extra/nurbs/nurbs.factor @@ -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) ; - - diff --git a/extra/pcre/pcre.factor b/extra/pcre/pcre.factor index 4f388e0e18..e17eeaa71e 100644 --- a/extra/pcre/pcre.factor +++ b/extra/pcre/pcre.factor @@ -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 ; diff --git a/extra/project-euler/265/265.factor b/extra/project-euler/265/265.factor index f9ae9393fc..261a9e8ff2 100644 --- a/extra/project-euler/265/265.factor +++ b/extra/project-euler/265/265.factor @@ -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 ) diff --git a/extra/sudoku/sudoku.factor b/extra/sudoku/sudoku.factor index 7c4b588ea2..47ab274cd1 100644 --- a/extra/sudoku/sudoku.factor +++ b/extra/sudoku/sudoku.factor @@ -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|| ; diff --git a/extra/usa-cities/usa-cities.factor b/extra/usa-cities/usa-cities.factor index 29f710061c..111ea99159 100644 --- a/extra/usa-cities/usa-cities.factor +++ b/extra/usa-cities/usa-cities.factor @@ -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 ; diff --git a/extra/window-controls-demo/window-controls-demo.factor b/extra/window-controls-demo/window-controls-demo.factor index 72811a2c7b..0db5ba62df 100644 --- a/extra/window-controls-demo/window-controls-demo.factor +++ b/extra/window-controls-demo/window-controls-demo.factor @@ -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 diff --git a/extra/yaml/yaml.factor b/extra/yaml/yaml.factor index 15491667b8..2a850eec96 100644 --- a/extra/yaml/yaml.factor +++ b/extra/yaml/yaml.factor @@ -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 ; -- 2.34.1