-USING: kernel io io.files splitting strings io.encodings.ascii
+USING: kernel locals io io.files splitting strings io.encodings.ascii
hashtables sequences assocs math namespaces prettyprint
math.parser combinators arrays sorting unicode.case ;
CHAR: \n swap remove >upper ;
: tally ( x exemplar -- b )
- clone tuck
- [
- [ [ 1 + ] [ 1 ] if* ] change-at
- ] curry each ;
+ clone [ [ inc-at ] curry each ] keep ;
: small-groups ( x n -- b )
swap
] each
drop ;
-: handle-n ( inputs x -- )
- tuck length
- small-groups H{ } tally
- at [ 0 ] unless*
+:: handle-n ( inputs x -- )
+ inputs x length small-groups :> groups
+ groups H{ } tally :> b
+ x b at [ 0 ] unless*
number>string 8 CHAR: \s pad-tail write ;
: process-input ( input -- )
: curses-writef ( window string -- )
[ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ;
-: (curses-read) ( window-ptr n encoding -- string )
- [ [ <byte-array> tuck ] keep wgetnstr curses-error ] dip alien>string ;
+:: (curses-read) ( window-ptr n encoding -- string )
+ n <byte-array> :> buf
+ window-ptr buf n wgetnstr curses-error
+ buf encoding alien>string ;
: curses-read ( window n -- string )
utf8 [ window-ptr ] 2dip (curses-read) ;
] 2bi ;
: scale-decimals ( D1 D2 -- D1' D2' )
- scale-mantissas tuck [ <decimal> ] 2dip <decimal> ;
+ scale-mantissas [ <decimal> ] curry bi@ ;
ERROR: decimal-types-expected d1 d2 ;
: get-private-key ( -- bin/f )
ec-key-handle EC_KEY_get0_private_key
- dup [ dup BN_num_bits bits>bytes <byte-array> tuck BN_bn2bin drop ] when ;
+ dup [ dup BN_num_bits bits>bytes <byte-array> [ BN_bn2bin drop ] keep ] when ;
:: get-public-key ( -- bin/f )
ec-key-handle :> KEY
: get-comm-state ( duplex -- dcb )
in>> handle>>
- DCB <struct> tuck
- GetCommState win32-error=0/f ;
+ DCB <struct> [ GetCommState win32-error=0/f ] keep ;
: set-comm-state ( duplex dcb -- )
[ in>> handle>> ] dip
USING: accessors alien.c-types jamshred.game jamshred.oint
jamshred.player jamshred.tunnel kernel math math.constants
math.functions math.vectors opengl opengl.gl opengl.glu
-opengl.demo-support sequences specialized-arrays ;
+opengl.demo-support sequences specialized-arrays locals ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: jamshred.gl
over color>> gl-color segment-vertex-and-normal
gl-normal gl-vertex ;
-: draw-vertex-pair ( theta next-segment segment -- )
- rot tuck draw-segment-vertex draw-segment-vertex ;
+:: draw-vertex-pair ( theta next-segment segment -- )
+ segment theta draw-segment-vertex
+ next-segment theta draw-segment-vertex ;
: draw-segment ( next-segment segment -- )
GL_QUAD_STRIP [
: scalar-projection ( v1 v2 -- n )
#! the scalar projection of v1 onto v2
- tuck v. swap norm / ;
+ [ v. ] [ norm ] bi / ;
: proj-perp ( u v -- w )
dupd proj v- ;
: perpendicular-distance ( oint oint -- distance )
- tuck distance-vector swap 2dup left>> scalar-projection abs
+ [ distance-vector ] keep 2dup left>> scalar-projection abs
-rot up>> scalar-projection abs + ;
:: reflect ( v n -- v' )
forward-pivot ;
: to-tunnel-start ( player -- )
- [ tunnel>> first dup location>> ]
- [ tuck (>>location) (>>nearest-segment) ] bi ;
+ dup tunnel>> first
+ [ >>nearest-segment ]
+ [ location>> >>location ] bi drop ;
: play-in-tunnel ( player segments -- )
>>tunnel to-tunnel-start ;
#! valid values
[ '[ _ clamp-length ] bi@ ] keep <slice> ;
-: nearer-segment ( segment segment oint -- segment )
- #! return whichever of the two segments is nearer to the oint
- [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ;
+:: nearer-segment ( seg-a seg-b oint -- segment )
+ seg-a oint distance
+ seg-b oint distance <
+ seg-a seg-b ? ;
: (find-nearest-segment) ( nearest next oint -- nearest ? )
#! find the nearest of 'next' and 'nearest' to 'oint', and return
[ [ 0.0 ] unless* ] tri@
[ (xy>loc) ] dip (z>loc) ;
-: move-axis ( gadget x y z -- )
- (xyz>loc) rot tuck
- [ indicator>> (>>loc) ]
- [ z-indicator>> (>>loc) ] 2bi* ;
+:: move-axis ( gadget x y z -- )
+ x y z (xyz>loc) :> ( xy z )
+ xy gadget indicator>> (>>loc)
+ z gadget z-indicator>> (>>loc) ;
: move-pov ( gadget pov -- )
swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ]
[ >>controller ] [ product-string <label> add-gadget ] bi ;
: add-axis-gadget ( gadget shelf -- gadget shelf )
- <axis-gadget> tuck [ >>axis ] [ add-gadget-with-border ] 2bi* ;
+ <axis-gadget> [ >>axis ] [ add-gadget-with-border ] bi-curry bi* ;
: add-raxis-gadget ( gadget shelf -- gadget shelf )
- <axis-gadget> tuck [ >>raxis ] [ add-gadget-with-border ] 2bi* ;
+ <axis-gadget> [ >>raxis ] [ add-gadget-with-border ] bi-curry bi* ;
:: (add-button-gadgets) ( gadget shelf -- )
gadget controller>> read-controller buttons>> length [
: <keys> ( gadget -- key-handler ) key-handler new-border { 0 0 } >>size ;
M: key-handler handle-gesture
- tuck handlers>> at [ call( gadget -- ) f ] [ drop t ] if* ;
\ No newline at end of file
+ [ handlers>> at ] keep swap [ call( gadget -- ) f ] [ drop t ] if* ;
: laplacian-betti ( basis1 basis2 basis3 -- n )
laplacian-matrix null/rank drop ;
-: laplacian-kernel ( basis1 basis2 basis3 -- basis )
- [ tuck ] dip
- laplacian-matrix dup empty-matrix? [
- 2drop f
- ] [
- nullspace [
- [ [ wedge (alt+) ] 2each ] with-terms
- ] with map
+:: laplacian-kernel ( basis1 basis2 basis3 -- basis )
+ basis1 basis2 basis3 laplacian-matrix :> lap
+ lap empty-matrix? [ f ] [
+ lap nullspace [| x |
+ basis2 x [ [ wedge (alt+) ] 2each ] with-terms
+ ] map
] if ;
: graded-triple ( seq n -- triple )
[ [ y>> second ] [ x>> second neg ] bi 2array ]
[ [ y>> first neg ] [ x>> first ] bi 2array ]
[ |a| ] tri
- tuck [ v/n ] 2bi@ ;
+ [ v/n ] curry bi@ ;
: inverse-axes ( a -- a^-1 )
(inverted-axes) { 0.0 0.0 } <affine-transform> ;
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: sequences kernel arrays vectors accessors assocs sorting math math.functions ;
+USING: sequences kernel arrays vectors accessors assocs shuffle sorting locals math math.functions ;
IN: math.binpack
[ [ values sum ] map ] keep
zip sort-keys values first push ;
-: binpack ( assoc n -- bins )
- [ sort-values <reversed> dup length ] dip
- tuck / ceiling <array> [ <vector> ] map
- tuck [ (binpack) ] curry each ;
+:: binpack ( assoc n -- bins )
+ assoc sort-values <reversed> :> values
+ values length :> #values
+ n #values n / ceiling <array> [ <vector> ] map :> bins
+ values [ bins (binpack) ] each
+ bins ;
: binpack* ( items n -- bins )
[ dup zip ] dip binpack [ keys ] map ;
<PRIVATE
: weighted ( x y a -- z )
- tuck [ * ] [ 1 - neg * ] 2bi* + ;
+ [ * ] [ 1 - neg * ] bi-curry bi* + ;
: a ( n -- a )
1 + 2 swap / ;
USING: kernel locals math math.functions ;
IN: math.quadratic
-: monic ( c b a -- c' b' ) tuck [ / ] 2bi@ ;
+: monic ( c b a -- c' b' ) [ / ] curry bi@ ;
-: discriminant ( c b -- b d ) tuck sq 4 / swap - sqrt ;
+: discriminant ( c b -- b d ) [ nip ] [ sq 4 / swap - sqrt ] 2bi ;
: critical ( b d -- -b/2 d ) [ -2 / ] dip ;
USING: accessors arrays kernel models models.product monads
-sequences sequences.extras ;
+sequences sequences.extras shuffle ;
FROM: syntax => >> ;
IN: models.combinators
: with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline
USE: models.combinators.templates
-<< { "$>" "<$" "fmap" } [ fmaps ] each >>
\ No newline at end of file
+<< { "$>" "<$" "fmap" } [ fmaps ] each >>
M: assoc <mdb-insert-msg> ( collection assoc -- mdb-insert-msg )
[ mdb-insert-msg new ] 2dip
[ >>collection ] dip
- V{ } clone tuck push
+ [ V{ } clone ] dip suffix!
>>objects OP_Insert >>opcode ;
PRIVATE>
: <tuple-info> ( tuple -- tuple-info )
- class V{ } clone tuck
+ class [ V{ } clone ] dip over
[ [ name>> ] dip push ]
[ [ vocabulary>> ] dip push ] 2bi ; inline
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: lists lists.lazy promises kernel sequences strings math
-arrays splitting quotations combinators namespaces
+arrays splitting quotations combinators namespaces locals
unicode.case unicode.categories sequences.deep accessors ;
IN: parser-combinators
: case-insensitive-token ( string -- parser ) t <token-parser> ;
-M: token-parser parse ( input parser -- list )
- [ string>> ] [ ignore-case?>> ] bi
- [ tuck ] dip ?string-head
+M:: token-parser parse ( input parser -- list )
+ parser string>> :> str
+ parser ignore-case?>> :> case?
+
+ str input str case? ?string-head
[ <parse-results> ] [ 2drop nil ] if ;
: 1token ( n -- parser ) 1string token ;
<& &> ;
: nonempty-list-of ( items separator -- parser )
- [ over &> <*> <&:> ] keep <?> tuck pack ;
+ [ over &> <*> <&:> ] keep <?> [ nip ] 2keep pack ;
: list-of ( items separator -- parser )
#! Given a parser for the separator and for the
V{ 0 } clone 1 rot (fib-upto) ;
: euler002 ( -- answer )
- 4000000 fib-upto [ even? ] filter sum ;
+ 4,000,000 fib-upto [ even? ] filter sum ;
! [ euler002 ] 100 ave-time
! 0 ms ave run time - 0.22 SD (100 trials)
! -------------------
: fib-upto* ( n -- seq )
- 0 1 [ pick over >= ] [ tuck + dup ] produce [ 3drop ] dip
+ 0 1 [ pick over >= ] [ [ nip ] 2keep + dup ] produce [ 3drop ] dip
but-last-slice { 0 1 } prepend ;
: euler002a ( -- answer )
- 4000000 fib-upto* [ even? ] filter sum ;
+ 4,000,000 fib-upto* [ even? ] filter sum ;
! [ euler002a ] 100 ave-time
! 0 ms ave run time - 0.2 SD (100 trials)
<PRIVATE
: next-fibs ( x y -- y x+y )
- tuck + ;
+ [ nip ] [ + ] 2bi ;
: ?retotal ( total fib- fib+ -- retotal fib- fib+ )
dup even? [ [ nip + ] 2keep ] when ;
! http://projecteuler.net/index.php?section=problems&id=100
-! DESCRIPTION
-! -----------
+! DESCRIPTION ! -----------
! If a box contains twenty-one coloured discs, composed of fifteen blue discs
-! and six red discs, and two discs were taken at random, it can be seen that
-! the probability of taking two blue discs, P(BB) = (15/21)*(14/20) = 1/2.
+! and six red discs, and two discs were taken at random, it can be seen that
+! the probability of taking two blue discs, P(BB) = (15/21)*(14/20) = 1/2.
! The next such arrangement, for which there is exactly 50% chance of taking
-! two blue discs at random, is a box containing eighty-five blue discs and
-! thirty-five red discs.
+! two blue discs at random, is a box containing eighty-five blue discs and
+! thirty-five red discs.
! By finding the first arrangement to contain over 10^12 = 1,000,000,000,000
-! discs in total, determine the number of blue discs that the box would contain.
+! discs in total, determine the number of blue discs that the box would contain.
! SOLUTION
: euler100 ( -- answer )
1 1
[ dup dup 1 - * 2 * 10 24 ^ <= ]
- [ tuck 6 * swap - 2 - ] while nip ;
+ [ [ 6 * swap - 2 - ] keep swap ] while nip ;
! TODO: solution needs generalization
[ 4 short tail* sum ] keep push ;
: (euler117) ( n -- m )
- V{ 1 } clone tuck [ next ] curry times last ;
+ [ V{ 1 } clone ] dip over [ next ] curry times last ;
PRIVATE>
[
[ datastack ]
[
- '[ _ gc benchmark 1000 / , ] tuck
- '[ _ _ with-datastack drop ]
+ '[ _ gc benchmark 1000 / , ]
+ [ '[ _ _ with-datastack drop ] ] keep swap
]
[ 1 - ] tri* swap times call
] { } make ; inline
! (c) 2009 Joe Groff, see BSD license
-USING: assocs kernel math.rectangles combinators accessors
+USING: assocs kernel math.rectangles combinators accessors locals
math.vectors vectors sequences math combinators.short-circuit arrays fry ;
IN: quadtrees
: insert ( value point tree -- )
dup leaf?>> [ leaf-insert ] [ node-insert ] if ;
-: leaf-at-point ( point leaf -- value/f ? )
- tuck point>> = [ value>> t ] [ drop f f ] if ;
+:: leaf-at-point ( point leaf -- value/f ? )
+ point leaf point>> =
+ [ leaf value>> t ] [ f f ] if ;
: node-at-point ( point node -- value/f ? )
descend at-point ;
: node-in-rect* ( values rect node -- values )
[ (node-in-rect*) ] with each-quadrant ;
-: leaf-in-rect* ( values rect leaf -- values )
- tuck { [ nip point>> ] [ point>> swap contains-point? ] } 2&&
- [ value>> over push ] [ drop ] if ;
+:: leaf-in-rect* ( values rect leaf -- values )
+ { [ leaf point>> ] [ leaf point>> rect contains-point? ] } 0&&
+ [ values leaf value>> suffix! ] [ values ] if ;
: in-rect* ( values rect tree -- values )
dup leaf?>> [ leaf-in-rect* ] [ node-in-rect* ] if ;
-: leaf-erase ( point leaf -- )
- tuck point>> = [ f >>point f >>value ] when drop ;
+:: leaf-erase ( point leaf -- )
+ point leaf point>> = [ leaf f >>point f >>value drop ] when ;
: node-erase ( point node -- )
descend erase ;
[ 3716213681 ]
[
- 100 T{ blum-blum-shub f 200352954495 846054538649 } clone tuck [
+ T{ blum-blum-shub f 200352954495 846054538649 } clone 100 over [
random-32* drop
] curry times
random-32*
USING: kernel math sequences strings io combinators ascii ;
IN: rot13
-: rotate ( ch base -- ch ) tuck - 13 + 26 mod + ;
+: rotate ( ch base -- ch ) [ - 13 + 26 mod ] [ + ] bi ;
: rot-letter ( ch -- ch )
{
[ prefixes ] keep 1array '[ _ ] H{ } map>assoc ;
: assoc-merge ( assoc1 assoc2 -- assoc3 )
- tuck '[ over _ at dup [ append ] [ drop ] if ] assoc-map assoc-union ;
+ [ '[ over _ at dup [ append ] [ drop ] if ] assoc-map ] keep swap assoc-union ;
PRIVATE>
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math math.order
+USING: accessors arrays kernel locals math math.order
sequences sequences.private shuffle ;
IN: sequences.modified
M: scaled modified-nth ( n seq -- elt )
[ seq>> nth ] [ c>> * ] bi ;
-M: scaled modified-set-nth ( elt n seq -- elt )
+M:: scaled modified-set-nth ( elt n seq -- elt )
! don't set c to 0!
- tuck [ c>> / ] 2dip seq>> set-nth ;
+ elt seq c>> / n seq seq>> set-nth ;
TUPLE: offset < 1modified n ;
C: <offset> offset
M: offset modified-nth ( n seq -- elt )
[ seq>> nth ] [ n>> + ] bi ;
-M: offset modified-set-nth ( elt n seq -- )
- tuck [ n>> - ] 2dip seq>> set-nth ;
+M:: offset modified-set-nth ( elt n seq -- )
+ elt seq n>> - n seq seq>> set-nth ;
TUPLE: summed < modified seqs ;
C: <summed> summed
io.files
io.pathnames
kernel
+ locals
math
+ math.order
openal
opengl.gl
sequences
first2 game-width 3 * * swap 3 * + ;
:: set-bitmap-pixel ( bitmap point color -- )
- color point bitmap
-
- point color :> index
+ point bitmap-index :> index
color first index bitmap set-nth
color second index 1 + bitmap set-nth
color third index 2 + bitmap set-nth ;
#! Setting this value affects the value read from port 3
(>>port2o) ;
-: bit-newly-set? ( old-value new-value bit -- bool )
- tuck bit? [ bit? not ] dip and ;
+:: bit-newly-set? ( old-value new-value bit -- bool )
+ new-value bit bit? [ old-value bit bit? not ] dip and ;
: port3-newly-set? ( new-value cpu bit -- bool )
[ port3o>> swap ] dip bit-newly-set? ;
#! point is a {x y}. color is a {r g b}.
set-bitmap-pixel ;
-: within ( n a b -- bool )
- #! n >= a and n <= b
- rot tuck swap <= [ swap >= ] dip and ;
-
: get-point-color ( point -- color )
#! Return the color to use for the given x/y position.
first2
{
- { [ dup 184 238 within pick 0 223 within and ] [ 2drop green ] }
- { [ dup 240 247 within pick 16 133 within and ] [ 2drop green ] }
- { [ dup 247 215 - 247 184 - within pick 0 223 within and ] [ 2drop red ] }
+ { [ dup 184 238 between? pick 0 223 between? and ] [ 2drop green ] }
+ { [ dup 240 247 between? pick 16 133 between? and ] [ 2drop green ] }
+ { [ dup 247 215 - 247 184 - between? pick 0 223 between? and ] [ 2drop red ] }
[ 2drop white ]
} cond ;
[ filter-base-links ] 2keep
depth>> 1 + swap
[ add-nonmatching ]
- [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
+ [ dup '[ _ apply-filters ] curry 2dip add-todo ] 2bi ;
: normalize-hrefs ( base links -- links' )
[ derive-url ] with map ;
: modulo ( n m -- n )
#! -2 7 mod => -2, -2 7 modulo => 5
- tuck mod over + swap mod ;
+ [ mod ] [ + ] [ mod ] tri ;
: (rotate-piece) ( rotation inc n-states -- rotation' )
[ + ] dip modulo ;
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel generic math math.functions
-math.parser namespaces io sequences trees
+math.parser namespaces io sequences trees shuffle
assocs parser accessors math.order prettyprint.custom ;
IN: trees.avl
! Copyright (c) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences assocs parser
-trees generic math.order accessors prettyprint.custom ;
+trees generic math.order accessors prettyprint.custom shuffle ;
IN: trees.splay
TUPLE: splay < tree ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic math sequences arrays io namespaces
prettyprint.private kernel.private assocs random combinators
-parser math.order accessors deques make prettyprint.custom ;
+parser math.order accessors deques make prettyprint.custom
+shuffle ;
IN: trees
TUPLE: tree root count ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.vectors classes.tuple math.rectangles colors
-kernel sequences models opengl math math.order namespaces
+kernel locals sequences models opengl math math.order namespaces
ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports
ui.gadgets.packs ;
dup list-empty? [
2drop
] [
- tuck control-value length rem >>index
+ [ control-value length rem ] [ (>>index) ] [ ] tri
[ relayout-1 ] [ scroll>selected ] bi
] if ;
[ index>> ] keep nth-gadget invoke-secondary
] if ;
-: select-gadget ( gadget list -- )
- tuck children>> index
- [ swap select-index ] [ drop ] if* ;
+:: select-gadget ( gadget list -- )
+ gadget list children>> index
+ [ list select-index ] when* ;
: clamp-loc ( point max -- point )
vmin { 0 0 } vmax ;
[ t ] [ 5 m 1 m d- 4 m = ] unit-test
[ t ] [ 5 m 2 m d* 10 m^2 = ] unit-test
[ t ] [ 5 m 2 m d/ 5/2 { } { } <dimensioned> = ] unit-test
-[ t ] [ 5 m 2 m tuck d/ drop 2 m = ] unit-test
+[ t ] [ 2 m 5 m 2 m d/ drop 2 m = ] unit-test
[ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test
[ t ] [ 3 m d-recip 1/3 { } { m } <dimensioned> = ] unit-test
MEMO: cities-named-in ( name state -- cities )
cities [
- tuck [ name>> = ] [ state>> = ] 2bi* and
+ [ name>> = ] [ state>> = ] bi-curry bi* and
] with with filter ;
: find-zip-code ( code -- city )
projects / factor.git / commitdiff