From 47abbfc4c6d1f6189d2f175d6869dd60243b73f3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 27 Apr 2008 22:44:30 -0500 Subject: [PATCH 1/7] fix calendar for <=> change --- extra/calendar/calendar-tests.factor | 8 ++++---- extra/calendar/format/format.factor | 16 ++++++++-------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index e2a2bc7e66..7d9716ae1a 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -131,16 +131,16 @@ IN: calendar.tests [ t ] [ 2004 1 1 23 0 0 9+1/2 hours >gmt 2004 1 1 13 30 0 instant = ] unit-test -[ 0 ] [ 2004 1 1 13 30 0 instant +[ +eq+ ] [ 2004 1 1 13 30 0 instant 2004 1 1 12 30 0 -1 hours <=> ] unit-test -[ 1 ] [ 2004 1 1 13 30 0 instant +[ +gt+ ] [ 2004 1 1 13 30 0 instant 2004 1 1 12 30 0 instant <=> ] unit-test -[ -1 ] [ 2004 1 1 12 30 0 instant +[ +lt+ ] [ 2004 1 1 12 30 0 instant 2004 1 1 13 30 0 instant <=> ] unit-test -[ 1 ] [ 2005 1 1 12 30 0 instant +[ +gt+ ] [ 2005 1 1 12 30 0 instant 2004 1 1 13 30 0 instant <=> ] unit-test [ t ] [ now timestamp>millis millis - 1000 < ] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 26daaddc40..91a034f8bd 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -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 -- ) From 0d8ddd2a3c155d5a10d78987b67cab9fc2121534 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 27 Apr 2008 22:44:42 -0500 Subject: [PATCH 2/7] fix multi-methods for <=> --- extra/multi-methods/multi-methods.factor | 16 ++++++++-------- .../multi-methods/tests/topological-sort.factor | 6 +++--- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 07d110b01a..d5a698f5f8 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -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 ; diff --git a/extra/multi-methods/tests/topological-sort.factor b/extra/multi-methods/tests/topological-sort.factor index cea7022759..f1618374ef 100644 --- a/extra/multi-methods/tests/topological-sort.factor +++ b/extra/multi-methods/tests/topological-sort.factor @@ -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 From 09c21f077bffeb3315d77136212d5bc97a595538 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 27 Apr 2008 23:23:51 -0500 Subject: [PATCH 3/7] add invert-comparison word --- core/kernel/kernel-docs.factor | 1 + core/math/order/order-docs.factor | 7 +++++++ core/math/order/order.factor | 3 +++ 3 files changed, 11 insertions(+) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index a3209ea42c..6862232f2d 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -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? } diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index 42a8d8123f..b761959a83 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -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 <=> } "." } diff --git a/core/math/order/order.factor b/core/math/order/order.factor index 1262d89ee0..36624f5ca9 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -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 <=> (<=>) ; From e0639d05471bfb985ebefeef2eab9ffb666b2ef8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 27 Apr 2008 23:23:59 -0500 Subject: [PATCH 4/7] fix trees for <=> a bit of refactoring to use new accessors, i hope wrunt doesn't mind --- extra/trees/trees.factor | 72 ++++++++++++++++++---------------------- 1 file changed, 32 insertions(+), 40 deletions(-) diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 89443dec8e..f0826137ea 100755 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -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,14 @@ TUPLE: node key value left right ; SYMBOL: current-side -: left -1 ; inline -: right 1 ; inline +: go-left? ( -- ? ) current-side get +lt+ eq? ; -: go-left? ( -- ? ) current-side get left = ; +: inc-count ( tree -- ) [ 1+ ] change-count drop ; -: inc-count ( tree -- ) - dup tree-count 1+ swap set-tree-count ; - -: dec-count ( tree -- ) - dup tree-count 1- swap set-tree-count ; +: 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,24 +42,21 @@ 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 -: go-left ( quot -- ) left swap with-side ; inline -: go-right ( quot -- ) right swap with-side ; inline +: with-other-side ( quot -- ) + current-side get invert-comparison swap with-side ; inline +: go-left ( quot -- ) +lt+ swap with-side ; inline +: go-right ( quot -- ) +gt+ 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 ; + [ left>> ] [ right>> ] bi or not ; -: key-side ( k1 k2 -- side ) - #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2 - <=> sgn ; - -: random-side ( -- side ) left right 2array random ; +: random-side ( -- side ) +lt+ +gt+ 2array random ; : choose-branch ( key node -- key node-left/right ) - 2dup node-key key-side [ node-link ] with-side ; + 2dup node-key <=> [ node-link ] with-side ; : node-at* ( key node -- value ? ) [ @@ -76,11 +68,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>> <=> dup +eq+ eq? [ + drop nip swap >>value ] [ [ [ node-link [ node-set ] [ swap ] if* ] keep @@ -93,12 +85,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 +99,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 +150,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 <=> dup +eq+ eq? [ drop nip delete-node ] [ [ tuck node-link delete-bst-node over set-node-link ] with-side @@ -197,7 +189,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 ; From 688202ea1fb847b4a7239e7e3623cf8566e7f3f0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 28 Apr 2008 10:11:26 -0500 Subject: [PATCH 5/7] fix bootstrap --- core/kernel/kernel-docs.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 6862232f2d..a3209ea42c 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -254,7 +254,6 @@ $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? } From 61ffc2efe6dcdb4408264e33be3f0cc010b37709 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 28 Apr 2008 10:36:41 -0500 Subject: [PATCH 6/7] better fix is a new boot image. --- core/kernel/kernel-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index a3209ea42c..6862232f2d 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -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? } From bd654f86210890f00344db6a3da2c2635c1b1a81 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 28 Apr 2008 14:42:42 -0500 Subject: [PATCH 7/7] revert some changes in trees --- extra/trees/trees.factor | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index f0826137ea..3cad81e447 100755 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -25,7 +25,17 @@ TUPLE: node key value left right ; SYMBOL: current-side -: go-left? ( -- ? ) current-side get +lt+ eq? ; +: left ( -- symbol ) -1 ; inline +: right ( -- symbol ) 1 ; inline + +: key-side ( k1 k2 -- n ) + <=> { + { +lt+ [ -1 ] } + { +eq+ [ 0 ] } + { +gt+ [ 1 ] } + } case ; + +: go-left? ( -- ? ) current-side get left eq? ; : inc-count ( tree -- ) [ 1+ ] change-count drop ; @@ -43,9 +53,9 @@ SYMBOL: current-side : with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline : with-other-side ( quot -- ) - current-side get invert-comparison swap with-side ; inline -: go-left ( quot -- ) +lt+ swap with-side ; inline -: go-right ( quot -- ) +gt+ swap with-side ; inline + 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 [ root>> swap call ] keep set-tree-root ; inline @@ -53,10 +63,10 @@ SYMBOL: current-side : leaf? ( node -- ? ) [ left>> ] [ right>> ] bi or not ; -: random-side ( -- side ) +lt+ +gt+ 2array random ; +: random-side ( -- side ) left right 2array random ; : choose-branch ( key node -- key node-left/right ) - 2dup node-key <=> [ node-link ] with-side ; + 2dup node-key key-side [ node-link ] with-side ; : node-at* ( key node -- value ? ) [ @@ -71,7 +81,7 @@ M: tree at* ( key tree -- value ? ) root>> node-at* ; : node-set ( value key node -- node ) - 2dup key>> <=> dup +eq+ eq? [ + 2dup key>> key-side dup 0 eq? [ drop nip swap >>value ] [ [ @@ -165,7 +175,7 @@ DEFER: delete-node ] if ; : delete-bst-node ( key node -- node ) - 2dup node-key <=> dup +eq+ eq? [ + 2dup node-key key-side dup 0 eq? [ drop nip delete-node ] [ [ tuck node-link delete-bst-node over set-node-link ] with-side