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

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

db4
Slava Pestov 2008-04-28 14:43:25 -05:00
parent 89df7fd104 bd654f8621
commit 1147b07bb9
8 changed files with 71 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
core/kernel/kernel-docs.factor
View File

@ -254,6 +254,7 @@ $nl
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
{ $subsection <=> }
{ $subsection compare }
{ $subsection invert-comparison }
"Utilities for comparing objects:"
{ $subsection after? }
{ $subsection before? }

7
core/math/order/order-docs.factor
View File

@ -25,6 +25,13 @@ HELP: +eq+
HELP: +gt+
{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
HELP: invert-comparison
{ $values { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" }
{ "new-symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
{ $examples
{ $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
HELP: compare
{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }

3
core/math/order/order.factor
View File

@ -11,6 +11,9 @@ GENERIC: <=> ( obj1 obj2 -- n )
: (<=>) - dup 0 < [ drop +lt+ ] [ zero? +eq+ +gt+ ? ] if ;
: invert-comparison ( symbol -- new-symbol )
dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
M: real <=> (<=>) ;
M: integer <=> (<=>) ;

8
extra/calendar/calendar-tests.factor
View File

@ -131,16 +131,16 @@ IN: calendar.tests
[ t ] [ 2004 1 1 23 0 0 9+1/2 hours <timestamp> >gmt
2004 1 1 13 30 0 instant <timestamp> = ] unit-test
[ 0 ] [ 2004 1 1 13 30 0 instant <timestamp>
[ +eq+ ] [ 2004 1 1 13 30 0 instant <timestamp>
2004 1 1 12 30 0 -1 hours <timestamp> <=> ] unit-test
[ 1 ] [ 2004 1 1 13 30 0 instant <timestamp>
[ +gt+ ] [ 2004 1 1 13 30 0 instant <timestamp>
2004 1 1 12 30 0 instant <timestamp> <=> ] unit-test
[ -1 ] [ 2004 1 1 12 30 0 instant <timestamp>
[ +lt+ ] [ 2004 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
[ 1 ] [ 2005 1 1 12 30 0 instant <timestamp>
[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test

16
extra/calendar/format/format.factor
View File

@ -87,10 +87,10 @@ M: timestamp year. ( timestamp -- )
[ hh ] [ mm ] bi ;
: write-gmt-offset ( gmt-offset -- )
dup instant <=> sgn {
{ 0 [ drop "GMT" write ] }
{ -1 [ "-" write before (write-gmt-offset) ] }
{ 1 [ "+" write (write-gmt-offset) ] }
dup instant <=> {
{ +eq+ [ drop "GMT" write ] }
{ +lt+ [ "-" write before (write-gmt-offset) ] }
{ +gt+ [ "+" write (write-gmt-offset) ] }
} case ;
: timestamp>rfc822 ( timestamp -- str )
@ -118,10 +118,10 @@ M: timestamp year. ( timestamp -- )
[ hh ":" write ] [ mm ] bi ;
: write-rfc3339-gmt-offset ( duration -- )
dup instant <=> sgn {
{ 0 [ drop "Z" write ] }
{ -1 [ "-" write before (write-rfc3339-gmt-offset) ] }
{ 1 [ "+" write (write-rfc3339-gmt-offset) ] }
dup instant <=> {
{ +eq+ [ drop "Z" write ] }
{ +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
{ +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
} case ;
: (timestamp>rfc3339) ( timestamp -- )

16
extra/multi-methods/multi-methods.factor
View File

@ -73,7 +73,7 @@ SYMBOL: total
! Part II: Topologically sorting specializers
: maximal-element ( seq quot -- n elt )
dupd [
swapd [ call 0 < ] 2curry filter empty?
swapd [ call +lt+ = ] 2curry filter empty?
] 2curry find [ "Topological sort failed" throw ] unless* ;
inline
@ -82,16 +82,16 @@ SYMBOL: total
[ dupd maximal-element >r over delete-nth r> ] curry
[ ] unfold nip ; inline
: classes< ( seq1 seq2 -- -1/0/1 )
: classes< ( seq1 seq2 -- lt/eq/gt )
[
{
{ [ 2dup eq? ] [ 0 ] }
{ [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
{ [ 2dup class< ] [ -1 ] }
{ [ 2dup swap class< ] [ 1 ] }
[ 0 ]
{ [ 2dup eq? ] [ +eq+ ] }
{ [ 2dup [ class< ] 2keep swap class< and ] [ +eq+ ] }
{ [ 2dup class< ] [ +lt+ ] }
{ [ 2dup swap class< ] [ +gt+ ] }
[ +eq+ ]
} cond 2nip
] 2map [ zero? not ] find nip 0 or ;
] 2map [ zero? not ] find nip +eq+ or ;
: sort-methods ( alist -- alist' )
[ [ first ] bi@ classes< ] topological-sort ;

6
extra/multi-methods/tests/topological-sort.factor
View File

@ -6,14 +6,14 @@ IN: multi-methods.tests
{ 6 4 5 1 3 2 } [ <=> ] topological-sort
] unit-test
[ -1 ] [
[ +lt+ ] [
{ fixnum array } { number sequence } classes<
] unit-test
[ 0 ] [
[ +eq+ ] [
{ number sequence } { number sequence } classes<
] unit-test
[ 1 ] [
[ +gt+ ] [
{ object object } { number sequence } classes<
] unit-test

72
extra/trees/trees.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic math sequences arrays io namespaces
prettyprint.private kernel.private assocs random combinators
parser prettyprint.backend math.order ;
parser prettyprint.backend math.order accessors ;
IN: trees
MIXIN: tree-mixin
@ -25,19 +25,24 @@ TUPLE: node key value left right ;
SYMBOL: current-side
: left -1 ; inline
: right 1 ; inline
: left ( -- symbol ) -1 ; inline
: right ( -- symbol ) 1 ; inline
: go-left? ( -- ? ) current-side get left = ;
: key-side ( k1 k2 -- n )
<=> {
{ +lt+ [ -1 ] }
{ +eq+ [ 0 ] }
{ +gt+ [ 1 ] }
} case ;
: inc-count ( tree -- )
dup tree-count 1+ swap set-tree-count ;
: go-left? ( -- ? ) current-side get left eq? ;
: dec-count ( tree -- )
dup tree-count 1- swap set-tree-count ;
: inc-count ( tree -- ) [ 1+ ] change-count drop ;
: dec-count ( tree -- ) [ 1- ] change-count drop ;
: node-link@ ( node ? -- node )
go-left? xor [ node-left ] [ node-right ] if ;
go-left? xor [ left>> ] [ right>> ] if ;
: set-node-link@ ( left parent ? -- )
go-left? xor [ set-node-left ] [ set-node-right ] if ;
@ -47,19 +52,16 @@ SYMBOL: current-side
: set-node+link ( child node -- ) t set-node-link@ ;
: with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline
: with-other-side ( quot -- ) current-side get neg swap with-side ; inline
: with-other-side ( quot -- )
current-side get neg swap with-side ; inline
: go-left ( quot -- ) left swap with-side ; inline
: go-right ( quot -- ) right swap with-side ; inline
: change-root ( tree quot -- )
swap [ tree-root swap call ] keep set-tree-root ; inline
swap [ root>> swap call ] keep set-tree-root ; inline
: leaf? ( node -- ? )
dup node-left swap node-right or not ;
: key-side ( k1 k2 -- side )
#! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
<=> sgn ;
[ left>> ] [ right>> ] bi or not ;
: random-side ( -- side ) left right 2array random ;
@ -76,11 +78,11 @@ SYMBOL: current-side
] [ drop f f ] if* ;
M: tree at* ( key tree -- value ? )
tree-root node-at* ;
root>> node-at* ;
: node-set ( value key node -- node )
2dup node-key key-side dup zero? [
drop nip [ set-node-value ] keep
2dup key>> key-side dup 0 eq? [
drop nip swap >>value
] [
[
[ node-link [ node-set ] [ swap <node> ] if* ] keep
@ -93,12 +95,12 @@ M: tree set-at ( value key tree -- )
: valid-node? ( node -- ? )
[
dup dup node-left [ node-key swap node-key before? ] when* >r
dup dup node-right [ node-key swap node-key after? ] when* r> and swap
dup node-left valid-node? swap node-right valid-node? and and
dup dup left>> [ node-key swap node-key before? ] when* >r
dup dup right>> [ node-key swap node-key after? ] when* r> and swap
dup left>> valid-node? swap right>> valid-node? and and
] [ t ] if* ;
: valid-tree? ( tree -- ? ) tree-root valid-node? ;
: valid-tree? ( tree -- ? ) root>> valid-node? ;
: tree-call ( node call -- )
>r [ node-key ] keep node-value r> call ; inline
@ -107,20 +109,20 @@ M: tree set-at ( value key tree -- )
{
{ [ over not ] [ 2drop f f f ] }
{ [ [
>r node-left r> find-node
>r left>> r> find-node
] 2keep rot ]
[ 2drop t ] }
{ [ >r 2nip r> [ tree-call ] 2keep rot ]
[ drop [ node-key ] keep node-value t ] }
[ >r node-right r> find-node ]
[ >r right>> r> find-node ]
} cond ; inline
M: tree-mixin assoc-find ( tree quot -- key value ? )
>r tree-root r> find-node ;
>r root>> r> find-node ;
M: tree-mixin clear-assoc
0 over set-tree-count
f swap set-tree-root ;
0 >>count
f >>root drop ;
: copy-node-contents ( new old -- )
dup node-key pick set-node-key node-value swap set-node-value ;
@ -158,22 +160,22 @@ DEFER: delete-node
: delete-node ( node -- node )
#! delete this node, returning its replacement
dup node-left [
dup node-right [
dup left>> [
dup right>> [
delete-node-with-two-children
] [
node-left ! left but no right
left>> ! left but no right
] if
] [
dup node-right [
node-right ! right but not left
dup right>> [
right>> ! right but not left
] [
drop f ! no children
] if
] if ;
: delete-bst-node ( key node -- node )
2dup node-key key-side dup zero? [
2dup node-key key-side dup 0 eq? [
drop nip delete-node
] [
[ tuck node-link delete-bst-node over set-node-link ] with-side
@ -197,7 +199,7 @@ M: tree-mixin assoc-like drop dup tree? [ >tree ] unless ;
M: tree pprint-delims drop \ TREE{ \ } ;
M: tree-mixin assoc-size tree-count ;
M: tree-mixin assoc-size count>> ;
M: tree-mixin clone dup assoc-clone-like ;
M: tree-mixin >pprint-sequence >alist ;
M: tree-mixin pprint-narrow? drop t ;