"." write flush
{
- new-sequence nth push pop peek flip
+ new-sequence nth push pop last flip
} compile-unoptimized
"." write flush
[
"\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
] [
- 16 11 <string> "Hi There" md5 hmac-bytes >string ] unit-test
+ "Hi There" 16 11 <string> md5 hmac-bytes >string ] unit-test
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
-[ "Jefe" "what do ya want for nothing?" md5 hmac-bytes >string ] unit-test
+[ "what do ya want for nothing?" "Jefe" md5 hmac-bytes >string ] unit-test
[
"V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
]
[
- 16 HEX: aa <string>
- 50 HEX: dd <repetition> md5 hmac-bytes >string
+ 50 HEX: dd <repetition>
+ 16 HEX: aa <string> md5 hmac-bytes >string
] unit-test
[
"g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
] [
- 16 11 <string> "Hi There" sha1 hmac-bytes >string
+ "Hi There" 16 11 <string> sha1 hmac-bytes >string
] unit-test
[
"\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
] [
- "Jefe" "what do ya want for nothing?" sha1 hmac-bytes >string
+ "what do ya want for nothing?" "Jefe" sha1 hmac-bytes >string
] unit-test
[
"\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
] [
- 16 HEX: aa <string>
- 50 HEX: dd <repetition> sha1 hmac-bytes >string
+ 50 HEX: dd <repetition>
+ 16 HEX: aa <string> sha1 hmac-bytes >string
] unit-test
[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
-[ 20 HEX: b <string> "Hi There" sha-256 hmac-bytes hex-string ] unit-test
+[ "Hi There" 20 HEX: b <string> sha-256 hmac-bytes hex-string ] unit-test
[ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ]
[
- "JefeJefeJefeJefeJefeJefeJefeJefe"
- "what do ya want for nothing?" sha-256 hmac-bytes hex-string
+ "what do ya want for nothing?"
+ "JefeJefeJefeJefeJefeJefeJefeJefe" sha-256 hmac-bytes hex-string
] unit-test
: ipad ( checksum-state -- seq ) block-size>> HEX: 36 <array> ;
-:: init-K ( K checksum checksum-state -- o i )
- checksum-state block-size>> K length <
- [ K checksum checksum-bytes ] [ K ] if
+:: init-key ( checksum key checksum-state -- o i )
+ checksum-state block-size>> key length <
+ [ key checksum checksum-bytes ] [ key ] if
checksum-state block-size>> 0 pad-tail
[ checksum-state opad seq-bitxor ]
[ checksum-state ipad seq-bitxor ] bi ;
PRIVATE>
-:: hmac-stream ( K stream checksum -- value )
- K checksum dup initialize-checksum-state
- dup :> checksum-state
- init-K :> Ki :> Ko
+:: hmac-stream ( stream key checksum -- value )
+ checksum initialize-checksum-state :> checksum-state
+ checksum key checksum-state init-key :> Ki :> Ko
checksum-state Ki add-checksum-bytes
stream add-checksum-stream get-checksum
checksum initialize-checksum-state
Ko add-checksum-bytes swap add-checksum-bytes
get-checksum ;
-: hmac-file ( K path checksum -- value )
- [ binary <file-reader> ] dip hmac-stream ;
+: hmac-file ( path key checksum -- value )
+ [ binary <file-reader> ] 2dip hmac-stream ;
-: hmac-bytes ( K seq checksum -- value )
- [ binary <byte-reader> ] dip hmac-stream ;
+: hmac-bytes ( seq key checksum -- value )
+ [ binary <byte-reader> ] 2dip hmac-stream ;
: full? ( circular -- ? )
[ length ] [ seq>> length ] bi = ;
-: set-peek ( elt seq -- )
+: set-last ( elt seq -- )
[ length 1- ] keep set-nth ;
PRIVATE>
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]
- [ [ 1+ ] change-length set-peek ] if ;
+ [ [ 1+ ] change-length set-last ] if ;
: <growing-circular> ( capacity -- growing-circular )
{ } new-sequence 0 0 growing-circular boa ;
: record-constant-set-slot ( slot# vreg -- )
history [
- dup empty? [ dup peek store? [ dup pop* ] when ] unless
+ dup empty? [ dup last store? [ dup pop* ] when ] unless
store new-action swap ?push
] change-at ;
[ second ds-load ] [ ^^load-literal ] bi prefix ;
: emit-<tuple-boa> ( node -- )
- dup node-input-infos peek literal>>
+ dup node-input-infos last literal>>
dup array? [
nip
ds-drop
: >node ( cursor -- ) node-stack get push ;
: node> ( -- cursor ) node-stack get pop ;
-: node@ ( -- cursor ) node-stack get peek ;
+: node@ ( -- cursor ) node-stack get last ;
: current-node ( -- node ) node@ first ;
: iterate-next ( -- cursor ) node@ rest-slice ;
: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
[ split-children ] map concat check-assigned ;
: picture ( uses -- str )
- dup peek 1 + CHAR: space <string>
+ dup last 1 + CHAR: space <string>
[ '[ CHAR: * swap _ set-nth ] each ] keep ;
: interval-picture ( interval -- str )
swap int-regs swap vreg boa >>vreg
max-uses get random 2 max [ not-taken ] replicate natural-sort
[ >>uses ] [ first >>start ] bi
- dup uses>> peek >>end
+ dup uses>> last >>end
] map
] with-scope ;
: delete-conditional? ( bb -- ? )
dup instructions>> [ drop f ] [
- peek class {
+ last class {
##compare-branch
##compare-imm-branch
##compare-float-branch
: remove-phi-inputs ( #phi -- )
if-node get children>>
- [ dup ends-with-terminate? [ drop f ] [ peek out-d>> ] if ] map
+ [ dup ends-with-terminate? [ drop f ] [ last out-d>> ] if ] map
pad-with-bottom >>phi-in-d drop ;
: live-value-indices ( values -- indices )
propagate
compute-def-use
dup check-nodes
- peek node-input-infos ;
+ last node-input-infos ;
: final-classes ( quot -- seq )
final-info [ class>> ] map ;
C: --> implication
: assume-implication ( p q -- )
- [ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
+ [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication assume*
resolve-copy value-infos get assoc-stack null-info or ;
: set-value-info ( info value -- )
- resolve-copy value-infos get peek set-at ;
+ resolve-copy value-infos get last set-at ;
: refine-value-info ( info value -- )
resolve-copy value-infos get
[ assoc-stack value-info-intersect ] 2keep
- peek set-at ;
+ last set-at ;
: value-literal ( value -- obj ? )
value-info >literal< ;
dup in-d>> first node-value-info literal>> ;
: last-literal ( #call -- obj )
- dup out-d>> peek node-value-info literal>> ;
+ dup out-d>> last node-value-info literal>> ;
: immutable-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
- dup in-d>> peek node-value-info
+ dup in-d>> last node-value-info
literal>> first immutable-tuple-class?
] [ drop f ] if ;
{ fixnum byte-array } declare
[ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
[ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
- 255 min 0 max
+ 0 255 clamp
] final-classes
] unit-test
] unit-test
[ V{ 1.5 } ] [
- [ /f 1.5 min 1.5 max ] final-literals
+ [ /f 1.5 1.5 clamp ] final-literals
] unit-test
[ V{ 1.5 } ] [
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
! Joe found an oversight
-[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
\ No newline at end of file
+[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
: ends-with-terminate? ( nodes -- ? )
- [ f ] [ peek #terminate? ] if-empty ;
+ [ f ] [ last #terminate? ] if-empty ;
M: vector child-visitor V{ } clone ;
M: vector #introduce, #introduce node, ;
}
: font-name ( string -- string' )
- font-names at-default ;
+ font-names ?at drop ;
: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
: csv ( stream -- rows )
[ [ (csv) ] { } make ] with-input-stream
- dup peek { "" } = [ but-last ] when ;
+ dup last { "" } = [ but-last ] when ;
: file>csv ( path encoding -- csv )
<file-reader> csv ;
[ "Goodbye, cruel world." ] [ "d" get doc-string ] unit-test
[ "" { 0 9 } { 0 15 } ] [
- "d" get undos>> peek
+ "d" get undos>> last
[ old-string>> ] [ from>> ] [ new-to>> ] tri
] unit-test
[ ] [ "Hello world" "d" get set-doc-string ] unit-test
-[ { "" } ] [ "value" get ] unit-test
\ No newline at end of file
+[ { "" } ] [ "value" get ] unit-test
] [
first swap length 1- + 0
] if
- ] dip peek length + 2array ;
+ ] dip last length + 2array ;
: prepend-first ( str seq -- )
0 swap [ append ] change-nth ;
[ undos>> ] [ redos>> ] [ undo-edit ] undo/redo ;
: redo ( document -- )
- [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;
\ No newline at end of file
+ [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;
: trim-row ( seq -- seq' )
rest
- dup peek empty? [ but-last ] when ;
+ dup last empty? [ but-last ] when ;
-: ?peek ( seq -- elt/f )
- [ f ] [ peek ] if-empty ;
+: ?last ( seq -- elt/f )
+ [ f ] [ last ] if-empty ;
: coalesce ( rows -- rows' )
V{ } clone [
'[
- _ dup ?peek ?peek CHAR: \\ =
+ _ dup ?last ?last CHAR: \\ =
[ [ pop "|" rot 3append ] keep ] when
push
] each
MACRO: nspread ( quots n -- )
over empty? [ 2drop [ ] ] [
[ [ but-last ] dip ]
- [ [ peek ] dip ] 2bi
+ [ [ last ] dip ] 2bi
swap
'[ [ _ _ nspread ] _ ndip @ ]
] if ;
data>> pop* ; inline
: data-peek ( heap -- entry )
- data>> peek ; inline
+ data>> last ; inline
: data-first ( heap -- entry )
data>> first ; inline
[ (eval>string) ] call( code -- output )
"\n" ?tail drop
] keep
- peek assert=
+ last assert=
] vocabs-quot get call( quot -- ) ;
: check-examples ( element -- )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser words definitions kernel sequences assocs arrays
-kernel.private fry combinators accessors vectors strings sbufs
-byte-arrays byte-vectors io.binary io.streams.string splitting math
-math.parser generic generic.single generic.standard classes
-hashtables namespaces ;
+USING: accessors arrays assocs byte-arrays byte-vectors classes
+combinators definitions fry generic generic.single
+generic.standard hashtables io.binary io.streams.string kernel
+kernel.private math math.parser namespaces parser sbufs
+sequences splitting splitting.private strings vectors words ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each
-{ peek pop* pop } [
+{ last pop* pop } [
{ vector } "specializer" set-word-prop
] each
'space' ,
'attr' ,
'space' ,
- [ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional ,
+ [ "=" token , 'space' , 'value' , ] seq* [ last ] action optional ,
'space' ,
] seq* ;
: &back ( -- )
inspector-stack get
- dup length 1 <= [ drop ] [ [ pop* ] [ peek reinspect ] bi ] if ;
+ dup length 1 <= [ drop ] [ [ pop* ] [ last reinspect ] bi ] if ;
: &add ( value key -- ) mirror get set-at &push reinspect ;
\ first4 [ 4array ] define-inverse
\ prefix \ unclip define-dual
-\ suffix [ dup but-last swap peek ] define-inverse
+\ suffix [ dup but-last swap last ] define-inverse
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
\ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
\r
: levenshtein ( old new -- n )\r
[ levenshtein-initialize ] [ levenshtein-step ]\r
- run-lcs peek peek ;\r
+ run-lcs last last ;\r
\r
TUPLE: retain item ;\r
TUPLE: delete item ;\r
building get empty? [\r
"Warning: log begins with multiline entry" print drop\r
] [\r
- message>> first building get peek message>> push\r
+ message>> first building get last message>> push\r
] if ;\r
\r
: parse-log ( lines -- entries )\r
] unit-test
[ t ] [
- 1067811677921310779 make-bits peek
+ 1067811677921310779 make-bits last
] unit-test
[ t ] [
- 1067811677921310779 >bignum make-bits peek
-] unit-test
\ No newline at end of file
+ 1067811677921310779 >bignum make-bits last
+] unit-test
"Incrementing, decrementing:"
{ $subsection 1+ }
{ $subsection 1- }
-"Minimum, maximum:"
+"Minimum, maximum, clamping:"
{ $subsection min }
{ $subsection max }
+{ $subsection clamp }
"Complex conjugation:"
{ $subsection conjugate }
"Tests:"
: /-last ( seq seq -- a )
#! divide the last two numbers in the sequences
- [ peek ] bi@ / ;
+ [ last ] bi@ / ;
: (p/mod) ( p p -- p p )
2dup /-last
USING: help.syntax help.markup arrays sequences ;
-
IN: math.ranges
ARTICLE: "math.ranges" "Numeric ranges"
{ $code "100 1 [a,b] product" }
"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
-ABOUT: "math.ranges"
\ No newline at end of file
+ABOUT: "math.ranges"
[ { 0 1/3 2/3 1 } ] [ 0 1 1/3 <range> >array ] unit-test
[ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 <range> >array reverse ] unit-test
-[ t ] [ 5 [0,b] range-increasing? ] unit-test
-[ f ] [ 5 [0,b] range-decreasing? ] unit-test
-[ f ] [ -5 [0,b] range-increasing? ] unit-test
-[ t ] [ -5 [0,b] range-decreasing? ] unit-test
-[ 0 ] [ 5 [0,b] range-min ] unit-test
-[ 5 ] [ 5 [0,b] range-max ] unit-test
-[ 3 ] [ 3 5 [0,b] clamp-to-range ] unit-test
-[ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test
-[ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test
-[ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test
-
[ 100 ] [
1 100 [a,b] [ 2^ [1,b] ] map prune length
-] unit-test
\ No newline at end of file
+] unit-test
INSTANCE: range immutable-sequence
+<PRIVATE
+
: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
: (a, ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline
: ,b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline
+PRIVATE>
+
: [a,b] ( a b -- range ) twiddle <range> ; inline
: (a,b] ( a b -- range ) twiddle (a, <range> ; inline
: [1,b] ( b -- range ) 1 swap [a,b] ; inline
: [0,b) ( b -- range ) 0 swap [a,b) ; inline
-
-: range-increasing? ( range -- ? )
- step>> 0 > ;
-
-: range-decreasing? ( range -- ? )
- step>> 0 < ;
-
-: first-or-peek ( seq head? -- elt )
- [ first ] [ peek ] if ;
-
-: range-min ( range -- min )
- dup range-increasing? first-or-peek ;
-
-: range-max ( range -- max )
- dup range-decreasing? first-or-peek ;
-
-: clamp-to-range ( n range -- n )
- [ range-min max ] [ range-max min ] bi ;
-
-: sequence-index-range ( seq -- range )
- length [0,b) ;
[ 2 ] [ { 1 2 3 } median ] unit-test
[ 5/2 ] [ { 1 2 3 4 } median ] unit-test
+[ 1 ] [ { 1 } mode ] unit-test
+[ 3 ] [ { 1 2 3 3 3 4 5 6 76 7 2 21 1 3 3 3 } mode ] unit-test
+
[ { } median ] must-fail
[ { } upper-median ] must-fail
[ { } lower-median ] must-fail
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel math math.analysis
math.functions math.order sequences sorting locals
-sequences.private ;
+sequences.private assocs fry ;
IN: math.statistics
: mean ( seq -- x )
: median ( seq -- x )
dup length odd? [ lower-median ] [ medians + 2 / ] if ;
+: frequency ( seq -- hashtable )
+ H{ } clone [ '[ _ inc-at ] each ] keep ;
+
+: mode ( seq -- x )
+ frequency >alist
+ [ ] [ [ [ second ] bi@ > ] 2keep ? ] map-reduce first ;
+
: minmax ( seq -- min max )
#! find the min and max of a seq in one pass
[ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ;
GENERIC: set-range-max-value ( value model -- )
: clamp-value ( value range -- newvalue )
- [ range-min-value max ] keep
- range-max-value* min ;
+ [ range-min-value ] [ range-max-value* ] bi clamp ;
] bind ;\r
\r
M: ebnf (transform) ( ast -- parser )\r
- rules>> [ (transform) ] map peek ;\r
+ rules>> [ (transform) ] map last ;\r
\r
M: ebnf-tokenizer (transform) ( ast -- parser )\r
elements>> dup "default" = [\r
dup level>> 1 = [
new-child
] [
- tuck children>> peek (ppush-new-tail)
+ tuck children>> last (ppush-new-tail)
[ swap new-child ] [ swap node-set-last f ] ?if
] if ;
: ppop-contraction ( node -- node' tail' )
dup children>> length 1 =
- [ children>> peek f swap ]
+ [ children>> last f swap ]
[ (ppop-contraction) ]
if ;
: (ppop-new-tail) ( root -- root' tail' )
dup level>> 1 > [
- dup children>> peek (ppop-new-tail) [
+ dup children>> last (ppop-new-tail) [
dup
[ swap node-set-last ]
[ drop ppop-contraction drop ]
: consonant-end? ( n seq -- ? )
[ length swap - ] keep consonant? ;
-: last-is? ( str possibilities -- ? ) [ peek ] dip member? ;
+: last-is? ( str possibilities -- ? ) [ last ] dip member? ;
: cvc? ( str -- ? )
{
pick consonant-seq 0 > [ nip ] [ drop ] if append ;
: step1a ( str -- newstr )
- dup peek CHAR: s = [
+ dup last CHAR: s = [
{
{ [ "sses" ?tail ] [ "ss" append ] }
{ [ "ies" ?tail ] [ "i" append ] }
[ 1 = [ but-last-slice cvc? not ] [ drop f ] if ] if ;
: remove-e ( str -- newstr )
- dup peek CHAR: e = [
+ dup last CHAR: e = [
dup remove-e? [ but-last-slice ] when
] when ;
: ll->l ( str -- newstr )
{
- { [ dup peek CHAR: l = not ] [ ] }
+ { [ dup last CHAR: l = not ] [ ] }
{ [ dup length 1- over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ but-last-slice ] }
[ ]
: <block> ( style -- block )
block new-block ;
-: pprinter-block ( -- block ) pprinter-stack get peek ;
+: pprinter-block ( -- block ) pprinter-stack get last ;
: add-section ( section -- )
pprinter-block sections>> push ;
! Long section layout algorithm
: chop-break ( seq -- seq )
- dup peek line-break? [ but-last-slice chop-break ] when ;
+ dup last line-break? [ but-last-slice chop-break ] when ;
SYMBOL: prev
SYMBOL: next
] { } make { t } split harvest ;
: break-group? ( seq -- ? )
- [ first section-fits? ] [ peek section-fits? not ] bi and ;
+ [ first section-fits? ] [ last section-fits? not ] bi and ;
: ?break-group ( seq -- )
dup break-group? [ first <fresh-line ] [ drop ] if ;
] with-scope ; inline
: with-pprint ( obj quot -- )
- make-pprint drop do-pprint ; inline
\ No newline at end of file
+ make-pprint drop do-pprint ; inline
[ 1 ] [ message >quoted string-lines length ] unit-test
[ t ] [ message >quoted-lines "=\r\n" swap subseq? ] unit-test
[ 4 ] [ message >quoted-lines string-lines length ] unit-test
-[ "===o" ] [ message >quoted-lines string-lines [ peek ] "" map-as ] unit-test
+[ "===o" ] [ message >quoted-lines string-lines [ last ] "" map-as ] unit-test
{
[ length 1 > ]
[ first quote? ]
- [ [ first ] [ peek ] bi = ]
+ [ [ first ] [ last ] bi = ]
} 1&& ;
: unquote ( str -- newstr )
- dup quoted? [ but-last-slice rest-slice >string ] when ;
\ No newline at end of file
+ dup quoted? [ but-last-slice rest-slice >string ] when ;
-USING: sorting.human tools.test sorting.slots ;
+USING: sorting.human tools.test sorting.slots sorting ;
IN: sorting.human.tests
-[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
+[ { "x1y" "x2" "x10y" } ]
+[ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
+
+[ { "4dup" "nip" } ]
+[ { "4dup" "nip" } [ human<=> ] sort ] unit-test
+
+[ { "4dup" "nip" } ]
+[ { "nip" "4dup" } [ human<=> ] sort ] unit-test
+
+[ { "4dup" "4nip" "5drop" "nip" "nip2" "nipd" } ]
+[ { "nip" "4dup" "4nip" "5drop" "nip2" "nipd" } [ human<=> ] sort ] unit-test
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser peg.ebnf sorting.functor ;
+USING: accessors kernel math math.order math.parser peg.ebnf
+sequences sorting.functor ;
IN: sorting.human
: find-numbers ( string -- seq )
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
-<< "human" [ find-numbers ] define-sorting >>
+! For comparing integers or sequences
+TUPLE: hybrid obj ;
+
+M: hybrid <=>
+ [ obj>> ] bi@
+ 2dup [ integer? ] bi@ xor [
+ drop integer? [ +lt+ ] [ +gt+ ] if
+ ] [
+ <=>
+ ] if ;
+
+<< "human" [ find-numbers [ hybrid boa ] map ] define-sorting >>
"The Beatles"
"A river runs through it"
"Another"
+ "The"
+ "A"
+ "Los"
"la vida loca"
"Basketball"
"racquetball"
} ;
[
{
+ "A"
"Another"
"Basketball"
"The Beatles"
"for the horde"
"Los Fujis"
"los Fujis"
+ "Los"
"of mice and men"
"on belay"
"racquetball"
"A river runs through it"
+ "The"
"la vida loca"
}
] [
unicode.case ;
IN: sorting.title
-<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >>
+<< "title" [
+ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match
+ [ to>> tail-slice ] when*
+] define-sorting >>
<PRIVATE
-: ,, ( obj -- ) building get peek push ;
+: ,, ( obj -- ) building get last push ;
: v, ( -- ) V{ } clone , ;
-: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
+: ,v ( -- ) building get dup last empty? [ dup pop* ] when drop ;
: (monotonic-split) ( seq quot -- newseq )
[
[
[ no-case ]
] [
- dup peek callable? [
- dup peek swap but-last
+ dup last callable? [
+ dup last swap but-last
] [
[ no-case ] swap
] if case>quot
2dup number=
[ drop ] [ nip V{ } clone pick push ] if
1+
- ] keep pick peek push
+ ] keep pick last push
] each ;
: runs ( seq -- newseq )
all-vocabs-seq name-completions ;
: chars-matching ( str -- seq )
- name-map keys dup zip completions ;
\ No newline at end of file
+ name-map keys dup zip completions ;
[ t ] [ B{ } hexdump "Length: 0, 0h\n" = ] unit-test
[ t ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
-[ t ] [ 256 [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
+[ t ] [ 256 iota [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
[
dup { 0 0 } = [
drop
windows get length 1 <= [ -> center ] [
- windows get peek second window-loc>>
+ windows get last second window-loc>>
dupd first2 <CGPoint> -> cascadeTopLeftFromPoint:
-> setFrameTopLeftPoint:
] if
: fix-sigma-end ( string -- string )
[ "" ] [
- dup peek CHAR: greek-small-letter-sigma =
+ dup last CHAR: greek-small-letter-sigma =
[ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
] if-empty ; inline
[ drop { } ]\r
[ [ AAAA ] [ BBBB ] bi 2array ] if ;\r
\r
-: last ( -- char )\r
- building get empty? [ 0 ] [ building get peek peek ] if ;\r
+: building-last ( -- char )\r
+ building get empty? [ 0 ] [ building get last last ] if ;\r
\r
: blocked? ( char -- ? )\r
combining-class dup { 0 f } member?\r
- [ drop last non-starter? ]\r
- [ last combining-class = ] if ;\r
+ [ drop building-last non-starter? ]\r
+ [ building-last combining-class = ] if ;\r
\r
: possible-bases ( -- slice-of-building )\r
building get dup [ first non-starter? not ] find-last\r
: name>char ( name -- char ) name-map at ; inline
: char>name ( char -- name ) name-map value-at ; inline
: property? ( char property -- ? ) properties at interval-key? ; inline
-: ch>lower ( ch -- lower ) simple-lower at-default ; inline
-: ch>upper ( ch -- upper ) simple-upper at-default ; inline
-: ch>title ( ch -- title ) simple-title at-default ; inline
+: ch>lower ( ch -- lower ) simple-lower ?at drop ; inline
+: ch>upper ( ch -- upper ) simple-upper ?at drop ; inline
+: ch>title ( ch -- title ) simple-title ?at drop ; inline
: special-case ( ch -- casing-tuple ) special-casing at ; inline
! For non-existent characters, use Cn
[ "foo" VL{ "hi" "there" } t ]
[
VL{ "hi" "there" "foo" } dup "v" set
- [ peek ] [ ppop ] bi
+ [ last ] [ ppop ] bi
dup "v" get [ vector>> ] bi@ eq?
] unit-test
{ "sans-serif" "Tahoma" }\r
{ "serif" "Times New Roman" }\r
{ "monospace" "Courier New" }\r
- } at-default ;\r
+ } ?at drop ;\r
\r
MEMO:: (cache-font) ( font -- HFONT )\r
font size>> neg ! nHeight\r
<PRIVATE
: add-child ( object -- )
- xml-stack get peek second push ;
+ xml-stack get last second push ;
: push-xml ( object -- )
V{ } clone 2array xml-stack get push ;
{ $see-also at* assoc-size } ;
ARTICLE: "assocs-values" "Transposed assoc operations"
-"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:"
+"default Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:"
{ $subsection value-at }
{ $subsection value-at* }
{ $subsection value? }
{ $subsection assoc-any? }
{ $subsection assoc-all? }
"Additional combinators:"
+{ $subsection assoc-partition }
{ $subsection cache }
+{ $subsection 2cache }
{ $subsection map>assoc }
{ $subsection assoc>map }
{ $subsection assoc-map-as } ;
{ assoc-filter assoc-filter-as } related-words
+HELP: assoc-partition
+{ $values
+ { "assoc" assoc } { "quot" quotation }
+ { "true-assoc" assoc } { "false-assoc" assoc }
+}
+{ $description "Calls a predicate quotation on each key of the input assoc. If the test yields true, the key/value pair is added to " { $snippet "true-assoc" } "; if false, it's added to " { $snippet "false-assoc" } "." } ;
+
HELP: assoc-any?
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
HELP: cache
{ $values { "key" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
-{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." }
+{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc. Returns a value either looked up or newly stored in the assoc." }
+{ $side-effects "assoc" } ;
+
+HELP: 2cache
+{ $values { "key1" "a key" } { "key2" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
+{ $description "If a single key composed of the input keys is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the keys/value pair into the assoc. Returns the value stored in the assoc. Returns a value either looked up or newly stored in the assoc." }
{ $side-effects "assoc" } ;
HELP: map>assoc
} extract-keys
] unit-test
-[ f ] [
- "a" H{ { "a" f } } at-default
-] unit-test
-
-[ "b" ] [
- "b" H{ { "a" f } } at-default
-] unit-test
-
-[ "x" ] [
- "a" H{ { "a" "x" } } at-default
-] unit-test
-
[ H{ { "b" [ 2 ] } { "d" [ 4 ] } } H{ { "a" [ 1 ] } { "c" [ 3 ] } } ] [
H{
{ "a" [ 1 ] }
: at ( key assoc -- value/f )
at* drop ; inline
-: at-default ( key assoc -- value/key )
- ?at drop ; inline
-
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ dup assoc-size ] dip new-assoc
[ [ set-at ] with-assoc assoc-each ] keep ;
: min-class ( class seq -- class/f )\r
over [ classes-intersect? ] curry filter\r
[ drop f ] [\r
- [ nip ] [ [ class<= ] with all? ] 2bi [ peek ] [ drop f ] if\r
+ [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if\r
] if-empty ;\r
\r
GENERIC: (flatten-class) ( class -- )\r
USING: alien strings kernel math tools.test io prettyprint
namespaces combinators words classes sequences accessors
-math.functions arrays ;
+math.functions arrays combinators.private ;
IN: combinators.tests
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
[ \ drop prefix ] bi*
] assoc-map alist>quot ;
+<PRIVATE
+
: (distribute-buckets) ( buckets pair keys -- )
dup t eq? [
drop [ swap adjoin ] curry each
] [ ] make , , \ if ,
] [ ] make ;
+PRIVATE>
+
: case>quot ( default assoc -- quot )
dup keys {
{ [ dup empty? ] [ 2drop ] }
[ drop linear-case-quot ]
} cond ;
-! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline
] [
[
[ [ , f ] compose [ , drop t ] recover ] curry all?
- ] { } make peek swap [ rethrow ] when
+ ] { } make last swap [ rethrow ] when
] if ; inline
TUPLE: condition error restarts continuation ;
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
- ] { } make [ peek rethrow ] unless-empty ;
+ ] { } make [ last rethrow ] unless-empty ;
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
<PRIVATE
-: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
+: last/first ( seq -- pair ) [ last ] [ first ] bi 2array ;
: bootstrap-words ( classes -- classes' )
[ bootstrap-word ] map ;
USING: accessors arrays assocs classes classes.algebra
combinators definitions generic hashtables kernel
kernel.private layouts math namespaces quotations
-sequences words generic.single.private effects make ;
+sequences words generic.single.private effects make
+combinators.private ;
IN: generic.single
ERROR: no-method object generic ;
quote-methods
prune-redundant-predicates
class-predicates
- [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
+ [ last ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
M: predicate-engine compile-engine
[ compile-predicate-engine ] [ class>> ] bi
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the smallest of two real numbers." } ;
+HELP: clamp
+{ $values { "x" real } { "min" real } { "max" real } { "y" real } }
+{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ;
+
HELP: between?
{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
{ $subsection "order-specifiers" }
"Utilities for comparing objects:"
{ $subsection after? }
+{ $subsection after? }
{ $subsection before? }
{ $subsection after=? }
{ $subsection before=? }
[ +eq+ ] [ 4 4 <=> ] unit-test
[ +gt+ ] [ 4 3 <=> ] unit-test
+[ 20 ] [ 20 0 100 clamp ] unit-test
+[ 0 ] [ -20 0 100 clamp ] unit-test
+[ 100 ] [ 120 0 100 clamp ] unit-test
: min ( x y -- z ) [ before? ] most ; inline
: max ( x y -- z ) [ after? ] most ; inline
+: clamp ( x min max -- y ) [ max ] dip min ; inline
: between? ( x y z -- ? )
pick after=? [ after=? ] [ 2drop f ] if ; inline
PRIVATE>
-: namespace ( -- namespace ) namestack* peek ; inline
+: namespace ( -- namespace ) namestack* last ; inline
: namestack ( -- namestack ) namestack* clone ;
: set-namestack ( namestack -- ) >vector 0 setenv ;
: global ( -- g ) 21 getenv { hashtable } declare ; inline
{ join concat concat-as } related-words
-HELP: peek
+HELP: last
{ $values { "seq" sequence } { "elt" object } }
{ $description "Outputs the last element of a sequence." }
{ $errors "Throws an error if the sequence is empty." } ;
-{ peek pop pop* } related-words
+{ pop pop* } related-words
HELP: pop*
{ $values { "seq" "a resizable mutable sequence" } }
{ $subsection second }
{ $subsection third }
{ $subsection fourth }
+"Extracting the last element:"
+{ $subsection last }
"Unpacking sequences:"
{ $subsection first2 }
{ $subsection first3 }
{ $subsection first4 }
-{ $see-also nth peek } ;
+{ $see-also nth } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
-{ $subsection peek }
{ $subsection push }
{ $subsection pop }
{ $subsection pop* }
[ 0 swap copy ] keep
] new-like ;
-: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
+: last ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
[ rest ] [ first-unsafe ] bi ;
: unclip-last ( seq -- butlast last )
- [ but-last ] [ peek ] bi ;
+ [ but-last ] [ last ] bi ;
: unclip-slice ( seq -- rest-slice first )
[ rest-slice ] [ first-unsafe ] bi ; inline
[ find-last ] (map-find) ; inline
: unclip-last-slice ( seq -- butlast-slice last )
- [ but-last-slice ] [ peek ] bi ; inline
+ [ but-last-slice ] [ last ] bi ; inline
: <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when
[ <reversed> ] bi@ split1-slice [ <reversed> ] bi@
[ f ] [ swap ] if-empty ;
+<PRIVATE
+
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1 + swap (split) ]
: split, ( seq separators -- ) 0 rot (split) ;
+PRIVATE>
+
: split ( seq separators -- pieces )
[ split, ] { } make ;
but-last-slice [
"\r" ?tail drop "\r" split
] map
- ] keep peek "\r" split suffix concat
+ ] keep last "\r" split suffix concat
] [
1array
] if ;
[ ] [ V{ 1 5 } "funny-stack" get push ] unit-test
[ ] [ V{ 2 3 } "funny-stack" get push ] unit-test
[ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test
-[ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test
+[ V{ 1 5 } ] [ "funny-stack" get last ] unit-test
[ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test
[ "funny-stack" get pop ] must-fail
[ "funny-stack" get pop ] must-fail
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
-[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test
\ No newline at end of file
+[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test
: vocab-dir+ ( vocab str/f -- path )
[ vocab-name "." split ] dip
- [ [ dup peek ] dip append suffix ] when*
+ [ [ dup last ] dip append suffix ] when*
"/" join ;
: find-vocab-root ( vocab -- path/f )
: qualified-search ( name manifest -- word/f )
qualified-vocabs>>
- (vocab-search) 0 = [ drop f ] [ peek ] if ;
+ (vocab-search) 0 = [ drop f ] [ last ] if ;
PRIVATE>
if ;
DEFER: check-status
: quit-game ( vector -- ) drop "you're a quitter" print ;
-: quit? ( vector -- t/f ) peek "quit" = ;
+: quit? ( vector -- t/f ) last "quit" = ;
: end-game ( vector -- )
dup victory?
[ drop "You WON!" ]
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
\r
: dimension ( array -- x ) length 1- ; inline \r
-: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
: change-last ( seq quot -- ) \r
[ [ dimension ] keep ] dip change-nth ; inline\r
\r
: set-end ( duration -- end-time ) duration>milliseconds millis + ;
: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline
: animate ( quot duration -- ) reset-progress set-end loop ; inline
-: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline
\ No newline at end of file
+: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline
get-state element>> pop ; inline
: peek-scope ( -- ht )
- get-state scope>> peek ; inline
+ get-state scope>> last ; inline
: read-elements ( -- )
read-element-type
read-int32 drop
get-state
[scope-changer] change-scope
- scope>> peek ; inline
+ scope>> last ; inline
M: bson-object element-data-read ( type -- object )
(object-data-read) ;
: fully-qualified ( name -- name )
{
{ [ dup empty? ] [ "." append ] }
- { [ dup peek CHAR: . = ] [ ] }
+ { [ dup last CHAR: . = ] [ ] }
{ [ t ] [ "." append ] }
}
cond ;
: closing-tag? ( string -- ? )
[ f ]
- [ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ;
+ [ { [ first CHAR: / = ] [ last CHAR: / = ] } 1|| ] if-empty ;
: <tag> ( name attributes closing? -- tag )
tag new
PREDICATE: channel-mode < mode name>> first "#&" member? ;
PREDICATE: participant-mode < channel-mode parameter>> ;
PREDICATE: ctcp < privmsg
- trailing>> { [ length 1 > ] [ first 1 = ] [ peek 1 = ] } 1&& ;
+ trailing>> { [ length 1 > ] [ first 1 = ] [ last 1 = ] } 1&& ;
PREDICATE: action < ctcp trailing>> rest "ACTION" head? ;
M: rpl-names post-process-irc-message ( rpl-names -- )
max-speed [0,b] ;
: change-player-speed ( inc player -- )
- [ + speed-range clamp-to-range ] change-speed drop ;
+ [ + 0 max-speed clamp ] change-speed drop ;
: multiply-player-speed ( n player -- )
- [ * speed-range clamp-to-range ] change-speed drop ;
+ [ * 0 max-speed clamp ] change-speed drop ;
: distance-to-move ( seconds-passed player -- distance )
speed>> * ;
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors combinators kernel literals locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ;
+USING: accessors arrays colors combinators fry jamshred.oint
+kernel literals locals math math.constants math.matrices
+math.order math.quadratic math.ranges math.vectors random
+sequences specialized-arrays.float vectors ;
FROM: jamshred.oint => distance ;
IN: jamshred.tunnel
: segment-number++ ( segment -- )
[ number>> 1+ ] keep (>>number) ;
+: clamp-length ( n seq -- n' )
+ 0 swap length clamp ;
+
: random-color ( -- color )
{ 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
: (random-segments) ( segments n -- segments )
dup 0 > [
- [ dup peek random-segment over push ] dip 1- (random-segments)
+ [ dup last random-segment over push ] dip 1- (random-segments)
] [ drop ] if ;
CONSTANT: default-segment-radius 1
: sub-tunnel ( from to segments -- segments )
#! return segments between from and to, after clamping from and to to
#! valid values
- [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
+ [ '[ _ clamp-length ] bi@ ] keep <slice> ;
: nearer-segment ( segment segment oint -- segment )
#! return whichever of the two segments is nearer to the oint
] dip nearer-segment ;
: get-segment ( segments n -- segment )
- over sequence-index-range clamp-to-range swap nth ;
+ over clamp-length swap nth ;
: next-segment ( segments current-segment -- segment )
number>> 1+ get-segment ;
SYMBOLS: host-name target-os target-cpu message message-arg ;
: parse-args ( command-line -- )
- dup peek message-arg set
+ dup last message-arg set
[
{
[ host-name set ]
HELP: negmin
{ $values { "a" number } { "b" number } { "x" number } }
{ $description "Returns the most-negative value, or zero if both are positive." } ;
-
-HELP: clamp
-{ $values { "value" number } { "a" number } { "b" number } { "x" number } }
-{ $description "Returns the value when between " { $snippet "a" } " and " { $snippet "b" } ", " { $snippet "a" } " if <= " { $snippet "a" } ", or " { $snippet "b" } " if >= " { $snippet "b" } "." } ;
-
[ 0 ] [ 1 3 negmin ] unit-test
[ -3 ] [ 1 -3 negmin ] unit-test
[ -1 ] [ -1 3 negmin ] unit-test
-
-[ 0 ] [ -1 0 2 clamp ] unit-test
-[ 1 ] [ 1 0 2 clamp ] unit-test
-[ 2 ] [ 3 0 2 clamp ] unit-test
-
! Copyright (C) 2008 John Benediktsson.
! See http://factorcode.org/license.txt for BSD license
-
USING: math math.order kernel ;
-
IN: math.compare
: absmin ( a b -- x )
: negmin ( a b -- x )
0 min min ;
-
-: clamp ( value a b -- x )
- [ max ] [ min ] bi* ;
: (homogeneous-xyz) ( h -- xyz )
1 head* ; inline
: (homogeneous-w) ( h -- w )
- peek ; inline
+ last ; inline
: h+ ( a b -- c )
2dup [ (homogeneous-w) ] bi@ over =
: (find-unusual-terms) ( n seq -- seq/f )
[ [ arithmetic-terms ] with map ] keep
- '[ _ [ peek ] dip member? ] find nip ;
+ '[ _ [ last ] dip member? ] find nip ;
: find-unusual-terms ( seq -- seq/? )
unclip-slice over (find-unusual-terms) [
] { } make nip ; inline
: most-frequent ( seq -- elt )
- frequency-analysis sort-values keys peek ;
+ frequency-analysis sort-values keys last ;
: crack-key ( seq key-length -- key )
[ " " decrypt ] dip group but-last-slice
[ length swap - 1- ] keep ?nth 0 or ;
: next ( colortile seq -- )
- [ nth* ] [ peek + ] [ push ] tri ;
+ [ nth* ] [ last + ] [ push ] tri ;
: ways ( length colortile -- permutations )
- V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ;
+ V{ 1 } clone [ [ next ] 2curry times ] keep last 1- ;
: (euler116) ( length -- permutations )
3 [1,b] [ ways ] with sigma ;
[ 4 short tail* sum ] keep push ;
: (euler117) ( n -- m )
- V{ 1 } clone tuck [ next ] curry times peek ;
+ V{ 1 } clone tuck [ next ] curry times last ;
PRIVATE>
<PRIVATE
: next-keys ( key -- keys )
- [ peek ] [ 10 swap sum - ] bi [ 2array ] with map ;
+ [ last ] [ 10 swap sum - ] bi [ 2array ] with map ;
: next-table ( assoc -- assoc )
H{ } clone swap
yaw>> 0.0
${ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
: clamp-pitch ( pitch -- pitch' )
- 90.0 min -90.0 max ;
+ -90.0 90.0 clamp ;
: walk-forward ( player -- )
dup forward-vector [ v+ ] curry change-velocity drop ;
syn keyword factorCompileDirective inline foldable parsing
syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most <wrapper> boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean
-syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? at-default unzip
+syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
syn keyword factorKeyword case execute-effect dispatch-case-quot <buckets> no-cond no-case? 3cleave>quot contiguous-range? 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case hash-dispatch-quot case>quot 3cleave wrong-values alist>quot hash-case-table hash-case-quot case-find (distribute-buckets) cond cleave distribute-buckets call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float 1+ 1- fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from prepare-index reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head replicate set-fourth peek shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth <flat-slice> second change-each join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
projects / factor.git / commitdiff