nip most uses of tuck from extra
parent
dbadab67ef
commit
a5957b188d
|
@ -1,4 +1,4 @@
|
|||
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 ;
|
||||
|
||||
|
@ -21,10 +21,7 @@ IN: benchmark.knucleotide
|
|||
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
|
||||
|
@ -42,10 +39,10 @@ IN: benchmark.knucleotide
|
|||
] 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 -- )
|
||||
|
|
|
@ -123,8 +123,10 @@ PRIVATE>
|
|||
: 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) ;
|
||||
|
|
|
@ -37,7 +37,7 @@ SYNTAX: D: parse-decimal suffix! ;
|
|||
] 2bi ;
|
||||
|
||||
: scale-decimals ( D1 D2 -- D1' D2' )
|
||||
scale-mantissas tuck [ <decimal> ] 2dip <decimal> ;
|
||||
scale-mantissas [ <decimal> ] curry bi@ ;
|
||||
|
||||
ERROR: decimal-types-expected d1 d2 ;
|
||||
|
||||
|
|
|
@ -50,7 +50,7 @@ PRIVATE>
|
|||
|
||||
: 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
|
||||
|
|
|
@ -11,8 +11,7 @@ IN: io.serial.windows
|
|||
|
||||
: 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
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
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
|
||||
|
@ -50,8 +50,9 @@ CONSTANT: wall-drawing-offset 0.15
|
|||
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 [
|
||||
|
|
|
@ -53,13 +53,13 @@ C: <oint> oint
|
|||
|
||||
: 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' )
|
||||
|
|
|
@ -31,8 +31,9 @@ CONSTANT: max-speed 30.0
|
|||
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 ;
|
||||
|
|
|
@ -63,9 +63,10 @@ CONSTANT: default-segment-radius 1
|
|||
#! 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
|
||||
|
|
|
@ -50,10 +50,10 @@ CONSTANT: pov-polygons
|
|||
[ [ 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 ]
|
||||
|
@ -82,10 +82,10 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
|
|||
[ >>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 [
|
||||
|
|
|
@ -7,4 +7,4 @@ TUPLE: key-handler < border handlers ;
|
|||
: <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* ;
|
||||
[ handlers>> at ] keep swap [ call( gadget -- ) f ] [ drop t ] if* ;
|
||||
|
|
|
@ -229,14 +229,12 @@ DEFER: (d)
|
|||
: 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 )
|
||||
|
|
|
@ -41,7 +41,7 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0
|
|||
[ [ 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> ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
|
||||
|
@ -9,10 +9,12 @@ 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 ;
|
||||
|
|
|
@ -7,7 +7,7 @@ IN: math.finance
|
|||
<PRIVATE
|
||||
|
||||
: weighted ( x y a -- z )
|
||||
tuck [ * ] [ 1 - neg * ] 2bi* + ;
|
||||
[ * ] [ 1 - neg * ] bi-curry bi* + ;
|
||||
|
||||
: a ( n -- a )
|
||||
1 + 2 swap / ;
|
||||
|
|
|
@ -3,9 +3,9 @@
|
|||
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 ;
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: accessors arrays kernel models models.product monads
|
||||
sequences sequences.extras ;
|
||||
sequences sequences.extras shuffle ;
|
||||
FROM: syntax => >> ;
|
||||
IN: models.combinators
|
||||
|
||||
|
|
|
@ -94,7 +94,7 @@ M: sequence <mdb-insert-msg> ( collection sequence -- mdb-insert-msg )
|
|||
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 ;
|
||||
|
||||
|
||||
|
|
|
@ -10,7 +10,7 @@ CONSTANT: MDB_TUPLE_INFO "_mfd_t_info"
|
|||
PRIVATE>
|
||||
|
||||
: <tuple-info> ( tuple -- tuple-info )
|
||||
class V{ } clone tuck
|
||||
class [ V{ } clone ] dip over
|
||||
[ [ name>> ] dip push ]
|
||||
[ [ vocabulary>> ] dip push ] 2bi ; inline
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
|
||||
|
@ -58,9 +58,11 @@ C: <token-parser> token-parser
|
|||
|
||||
: 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 ;
|
||||
|
@ -319,7 +321,7 @@ LAZY: <(+)> ( parser -- parser )
|
|||
<& &> ;
|
||||
|
||||
: 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
|
||||
|
|
|
@ -31,7 +31,7 @@ PRIVATE>
|
|||
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)
|
||||
|
@ -41,11 +41,11 @@ PRIVATE>
|
|||
! -------------------
|
||||
|
||||
: 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)
|
||||
|
@ -54,7 +54,7 @@ PRIVATE>
|
|||
<PRIVATE
|
||||
|
||||
: next-fibs ( x y -- y x+y )
|
||||
tuck + ;
|
||||
[ nip ] [ + ] 2bi ;
|
||||
|
||||
: ?retotal ( total fib- fib+ -- retotal fib- fib+ )
|
||||
dup even? [ [ nip + ] 2keep ] when ;
|
||||
|
|
|
@ -5,19 +5,18 @@ IN: project-euler.100
|
|||
|
||||
! 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
|
||||
|
@ -26,7 +25,7 @@ IN: project-euler.100
|
|||
: 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
|
||||
|
||||
|
|
|
@ -31,7 +31,7 @@ IN: project-euler.117
|
|||
[ 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>
|
||||
|
||||
|
|
|
@ -11,8 +11,8 @@ IN: project-euler.ave-time
|
|||
[
|
||||
[ datastack ]
|
||||
[
|
||||
'[ _ gc benchmark 1000 / , ] tuck
|
||||
'[ _ _ with-datastack drop ]
|
||||
'[ _ gc benchmark 1000 / , ]
|
||||
[ '[ _ _ with-datastack drop ] ] keep swap
|
||||
]
|
||||
[ 1 - ] tri* swap times call
|
||||
] { } make ; inline
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
! (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
|
||||
|
||||
|
@ -89,8 +89,9 @@ DEFER: in-rect*
|
|||
: 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 ;
|
||||
|
@ -103,15 +104,15 @@ DEFER: in-rect*
|
|||
: 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 ;
|
||||
|
|
|
@ -22,7 +22,7 @@ IN: blum-blum-shub.tests
|
|||
|
||||
[ 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*
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
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 )
|
||||
{
|
||||
|
|
|
@ -12,7 +12,7 @@ IN: sequences.abbrev
|
|||
[ 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>
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! 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
|
||||
|
||||
|
@ -32,9 +32,9 @@ C: <scaled> scaled
|
|||
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
|
||||
|
@ -45,8 +45,8 @@ 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
|
||||
|
|
|
@ -14,7 +14,9 @@ USING:
|
|||
io.files
|
||||
io.pathnames
|
||||
kernel
|
||||
locals
|
||||
math
|
||||
math.order
|
||||
openal
|
||||
opengl.gl
|
||||
sequences
|
||||
|
@ -41,9 +43,7 @@ CONSTANT: game-height 256
|
|||
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 ;
|
||||
|
@ -140,8 +140,8 @@ M: space-invaders read-port ( port cpu -- byte )
|
|||
#! 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? ;
|
||||
|
@ -320,17 +320,13 @@ CONSTANT: red { 255 0 0 }
|
|||
#! 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 ;
|
||||
|
||||
|
|
|
@ -57,7 +57,7 @@ fetched-in parsed-html links processed-in fetched-at ;
|
|||
[ 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 ;
|
||||
|
|
|
@ -37,7 +37,7 @@ TUPLE: piece
|
|||
|
||||
: 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 ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! 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 ;
|
||||
|
|
|
@ -2,7 +2,8 @@
|
|||
! 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 ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! 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 ;
|
||||
|
@ -78,7 +78,7 @@ M: list focusable-child* drop t ;
|
|||
dup list-empty? [
|
||||
2drop
|
||||
] [
|
||||
tuck control-value length rem >>index
|
||||
[ control-value length rem ] [ (>>index) ] [ ] tri
|
||||
[ relayout-1 ] [ scroll>selected ] bi
|
||||
] if ;
|
||||
|
||||
|
@ -95,9 +95,9 @@ M: list focusable-child* drop t ;
|
|||
[ 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 ;
|
||||
|
|
|
@ -10,7 +10,7 @@ IN: units.tests
|
|||
[ 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
|
||||
|
|
|
@ -48,7 +48,7 @@ MEMO: cities-named ( name -- cities )
|
|||
|
||||
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 )
|
||||
|
|
Loading…
Reference in New Issue