: 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 )
[
: 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-|| ;
: 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
: 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 [
: 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
: 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 [
{ $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.
: open-game-input ( -- )
game-input-opened? [
- (open-game-input)
+ (open-game-input)
] unless
game-input-opened [ 1 + ] change-global
reset-mouse ;
1 -
] change-global
game-input-opened? [
- (close-game-input)
+ (close-game-input)
reset-game-input
] unless ;
get-controllers [
[ product-id = ]
[ instance-id = ] bi-curry bi* and
- ] with with find nip ;
+ ] 2with find nip ;
TUPLE: keyboard-state keys ;
{ +rename-file-new+ [ child-added ] }
[ 3drop ]
} case
- ] with with each ;
+ ] 2with each ;
: pump-loop ( -- )
receive {
: 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
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 |
! 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 ;
] 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 )
[ [ 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>> ;
: 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
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
! (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 ;
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 )
[ 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
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 ;
] 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 ;
\r
: test-equality ( str1 str2 -- ? ? ? ? )\r
{ primary= secondary= tertiary= quaternary= }\r
- [ execute( a b -- ? ) ] with with map\r
+ [ execute( a b -- ? ) ] 2with map\r
first4 ;\r
\r
[ f f f f ] [ "hello" "hi" test-equality ] unit-test\r
: add ( char -- )\r
dup blocked? [ 1string , ] [\r
dup possible-bases dup length iota\r
- [ ?combine ] with with any?\r
+ [ ?combine ] 2with any?\r
[ drop ] [ 1string , ] if\r
] if ;\r
\r
[ 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 -- )
dup file-info directory?
[ drop make-directories ]
[ swap [ parent-directory make-directories ] [ copy-file ] bi ] if ;
-
+
PRIVATE>
: vocab-dir-in-root ( vocab -- dir )
[ 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 ;
-
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
: 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 ;
{ $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" } "." }
assert
assert=
} ;
-
[ 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
: 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
! 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 ;
: 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 )
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 -- )
: 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 ( -- )
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
: 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
behaviour radius>> :> r
boid pos>> neighbors
[ pos>> v- [ normalize ] [ r v/n ] bi v- ] with map vsum ;
-
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
] 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 ;
[ 0 swap nth ]
[ 1 swap nth neg ]
[ 2 swap nth ] tri
- swap -rot
+ swap -rot
] [
[ 2 swap set-nth ]
[ 1 swap set-nth ]
[
[
[ 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 ;
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 )
[
selected selected-vertices :> ( sel-vertices sel-count )\r
face-vertices face-count edge-vertices edge-count sel-vertices sel-count\r
<b-rep-vertices> :> vertices\r
- \r
+\r
vertices array>>\r
\r
face-indices\r
M: gml-viewer-world model-changed\r
nip\r
[ model>> value>> ]\r
- [ b-rep<< ] \r
+ [ b-rep<< ]\r
[ dup viewable? [ refresh-b-rep-view ] [ drop ] if ] tri ;\r
\r
: init-viewer-model ( gml-viewer-world -- )\r
- [ dup model>> add-connection ] \r
+ [ dup model>> add-connection ]\r
[ dup selected>> add-connection ] bi ;\r
\r
: reset-view ( gml-viewer-world -- )\r
{ default-attachment { 0.0 0.0 0.0 1.0 } }\r
{ depth-attachment 1.0 }\r
} clear-framebuffer\r
- \r
+\r
[\r
dup view-faces?>> [\r
T{ depth-state { comparison cmp-less } } set-gpu-state\r
{ "vertex-array" [ vertex-array>> ] }\r
} <render-set> render\r
] [ drop ] if\r
- ] [ \r
+ ] [\r
{\r
{ "primitive-mode" [ drop points-mode ] }\r
{ "indexes" [ point-indices>> ] }\r
] [ f ] if ;\r
\r
: intersecting-edge-node ( source direction b-rep -- edge/f )\r
- edges>> [ intersects-edge-node? ] with with find nip ;\r
+ edges>> [ intersects-edge-node? ] 2with find nip ;\r
\r
: select-edge ( world -- )\r
[ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ]\r
_ >>selected\r
drop\r
] with-ui ;\r
-\r
name>>
[ attrs-obj-=attr ] keep
graph-obj-=attr
- ] with with each ;
+ ] 2with each ;
PRIVATE>
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 ;
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 ;
: 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 ;
TUPLE: nurbs-curve
{ order integer }
- control-points
+ control-points
knots
(knot-constants) ;
: 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]
: eval-nurbs ( nurbs-curve t -- value )
2dup knot-interval 1 - { 1.0 } 2 (eval-bases) ;
-
-
: 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 ;
! 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
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 )
! 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
: 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|| ;
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 ;
open-window*
windows >>windows
windows push
- ] with with assoc-each ;
+ ] 2with assoc-each ;
MAIN: window-controls-demo
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 -- )
[
: >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 ;
projects / factor.git / commitdiff