! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-text core-text.fonts core-foundation
core-foundation.dictionaries destructors arrays kernel generalizations
-math accessors core-foundation.utilities combinators hashtables colors
+locals math accessors core-foundation.utilities combinators hashtables colors
colors.constants ;
IN: core-text.tests
] with-destructors
] unit-test
-: test-typographic-bounds ( string font -- ? )
+:: test-typographic-bounds ( string font -- ? )
[
- test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
- compute-line-metrics {
+ font test-font &CFRelease :> ctfont
+ string ctfont COLOR: white <CTLine> &CFRelease :> ctline
+ ctfont ctline compute-line-metrics {
[ width>> float? ]
[ ascent>> float? ]
[ descent>> float? ]
[ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test
-[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test
\ No newline at end of file
+[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test
"can write csv too!"
[ "foo1,bar1\nfoo2,bar2\n" ]
-[ { { "foo1" "bar1" } { "foo2" "bar2" } } <string-writer> tuck write-csv >string ] named-unit-test
+[ { { "foo1" "bar1" } { "foo2" "bar2" } } <string-writer> [ write-csv ] keep >string ] named-unit-test
+
"escapes quotes commas and newlines when writing"
[ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
-[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "
+[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> [ write-csv ] keep >string ] named-unit-test ! "
[ { { "writing" "some" "csv" "tests" } } ]
[
io.files kernel math math.parser namespaces prettyprint fry
sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
-math.intervals io nmake accessors vectors math.ranges random
+math.intervals io locals nmake accessors vectors math.ranges random
math.bitwise db.queries destructors db.tuples.private interpolate
io.streams.string make db.private sequences.deep
db.errors.sqlite ;
nip [ key>> ] [ value>> ] [ type>> ] tri
<sqlite-low-level-binding> ;
-M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
- tuck
- [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
- rot set-slot-named
- [ [ key>> ] [ type>> ] bi ] dip
- swap <sqlite-low-level-binding> ;
+M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
+ generate-bind generator-singleton>> eval-generator :> obj
+ generate-bind slot-name>> :> name
+ obj name tuple set-slot-named
+ generate-bind key>> obj generate-bind type>> <sqlite-low-level-binding> ;
M: sqlite-statement bind-tuple ( tuple statement -- )
[
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }\r
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }\r
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }\r
- { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }\r
} ;\r
\r
ARTICLE: "fry.philosophy" "Fried quotation philosophy"\r
get-controllers [ product-id = ] with filter ;
: find-controller-instance ( product-id instance-id -- controller/f )
get-controllers [
- tuck
[ product-id = ]
- [ instance-id = ] 2bi* and
+ [ instance-id = ] bi-curry bi* and
] with with find nip ;
TUPLE: keyboard-state keys ;
\r
{ nappend nappend-as } related-words\r
\r
-HELP: ntuck\r
-{ $values\r
- { "n" integer }\r
-}\r
-{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;\r
-\r
-HELP: nspin\r
-{ $values\r
- { "n" integer }\r
-}\r
-{ $description "A generalization of " { $link spin } " that can work for any stack depth. The top " { $snippet "n" } " items will be reversed in order." } ;\r
-\r
ARTICLE: "sequence-generalizations" "Generalized sequence operations"\r
{ $subsections\r
narray\r
-nrot\r
nnip\r
ndrop\r
- ntuck\r
- nspin\r
mnswap\r
nweave\r
} ;\r
{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test\r
[ [ 1 ] 5 ndip ] must-infer\r
[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test\r
-[ 5 nspin ] must-infer\r
-[ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test\r
\r
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer\r
[ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer\r
MACRO: nnip ( n -- )
'[ [ _ ndrop ] dip ] ;
-MACRO: ntuck ( n -- )
- 2 + '[ dup _ -nrot ] ;
-
MACRO: ndip ( n -- )
[ [ dip ] curry ] n*quot [ call ] compose ;
[ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
if-zero ;
-MACRO: napply ( n -- )
- [ [ drop ] ] dip [ '[ tuck _ 2dip call ] ] times ;
+: napply ( quot n -- )
+ [ dupn ] [ spread* ] bi ; inline
: apply-curry ( ...a quot n -- )
[ [curry] ] dip napply ; inline
: nappend ( n -- seq ) narray concat ; inline
-MACRO: nspin ( n -- )
- [ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ;
-
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
HELP: HINTS:
-{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } }
+{ $values { "defspec" "a word or method" } { "hints..." "a list of sequences of classes or literals" } }
{ $description "Defines specialization hints for a word or a method."
$nl
"Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." }
"M: assoc count-occurrences"
" swap [ = nip ] curry assoc-filter assoc-size ;"
""
- "HINTS: { sequence count-occurrences } { object array } ;"
- "HINTS: { assoc count-occurrences } { object hashtable } ;"
+ "HINTS: M\ sequence count-occurrences { object array } ;"
+ "HINTS: M\ assoc count-occurrences { object hashtable } ;"
}
} ;
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators
-grouping compression.huffman images
+grouping compression.huffman images fry
images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
block dup length>> sqrt >fixnum group flip
dup matrix-dim coord-matrix flip
[
- [ first2 spin nth nth ]
+ [ '[ _ [ second ] [ first ] bi ] dip nth nth ]
[ x,y v+ color-id jpeg-image draw-color ] bi
] with each^2 ;
binary [
[
{ HEX: FF } read-until
- read1 tuck HEX: 00 = and
+ read1 [ HEX: 00 = and ] keep swap
]
[ drop ] produce
swap >marker { EOI } assert=
} cond
] with-timeout ;
-:: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
+:: wait-for-overlapped ( usec -- bytes-transferred overlapped error? )
master-completion-port get-global
- 0 <int> [ ! bytes
- f <void*> ! key
- f <void*> [ ! overlapped
- us [ 1000 /i ] [ INFINITE ] if* ! timeout
- GetQueuedCompletionStatus zero?
- ] keep
- *void* dup [ OVERLAPPED memory>struct ] when
- ] keep *int spin ;
+ 0 <int> :> bytes
+ f <void*> :> key
+ f <void*> :> overlapped
+ usec [ 1000 /i ] [ INFINITE ] if* :> timeout
+ bytes key overlapped timeout GetQueuedCompletionStatus zero? :> error?
+
+ bytes *int
+ overlapped *void* dup [ OVERLAPPED memory>struct ] when
+ error? ;
: resume-callback ( result overlapped -- )
>c-ptr pending-overlapped get-global delete-at* drop resume-with ;
[ length ] dip buffer-reset ;
: string>buffer ( string -- buffer )
- dup length <buffer> tuck buffer-set ;
+ dup length <buffer> [ buffer-set ] keep ;
: buffer-read-all ( buffer -- byte-array )
[ [ pos>> ] [ ptr>> ] bi <displaced-alien> ]
M: winnt file-system-info ( path -- file-system-info )
normalize-path root-directory (file-system-info) ;
-: volume>paths ( string -- array )
- 16384 <ushort-array> tuck dup length
- 0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
- win32-error-string throw
+:: volume>paths ( string -- array )
+ 16384 :> names-buf-length
+ names-buf-length <ushort-array> :> names
+ 0 <uint> :> names-length
+
+ string names names-buf-length names-length GetVolumePathNamesForVolumeName :> ret
+ ret 0 = [
+ ret win32-error-string throw
] [
- *uint "ushort" heap-size * head
+ names names-length *uint "ushort" heap-size * head
utf16n alien>string CHAR: \0 split
] if ;
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
-: find-next-volume ( handle -- string/f )
- MAX_PATH 1 + [ <ushort-array> tuck ] keep
- FindNextVolume 0 = [
+:: find-next-volume ( handle -- string/f )
+ MAX_PATH 1 + :> buf-length
+ buf-length <ushort-array> :> buf
+
+ handle buf buf-length FindNextVolume :> ret
+ ret 0 = [
GetLastError ERROR_NO_MORE_FILES =
[ drop f ] [ win32-error-string throw ] if
] [
- utf16n alien>string
+ buf utf16n alien>string
] if ;
: find-volumes ( -- array )
current-directory get absolute-path cd
dup make-CreateProcess-args
- tuck fill-redirection
+ [ fill-redirection ] keep
dup call-CreateProcess
lpProcessInformation>>
] with-destructors ;
cons>> car ;
M: lazy-until cdr ( lazy-until -- cdr )
- [ cons>> unswons ] keep quot>> tuck call( elt -- ? )
+ [ quot>> ] [ cons>> unswons ] bi over call( elt -- ? )
[ 2drop nil ] [ luntil ] if ;
M: lazy-until nil? ( lazy-until -- ? )
: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
-: V+ ( x y -- x+y )
- 1.0 -rot n*V+V ; inline
-: V- ( x y -- x-y )
- -1.0 spin n*V+V ; inline
+:: V+ ( x y -- x+y )
+ 1.0 x y n*V+V ; inline
+:: V- ( x y -- x-y )
+ -1.0 y x n*V+V ; inline
: Vneg ( x -- -x )
-1.0 swap n*V ; inline
initial-values [ over 0 > ] [ next-values ] produce
[ 3drop ] dip ;
-: combination-indices ( m combo -- seq )
- [ tuck dual-index combinadic ] keep
- seq>> length 1 - swap [ - ] with map ;
+:: combination-indices ( m combo -- seq )
+ combo m combo dual-index combinadic
+ combo seq>> length 1 - swap [ - ] with map ;
: apply-combination ( m combo -- seq )
[ combination-indices ] keep seq>> nths ;
[ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test
-[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test
+[ t ] [ 1 2 [a,b] empty-interval over interval-union = ] unit-test
[ t ] [
0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] =
dup full-interval eq? [
drop 32 random-bits 31 2^ -
] [
- dup to>> first over from>> first tuck - random +
+ [ ] [ from>> first ] [ to>> first ] tri over - random +
2dup swap interval-contains? [
nip
] [
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.vectors math.matrices namespaces
-sequences ;
+USING: kernel locals math math.vectors math.matrices
+namespaces sequences ;
IN: math.matrices.elimination
SYMBOL: matrix
] each
] with-matrix ;
-: basis-vector ( row col# -- )
- [ clone ] dip
- [ swap nth neg recip ] 2keep
- [ 0 spin set-nth ] 2keep
- [ n*v ] dip
- matrix get set-nth ;
+:: basis-vector ( row col# -- )
+ row clone :> row'
+ col# row' nth neg recip :> a
+ 0 col# row' set-nth
+ a row n*v col# matrix get set-nth ;
: nullspace ( matrix -- seq )
echelon reduced dup empty? [
IN: persistent.hashtables.tests
USING: persistent.hashtables persistent.assocs hashtables assocs
-tools.test kernel namespaces random math.ranges sequences fry ;
+tools.test kernel locals namespaces random math.ranges sequences fry ;
[ t ] [ PH{ } assoc-empty? ] unit-test
: random-assocs ( n -- hash phash )
[ random-string ] replicate
[ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
- [ PH{ } clone swap [ spin new-at ] each-index ]
+ [ PH{ } clone swap [| ph elt i | i elt ph new-at ] each-index ]
bi ;
: ok? ( assoc1 assoc2 -- ? )
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: kernel math accessors assocs fry combinators parser
-prettyprint.custom make
+prettyprint.custom locals make
persistent.assocs
persistent.hashtables.nodes
persistent.hashtables.nodes.empty
M: persistent-hash >alist [ root>> >alist% ] { } make ;
-: >persistent-hash ( assoc -- phash )
- T{ persistent-hash } swap [ spin new-at ] assoc-each ;
+:: >persistent-hash ( assoc -- phash )
+ T{ persistent-hash } assoc [| ph k v | v k ph new-at ] assoc-each ;
M: persistent-hash equal?
over persistent-hash? [ assoc= ] [ 2drop f ] if ;
[ 2array ] [ drop level>> 1 + ] 2bi node boa ;
: new-child ( new-child node -- node' expansion/f )
- dup full? [ tuck level>> 1node ] [ node-add f ] if ;
+ dup full? [ [ level>> 1node ] keep swap ] [ node-add f ] if ;
: new-last ( val seq -- seq' )
[ length 1 - ] keep new-nth ;
dup level>> 1 = [
new-child
] [
- tuck children>> last (ppush-new-tail)
+ [ nip ] 2keep children>> last (ppush-new-tail)
[ swap new-child ] [ swap node-set-last f ] ?if
] if ;
] unless ;
: epsilon-table ( states nfa -- table )
- [ H{ } clone tuck ] dip
+ [ [ H{ } clone ] dip over ] dip
'[ _ _ t epsilon-loop ] each ;
: find-epsilon-closure ( states nfa -- dfa-state )
[ _ meaningful-integers ] keep add-out
] map ;
-: class-partitions ( classes -- assoc )
- [ integer? ] partition [
- dup powerset-partition spin add-integers
- [ [ partition>class ] keep 2array ] map
- [ first ] filter
- ] [ '[ _ singleton-partition ] map ] 2bi append ;
+:: class-partitions ( classes -- assoc )
+ classes [ integer? ] partition :> ( integers classes )
+
+ classes powerset-partition classes integers add-integers
+ [ [ partition>class ] keep 2array ] map [ first ] filter
+ integers [ classes singleton-partition ] map append ;
: new-transitions ( transitions -- assoc ) ! assoc is class, partition
values [ keys ] gather
'[ _ delete-duplicates ] change-transitions ;
: combine-state-transitions ( hash -- hash )
- H{ } clone tuck '[
+ [ H{ } clone ] dip over '[
_ [ 2array <or-class> ] change-at
] assoc-each [ swap ] assoc-map ;
USING: help.markup help.syntax ;
IN: shuffle
+HELP: spin $complex-shuffle ;
HELP: roll $complex-shuffle ;
HELP: -roll $complex-shuffle ;
SYNTAX: shuffle(
")" parse-effect suffix! \ shuffle-effect suffix! ;
+: spin ( x y z -- z y x ) swap rot ; inline deprecated
+
: roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline deprecated
: -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline deprecated
: <funky-slice> ( from/f to/f seq -- slice )
[
- tuck
- [ drop 0 or ] [ length or ] 2bi*
+ [ drop 0 or ] [ length or ] bi-curry bi*
[ min ] keep
] keep <slice> ; inline
[ main-file-string ] dip utf8 set-file-contents ;
: scaffold-main ( vocab-root vocab -- )
- tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [
+ [ ".factor" vocab-root/vocab/suffix>path ] keep swap scaffolding? [
set-scaffold-main-file
] [
2drop
] [
[
[ children>> swap first head-slice % ]
- [ tuck traverse-step traverse-to-path ]
- 2bi
+ [ nip ]
+ [ traverse-step traverse-to-path ]
+ 2tri
] make-node
] if
] if ;
] [
[
[ traverse-step traverse-from-path ]
- [ tuck children>> swap first 1 + tail-slice % ] 2bi
+ [ nip ]
+ [ children>> swap first 1 + tail-slice % ]
+ 2tri
] make-node
] if
] if ;
gr_mem>> utf8 alien>strings ;
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
- \ unix:group <struct> tuck 4096
+ [ \ unix:group <struct> ] dip over 4096
[ <byte-array> ] keep f <void*> ;
: check-group-struct ( group-struct ptr -- group-struct/f )
>lower "on" = ;
: v-default ( str def -- str/def )
- over empty? spin ? ;
+ [ nip empty? ] 2keep ? ;
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;
[ >>x drop ] ! IInherited::setX
} }
{ IUnrelated {
- [ swap x>> + ] ! IUnrelated::xPlus
- [ spin x>> * + ] ! IUnrelated::xMulAdd
+ [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
+ [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd
} }
} <com-wrapper>
dup +test-wrapper+ set [
[ >>x drop ] ! IInherited::setX\r
} }\r
{ "IUnrelated" {\r
- [ swap x>> + ] ! IUnrelated::xPlus\r
- [ spin x>> * + ] ! IUnrealted::xMulAdd\r
+ [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus\r
+ [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd\r
} }\r
} <com-wrapper>""" } ;\r
\r
dup [ glob-matches? ] [ 2drop f ] if ;
: suitable-mode? ( file-name first-line mode -- ? )
- tuck first-line-glob>> ?glob-matches
+ [ nip ] 2keep first-line-glob>> ?glob-matches
[ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
: find-mode ( file-name first-line -- mode )
[ >string ] dip first-match dup [ to>> ] when ;
: rule-start-matches? ( rule -- match-count/f )
- dup start>> tuck swap can-match-here? [
+ [ start>> dup ] keep can-match-here? [
rest-of-line swap text>> text-matches?
] [
drop f
dup mark-following-rule? [
dup start>> swap can-match-here? 0 and
] [
- dup end>> tuck swap can-match-here? [
+ [ end>> dup ] keep can-match-here? [
rest-of-line
swap text>> context get end>> or
text-matches?
?end-rule
mark-token
add-remaining-token
- tuck body-token>> next-token,
+ [ body-token>> next-token, ] keep
delegate>> [ push-context ] when* ;
UNION: abstract-span-rule span-rule eol-span-rule ;
?end-rule
mark-token
add-remaining-token
- tuck rule-match-token* next-token,
+ [ rule-match-token* next-token, ] keep
! ... end subst ...
dup context get (>>in-rule)
delegate>> push-context ;
M: mark-following-rule handle-rule-start
?end-rule
mark-token add-remaining-token
- tuck rule-match-token* next-token,
+ [ rule-match-token* next-token, ] keep
f context get (>>end)
context get (>>in-rule) ;
C: <predicate-engine> predicate-engine
-: push-method ( method specializer atomic assoc -- )
+: push-method ( specializer method atomic assoc -- )
dupd [
[ ] [ H{ } clone <predicate-engine> ] ?if
[ methods>> set-at ] keep
: flatten-method ( class method assoc -- )
[ [ flatten-class keys ] keep ] 2dip [
- [ spin ] dip push-method
+ [ swap rot ] dip push-method
] 3curry each ;
: flatten-methods ( assoc -- assoc' )
HELP: pick ( x y z -- x y z x ) $shuffle ;
HELP: swap ( x y -- y x ) $shuffle ;
-HELP: spin $complex-shuffle ;
HELP: rot ( x y z -- y z x ) $complex-shuffle ;
HELP: -rot ( x y z -- z x y ) $complex-shuffle ;
HELP: dupd ( x y -- x x y ) $complex-shuffle ;
swapd
rot
-rot
- spin
} ;
ARTICLE: "shuffle-words" "Shuffle words"
DEFER: 3dip
! Stack stuff
-: spin ( x y z -- z y x ) swap rot ; inline
-
: 2over ( x y z -- x y z x y ) pick pick ; inline
: clear ( -- ) { } set-datastack ;
: process-to-date ( account date -- account )
over interest-last-paid>> 1 days time+
- [ dupd process-day ] spin each-day ;
+ [ [ dupd process-day ] ] 2dip swap each-day ;
: inserting-transactions ( account transactions -- account )
[ [ date>> process-to-date ] keep >>transaction ] each ;
-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 -- )
skip-whitespace/comments
[ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
-: handle-define ( preprocessor-state sequence-parser -- )
- [ take-define-identifier ]
- [ skip-whitespace/comments take-rest ] bi
- "\\" ?tail [ readlns append ] when
- spin symbol-table>> set-at ;
+:: handle-define ( preprocessor-state sequence-parser -- )
+ sequence-parser take-define-identifier :> ident
+ sequence-parser skip-whitespace/comments take-rest :> def
+ def "\\" ?tail [ readlns append ] when :> def
+ def ident preprocessor-state symbol-table>> set-at ;
: handle-undef ( preprocessor-state sequence-parser -- )
take-token swap symbol-table>> delete-at ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations debugger hashtables http
http.client io io.encodings.string io.encodings.utf8 json.reader
-json.writer kernel make math math.parser namespaces sequences strings
-urls urls.encoding vectors ;
+json.writer kernel locals make math math.parser namespaces sequences
+strings urls urls.encoding vectors ;
IN: couchdb
! NOTE: This code only works with the latest couchdb (0.9.*), because old
: attachments> ( assoc -- attachments ) "_attachments" swap at ;
: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
-: copy-key ( to from to-key from-key -- )
- rot at spin set-at ;
+:: copy-key ( to from to-key from-key -- )
+ from-key from at
+ to-key to set-at ;
: copy-id ( to from -- )
"_id" "id" copy-key ;
: 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 ;
] if ;
: topological-sort ( digraph -- seq )
- dup clone V{ } clone spin
+ [ V{ } clone ] dip [ clone ] keep
[ drop (topological-sort) ] assoc-each drop reverse ;
: topological-sorted-values ( digraph -- seq )
: 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
USING: arrays vectors combinators effects kernel math sequences splitting
strings.parser parser fry sequences.extras ;
+
+! a b c glue => acb
+! c b a [ append ] dip prepend
+
IN: fries
: str-fry ( str on -- quot ) split
- [ unclip-last [ [ spin glue ] reduce-r ] 2curry ]
+ [ unclip-last [ [ [ append ] [ prepend ] bi* ] reduce-r ] 2curry ]
[ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
: gen-fry ( str on -- quot ) split
- [ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ]
+ [ unclip-last [ [ [ 1array ] [ append ] [ prepend ] tri* ] reduce-r ] 2curry ]
[ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
SYNTAX: i" parse-string rest "_" str-fry append! ;
[ swap depth-attachment>> [ swap call ] [ drop ] if* ]
[ swap stencil-attachment>> [ swap call ] [ drop ] if* ] 2tri ; inline
-: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
- [ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ]
- [ swap depth-attachment>> [ GL_DEPTH_ATTACHMENT spin call ] [ drop ] if* ]
- [ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline
+:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
+ framebuffer color-attachments>>
+ [| attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index
+ framebuffer depth-attachment>>
+ [| attachment | GL_DEPTH_ATTACHMENT attachment quot call ] when*
+ framebuffer stencil-attachment>>
+ [| attachment | GL_STENCIL_ATTACHMENT attachment quot call ] when* ; inline
GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- )
: 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
find 2drop ;
: nearest-segment-forward ( segments oint start -- segment )
- rot dup length swap <slice> find-nearest-segment ;
+ rot tail-slice find-nearest-segment ;
: nearest-segment-backward ( segments oint start -- segment )
- swapd 1 + 0 spin <slice> <reversed> find-nearest-segment ;
+ 1 + rot head-slice <reversed> find-nearest-segment ;
: nearest-segment ( segments oint start-segment -- segment )
#! find the segment nearest to 'oint', and return it.
[ [ 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* ;
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables assocs io kernel math
+USING: accessors arrays hashtables assocs io kernel locals math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
splitting sorting shuffle sets math.order ;
[ ?nth ?nth ] 3keep [ [ 2 + ] dip 1 - ] dip ?nth ?nth
dim-im/ker-d ;
-: bigraded-ker/im-d ( bigraded-basis -- seq )
- dup length [
- over first length [
- [ 2dup ] dip spin (bigraded-ker/im-d)
- ] map 2nip
- ] with map ;
+:: bigraded-ker/im-d ( basis -- seq )
+ basis length iota [| z |
+ basis first length iota [| u |
+ u z basis (bigraded-ker/im-d)
+ ] map
+ ] map ;
: bigraded-betti ( u-generators z-generators -- seq )
[ basis graded ] bi@ tensor bigraded-ker/im-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 )
3tri
3array ;
-: bigraded-triples ( grid -- triples )
- dup length [
- over first length [
- [ 2dup ] dip spin bigraded-triple
- ] map 2nip
- ] with map ;
+:: bigraded-triples ( grid -- triples )
+ grid length [| z |
+ grid first length [| u |
+ u z grid bigraded-triple
+ ] map
+ ] map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq )
[ [ basis graded ] bi@ tensor bigraded-triples ] dip
[ [ 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*
{ nkeep 5 }\r
{ npick 6 }\r
{ nrot 5 }\r
- { ntuck 6 }\r
{ nwith 4 }\r
{ over 2 }\r
{ pick 4 }\r
{ rot 3 }\r
- { spin 3 }\r
{ swap 1 }\r
{ swapd 3 }\r
- { tuck 2 }\r
{ with 1/2 }\r
\r
{ bi 1/2 }\r
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
-USING: accessors assocs fry generalizations kernel math
-namespaces parser sequences words ;
+USING: accessors assocs fry generalizations kernel locals math
+namespaces parser sequences shuffle words ;
IN: set-n
: get* ( var n -- val ) namestack dup length rot - head assoc-stack ;
: set* ( val var n -- ) 1 + namestack [ length swap - ] keep nth set-at ;
! dynamic lambda
-SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ;
\ No newline at end of file
+SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ;
io.files
io.pathnames
kernel
+ locals
math
+ math.order
openal
opengl.gl
sequences
#! Point is a {x y}.
first2 game-width 3 * * swap 3 * + ;
-: set-bitmap-pixel ( color point array -- )
- #! 'color' is a {r g b}. Point is {x y}.
- [ bitmap-index ] dip ! color index array
- [ [ first ] 2dip set-nth ] 3keep
- [ [ second ] 2dip [ 1 + ] dip set-nth ] 3keep
- [ third ] 2dip [ 2 + ] dip set-nth ;
+:: set-bitmap-pixel ( bitmap point color -- )
+ point bitmap-index :> index
+ color first index bitmap set-nth
+ color second index 1 + bitmap set-nth
+ color third index 2 + bitmap set-nth ;
: get-bitmap-pixel ( point array -- color )
#! Point is a {x y}. color is a {r g b}
#! 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? ;
: plot-bitmap-pixel ( bitmap point color -- )
#! point is a {x y}. color is a {r g b}.
- spin set-bitmap-pixel ;
-
-: within ( n a b -- bool )
- #! n >= a and n <= b
- rot tuck swap <= [ swap >= ] dip and ;
+ set-bitmap-pixel ;
: 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 ;
: solution ( puzzle random? -- solution ) dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ;
: hint ( puzzle -- puzzle' ) [ [ f swap indices random dup ] [ f solution ] bi nth ] keep swapd >vector [ set-nth ] keep ;
: create ( difficulty -- puzzle ) 81 [ f ] replicate
- 40 random solution [ [ dup length random f spin set-nth ] curry times ] keep ;
+ 40 random solution [ [ f swap [ length random ] keep set-nth ] curry times ] keep ;
: do-sudoku ( -- ) [ [
[
level>> 1 - 60 * 1000 swap - ;
: add-block ( tetris block -- )
- over board>> spin current-piece tetromino>> colour>> set-block ;
+ over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ;
: game-over? ( tetris -- ? )
[ board>> ] [ next-piece ] bi piece-valid? not ;
: 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 ;
M: TYPE >alist ( db -- alist )
[ DBKEYS dup ] keep '[ dup _ at 2array ] map! drop ;
-M: TYPE set-at ( value key db -- )
- handle>> spin [ object>bytes dup length ] bi@ DBPUT drop ;
+M:: TYPE set-at ( value key db -- )
+ db handle>> key value [ object>bytes dup length ] bi@ DBPUT drop ;
-M: TYPE delete-at ( key db -- )
- handle>> swap object>bytes dup length DBOUT drop ;
+M:: TYPE delete-at ( key db -- )
+ db handle>> key object>bytes dup length DBOUT drop ;
M: TYPE clear-assoc ( db -- ) handle>> DBVANISH drop ;
! 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 ;
! Just take the previous mentioned placeholder and use it
! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves
DEFER: with-interface
-: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
- templates get spin '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
+: insertion-quot ( quot -- quot' )
+ make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
+ [ templates get ] 2dip swap '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
SYNTAX: ,% scan string>number [ <layout> , ] curry append! ;
SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] append! ;
! 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
dimensioned boa ;
: >dimensioned< ( d -- n top bot )
- [ value>> ] [ top>> ] [ bot>> ] tri ;
+ [ bot>> ] [ top>> ] [ value>> ] tri ;
-\ <dimensioned> [ >dimensioned< ] define-inverse
+\ <dimensioned> [ [ dimensioned boa ] undo ] define-inverse
: dimensions ( dimensioned -- top bot )
[ top>> ] [ bot>> ] bi ;
: d-sq ( d -- d ) dup d* ;
: d-recip ( d -- d' )
- >dimensioned< spin recip dimension-op> ;
+ >dimensioned< recip dimension-op> ;
: d/ ( d d -- d ) d-recip d* ;
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