From 7a1837b15ac69dec8a6ccddcbda560cf3e81525e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 15:34:11 -0500 Subject: [PATCH 01/16] don't capitalize the first letter of each word in math.text.english --- extra/math/text/english/english-tests.factor | 22 +++++------ extra/math/text/english/english.factor | 39 ++++++++++++-------- 2 files changed, 35 insertions(+), 26 deletions(-) diff --git a/extra/math/text/english/english-tests.factor b/extra/math/text/english/english-tests.factor index 8f8932c97d..81a94687a7 100644 --- a/extra/math/text/english/english-tests.factor +++ b/extra/math/text/english/english-tests.factor @@ -1,15 +1,15 @@ 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 diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index 5a10e7af37..492453450b 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -7,35 +7,44 @@ IN: math.text.english ] } 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 ; From e23b4b54eaa18cd25914a383fc46fb828a0e444c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 15:35:57 -0500 Subject: [PATCH 02/16] fix docs --- extra/math/text/english/english-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/math/text/english/english-docs.factor b/extra/math/text/english/english-docs.factor index a7fdc421aa..5bd24c3e98 100644 --- a/extra/math/text/english/english-docs.factor +++ b/extra/math/text/english/english-docs.factor @@ -4,4 +4,4 @@ IN: math.text.english 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\"" } } ; From 7bfbb0c5ac97327f29a24baef78a66440514bc56 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Aug 2009 16:49:28 -0500 Subject: [PATCH 03/16] math.intervals: fix interval-rem --- basis/compiler/tests/optimizer.factor | 11 ++++ basis/math/intervals/intervals-tests.factor | 62 +++++++++++---------- basis/math/intervals/intervals.factor | 4 +- 3 files changed, 46 insertions(+), 31 deletions(-) diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 72618db456..20fcff8440 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -391,6 +391,17 @@ DEFER: loop-bbb [ ] [ [ \ 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 ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index dbf014bda8..760338a7c3 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -1,6 +1,6 @@ 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 @@ -246,7 +246,7 @@ IN: math.intervals.tests } case ] if ; -: random-unary-op ( -- pair ) +: unary-ops ( -- alist ) { { bitnot interval-bitnot } { abs interval-abs } @@ -257,11 +257,10 @@ IN: math.intervals.tests } "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 ] [ @@ -269,9 +268,11 @@ IN: math.intervals.tests 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- } @@ -282,17 +283,15 @@ IN: math.intervals.tests { 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 ] [ @@ -300,22 +299,26 @@ IN: math.intervals.tests 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 @@ -335,18 +338,19 @@ IN: math.intervals.tests : 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 diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 8b07394596..3c33940676 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -340,8 +340,8 @@ SYMBOL: incomparable { { [ over empty-interval eq? ] [ drop ] } { [ dup empty-interval eq? ] [ nip ] } - { [ dup full-interval eq? ] [ nip ] } - [ (rem-range) 2dup interval-subset? [ drop ] [ nip ] if ] + { [ dup full-interval eq? ] [ 2drop [0,inf] ] } + [ nip (rem-range) ] } cond ; : interval->fixnum ( i1 -- i2 ) From 14ef1649d423a8e6b18f8c50b3f9c8d8ae2fc55b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 17:59:40 -0500 Subject: [PATCH 04/16] add if-zero/when-zero/unless-zero to core/ and update usages --- core/arrays/arrays.factor | 2 +- core/io/encodings/utf8/utf8.factor | 4 ++-- core/math/integers/integers.factor | 6 +++--- core/math/parser/parser.factor | 2 +- core/sequences/sequences-docs.factor | 2 +- core/sequences/sequences.factor | 16 +++++++++++++++- core/splitting/splitting.factor | 2 +- 7 files changed, 24 insertions(+), 10 deletions(-) diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 4a998a1ebb..dd70e45b6b 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -14,7 +14,7 @@ M: array resize resize-array ; M: object new-sequence drop 0 ; -M: f new-sequence drop dup zero? [ drop f ] [ 0 ] if ; +M: f new-sequence drop [ f ] [ 0 ] if-zero ; M: array equal? over array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 4846b06f32..a722655cad 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -73,14 +73,14 @@ M: utf8 encode-char 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 ; diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index bb7fc107b2..2b35ef76fd 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -121,14 +121,14 @@ M: bignum (log2) bignum-log2 ; 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 ) diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 437308d53f..ef8f350e27 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -131,7 +131,7 @@ M: ratio >base [ dup 0 < negative? set abs 1 /mod - [ dup zero? [ drop "" ] [ (>base) sign append ] if ] + [ [ "" ] [ (>base) sign append ] if-zero ] [ [ numerator (>base) ] [ denominator (>base) ] bi diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 71d42705a2..d7db7f5242 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1214,7 +1214,7 @@ HELP: follow { $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 }" } } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index f0dc6d36c7..2e41d9d2e1 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -29,13 +29,27 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; : empty? ( seq -- ? ) length 0 = ; inline + + : 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 ( seq quot -- ) [ ] if-zero ; inline + +: unless-zero ( seq quot -- ) [ ] swap if-zero ; inline + : delete-all ( seq -- ) 0 swap set-length ; : first ( seq -- first ) 0 swap nth ; inline diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 5ec396e5ba..7aae30f20b 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -58,7 +58,7 @@ PRIVATE> : (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) ; From 4fef246ca4aa4d43c345fe8a98e54f9f982b40cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 18:00:24 -0500 Subject: [PATCH 05/16] add 10^ to math.functions and update usages --- basis/calendar/format/format.factor | 2 +- basis/formatting/formatting.factor | 2 +- basis/io/files/info/windows/windows.factor | 6 +++--- basis/math/functions/functions.factor | 6 +++++- extra/math/analysis/analysis.factor | 4 ++-- extra/math/text/english/english.factor | 2 +- extra/math/text/french/french.factor | 2 +- extra/math/text/utils/utils-docs.factor | 6 +++--- extra/math/text/utils/utils-tests.factor | 2 +- extra/math/text/utils/utils.factor | 6 +++--- extra/money/money.factor | 2 +- extra/project-euler/048/048.factor | 5 +++-- extra/project-euler/ave-time/ave-time.factor | 6 +++--- extra/svg/svg.factor | 2 +- 14 files changed, 29 insertions(+), 24 deletions(-) mode change 100644 => 100755 extra/math/text/utils/utils-docs.factor mode change 100644 => 100755 extra/math/text/utils/utils-tests.factor mode change 100644 => 100755 extra/math/text/utils/utils.factor diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index ad43cc2f1d..a187f0c9af 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- ) : read-rfc3339-seconds ( s -- s' ch ) "+-Z" read-until [ - [ string>number ] [ length 10 swap ^ ] bi / + + [ string>number ] [ length 10^ ] bi / + ] dip ; : (rfc3339>timestamp) ( -- timestamp ) diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index f8b9ba501b..55ebdf1442 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -32,7 +32,7 @@ IN: formatting [ "." 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 ) [ diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 81e43f8dd9..88e1547b7b 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -9,11 +9,11 @@ calendar ascii combinators.short-circuit locals ; 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 ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 314062591d..3cbe8e19d4 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -104,10 +104,12 @@ PRIVATE> : 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 < [ @@ -116,6 +118,8 @@ PRIVATE> -rot (^mod) ] if ; foldable +: 10^ ( n -- n' ) 10 swap ^ ; inline + GENERIC: absq ( x -- y ) foldable M: real absq sq ; diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor index a1fc0bd07b..16a45fc691 100755 --- a/extra/math/analysis/analysis.factor +++ b/extra/math/analysis/analysis.factor @@ -1,7 +1,7 @@ ! 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 text) ( n -- str ) - [ negative-text ] [ abs 3digit-groups recombine ] bi append ; + [ negative-text ] [ abs 3 digit-groups recombine ] bi append ; PRIVATE> diff --git a/extra/math/text/french/french.factor b/extra/math/text/french/french.factor index f8b97103eb..46e326b7e7 100644 --- a/extra/math/text/french/french.factor +++ b/extra/math/text/french/french.factor @@ -73,7 +73,7 @@ MEMO: units ( -- seq ) ! up to 10^99 } 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 ; diff --git a/extra/math/text/utils/utils-docs.factor b/extra/math/text/utils/utils-docs.factor old mode 100644 new mode 100755 index e1d1a005d3..2352ab9488 --- a/extra/math/text/utils/utils-docs.factor +++ b/extra/math/text/utils/utils-docs.factor @@ -1,6 +1,6 @@ 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." } ; diff --git a/extra/math/text/utils/utils-tests.factor b/extra/math/text/utils/utils-tests.factor old mode 100644 new mode 100755 index d14bb06a2a..04fbcdc1a7 --- a/extra/math/text/utils/utils-tests.factor +++ b/extra/math/text/utils/utils-tests.factor @@ -1,3 +1,3 @@ USING: math.text.utils tools.test ; -[ { 1 999 2 } ] [ 2999001 3digit-groups ] unit-test +[ { 1 999 2 } ] [ 2999001 3 digit-groups ] unit-test diff --git a/extra/math/text/utils/utils.factor b/extra/math/text/utils/utils.factor old mode 100644 new mode 100755 index 422a79a1f3..13551f19e4 --- a/extra/math/text/utils/utils.factor +++ b/extra/math/text/utils/utils.factor @@ -1,7 +1,7 @@ ! 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 ; diff --git a/extra/money/money.factor b/extra/money/money.factor index 994d214335..36dedb2a65 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -28,6 +28,6 @@ ERROR: not-an-integer x ; [ [ 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 ; diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor index 640a3a68f6..fde3fa6026 100644 --- a/extra/project-euler/048/048.factor +++ b/extra/project-euler/048/048.factor @@ -1,6 +1,7 @@ ! 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 @@ -17,7 +18,7 @@ IN: project-euler.048 ! -------- : 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 diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index a7762836f1..6c555f92b5 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -1,11 +1,11 @@ ! 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 ) [ diff --git a/extra/svg/svg.factor b/extra/svg/svg.factor index 2ed5d21707..2d2d38314a 100644 --- a/extra/svg/svg.factor +++ b/extra/svg/svg.factor @@ -11,7 +11,7 @@ XML-NS: inkscape-name http://www.inkscape.org/namespaces/inkscape : 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 / ; From 15ae8fb673e4b4fbfa9732bcf8a9fabbef414909 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 18:15:24 -0500 Subject: [PATCH 06/16] fix sgn docs --- core/math/math-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 55a50cd5d7..c4a1bb4f34 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -213,9 +213,9 @@ HELP: sgn { $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" } } } ; From 4a3d63e00ae0a5e27d65a0fee0c55c98a49f627b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 18:15:53 -0500 Subject: [PATCH 07/16] use if-zero in a few more places --- basis/calendar/calendar.factor | 4 ++-- basis/io/sockets/unix/unix.factor | 2 +- basis/math/bits/bits.factor | 2 +- basis/math/functions/functions.factor | 8 ++++---- basis/math/primes/erato/erato.factor | 4 ++-- basis/math/ratios/ratios.factor | 14 ++++++++++---- basis/serialize/serialize.factor | 12 ++++++------ basis/windows/errors/errors.factor | 6 +----- extra/benchmark/fasta/fasta.factor | 2 +- extra/game-loop/game-loop.factor | 7 ++++--- 10 files changed, 32 insertions(+), 29 deletions(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 4b58b1b496..e9028b7841 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -45,11 +45,11 @@ M: not-a-month summary 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 ; diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index fe136cd887..ec8b4206e3 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -19,7 +19,7 @@ IN: io.sockets.unix [ handle-fd ] 2dip 1 "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 ) diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 0fbfdf0bd9..27a9a23ca3 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ; C: bits : make-bits ( number -- bits ) - dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + ] if ; inline + [ T{ bits f 0 0 } ] [ dup abs log2 1 + ] if-zero ; inline M: bits length length>> ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 3cbe8e19d4..8a0d39063b 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -71,7 +71,7 @@ PRIVATE> 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 [ @@ -263,13 +263,13 @@ M: real atan fatan ; : 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 diff --git a/basis/math/primes/erato/erato.factor b/basis/math/primes/erato/erato.factor index 673f9c97cd..fdc2f9fc3b 100644 --- a/basis/math/primes/erato/erato.factor +++ b/basis/math/primes/erato/erato.factor @@ -9,7 +9,7 @@ IN: math.primes.erato 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* ; @@ -38,4 +38,4 @@ PRIVATE> : 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 ; diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index d4f457180e..10ba14d13c 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -1,6 +1,7 @@ ! 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 ) @@ -19,13 +20,18 @@ IN: math.ratios PRIVATE> +ERROR: division-by-zero ; + +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 ; diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index b7e395fa35..da154444c1 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -47,7 +47,7 @@ M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; ! 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 ] [ @@ -60,7 +60,7 @@ M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; ] if >be write ] if - ] if ; + ] if-zero ; : deserialize-cell ( -- n ) read1 { @@ -79,12 +79,12 @@ M: f (serialize) ( obj -- ) 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 @@ -295,4 +295,4 @@ PRIVATE> 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 ; diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index d180cb20e7..8bdbb9f1e9 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -713,11 +713,7 @@ ERROR: error-message-failed id ; 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) ; diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index f457b90c30..c1d554a5a3 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -63,7 +63,7 @@ CONSTANT: homo-sapiens :: 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 diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor index 982319541b..5fe3d85e02 100644 --- a/extra/game-loop/game-loop.factor +++ b/extra/game-loop/game-loop.factor @@ -1,5 +1,6 @@ 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 @@ -52,11 +53,11 @@ TUPLE: game-loop-error game-loop error ; 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?>> From eccc919c1891f6f1992dfe0b545a4b0f2603cb1d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 18:22:44 -0500 Subject: [PATCH 08/16] fix project euler 151 and add a unit test --- extra/project-euler/151/151-tests.factor | 4 ++++ extra/project-euler/151/151.factor | 10 ++++------ 2 files changed, 8 insertions(+), 6 deletions(-) create mode 100644 extra/project-euler/151/151-tests.factor diff --git a/extra/project-euler/151/151-tests.factor b/extra/project-euler/151/151-tests.factor new file mode 100644 index 0000000000..beea8e3645 --- /dev/null +++ b/extra/project-euler/151/151-tests.factor @@ -0,0 +1,4 @@ +USING: project-euler.151 tools.test ; +IN: project-euler.151.tests + +[ 12138569781349/26138246400000 ] [ euler151 ] unit-test diff --git a/extra/project-euler/151/151.factor b/extra/project-euler/151/151.factor index 66c5a6301e..708fe9849e 100644 --- a/extra/project-euler/151/151.factor +++ b/extra/project-euler/151/151.factor @@ -39,11 +39,11 @@ SYMBOL: table : (pick-sheet) ( seq i -- newseq ) [ - <=> sgn + <=> { - { -1 [ ] } - { 0 [ 1- ] } - { 1 [ 1+ ] } + { +lt+ [ ] } + { +eq+ [ 1- ] } + { +gt+ [ 1+ ] } } case ] curry map-index ; @@ -71,8 +71,6 @@ DEFER: (euler151) { 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 From 02becc26fcd376fbba198673906bec02f8926ba4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 18:45:01 -0500 Subject: [PATCH 09/16] add docs for if-zero etc, add docs for 10^ --- basis/math/functions/functions-docs.factor | 10 ++++ basis/math/functions/functions.factor | 6 ++- core/sequences/sequences-docs.factor | 57 +++++++++++++++++++++- core/sequences/sequences.factor | 4 +- extra/project-euler/common/common.factor | 3 -- 5 files changed, 72 insertions(+), 8 deletions(-) diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 41800e46da..0fe77fa4ae 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -50,8 +50,10 @@ ARTICLE: "power-functions" "Powers and logarithms" { $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 } @@ -122,6 +124,10 @@ HELP: log { $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." } ; @@ -261,6 +267,10 @@ HELP: ^ { $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" } } diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 8a0d39063b..801522b376 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -118,8 +118,6 @@ ERROR: non-trivial-divisor n ; -rot (^mod) ] if ; foldable -: 10^ ( n -- n' ) 10 swap ^ ; inline - GENERIC: absq ( x -- y ) foldable M: real absq sq ; @@ -160,6 +158,10 @@ M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; 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 diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index d7db7f5242..fbdd8268da 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -123,7 +123,48 @@ HELP: unless-empty } } ; -{ 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" } } @@ -1393,6 +1434,18 @@ $nl $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:" @@ -1658,6 +1711,8 @@ $nl "Using sequences for looping:" { $subsection "sequences-integers" } { $subsection "math.ranges" } +"Using sequences for control flow:" +{ $subsection "sequences-if" } "For inner loops:" { $subsection "sequences-unsafe" } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 2e41d9d2e1..39c38d8688 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -46,9 +46,9 @@ PRIVATE> : if-zero ( n quot1 quot2 -- ) [ dup zero? ] (if-empty) ; inline -: when-zero ( seq quot -- ) [ ] if-zero ; inline +: when-zero ( n quot -- ) [ ] if-zero ; inline -: unless-zero ( seq quot -- ) [ ] swap if-zero ; inline +: unless-zero ( n quot -- ) [ ] swap if-zero ; inline : delete-all ( seq -- ) 0 swap set-length ; diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 497fc31de7..c97c6f1a95 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -62,9 +62,6 @@ PRIVATE> : 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@ / ; From 415d89e82141ef85a3224eaead798e2c65b263cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 21:18:43 -0500 Subject: [PATCH 10/16] use unless-empty --- basis/fry/fry.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index d50fd9442b..ecb5cbf856 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -26,7 +26,7 @@ M: >r/r>-in-fry-error summary : 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? ; From 14e8abd563153eaa345024b03498ca81a879690b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 22:30:16 -0500 Subject: [PATCH 11/16] even better error handling for division by zero --- basis/math/ratios/ratios.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 10ba14d13c..7da92cd154 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -20,7 +20,7 @@ IN: math.ratios PRIVATE> -ERROR: division-by-zero ; +ERROR: division-by-zero x ; M: division-by-zero summary drop "Division by zero" ; From 379c17a284cfd276323c9875f3c55e6db6a305a0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 22:40:29 -0500 Subject: [PATCH 12/16] Throw typed errors instead of strings for calling/executing non-callables --- basis/stack-checker/backend/backend.factor | 10 ++++++---- basis/stack-checker/known-words/known-words.factor | 8 ++++++-- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 338b052316..5411c885ad 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -5,7 +5,7 @@ parser sequences strings vectors words quotations effects classes 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 ; @@ -98,8 +98,10 @@ M: object apply-object push-literal ; : 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? [ @@ -110,7 +112,7 @@ M: object apply-object push-literal ; [ [ recursion>> ] keep add-local-quotation ] bi infer-quot ] [ - drop bad-call + value>> \ bad-call boa time-bomb ] if ] if ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 6959e32452..59aeb97d82 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -134,13 +134,17 @@ M: object infer-call* \ 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 From aabfc614a1c971ac5a03257e64746387c9e7baee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 23:07:13 -0500 Subject: [PATCH 13/16] fix build errors --- basis/calendar/calendar-docs.factor | 2 +- extra/descriptive/descriptive-tests.factor | 26 ++++++++++++++++++---- 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index b39a7c7464..71e052bb6c 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -27,7 +27,7 @@ HELP: } ; 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." } ; diff --git a/extra/descriptive/descriptive-tests.factor b/extra/descriptive/descriptive-tests.factor index 755c57ceda..6630d2addb 100755 --- a/extra/descriptive/descriptive-tests.factor +++ b/extra/descriptive/descriptive-tests.factor @@ -1,16 +1,34 @@ -USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see ; +USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see +math.ratios ; IN: descriptive.tests DESCRIPTIVE: divide ( num denom -- fraction ) / ; [ 3 ] [ 9 3 divide ] unit-test -[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test -[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test +[ + T{ descriptive-error f + { { "num" 3 } { "denom" 0 } } + T{ division-by-zero f 3 } + divide + } +] [ + [ 3 0 divide ] [ ] recover +] unit-test + +[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] +[ \ divide [ see ] with-string-writer ] unit-test DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ; [ 3 ] [ 9 3 divide* ] unit-test -[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test + +[ + T{ descriptive-error f + { { "num" 3 } { "denom" 0 } } + T{ division-by-zero f 3 } + divide* + } +] [ [ 3 0 divide* ] [ ] recover ] unit-test [ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test From 686b3e348e8ab69cc14dc14e900633b3a5edfead Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 23:09:02 -0500 Subject: [PATCH 14/16] use ERROR: in several places instead of throwing strings --- core/classes/algebra/algebra.factor | 4 +++- core/effects/parser/parser.factor | 4 +++- core/generic/single/single.factor | 4 +++- core/math/math.factor | 4 +++- core/sequences/sequences.factor | 4 +++- 5 files changed, 15 insertions(+), 5 deletions(-) diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 6bfc94d79a..df4f8f2563 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -202,9 +202,11 @@ M: anonymous-complement (classes-intersect?) : class= ( first second -- ? ) [ class<= ] [ swap class<= ] 2bi and ; +ERROR: topological-sort-failed ; + : largest-class ( seq -- n elt ) dup [ [ class< ] with any? not ] curry find-last - [ "Topological sort failed" throw ] unless* ; + [ topological-sort-failed ] unless* ; : sort-classes ( seq -- newseq ) [ name>> ] sort-with >vector diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index c8ed6da2aa..66179c5e52 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -24,9 +24,11 @@ ERROR: bad-effect ; : 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 - [ ] [ "Stack effect declaration must contain --" throw ] if ; + [ ] [ drop stack-effect-omits-dashes ] if ; : complete-effect ( -- effect ) "(" expect ")" parse-effect ; diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 88387abd5c..8a53368062 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -208,9 +208,11 @@ SYMBOL: predicate-engines : 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 ] diff --git a/core/math/math.factor b/core/math/math.factor index 28efbaa26e..8fa56e6e24 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -48,9 +48,11 @@ GENERIC: (log2) ( x -- n ) foldable PRIVATE> +ERROR: log2-expects-positive x ; + : log2 ( x -- n ) dup 0 <= [ - "log2 expects positive inputs" throw + log2-expects-positive ] [ (log2) ] if ; inline diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 39c38d8688..aecc9e33d8 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -281,9 +281,11 @@ INSTANCE: repetition immutable-sequence Date: Wed, 12 Aug 2009 03:25:53 -0500 Subject: [PATCH 15/16] More accurate wrap-interval in compiler.tree.propagation.info fixes test regression; constructing an interval with endpoints at infinity now outputs full-interval --- .../tree/propagation/info/info.factor | 32 ++++++++++++++----- basis/math/intervals/intervals-tests.factor | 16 ++++++++++ basis/math/intervals/intervals.factor | 28 ++++++++-------- 3 files changed, 55 insertions(+), 21 deletions(-) diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index cae8d6cde6..0a04b48160 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -2,7 +2,7 @@ ! 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 @@ -78,21 +78,37 @@ UNION: fixed-length array byte-array string ; : 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 diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 760338a7c3..de402b48b9 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -113,6 +113,22 @@ IN: math.intervals.tests 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 diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 3c33940676..8ea28b2235 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -11,14 +11,21 @@ SYMBOL: full-interval TUPLE: interval { from read-only } { to read-only } ; +: closed-point? ( from to -- ? ) + 2dup [ first ] bi@ number= + [ [ second ] both? ] [ 2drop f ] if ; + : ( 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 ; @@ -53,6 +60,9 @@ MEMO: [0,inf] ( -- interval ) 0 [a,inf] ; foldable 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 -- ? ) @@ -344,14 +354,6 @@ SYMBOL: incomparable [ nip (rem-range) ] } 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 ] } - [ ] - } cond ; - : interval-bitand-pos ( i1 i2 -- ? ) [ to>> first ] bi@ min 0 swap [a,b] ; From 56b81a74abbaf8df82a457cf5319a949fe22ae0f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 12 Aug 2009 17:46:10 -0500 Subject: [PATCH 16/16] add chameneos-redux benchmark --- extra/benchmark/chameneos-redux/authors.txt | 1 + .../chameneos-redux/chameneos-redux.factor | 106 ++++++++++++++++++ 2 files changed, 107 insertions(+) create mode 100644 extra/benchmark/chameneos-redux/authors.txt create mode 100644 extra/benchmark/chameneos-redux/chameneos-redux.factor diff --git a/extra/benchmark/chameneos-redux/authors.txt b/extra/benchmark/chameneos-redux/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/benchmark/chameneos-redux/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/benchmark/chameneos-redux/chameneos-redux.factor b/extra/benchmark/chameneos-redux/chameneos-redux.factor new file mode 100644 index 0000000000..afd2f8830a --- /dev/null +++ b/extra/benchmark/chameneos-redux/chameneos-redux.factor @@ -0,0 +1,106 @@ +! 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 ; + +: ( count -- meeting-place ) + meeting-place new + swap >>count + >>mailbox ; + +: ( n color -- creature ) + creature new + swap >>color + swap >>n + 0 >>count + 0 >>self-count + >>mailbox ; + +: make-creatures ( colors -- seq ) + [ length iota ] [ ] bi [ ] 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 -- ) + [ ] [ 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