} ;
HELP: month-names
-{ $values { "array" array } }
+{ $values { "value" object } }
{ $description "Returns an array with the English names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
PRIVATE>
-: month-names ( -- array )
+CONSTANT: month-names
{
"January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"
- } ;
+ }
: month-name ( n -- string )
check-month 1- month-names nth ;
\r
: read-rfc3339-seconds ( s -- s' ch )\r
"+-Z" read-until [\r
- [ string>number ] [ length 10 swap ^ ] bi / +\r
+ [ string>number ] [ length 10^ ] bi / +\r
] dip ;\r
\r
: (rfc3339>timestamp) ( -- timestamp )\r
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
+! Interval inference issue
+[ f ] [
+ 10 70
+ [
+ dup 70 >=
+ [ dup 700 <= [ swap 1024 rem rem ] [ 2drop 70 ] if ]
+ [ 2drop 70 ] if
+ 70 >=
+ ] compile-call
+] unit-test
+
! Modular arithmetic bug
: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals namespaces
-sequences sequences.private words combinators
+sequences sequences.private words combinators memoize
combinators.short-circuit byte-arrays strings arrays layouts
cpu.architecture compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: empty-set? ( info -- ? )
{
[ class>> null-class? ]
- [ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ]
+ [ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ]
} 1|| ;
-: min-value ( class -- n ) fixnum eq? [ most-negative-fixnum ] [ -1/0. ] if ;
+: min-value ( class -- n )
+ {
+ { fixnum [ most-negative-fixnum ] }
+ { array-capacity [ 0 ] }
+ [ drop -1/0. ]
+ } case ;
-: max-value ( class -- n ) fixnum eq? [ most-positive-fixnum ] [ 1/0. ] if ;
+: max-value ( class -- n )
+ {
+ { fixnum [ most-positive-fixnum ] }
+ { array-capacity [ max-array-capacity ] }
+ [ drop 1/0. ]
+ } case ;
-: class-interval ( class -- i ) fixnum eq? [ fixnum-interval ] [ full-interval ] if ;
+: class-interval ( class -- i )
+ {
+ { fixnum [ fixnum-interval ] }
+ { array-capacity [ array-capacity-interval ] }
+ [ drop full-interval ]
+ } case ;
: wrap-interval ( interval class -- interval' )
{
- { fixnum [ interval->fixnum ] }
- { array-capacity [ max-array-capacity [a,a] interval-rem ] }
+ { [ over empty-interval eq? ] [ drop ] }
+ { [ over full-interval eq? ] [ nip class-interval ] }
+ { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] }
[ drop ]
- } case ;
+ } cond ;
: init-interval ( info -- info )
dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval
[ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
: max-digits ( n digits -- n' )
- 10 swap ^ [ * round ] keep / ; inline
+ 10^ [ * round ] keep / ; inline
: >exp ( x -- exp base )
[
: check-fry ( quot -- quot )
dup { load-local load-locals get-local drop-locals } intersect
- empty? [ >r/r>-in-fry-error ] unless ;
+ [ >r/r>-in-fry-error ] unless-empty ;
PREDICATE: fry-specifier < word { _ @ } memq? ;
IN: io.files.info.windows
:: round-up-to ( n multiple -- n' )
- n multiple rem dup 0 = [
- drop n
+ n multiple rem [
+ n
] [
multiple swap - n +
- ] if ;
+ ] if-zero ;
TUPLE: windows-file-info < file-info attributes ;
[ handle-fd ] 2dip 1 <int> "int" heap-size setsockopt io-error ;
M: unix addrinfo-error ( n -- )
- dup zero? [ drop ] [ gai_strerror throw ] if ;
+ [ gai_strerror throw ] unless-zero ;
! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr )
C: <bits> bits
: make-bits ( number -- bits )
- dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if ; inline
+ [ T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if-zero ; inline
M: bits length length>> ;
{ $subsection exp }
{ $subsection cis }
{ $subsection log }
+{ $subsection log10 }
"Raising a number to a power:"
{ $subsection ^ }
+{ $subsection 10^ }
"Converting between rectangular and polar form:"
{ $subsection abs }
{ $subsection absq }
{ $values { "x" number } { "y" number } }
{ $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
+HELP: log10
+{ $values { "x" number } { "y" number } }
+{ $description "Logarithm function base 10. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
+
HELP: sqrt
{ $values { "x" number } { "y" number } }
{ $description "Square root function." } ;
{ $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." }
{ $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ;
+HELP: 10^
+{ $values { "x" number } { "y" number } }
+{ $description "Raises " { $snippet "x" } " to the power of 10. If " { $snippet "x" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } ;
+
HELP: gcd
{ $values { "x" integer } { "y" integer } { "a" integer } { "d" integer } }
{ $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline
: 0^ ( x -- z )
- dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline
+ [ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline
: (^mod) ( n x y -- z )
make-bits 1 [
: divisor? ( m n -- ? )
mod 0 = ;
+ERROR: non-trivial-divisor n ;
+
: mod-inv ( x n -- y )
[ nip ] [ gcd 1 = ] 2bi
[ dup 0 < [ + ] [ nip ] if ]
- [ "Non-trivial divisor found" throw ] if ; foldable
+ [ non-trivial-divisor ] if ; foldable
: ^mod ( x y n -- z )
over 0 < [
M: complex log >polar swap flog swap rect> ;
+: 10^ ( x -- y ) 10 swap ^ ; inline
+
+: log10 ( x -- y ) log 10 log / ; inline
+
GENERIC: cos ( x -- y ) foldable
M: complex cos
: round ( x -- y ) dup sgn 2 / + truncate ; inline
: floor ( x -- y )
- dup 1 mod dup zero?
- [ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable
+ dup 1 mod
+ [ ] [ dup 0 < [ - 1 - ] [ - ] if ] if-zero ; foldable
: ceiling ( x -- y ) neg floor neg ; foldable
: floor-to ( x step -- y )
- dup zero? [ drop ] [ [ / floor ] [ * ] bi ] if ;
+ [ [ / floor ] [ * ] bi ] unless-zero ;
: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
USING: math.intervals kernel sequences words math math.order
arrays prettyprint tools.test random vocabs combinators
-accessors math.constants ;
+accessors math.constants fry ;
IN: math.intervals.tests
[ empty-interval ] [ 2 2 (a,b) ] unit-test
0 1 (a,b) 0 1 [a,b] interval-subset?
] unit-test
+[ t ] [
+ full-interval -1/0. 1/0. [a,b] interval-subset?
+] unit-test
+
+[ t ] [
+ -1/0. 1/0. [a,b] full-interval interval-subset?
+] unit-test
+
+[ f ] [
+ full-interval 0 1/0. [a,b] interval-subset?
+] unit-test
+
+[ t ] [
+ 0 1/0. [a,b] full-interval interval-subset?
+] unit-test
+
[ f ] [
0 0 1 (a,b) interval-contains?
] unit-test
} case
] if ;
-: random-unary-op ( -- pair )
+: unary-ops ( -- alist )
{
{ bitnot interval-bitnot }
{ abs interval-abs }
}
"math.ratios.private" vocab [
{ recip interval-recip } suffix
- ] when
- random ;
+ ] when ;
-: unary-test ( -- ? )
- random-interval random-unary-op ! 2dup . .
+: unary-test ( op -- ? )
+ [ random-interval ] dip
0 pick interval-contains? over first \ recip eq? and [
2drop t
] [
second execute( a -- b ) interval-contains?
] if ;
-[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
+unary-ops [
+ [ [ t ] ] dip '[ 8000 iota [ drop _ unary-test ] all? ] unit-test
+] each
-: random-binary-op ( -- pair )
+: binary-ops ( -- alist )
{
{ + interval+ }
{ - interval- }
{ bitand interval-bitand }
{ bitor interval-bitor }
{ bitxor interval-bitxor }
- ! { shift interval-shift }
{ min interval-min }
{ max interval-max }
}
"math.ratios.private" vocab [
{ / interval/ } suffix
- ] when
- random ;
+ ] when ;
-: binary-test ( -- ? )
- random-interval random-interval random-binary-op ! 3dup . . .
+: binary-test ( op -- ? )
+ [ random-interval random-interval ] dip
0 pick interval-contains? over first { / /i mod rem } member? and [
3drop t
] [
second execute( a b -- c ) interval-contains?
] if ;
-[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
+binary-ops [
+ [ [ t ] ] dip '[ 8000 iota [ drop _ binary-test ] all? ] unit-test
+] each
-: random-comparison ( -- pair )
+: comparison-ops ( -- alist )
{
{ < interval< }
{ <= interval<= }
{ > interval> }
{ >= interval>= }
- } random ;
+ } ;
-: comparison-test ( -- ? )
- random-interval random-interval random-comparison
+: comparison-test ( op -- ? )
+ [ random-interval random-interval ] dip
[ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep
second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ;
-[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
+comparison-ops [
+ [ [ t ] ] dip '[ 8000 iota [ drop _ comparison-test ] all? ] unit-test
+] each
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
: random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ;
-: random-commutative-op ( -- op )
+: commutative-ops ( -- seq )
{
interval+ interval*
interval-bitor interval-bitand interval-bitxor
interval-max interval-min
- } random ;
-
-[ t ] [
- 80000 iota [
- drop
- random-interval-or-empty random-interval-or-empty
- random-commutative-op
- [ execute ] [ swapd execute ] 3bi =
- ] all?
-] unit-test
+ } ;
+
+commutative-ops [
+ [ [ t ] ] dip '[
+ 8000 iota [
+ drop
+ random-interval-or-empty random-interval-or-empty _
+ [ execute ] [ swapd execute ] 3bi =
+ ] all?
+ ] unit-test
+] each
TUPLE: interval { from read-only } { to read-only } ;
+: closed-point? ( from to -- ? )
+ 2dup [ first ] bi@ number=
+ [ [ second ] both? ] [ 2drop f ] if ;
+
: <interval> ( from to -- interval )
- 2dup [ first ] bi@ {
- { [ 2dup > ] [ 2drop 2drop empty-interval ] }
- { [ 2dup number= ] [
- 2drop 2dup [ second ] both?
+ {
+ { [ 2dup [ first ] bi@ > ] [ 2drop empty-interval ] }
+ { [ 2dup [ first ] bi@ number= ] [
+ 2dup [ second ] both?
[ interval boa ] [ 2drop empty-interval ] if
] }
- [ 2drop interval boa ]
+ { [ 2dup [ { -1/0. t } = ] [ { 1/0. t } = ] bi* and ] [
+ 2drop full-interval
+ ] }
+ [ interval boa ]
} cond ;
: open-point ( n -- endpoint ) f 2array ;
MEMO: fixnum-interval ( -- interval )
most-negative-fixnum most-positive-fixnum [a,b] ; inline
+MEMO: array-capacity-interval ( -- interval )
+ 0 max-array-capacity [a,b] ; inline
+
: [-inf,inf] ( -- interval ) full-interval ; inline
: compare-endpoints ( p1 p2 quot -- ? )
{
{ [ over empty-interval eq? ] [ drop ] }
{ [ dup empty-interval eq? ] [ nip ] }
- { [ dup full-interval eq? ] [ nip ] }
- [ (rem-range) 2dup interval-subset? [ drop ] [ nip ] if ]
- } cond ;
-
-: interval->fixnum ( i1 -- i2 )
- {
- { [ dup empty-interval eq? ] [ ] }
- { [ dup full-interval eq? ] [ drop fixnum-interval ] }
- { [ dup fixnum-interval interval-subset? not ] [ drop fixnum-interval ] }
- [ ]
+ { [ dup full-interval eq? ] [ 2drop [0,inf] ] }
+ [ nip (rem-range) ]
} cond ;
: interval-bitand-pos ( i1 i2 -- ? )
CONSTANT: masks B{ 0 128 0 0 0 0 0 64 0 0 0 32 0 16 0 0 0 8 0 4 0 0 0 2 0 0 0 0 0 1 }
: bit-pos ( n -- byte/f mask/f )
- 30 /mod masks nth-unsafe dup zero? [ 2drop f f ] when ;
+ 30 /mod masks nth-unsafe [ drop f f ] when-zero ;
: marked-unsafe? ( n arr -- ? )
[ bit-pos ] dip swap [ [ nth-unsafe ] [ bitand zero? not ] bi* ] [ 2drop f ] if* ;
: marked-prime? ( n arr -- ? )
2dup upper-bound 2 swap between? [ bounds-error ] unless
- over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ;
\ No newline at end of file
+ over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel kernel.private math math.functions math.private ;
+USING: accessors kernel kernel.private math math.functions
+math.private sequences summary ;
IN: math.ratios
: 2>fraction ( a/b c/d -- a c b d )
PRIVATE>
+ERROR: division-by-zero x ;
+
+M: division-by-zero summary
+ drop "Division by zero" ;
+
M: integer /
- dup zero? [
- "Division by zero" throw
+ [
+ division-by-zero
] [
dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip [ /i ] curry bi@ fraction>
- ] if ;
+ ] if-zero ;
M: ratio hashcode*
nip >fraction [ hashcode ] bi@ bitxor ;
! The last case is needed because a very large number would
! otherwise be confused with a small number.
: serialize-cell ( n -- )
- dup zero? [ drop 0 write1 ] [
+ [ 0 write1 ] [
dup HEX: 7e <= [
HEX: 80 bitor write1
] [
] if
>be write
] if
- ] if ;
+ ] if-zero ;
: deserialize-cell ( -- n )
read1 {
drop CHAR: n write1 ;
M: integer (serialize) ( obj -- )
- dup zero? [
- drop CHAR: z write1
+ [
+ CHAR: z write1
] [
dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
serialize-cell
- ] if ;
+ ] if-zero ;
M: float (serialize) ( obj -- )
CHAR: F write1
binary [ deserialize ] with-byte-reader ;
: object>bytes ( obj -- bytes )
- binary [ serialize ] with-byte-writer ;
\ No newline at end of file
+ binary [ serialize ] with-byte-writer ;
continuations assocs combinators compiler.errors accessors math.order
definitions sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
-stack-checker.recursive-state ;
+stack-checker.recursive-state summary ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d push ;
: time-bomb ( error -- )
'[ _ throw ] infer-quot-here ;
-: bad-call ( -- )
- "call must be given a callable" time-bomb ;
+ERROR: bad-call obj ;
+
+M: bad-call summary
+ drop "call must be given a callable" ;
: infer-literal-quot ( literal -- )
dup recursive-quotation? [
[ [ recursion>> ] keep add-local-quotation ]
bi infer-quot
] [
- drop bad-call
+ value>> \ bad-call boa time-bomb
] if
] if ;
\ compose [ infer-compose ] "special" set-word-prop
+ERROR: bad-executable obj ;
+
+M: bad-executable summary
+ drop "execute must be given a word" ;
+
: infer-execute ( -- )
pop-literal nip
dup word? [
apply-object
] [
- drop
- "execute must be given a word" time-bomb
+ \ bad-executable boa time-bomb
] if ;
\ execute [ infer-execute ] "special" set-word-prop
GetLastError n>win32-error-string ;
: (win32-error) ( n -- )
- dup zero? [
- drop
- ] [
- win32-error-string throw
- ] if ;
+ [ win32-error-string throw ] unless-zero ;
: win32-error ( -- )
GetLastError (win32-error) ;
M: object new-sequence drop 0 <array> ;
-M: f new-sequence drop dup zero? [ drop f ] [ 0 <array> ] if ;
+M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ;
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;
: class= ( first second -- ? )\r
[ class<= ] [ swap class<= ] 2bi and ;\r
\r
+ERROR: topological-sort-failed ;\r
+\r
: largest-class ( seq -- n elt )\r
dup [ [ class< ] with any? not ] curry find-last\r
- [ "Topological sort failed" throw ] unless* ;\r
+ [ topological-sort-failed ] unless* ;\r
\r
: sort-classes ( seq -- newseq )\r
[ name>> ] sort-with >vector\r
: parse-effect-tokens ( end -- tokens )
[ parse-effect-token dup ] curry [ ] produce nip ;
+ERROR: stack-effect-omits-dashes effect ;
+
: parse-effect ( end -- effect )
parse-effect-tokens { "--" } split1 dup
- [ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;
+ [ <effect> ] [ drop stack-effect-omits-dashes ] if ;
: complete-effect ( -- effect )
"(" expect ")" parse-effect ;
: keep-going? ( assoc -- ? )
assumed get swap second first class<= ;
+ERROR: unreachable ;
+
: prune-redundant-predicates ( assoc -- default assoc' )
{
- { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+ { [ dup empty? ] [ drop [ unreachable ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
[ [ first second ] [ rest-slice ] bi ]
PRIVATE>
: code-point-length ( n -- x )
- dup zero? [ drop 1 ] [
+ [ 1 ] [
log2 {
{ [ dup 0 6 between? ] [ 1 ] }
{ [ dup 7 10 between? ] [ 2 ] }
{ [ dup 11 15 between? ] [ 3 ] }
{ [ dup 16 20 between? ] [ 4 ] }
} cond nip
- ] if ;
+ ] if-zero ;
: code-point-offsets ( string -- indices )
0 [ code-point-length + ] accumulate swap suffix ;
over zero? [
2drop 0.0
] [
- dup zero? [
- 2drop 1/0.
+ [
+ drop 1/0.
] [
pre-scale
/f-loop over odd?
[ zero? [ 1 + ] unless ] [ drop ] if
post-scale
- ] if
+ ] if-zero
] if ; inline
M: bignum /f ( m n -- f )
{ $description
"Outputs one of the following:"
{ $list
- "-1 if " { $snippet "x" } " is negative"
- "0 if " { $snippet "x" } " is equal to 0"
- "1 if " { $snippet "x" } " is positive"
+ { "-1 if " { $snippet "x" } " is negative" }
+ { "0 if " { $snippet "x" } " is equal to 0" }
+ { "1 if " { $snippet "x" } " is positive" }
}
} ;
PRIVATE>
+ERROR: log2-expects-positive x ;
+
: log2 ( x -- n )
dup 0 <= [
- "log2 expects positive inputs" throw
+ log2-expects-positive
] [
(log2)
] if ; inline
[
dup 0 < negative? set
abs 1 /mod
- [ dup zero? [ drop "" ] [ (>base) sign append ] if ]
+ [ [ "" ] [ (>base) sign append ] if-zero ]
[
[ numerator (>base) ]
[ denominator (>base) ] bi
}
} ;
-{ if-empty when-empty unless-empty } related-words
+HELP: if-zero
+{ $values { "n" number } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Makes an implicit check if the number is zero. A zero is dropped and " { $snippet "quot1" } " is called. Otherwise, if the number is not zero, " { $snippet "quot2" } " is called on it." }
+{ $example
+ "USING: kernel math prettyprint sequences ;"
+ "3 [ \"zero\" ] [ sq ] if-zero ."
+ "9"
+} ;
+
+HELP: when-zero
+{ $values
+ { "n" number } { "quot" "the first quotation of an " { $link if-zero } } }
+{ $description "Makes an implicit check if the sequence is empty. A zero is dropped and the " { $snippet "quot" } " is called." }
+{ $examples "This word is equivalent to " { $link if-zero } " with an empty second quotation:"
+ { $example
+ "USING: sequences prettyprint ;"
+ "0 [ 4 ] [ ] if-zero ."
+ "4"
+ }
+ { $example
+ "USING: sequences prettyprint ;"
+ "0 [ 4 ] when-zero ."
+ "4"
+ }
+} ;
+
+HELP: unless-zero
+{ $values
+ { "n" number } { "quot" "the second quotation of an " { $link if-empty } } }
+{ $description "Makes an implicit check if the number is zero. A zero is dropped. Otherwise, the " { $snippet "quot" } " is called on the number." }
+{ $examples "This word is equivalent to " { $link if-zero } " with an empty first quotation:"
+ { $example
+ "USING: sequences math prettyprint ;"
+ "3 [ ] [ sq ] if-empty ."
+ "9"
+ }
+ { $example
+ "USING: sequences math prettyprint ;"
+ "3 [ sq ] unless-zero ."
+ "9"
+ }
+} ;
HELP: delete-all
{ $values { "seq" "a resizable sequence" } }
{ $examples "Get random numbers until zero is reached:"
{ $unchecked-example
"USING: random sequences prettyprint math ;"
- "100 [ random dup zero? [ drop f ] when ] follow ."
+ "100 [ random [ f ] when-zero ] follow ."
"{ 100 86 34 32 24 11 7 2 }"
} } ;
$nl
"More elaborate counted loops can be performed with " { $link "math.ranges" } "." ;
+ARTICLE: "sequences-if" "Control flow with sequences"
+"To reduce the boilerplate of checking if a sequence is empty or a number is zero, several combinators are provided."
+$nl
+"Checking if a sequence is empty:"
+{ $subsection if-empty }
+{ $subsection when-empty }
+{ $subsection unless-empty }
+"Checking if a number is zero:"
+{ $subsection if-zero }
+{ $subsection when-zero }
+{ $subsection unless-zero } ;
+
ARTICLE: "sequences-access" "Accessing sequence elements"
{ $subsection ?nth }
"Concise way of extracting one of the first four elements:"
"Using sequences for looping:"
{ $subsection "sequences-integers" }
{ $subsection "math.ranges" }
+"Using sequences for control flow:"
+{ $subsection "sequences-if" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
: empty? ( seq -- ? ) length 0 = ; inline
+<PRIVATE
+
+: (if-empty) ( seq quot1 quot2 quot3 -- )
+ [ [ drop ] prepose ] [ ] tri* if ; inline
+
+PRIVATE>
+
: if-empty ( seq quot1 quot2 -- )
- [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
+ [ dup empty? ] (if-empty) ; inline
: when-empty ( seq quot -- ) [ ] if-empty ; inline
: unless-empty ( seq quot -- ) [ ] swap if-empty ; inline
+: if-zero ( n quot1 quot2 -- )
+ [ dup zero? ] (if-empty) ; inline
+
+: when-zero ( n quot -- ) [ ] if-zero ; inline
+
+: unless-zero ( n quot -- ) [ ] swap if-zero ; inline
+
: delete-all ( seq -- ) 0 swap set-length ;
: first ( seq -- first ) 0 swap nth ; inline
<PRIVATE
+ERROR: integer-length-expected obj ;
+
: check-length ( n -- n )
#! Ricing.
- dup integer? [ "length not an integer" throw ] unless ; inline
+ dup integer? [ integer-length-expected ] unless ; inline
: ((copy)) ( dst i src j n -- dst i src j n )
dup -roll [
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1 + swap (split) ]
- [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
+ [ swap [ tail ] unless-zero , drop ] if* ; inline recursive
: split, ( seq separators -- ) 0 rot (split) ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators
+concurrency.mailboxes fry io kernel make math math.parser
+math.text.english sequences threads ;
+IN: benchmark.chameneos-redux
+
+SYMBOLS: red yellow blue ;
+
+ERROR: bad-color-pair pair ;
+
+TUPLE: creature n color count self-count mailbox ;
+
+TUPLE: meeting-place count mailbox ;
+
+: <meeting-place> ( count -- meeting-place )
+ meeting-place new
+ swap >>count
+ <mailbox> >>mailbox ;
+
+: <creature> ( n color -- creature )
+ creature new
+ swap >>color
+ swap >>n
+ 0 >>count
+ 0 >>self-count
+ <mailbox> >>mailbox ;
+
+: make-creatures ( colors -- seq )
+ [ length iota ] [ ] bi [ <creature> ] 2map ;
+
+: complement-color ( color1 color2 -- color3 )
+ 2dup = [ drop ] [
+ 2array {
+ { { red yellow } [ blue ] }
+ { { red blue } [ yellow ] }
+ { { yellow red } [ blue ] }
+ { { yellow blue } [ red ] }
+ { { blue red } [ yellow ] }
+ { { blue yellow } [ red ] }
+ [ bad-color-pair ]
+ } case
+ ] if ;
+
+: color-string ( color1 color2 -- string )
+ [
+ [ [ name>> ] bi@ " + " glue % " -> " % ]
+ [ complement-color name>> % ] 2bi
+ ] "" make ;
+
+: print-color-table ( -- )
+ { blue red yellow } dup
+ '[ _ '[ color-string print ] with each ] each ;
+
+: try-meet ( meeting-place creature -- )
+ over count>> 0 < [
+ 2drop
+ ] [
+ [ swap mailbox>> mailbox-put ]
+ [ nip mailbox>> mailbox-get drop ]
+ [ try-meet ] 2tri
+ ] if ;
+
+: creature-meeting ( seq -- )
+ first2 {
+ [ [ [ 1 + ] change-count ] bi@ 2drop ]
+ [ 2dup = [ [ 1 + ] change-self-count ] when 2drop ]
+ [ [ [ color>> ] bi@ complement-color ] [ [ (>>color) ] bi-curry@ bi ] 2bi ]
+ [ [ mailbox>> f swap mailbox-put ] bi@ ]
+ } 2cleave ;
+
+: run-meeting-place ( meeting-place -- )
+ [ 1 - ] change-count
+ dup count>> 0 < [
+ mailbox>> mailbox-get-all
+ [ f swap mailbox>> mailbox-put ] each
+ ] [
+ [ mailbox>> 2 swap '[ _ mailbox-get ] replicate creature-meeting ]
+ [ run-meeting-place ] bi
+ ] if ;
+
+: number>chameneos-string ( n -- string )
+ number>string string>digits [ number>text ] { } map-as " " join ;
+
+: chameneos-redux ( n colors -- )
+ [ <meeting-place> ] [ make-creatures ] bi*
+ {
+ [ nip nl bl [ bl ] [ color>> name>> write ] interleave nl ]
+ [ [ '[ _ _ try-meet ] in-thread ] with each ]
+ [ drop run-meeting-place ]
+
+ [ nip [ [ count>> number>string write bl ] [ self-count>> number>text write nl ] bi ] each ]
+ [ nip 0 [ count>> + ] reduce bl number>chameneos-string print ]
+ } 2cleave ;
+
+! 6000000 for shootout, too slow right now
+
+: chameneos-redux-main ( -- )
+ print-color-table
+ 60000 [
+ { blue red yellow } chameneos-redux
+ ] [
+ { blue red yellow red yellow blue red yellow red blue } chameneos-redux
+ ] bi ;
+
+MAIN: chameneos-redux-main
:: split-lines ( n quot -- )
n line-length /mod
[ [ line-length quot call ] times ] dip
- dup zero? [ drop ] quot if ; inline
+ quot unless-zero ; inline
: write-random-fasta ( seed n chars floats desc id -- seed )
write-description
-USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see ;\r
+USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see\r
+math.ratios ;\r
IN: descriptive.tests\r
\r
DESCRIPTIVE: divide ( num denom -- fraction ) / ;\r
\r
[ 3 ] [ 9 3 divide ] unit-test\r
-[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test\r
\r
-[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test\r
+[\r
+ T{ descriptive-error f\r
+ { { "num" 3 } { "denom" 0 } }\r
+ T{ division-by-zero f 3 }\r
+ divide\r
+ }\r
+] [\r
+ [ 3 0 divide ] [ ] recover\r
+] unit-test\r
+\r
+[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ]\r
+[ \ divide [ see ] with-string-writer ] unit-test\r
\r
DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\r
\r
[ 3 ] [ 9 3 divide* ] unit-test\r
-[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test\r
+\r
+[\r
+ T{ descriptive-error f\r
+ { { "num" 3 } { "denom" 0 } }\r
+ T{ division-by-zero f 3 }\r
+ divide*\r
+ }\r
+] [ [ 3 0 divide* ] [ ] recover ] unit-test\r
\r
[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test\r
USING: accessors calendar continuations destructors kernel math
-math.order namespaces system threads ui ui.gadgets.worlds ;
+math.order namespaces system threads ui ui.gadgets.worlds
+sequences ;
IN: game-loop
TUPLE: game-loop
drop ;
: ?tick ( loop count -- )
- dup zero? [ drop millis >>last-tick drop ] [
+ [ millis >>last-tick drop ] [
over [ since-last-tick ] [ tick-length>> ] bi >=
[ [ drop increment-tick ] [ drop tick ] [ 1- ?tick ] 2tri ]
[ 2drop ] if
- ] if ;
+ ] if-zero ;
: (run-loop) ( loop -- )
dup running?>>
! Copyright (C) 2008 Doug Coleman, Slava Pestov, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math math.constants math.functions
- math.vectors sequences ;
+USING: combinators.short-circuit kernel math math.constants
+math.functions math.vectors sequences ;
IN: math.analysis
<PRIVATE
HELP: number>text
{ $values { "n" integer } { "str" string } }
{ $description "Converts an integer to a text string representation in English, including appropriate punctuation and conjunctions." }
-{ $examples { $example "USING: math.text.english prettyprint ;" "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ;
+{ $examples { $example "USING: math.text.english prettyprint ;" "12345 number>text ." "\"twelve thousand, three hundred and forty-five\"" } } ;
USING: math.functions math.text.english tools.test ;
IN: math.text.english.tests
-[ "Zero" ] [ 0 number>text ] unit-test
-[ "Twenty-One" ] [ 21 number>text ] unit-test
-[ "One Hundred" ] [ 100 number>text ] unit-test
-[ "One Hundred and One" ] [ 101 number>text ] unit-test
-[ "One Thousand and One" ] [ 1001 number>text ] unit-test
-[ "One Thousand, One Hundred and One" ] [ 1101 number>text ] unit-test
-[ "One Million, One Thousand and One" ] [ 1001001 number>text ] unit-test
-[ "One Million, One Thousand, One Hundred and One" ] [ 1001101 number>text ] unit-test
-[ "One Million, One Hundred and Eleven Thousand, One Hundred and Eleven" ] [ 1111111 number>text ] unit-test
-[ "One Duotrigintillion" ] [ 10 99 ^ number>text ] unit-test
+[ "zero" ] [ 0 number>text ] unit-test
+[ "twenty-one" ] [ 21 number>text ] unit-test
+[ "one hundred" ] [ 100 number>text ] unit-test
+[ "one hundred and one" ] [ 101 number>text ] unit-test
+[ "one thousand and one" ] [ 1001 number>text ] unit-test
+[ "one thousand, one hundred and one" ] [ 1101 number>text ] unit-test
+[ "one million, one thousand and one" ] [ 1001001 number>text ] unit-test
+[ "one million, one thousand, one hundred and one" ] [ 1001101 number>text ] unit-test
+[ "one million, one hundred and eleven thousand, one hundred and eleven" ] [ 1111111 number>text ] unit-test
+[ "one duotrigintillion" ] [ 10 99 ^ number>text ] unit-test
-[ "Negative One Hundred and Twenty-Three" ] [ -123 number>text ] unit-test
+[ "negative one hundred and twenty-three" ] [ -123 number>text ] unit-test
<PRIVATE
: small-numbers ( n -- str )
- { "Zero" "One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine"
- "Ten" "Eleven" "Twelve" "Thirteen" "Fourteen" "Fifteen" "Sixteen"
- "Seventeen" "Eighteen" "Nineteen" } nth ;
+ {
+ "zero" "one" "two" "three" "four" "five" "six"
+ "seven" "eight" "nine" "ten" "eleven" "twelve"
+ "thirteen" "fourteen" "fifteen" "sixteen" "seventeen"
+ "eighteen" "nineteen"
+ } nth ;
: tens ( n -- str )
- { f f "Twenty" "Thirty" "Forty" "Fifty" "Sixty" "Seventy" "Eighty" "Ninety" } nth ;
-
+ {
+ f f "twenty" "thirty" "forty" "fifty" "sixty"
+ "seventy" "eighty" "ninety"
+ } nth ;
+
: scale-numbers ( n -- str ) ! up to 10^99
- { f "Thousand" "Million" "Billion" "Trillion" "Quadrillion" "Quintillion"
- "Sextillion" "Septillion" "Octillion" "Nonillion" "Decillion" "Undecillion"
- "Duodecillion" "Tredecillion" "Quattuordecillion" "Quindecillion"
- "Sexdecillion" "Septendecillion" "Octodecillion" "Novemdecillion"
- "Vigintillion" "Unvigintillion" "Duovigintillion" "Trevigintillion"
- "Quattuorvigintillion" "Quinvigintillion" "Sexvigintillion"
- "Septvigintillion" "Octovigintillion" "Novemvigintillion" "Trigintillion"
- "Untrigintillion" "Duotrigintillion" } nth ;
+ {
+ f "thousand" "million" "billion" "trillion" "quadrillion"
+ "quintillion" "sextillion" "septillion" "octillion"
+ "nonillion" "decillion" "undecillion" "duodecillion"
+ "tredecillion" "quattuordecillion" "quindecillion"
+ "sexdecillion" "septendecillion" "octodecillion" "novemdecillion"
+ "vigintillion" "unvigintillion" "duovigintillion" "trevigintillion"
+ "quattuorvigintillion" "quinvigintillion" "sexvigintillion"
+ "septvigintillion" "octovigintillion" "novemvigintillion"
+ "trigintillion" "untrigintillion" "duotrigintillion"
+ } nth ;
SYMBOL: and-needed?
: set-conjunction ( seq -- )
first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ;
: negative-text ( n -- str )
- 0 < "Negative " "" ? ;
+ 0 < "negative " "" ? ;
: hundreds-place ( n -- str )
100 /mod over 0 = [
2drop ""
] [
- [ small-numbers " Hundred" append ] dip
+ [ small-numbers " hundred" append ] dip
0 = [ " and " append ] unless
] if ;
] if ;
: (number>text) ( n -- str )
- [ negative-text ] [ abs 3digit-groups recombine ] bi append ;
+ [ negative-text ] [ abs 3 digit-groups recombine ] bi append ;
PRIVATE>
} cond ;
: over-1000000 ( n -- str )
- 3digit-groups [ 1+ units nth n-units ] map-index sift
+ 3 digit-groups [ 1+ units nth n-units ] map-index sift
reverse " " join ;
: decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip complete ;
USING: help.markup help.syntax ;
IN: math.text.utils
-HELP: 3digit-groups
-{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
-{ $description "Decompose a number into 3 digits groups and return them in a sequence, starting with the units, then the tenths, etc." } ;
+HELP: digit-groups
+{ $values { "n" "a positive integer" } { "k" "a positive integer" } { "seq" "a sequence" } }
+{ $description "Decompose a number into groups of " { $snippet "k" } " digits and return them in a sequence starting with the least significant grouped digits first." } ;
USING: math.text.utils tools.test ;
-[ { 1 999 2 } ] [ 2999001 3digit-groups ] unit-test
+[ { 1 999 2 } ] [ 2999001 3 digit-groups ] unit-test
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel fry math.functions math sequences ;
IN: math.text.utils
-: 3digit-groups ( n -- seq )
- [ dup 0 > ] [ 1000 /mod ] produce nip ;
+: digit-groups ( n k -- seq )
+ [ dup 0 > ] swap '[ _ 10^ /mod ] produce nip ;
[
[ dup string>number [ nip ] [ not-an-integer ] if* ] bi@
] keep length
- 10 swap ^ / + swap [ neg ] when ;
+ 10^ / + swap [ neg ] when ;
SYNTAX: DECIMAL: scan parse-decimal parsed ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges project-euler.common sequences ;
+USING: kernel math math.functions math.ranges
+project-euler.common sequences ;
IN: project-euler.048
! http://projecteuler.net/index.php?section=problems&id=48
! --------
: euler048 ( -- answer )
- 1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ;
+ 1000 [1,b] [ dup ^ ] sigma 10 10^ mod ;
! [ euler048 ] 100 ave-time
! 276 ms run / 1 ms GC ave time - 100 trials
--- /dev/null
+USING: project-euler.151 tools.test ;
+IN: project-euler.151.tests
+
+[ 12138569781349/26138246400000 ] [ euler151 ] unit-test
: (pick-sheet) ( seq i -- newseq )
[
- <=> sgn
+ <=>
{
- { -1 [ ] }
- { 0 [ 1- ] }
- { 1 [ 1+ ] }
+ { +lt+ [ ] }
+ { +eq+ [ 1- ] }
+ { +gt+ [ 1+ ] }
} case
] curry map-index ;
{ 1 1 1 1 } (euler151)
] with-scope ;
-! TODO: doesn't work currently, problem in area of 'with map' in (euler151)
-
! [ euler151 ] 100 ave-time
! ? ms run time - 100 trials
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations fry io kernel make math math.functions math.parser
- math.statistics memory tools.time ;
+USING: continuations fry io kernel make math math.functions
+math.parser math.statistics memory tools.time ;
IN: project-euler.ave-time
: nth-place ( x n -- y )
- 10 swap ^ [ * round >integer ] keep /f ;
+ 10^ [ * round >integer ] keep /f ;
: collect-benchmarks ( quot n -- seq )
[
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
[ [ 2array ] with map ] curry map concat ;
-: log10 ( m -- n )
- log 10 log / ;
-
: mediant ( a/c b/d -- (a+b)/(c+d) )
2>fraction [ + ] 2bi@ / ;
: svg-string>number ( string -- number )
{ { CHAR: E CHAR: e } } substitute "e" split1
- [ string>number ] [ [ string>number 10 swap ^ ] [ 1 ] if* ] bi* *
+ [ string>number ] [ [ string>number 10^ ] [ 1 ] if* ] bi* *
>float ;
: degrees ( deg -- rad ) pi * 180.0 / ;
projects / factor.git / commitdiff