steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2009-04-24 01:19:08 -05:00
parent 0759ddcfca b78332d645
commit 3b19a26e07
14 changed files with 161 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/help/help.factor
View File

@ -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 ;

15
basis/prettyprint/backend/backend.factor
View File

@ -35,8 +35,8 @@ M: effect pprint* effect>string "(" ")" surround text ;
name>> "( no name )" or ;
: pprint-word ( word -- )
dup record-vocab
dup word-name* swap word-style styled-text ;
[ record-vocab ]
[ [ 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 ]
[ "method-generic" word-prop pprint-word ] bi
block> ;
[
[
[ "M\\ " % "method-class" word-prop word-name* % ]
[ " " % "method-generic" word-prop word-name* % ] bi
] "" make
] [ word-style ] bi styled-text ;
M: real pprint* number>string text ;

6
basis/tools/errors/errors-docs.factor
View File

@ -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

9
basis/tools/errors/errors-tests.factor
View File

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

35
basis/ui/gadgets/tables/tables-tests.factor
View File

@ -1,6 +1,6 @@
IN: ui.gadgets.tables.tests
USING: ui.gadgets.tables ui.gadgets.scrollers accessors
models namespaces tools.test kernel ;
USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors
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>
"table" set
} <model> test-renderer <table> ;
[ ] [
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

37
basis/ui/gadgets/tables/tables.factor
View File

@ -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
strings ;
math.rectangles models math.ranges sequences combinators
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 }

1
extra/benchmark/gc1/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

8
extra/benchmark/gc1/gc1.factor Normal file
View File

@ -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

1
extra/benchmark/pidigits/authors.txt Normal file
View File

@ -0,0 +1 @@
Aaron Schaefer

59
extra/benchmark/pidigits/pidigits.factor Normal file
View File

@ -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

13
extra/poker/poker.factor
View File

@ -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 unique5? ] [ unique5-table lookup ] }
[ prime-bits perfect-hash-find ]
} cond ;
dup flush? [ flushes-table lookup ] [
dup unique5-table lookup dup 0 > [ nip ] [
drop prime-bits perfect-hash-find
] if
] if ;
: >card-rank ( card -- str )
-8 shift HEX: F bitand RANK_STR nth ;

1
extra/project-euler/001/001-tests.factor
View File

@ -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

16
extra/project-euler/001/001.factor
View File

@ -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

7
extra/project-euler/069/069.factor
View File

@ -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>