Merge branch 'master' of git://factorcode.org/git/factor

basis/help/help.factor

@@ -54,7 +54,7 @@ M: word article-title
     dup [ parsing-word? ] [ symbol? ] bi or [
         name>> 
     ] [
-        [ name>> ]
+        [ unparse ]
         [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
         append
     ] if ;

basis/prettyprint/backend/backend.factor

@@ -35,8 +35,8 @@ M: effect pprint* effect>string "(" ")" surround text ;
     name>> "( no name )" or ;
 
 : pprint-word ( word -- )
-    dup record-vocab
+    [ record-vocab ]
-    dup word-name* swap word-style styled-text ;
+    [ [ word-name* ] [ word-style ] bi styled-text ] bi ;
 
 : pprint-prefix ( word quot -- )
     <block swap pprint-word call block> ; inline
@@ -48,11 +48,12 @@ M: word pprint*
     [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
 
 M: method-body pprint*
-    <block
+    [
-    \ M\ pprint-word
+        [
-    [ "method-class" word-prop pprint-word ]
+            [ "M\\ " % "method-class" word-prop word-name* % ]
-    [ "method-generic" word-prop pprint-word ] bi
+            [ " " % "method-generic" word-prop word-name* % ] bi
-    block> ;
+        ] "" make
+    ] [ word-style ] bi styled-text ;
 
 M: real pprint* number>string text ;
 

basis/tools/errors/errors-docs.factor

@@ -1,6 +1,6 @@
 IN: tools.errors
 USING: help.markup help.syntax source-files.errors words io
-compiler.errors ;
+compiler.errors classes ;
 
 ARTICLE: "compiler-errors" "Compiler errors"
 "After loading a vocabulary, you might see a message like:"
@@ -15,11 +15,11 @@ $nl
 "Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ;
 
 HELP: compiler-error
-{ $values { "error" compiler-error } { "word" word } }
+{ $values { "error" compiler-error } }
 { $description "Saves the error for viewing with " { $link :errors } "." } ;
 
 HELP: linkage-error
-{ $values { "error" linkage-error } { "word" word } }
+{ $values { "error" linkage-error } { "word" word } { "class" class } }
 { $description "Saves the error for viewing with " { $link :linkage } "." } ;
 
 HELP: :errors

basis/tools/errors/errors-tests.factor

@@ -6,14 +6,7 @@ DEFER: blah
 [ ] [
     {
         T{ compiler-error
-           { error
+           { error T{ do-not-compile f blah } }
-             T{ inference-error
-                f
-                T{ do-not-compile f blah }
-                +compiler-error+
-                blah
-             }
-           }
            { asset blah }
         }
     } errors.

basis/ui/gadgets/tables/tables-tests.factor

@@ -1,6 +1,6 @@
 IN: ui.gadgets.tables.tests
-USING: ui.gadgets.tables ui.gadgets.scrollers accessors
+USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors
-models namespaces tools.test kernel ;
+models namespaces tools.test kernel combinators ;
 
 SINGLETON: test-renderer
 
@@ -8,15 +8,40 @@ M: test-renderer row-columns drop ;
 
 M: test-renderer column-titles drop { "First" "Last" } ;
 
-[ ] [
+: test-table ( -- table )
     {
         { "Britney" "Spears" }
         { "Justin" "Timberlake" }
         { "Don" "Stewart" }
-    } <model> test-renderer <table>
+    } <model> test-renderer <table> ;
-    "table" set
+
+[ ] [
+    test-table "table" set
 ] unit-test
 
 [ ] [
     "table" get <scroller> "scroller" set
 ] unit-test
+
+[ { "Justin" "Timberlake" } { "Britney" "Spears" } ] [
+    test-table t >>selection-required? dup [
+        {
+            [ 1 select-row ]
+            [
+                model>> {
+                    { "Justin" "Timberlake" }
+                    { "Britney" "Spears" }
+                    { "Don" "Stewart" }
+                } swap set-model
+            ]
+            [ selected-row drop ]
+            [
+                model>> {
+                    { "Britney" "Spears" }
+                    { "Don" "Stewart" }
+                } swap set-model
+            ]
+            [ selected-row drop ]
+        } cleave
+    ] with-grafted-gadget
+] unit-test

basis/ui/gadgets/tables/tables.factor

@@ -5,8 +5,8 @@ math.functions math.rectangles math.order math.vectors namespaces
 opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
 ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text
 ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support
-math.rectangles models math.ranges sequences combinators fonts locals
+math.rectangles models math.ranges sequences combinators
-strings ;
+combinators.short-circuit fonts locals strings ;
 IN: ui.gadgets.tables
 
 ! Row rendererer protocol
@@ -246,9 +246,6 @@ PRIVATE>
 : update-selected-value ( table -- )
     [ selected-row drop ] [ selected-value>> ] bi set-model ;
 
-: initial-selected-index ( model table -- n/f )
-    [ value>> length 1 >= ] [ selection-required?>> ] bi* and 0 f ? ;
-
 : show-row-summary ( table n -- )
     over nth-row
     [ swap [ renderer>> row-value ] keep show-summary ]
@@ -258,8 +255,28 @@ PRIVATE>
 : hide-mouse-help ( table -- )
     f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
 
+: find-row-index ( value table -- n/f )
+    [ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ;
+
+: initial-selected-index ( table -- n/f )
+    {
+        [ model>> value>> empty? not ]
+        [ selection-required?>> ]
+        [ drop 0 ]
+    } 1&& ;
+
+: (update-selected-index) ( table -- n/f )
+    [ selected-value>> value>> ] keep over
+    [ find-row-index ] [ 2drop f ] if ;
+
+: update-selected-index ( table -- n/f )
+    {
+        [ (update-selected-index) ]
+        [ initial-selected-index ]
+    } 1|| ;
+
 M: table model-changed
-    [ nip ] [ initial-selected-index ] 2bi {
+    nip dup update-selected-index {
         [ >>selected-index f >>mouse-index drop ]
         [ show-row-summary ]
         [ drop update-selected-value ]
@@ -302,6 +319,8 @@ PRIVATE>
 : table-button-up ( table -- )
     dup row-action? [ row-action ] [ update-selected-value ] if ;
 
+PRIVATE>
+
 : select-row ( table n -- )
     over validate-line
     [ (select-row) ]
@@ -309,6 +328,8 @@ PRIVATE>
     [ show-row-summary ]
     2tri ;
 
+<PRIVATE
+
 : prev/next-row ( table n -- )
     [ dup selected-index>> ] dip '[ _ + ] [ 0 ] if* select-row ;
     
@@ -354,9 +375,9 @@ PRIVATE>
         show-operations-menu
     ] [ drop ] if-mouse-row ;
 
-: focus-table ( table -- ) t >>focused? drop ;
+: focus-table ( table -- ) t >>focused? relayout-1 ;
 
-: unfocus-table ( table -- ) f >>focused? drop ;
+: unfocus-table ( table -- ) f >>focused? relayout-1 ;
 
 table "sundry" f {
     { mouse-enter show-mouse-help }

extra/benchmark/gc1/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/benchmark/gc1/gc1.factor

@@ -0,0 +1,8 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math sequences kernel ;
+IN: benchmark.gc1
+
+: gc1 ( -- ) 6000000 [ >bignum 1+ ] map drop ;
+
+MAIN: gc1

extra/benchmark/pidigits/authors.txt

@@ -0,0 +1 @@
+Aaron Schaefer

extra/benchmark/pidigits/pidigits.factor

@@ -0,0 +1,59 @@
+! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
+! The contents of this file are licensed under the Simplified BSD License
+! A copy of the license is available at http://factorcode.org/license.txt
+USING: arrays formatting fry grouping io kernel locals math math.functions
+    math.matrices math.parser math.primes.factors math.vectors prettyprint
+    sequences sequences.deep sets ;
+IN: benchmark.pidigits
+
+: extract ( z x -- n )
+    1 2array '[ _ v* sum ] map first2 /i ;
+
+: next ( z -- n )
+    3 extract ;
+
+: safe? ( z n -- ? )
+    [ 4 extract ] dip = ;
+
+: >matrix ( q s r t -- z )
+    4array 2 group ;
+
+: produce ( z n -- z' )
+    [ 10 ] dip -10 * 0 1 >matrix swap m. ;
+
+: gen-x ( x -- matrix )
+    dup 2 * 1 + [ 2 * 0 ] keep >matrix ;
+
+: consume ( z k -- z' )
+    gen-x m. ;
+
+:: (padded-total) ( row col -- str n format )
+    "" row col + "%" "s\t:%d\n"
+    10 col - number>string glue ;
+
+: padded-total ( row col -- )
+    (padded-total) '[ _ printf ] call( str n -- ) ;
+
+:: (pidigits) ( k z n row col -- )
+    n 0 > [
+        z next :> y
+        z y safe? [
+            col 10 = [
+                row 10 + y "\t:%d\n%d" printf
+                k z y produce n 1 - row 10 + 1 (pidigits)
+            ] [
+                y number>string write
+                k z y produce n 1 - row col 1 + (pidigits)
+            ] if
+        ] [
+            k 1 + z k consume n row col (pidigits)
+        ] if
+    ] [ row col padded-total ] if ;
+
+: pidigits ( n -- )
+    [ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ;
+
+: pidigits-main ( -- )
+    10000 pidigits ;
+
+MAIN: pidigits-main

extra/poker/poker.factor

@@ -117,9 +117,6 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
 : lookup ( cards table -- value )
     [ rank-bits ] dip nth ;
 
-: unique5? ( cards -- ? )
-    unique5-table lookup 0 > ;
-
 : map-product ( seq quot -- n )
     [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
 
@@ -138,11 +135,11 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
     bitxor values-table nth ;
 
 : hand-value ( cards -- value )
-    {
+    dup flush? [ flushes-table lookup ] [
-        { [ dup flush?   ] [ flushes-table lookup ] }
+        dup unique5-table lookup dup 0 > [ nip ] [
-        { [ dup unique5? ] [ unique5-table lookup ] }
+            drop prime-bits perfect-hash-find
-        [ prime-bits perfect-hash-find ]
+        ] if
-    } cond ;
+    ] if ;
 
 : >card-rank ( card -- str )
     -8 shift HEX: F bitand RANK_STR nth ;

extra/project-euler/001/001-tests.factor

@@ -5,3 +5,4 @@ IN: project-euler.001.tests
 [ 233168 ] [ euler001a ] unit-test
 [ 233168 ] [ euler001b ] unit-test
 [ 233168 ] [ euler001c ] unit-test
+[ 233168 ] [ euler001d ] unit-test

extra/project-euler/001/001.factor

@@ -1,6 +1,7 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.ranges project-euler.common sequences
+    sets ;
 IN: project-euler.001
 
 ! http://projecteuler.net/index.php?section=problems&id=1
@@ -32,7 +33,7 @@ PRIVATE>
     999 15 sum-divisible-by - ;
 
 ! [ euler001 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.0 SD (100 trials)
 
 
 ! ALTERNATE SOLUTIONS
@@ -42,14 +43,14 @@ PRIVATE>
     0 999 3 <range> sum 0 999 5 <range> sum + 0 999 15 <range> sum - ;
 
 ! [ euler001a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.03 SD (100 trials)
 
 
 : euler001b ( -- answer )
     1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
 
 ! [ euler001b ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.06 SD (100 trials)
 
 
 : euler001c ( -- answer )
@@ -58,4 +59,11 @@ PRIVATE>
 ! [ euler001c ] 100 ave-time
 ! 0 ms ave run time - 0.06 SD (100 trials)
 
+
+: euler001d ( -- answer )
+    { 3 5 } [ [ 999 ] keep <range> ] gather sum ;
+
+! [ euler001d ] 100 ave-time
+! 0 ms ave run time - 0.08 SD (100 trials)
+
 SOLUTION: euler001

extra/project-euler/069/069.factor

@@ -69,12 +69,9 @@ PRIVATE>
         [ nth-prime primes-upto ]
     } cond product ;
 
-: (primorial-upto) ( count limit -- m )
-    '[ dup primorial _ <= ] [ 1+ dup primorial ] produce
-    nip penultimate ;
-
 : primorial-upto ( limit -- m )
-    1 swap (primorial-upto) ;
+    1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce
+    nip penultimate ;
 
 PRIVATE>