From 89852b22d4b1f304008801750973a810eb2f1fb8 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 16 Dec 2008 22:43:22 -0500 Subject: [PATCH 001/543] Add Project Euler solution for problem 1 from IRC --- extra/project-euler/001/001-tests.factor | 1 + extra/project-euler/001/001.factor | 9 ++++++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/extra/project-euler/001/001-tests.factor b/extra/project-euler/001/001-tests.factor index 8d2461a510..1cab275619 100644 --- a/extra/project-euler/001/001-tests.factor +++ b/extra/project-euler/001/001-tests.factor @@ -4,3 +4,4 @@ IN: project-euler.001.tests [ 233168 ] [ euler001 ] unit-test [ 233168 ] [ euler001a ] unit-test [ 233168 ] [ euler001b ] unit-test +[ 233168 ] [ euler001c ] unit-test diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 1e49be9a60..c9145c9b73 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.ranges sequences ; IN: project-euler.001 @@ -51,4 +51,11 @@ PRIVATE> ! [ euler001b ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials + +: euler001c ( -- answer ) + 1000 [ { 3 5 } [ mod 0 = ] with contains? ] filter sum ; + +! [ euler001c ] 100 ave-time +! 0 ms ave run time - 0.06 SD (100 trials) + MAIN: euler001 From adac92dfa5ad7439fc8a0c23078afcb4975e2a6b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 20 Dec 2008 18:53:17 -0500 Subject: [PATCH 002/543] Remove roll from Project Euler problem 33 solution --- extra/project-euler/033/033.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/033/033.factor b/extra/project-euler/033/033.factor index d0c79c220a..2cc114a545 100644 --- a/extra/project-euler/033/033.factor +++ b/extra/project-euler/033/033.factor @@ -33,7 +33,7 @@ IN: project-euler.033 10 99 [a,b] dup cartesian-product [ first2 < ] filter ; : safe? ( ax xb -- ? ) - [ 10 /mod ] bi@ -roll = rot zero? not and nip ; + [ 10 /mod ] bi@ [ = ] dip zero? not and nip ; : ax/xb ( ax xb -- z/f ) 2dup safe? [ [ 10 /mod ] bi@ 2nip / ] [ 2drop f ] if ; From 51530700f406f2effe8ff1f6cde953a10d7a0665 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 7 Jan 2009 18:47:32 -0500 Subject: [PATCH 003/543] Add number-length word and clean cartesian-product --- extra/project-euler/common/common.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 1a57a91e5e..49eb730632 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -56,7 +56,7 @@ PRIVATE> >lower [ CHAR: a - 1+ ] sigma ; : cartesian-product ( seq1 seq2 -- seq1xseq2 ) - swap [ swap [ 2array ] with map ] with map concat ; + [ [ 2array ] with map ] curry map concat ; : log10 ( m -- n ) log 10 log / ; @@ -74,6 +74,9 @@ PRIVATE> : number>digits ( n -- seq ) [ dup 0 = not ] [ 10 /mod ] [ ] produce reverse nip ; +: number-length ( n -- m ) + log10 floor 1+ >integer ; + : nth-triangle ( n -- n ) dup 1+ * 2 / ; From 3636a4f05fa500bfe553612047621ab7944af76e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 28 Feb 2009 16:16:09 -0600 Subject: [PATCH 004/543] chess960 buddy --- extra/chess960/chess960.factor | 43 ++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) create mode 100644 extra/chess960/chess960.factor diff --git a/extra/chess960/chess960.factor b/extra/chess960/chess960.factor new file mode 100644 index 0000000000..6535cc1925 --- /dev/null +++ b/extra/chess960/chess960.factor @@ -0,0 +1,43 @@ +USING: math.ranges kernel random sequences arrays combinators ; +IN: chess960 + +SYMBOLS: pawn rook knight bishop queen king ; + +: all-positions ( -- range ) 0 8 [a,b) ; + +: black-bishop-positions ( -- range ) 0 6 2 ; +: white-bishop-positions ( -- range ) 1 7 2 ; + +: frisk ( position positions -- position positions' ) + [ drop ] [ remove ] 2bi ; + +: white-bishop ( positions -- position positions' ) + [ white-bishop-positions random ] dip frisk ; +: black-bishop ( positions -- position positions' ) + [ black-bishop-positions random ] dip frisk ; + +: random-position ( positions -- position positions' ) + [ random ] keep frisk ; + +: make-position ( white-bishop black-bishop knight knight queen {r,k,r} -- position ) + first3 + 8 f { + [ [ rook ] 2dip set-nth ] + [ [ king ] 2dip set-nth ] + [ [ rook ] 2dip set-nth ] + [ [ queen ] 2dip set-nth ] + [ [ knight ] 2dip set-nth ] + [ [ knight ] 2dip set-nth ] + [ [ bishop ] 2dip set-nth ] + [ [ bishop ] 2dip set-nth ] + [ ] + } cleave ; + +: chess960-position ( -- position ) + all-positions + white-bishop + black-bishop + random-position + random-position + random-position + make-position ; From 4f156348d37f4e1ff13426ecb320fff71af6fe7e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 4 Mar 2009 11:44:24 -0600 Subject: [PATCH 005/543] inline quadtrees:swizzle. add axes word to math.affine-transforms to remove translation from transform --- extra/math/affine-transforms/affine-transforms.factor | 3 +++ extra/quadtrees/quadtrees.factor | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor index 822af51614..132082fdba 100644 --- a/extra/math/affine-transforms/affine-transforms.factor +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -8,6 +8,9 @@ C: affine-transform CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } } +: axes ( a -- a' ) + clone { 0.0 0.0 } >>origin ; + : a.v ( a v -- v ) [ [ x>> ] [ first ] bi* v*n ] [ [ y>> ] [ second ] bi* v*n ] diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor index d9bdbe4aeb..9ce8003736 100644 --- a/extra/quadtrees/quadtrees.factor +++ b/extra/quadtrees/quadtrees.factor @@ -195,5 +195,5 @@ M: quadtree clear-assoc ( assoc -- ) : swizzle ( sequence quot -- sequence' ) [ dup ] dip map [ zip ] [ rect-containing ] bi - [ '[ first2 _ set-at ] each ] [ values ] bi ; + [ '[ first2 _ set-at ] each ] [ values ] bi ; inline From 992d1f4d132921d4dae8fed10ddafbc276c22e2d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 4 Mar 2009 13:34:28 -0600 Subject: [PATCH 006/543] crc32 the png chunks, helper word to concatenate deflated bytes --- basis/images/png/png.factor | 47 ++++++++++++++++++++++++++++++------- 1 file changed, 39 insertions(+), 8 deletions(-) diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index 0965a13ad6..b027362977 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -2,15 +2,18 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors constructors images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.files io.files.info kernel -sequences io.streams.limited ; +sequences io.streams.limited fry combinators arrays math +checksums checksums.crc32 ; IN: images.png -TUPLE: png-image < image chunks ; +TUPLE: png-image < image chunks +width height bit-depth color-type compression-method +filter-method interlace-method uncompressed ; CONSTRUCTOR: png-image ( -- image ) V{ } clone >>chunks ; -TUPLE: png-chunk length type data crc ; +TUPLE: png-chunk length type data ; CONSTRUCTOR: png-chunk ( -- png-chunk ) ; @@ -23,19 +26,47 @@ ERROR: bad-png-header header ; bad-png-header ] unless drop ; +ERROR: bad-checksum ; + : read-png-chunks ( image -- image ) - 4 read be> >>length - 4 read ascii decode >>type - dup length>> read >>data - 4 read >>crc + 4 read be> [ >>length ] [ 4 + ] bi + read dup crc32 checksum-bytes + 4 read = [ bad-checksum ] unless + 4 cut-slice + [ ascii decode >>type ] + [ B{ } like >>data ] bi* [ over chunks>> push ] [ type>> ] bi "IEND" = [ read-png-chunks ] unless ; +: find-chunk ( image string -- chunk ) + [ chunks>> ] dip '[ type>> _ = ] find nip ; + +: parse-ihdr-chunk ( image -- image ) + dup "IHDR" find-chunk data>> { + [ [ 0 4 ] dip subseq be> >>width ] + [ [ 4 8 ] dip subseq be> >>height ] + [ [ 8 ] dip nth >>bit-depth ] + [ [ 9 ] dip nth >>color-type ] + [ [ 10 ] dip nth >>compression-method ] + [ [ 11 ] dip nth >>filter-method ] + [ [ 12 ] dip nth >>interlace-method ] + } cleave ; + +: find-compressed-bytes ( image -- bytes ) + chunks>> [ type>> "IDAT" = ] filter + [ data>> ] map concat ; + +: fill-image-data ( image -- image ) + dup [ width>> ] [ height>> ] bi 2array >>dim ; + : load-png ( path -- image ) - [ binary ] [ file-info size>> ] bi stream-throws [ + [ binary ] [ file-info size>> ] bi + stream-throws [ read-png-header read-png-chunks + parse-ihdr-chunk + fill-image-data ] with-input-stream ; From b05737f5f13453fc6a7ca548c154a6517d002d5f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 4 Mar 2009 15:04:55 -0600 Subject: [PATCH 007/543] clarify docs a bit --- basis/lists/lists-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index 8494d7c352..c03a869ebd 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -21,7 +21,7 @@ ARTICLE: { "lists" "protocol" } "The list protocol" { $subsection cdr } { $subsection nil? } ; -ARTICLE: { "lists" "strict" } "Strict lists" +ARTICLE: { "lists" "strict" } "Constructing strict lists" "Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:" { $subsection cons } { $subsection swons } From a25565e8eb874230c81f9f03345ee2f2b8cbdba8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 4 Mar 2009 16:02:21 -0600 Subject: [PATCH 008/543] move trees from unmaintained to extra --- extra/trees/authors.txt | 2 + extra/trees/avl/authors.txt | 2 + extra/trees/avl/avl-docs.factor | 27 ++++ extra/trees/avl/avl-tests.factor | 117 ++++++++++++++++ extra/trees/avl/avl.factor | 158 +++++++++++++++++++++ extra/trees/avl/summary.txt | 1 + extra/trees/avl/tags.txt | 1 + extra/trees/splay/authors.txt | 2 + extra/trees/splay/splay-docs.factor | 27 ++++ extra/trees/splay/splay-tests.factor | 33 +++++ extra/trees/splay/splay.factor | 140 +++++++++++++++++++ extra/trees/splay/summary.txt | 1 + extra/trees/splay/tags.txt | 2 + extra/trees/summary.txt | 1 + extra/trees/tags.txt | 2 + extra/trees/trees-docs.factor | 27 ++++ extra/trees/trees-tests.factor | 27 ++++ extra/trees/trees.factor | 197 +++++++++++++++++++++++++++ 18 files changed, 767 insertions(+) create mode 100644 extra/trees/authors.txt create mode 100644 extra/trees/avl/authors.txt create mode 100644 extra/trees/avl/avl-docs.factor create mode 100755 extra/trees/avl/avl-tests.factor create mode 100755 extra/trees/avl/avl.factor create mode 100644 extra/trees/avl/summary.txt create mode 100644 extra/trees/avl/tags.txt create mode 100644 extra/trees/splay/authors.txt create mode 100644 extra/trees/splay/splay-docs.factor create mode 100644 extra/trees/splay/splay-tests.factor create mode 100755 extra/trees/splay/splay.factor create mode 100644 extra/trees/splay/summary.txt create mode 100644 extra/trees/splay/tags.txt create mode 100644 extra/trees/summary.txt create mode 100644 extra/trees/tags.txt create mode 100644 extra/trees/trees-docs.factor create mode 100644 extra/trees/trees-tests.factor create mode 100755 extra/trees/trees.factor diff --git a/extra/trees/authors.txt b/extra/trees/authors.txt new file mode 100644 index 0000000000..39c1f37d37 --- /dev/null +++ b/extra/trees/authors.txt @@ -0,0 +1,2 @@ +Alex Chapman +Daniel Ehrenberg diff --git a/extra/trees/avl/authors.txt b/extra/trees/avl/authors.txt new file mode 100644 index 0000000000..39c1f37d37 --- /dev/null +++ b/extra/trees/avl/authors.txt @@ -0,0 +1,2 @@ +Alex Chapman +Daniel Ehrenberg diff --git a/extra/trees/avl/avl-docs.factor b/extra/trees/avl/avl-docs.factor new file mode 100644 index 0000000000..3b18f91293 --- /dev/null +++ b/extra/trees/avl/avl-docs.factor @@ -0,0 +1,27 @@ +USING: help.syntax help.markup assocs ; +IN: trees.avl + +HELP: AVL{ +{ $syntax "AVL{ { key value }... }" } +{ $values { "key" "a key" } { "value" "a value" } } +{ $description "Literal syntax for an AVL tree." } ; + +HELP: +{ $values { "tree" avl } } +{ $description "Creates an empty AVL tree" } ; + +HELP: >avl +{ $values { "assoc" assoc } { "avl" avl } } +{ $description "Converts any " { $link assoc } " into an AVL tree." } ; + +HELP: avl +{ $class-description "This is the class for AVL trees. These conform to the assoc protocol and have efficient (logarithmic time) storage and retrieval operations." } ; + +ARTICLE: "trees.avl" "AVL trees" +"This is a library for AVL trees, with logarithmic time storage and retrieval operations. These trees conform to the assoc protocol." +{ $subsection avl } +{ $subsection } +{ $subsection >avl } +{ $subsection POSTPONE: AVL{ } ; + +ABOUT: "trees.avl" diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor new file mode 100755 index 0000000000..f9edc9c3b8 --- /dev/null +++ b/extra/trees/avl/avl-tests.factor @@ -0,0 +1,117 @@ +USING: kernel tools.test trees trees.avl math random sequences +assocs accessors ; +IN: trees.avl.tests + +[ "key1" 0 "key2" 0 ] [ + T{ avl-node f "key1" f f T{ avl-node f "key2" f f 1 } 2 } + [ single-rotate ] go-left + [ left>> dup key>> swap balance>> ] keep + dup key>> swap balance>> +] unit-test + +[ "key1" 0 "key2" 0 ] [ + T{ avl-node f "key1" f f T{ avl-node f "key2" f f f 1 } 2 } + [ select-rotate ] go-left + [ left>> dup key>> swap balance>> ] keep + dup key>> swap balance>> +] unit-test + +[ "key1" 0 "key2" 0 ] [ + T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 } + [ single-rotate ] go-right + [ right>> dup key>> swap balance>> ] keep + dup key>> swap balance>> +] unit-test + +[ "key1" 0 "key2" 0 ] [ + T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 } + [ select-rotate ] go-right + [ right>> dup key>> swap balance>> ] keep + dup key>> swap balance>> +] unit-test + +[ "key1" -1 "key2" 0 "key3" 0 ] +[ T{ avl-node f "key1" f f + T{ avl-node f "key2" f + T{ avl-node f "key3" f f f 1 } f -1 } 2 } + [ double-rotate ] go-left + [ left>> dup key>> swap balance>> ] keep + [ right>> dup key>> swap balance>> ] keep + dup key>> swap balance>> ] unit-test +[ "key1" 0 "key2" 0 "key3" 0 ] +[ T{ avl-node f "key1" f f + T{ avl-node f "key2" f + T{ avl-node f "key3" f f f 0 } f -1 } 2 } + [ double-rotate ] go-left + [ left>> dup key>> swap balance>> ] keep + [ right>> dup key>> swap balance>> ] keep + dup key>> swap balance>> ] unit-test +[ "key1" 0 "key2" 1 "key3" 0 ] +[ T{ avl-node f "key1" f f + T{ avl-node f "key2" f + T{ avl-node f "key3" f f f -1 } f -1 } 2 } + [ double-rotate ] go-left + [ left>> dup key>> swap balance>> ] keep + [ right>> dup key>> swap balance>> ] keep + dup key>> swap balance>> ] unit-test + +[ "key1" 1 "key2" 0 "key3" 0 ] +[ T{ avl-node f "key1" f + T{ avl-node f "key2" f f + T{ avl-node f "key3" f f f -1 } 1 } f -2 } + [ double-rotate ] go-right + [ right>> dup key>> swap balance>> ] keep + [ left>> dup key>> swap balance>> ] keep + dup key>> swap balance>> ] unit-test +[ "key1" 0 "key2" 0 "key3" 0 ] +[ T{ avl-node f "key1" f + T{ avl-node f "key2" f f + T{ avl-node f "key3" f f f 0 } 1 } f -2 } + [ double-rotate ] go-right + [ right>> dup key>> swap balance>> ] keep + [ left>> dup key>> swap balance>> ] keep + dup key>> swap balance>> ] unit-test +[ "key1" 0 "key2" -1 "key3" 0 ] +[ T{ avl-node f "key1" f + T{ avl-node f "key2" f f + T{ avl-node f "key3" f f f 1 } 1 } f -2 } + [ double-rotate ] go-right + [ right>> dup key>> swap balance>> ] keep + [ left>> dup key>> swap balance>> ] keep + dup key>> swap balance>> ] unit-test + +[ "eight" ] [ + "seven" 7 pick set-at + "eight" 8 pick set-at "nine" 9 pick set-at + root>> value>> +] unit-test + +[ "another eight" ] [ ! ERROR! + "seven" 7 pick set-at + "another eight" 8 pick set-at 8 swap at +] unit-test + +: test-tree ( -- tree ) + AVL{ + { 7 "seven" } + { 9 "nine" } + { 4 "four" } + { 4 "replaced four" } + { 7 "replaced seven" } + } clone ; + +! test set-at, at, at* +[ t ] [ test-tree avl? ] unit-test +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test +[ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "replacement" ] [ "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test +[ "nine" ] [ test-tree 9 swap at ] unit-test +[ "replaced four" ] [ test-tree 4 swap at ] unit-test +[ "replaced seven" ] [ test-tree 7 swap at ] unit-test + +! test delete-at--all errors! +[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test +[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test +[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor new file mode 100755 index 0000000000..c37448fc1f --- /dev/null +++ b/extra/trees/avl/avl.factor @@ -0,0 +1,158 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: combinators kernel generic math math.functions +math.parser namespaces io prettyprint.backend sequences trees +assocs parser accessors math.order ; +IN: trees.avl + +TUPLE: avl < tree ; + +: ( -- tree ) + avl new-tree ; + +TUPLE: avl-node < node balance ; + +: ( key value -- node ) + avl-node new-node + 0 >>balance ; + +: increase-balance ( node amount -- ) + swap [ + ] change-balance drop ; + +: rotate ( node -- node ) + dup node+link dup node-link pick set-node+link + tuck set-node-link ; + +: single-rotate ( node -- node ) + 0 over (>>balance) 0 over node+link + (>>balance) rotate ; + +: pick-balances ( a node -- balance balance ) + balance>> { + { [ dup zero? ] [ 2drop 0 0 ] } + { [ over = ] [ neg 0 ] } + [ 0 swap ] + } cond ; + +: double-rotate ( node -- node ) + [ + node+link [ + node-link current-side get neg + over pick-balances rot 0 swap (>>balance) + ] keep (>>balance) + ] keep swap >>balance + dup node+link [ rotate ] with-other-side + over set-node+link rotate ; + +: select-rotate ( node -- node ) + dup node+link balance>> current-side get = + [ double-rotate ] [ single-rotate ] if ; + +: balance-insert ( node -- node taller? ) + dup balance>> { + { [ dup zero? ] [ drop f ] } + { [ dup abs 2 = ] + [ sgn neg [ select-rotate ] with-side f ] } + { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller + } cond ; + +DEFER: avl-set + +: avl-insert ( value key node -- node taller? ) + 2dup key>> before? left right ? [ + [ node-link avl-set ] keep swap + [ tuck set-node-link ] dip + [ dup current-side get increase-balance balance-insert ] + [ f ] if + ] with-side ; + +: (avl-set) ( value key node -- node taller? ) + 2dup key>> = [ + -rot pick (>>key) over (>>value) f + ] [ avl-insert ] if ; + +: avl-set ( value key node -- node taller? ) + [ (avl-set) ] [ swap t ] if* ; + +M: avl set-at ( value key node -- node ) + [ avl-set drop ] change-root drop ; + +: delete-select-rotate ( node -- node shorter? ) + dup node+link balance>> zero? [ + current-side get neg over (>>balance) + current-side get over node+link (>>balance) rotate f + ] [ + select-rotate t + ] if ; + +: rebalance-delete ( node -- node shorter? ) + dup balance>> { + { [ dup zero? ] [ drop t ] } + { [ dup abs 2 = ] [ sgn neg [ delete-select-rotate ] with-side ] } + { [ drop t ] [ f ] } ! balance is -1 or 1, tree is not shorter + } cond ; + +: balance-delete ( node -- node shorter? ) + current-side get over balance>> { + { [ dup zero? ] [ drop neg over (>>balance) f ] } + { [ dupd = ] [ drop 0 >>balance t ] } + [ dupd neg increase-balance rebalance-delete ] + } cond ; + +: avl-replace-with-extremity ( to-replace node -- node shorter? ) + dup node-link [ + swapd avl-replace-with-extremity [ over set-node-link ] dip + [ balance-delete ] [ f ] if + ] [ + [ copy-node-contents drop ] keep node+link t + ] if* ; + +: replace-with-a-child ( node -- node shorter? ) + #! assumes that node is not a leaf, otherwise will recurse forever + dup node-link [ + dupd [ avl-replace-with-extremity ] with-other-side + [ over set-node-link ] dip [ balance-delete ] [ f ] if + ] [ + [ replace-with-a-child ] with-other-side + ] if* ; + +: avl-delete-node ( node -- node shorter? ) + #! delete this node, returning its replacement, and whether this subtree is + #! shorter as a result + dup leaf? [ + drop f t + ] [ + left [ replace-with-a-child ] with-side + ] if ; + +GENERIC: avl-delete ( key node -- node shorter? deleted? ) + +M: f avl-delete ( key f -- f f f ) nip f f ; + +: (avl-delete) ( key node -- node shorter? deleted? ) + tuck node-link avl-delete [ + [ over set-node-link ] dip [ balance-delete ] [ f ] if + ] dip ; + +M: avl-node avl-delete ( key node -- node shorter? deleted? ) + 2dup key>> key-side dup zero? [ + drop nip avl-delete-node t + ] [ + [ (avl-delete) ] with-side + ] if ; + +M: avl delete-at ( key node -- ) + [ avl-delete 2drop ] change-root drop ; + +M: avl new-assoc 2drop ; + +: >avl ( assoc -- avl ) + T{ avl f f 0 } assoc-clone-like ; + +M: avl assoc-like + drop dup avl? [ >avl ] unless ; + +: AVL{ + \ } [ >avl ] parse-literal ; parsing + +! M: avl pprint-delims drop \ AVL{ \ } ; diff --git a/extra/trees/avl/summary.txt b/extra/trees/avl/summary.txt new file mode 100644 index 0000000000..c2360c2ed3 --- /dev/null +++ b/extra/trees/avl/summary.txt @@ -0,0 +1 @@ +Balanced AVL trees diff --git a/extra/trees/avl/tags.txt b/extra/trees/avl/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/trees/avl/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/trees/splay/authors.txt b/extra/trees/splay/authors.txt new file mode 100644 index 0000000000..06a7cfb215 --- /dev/null +++ b/extra/trees/splay/authors.txt @@ -0,0 +1,2 @@ +Mackenzie Straight +Daniel Ehrenberg diff --git a/extra/trees/splay/splay-docs.factor b/extra/trees/splay/splay-docs.factor new file mode 100644 index 0000000000..e1b447c339 --- /dev/null +++ b/extra/trees/splay/splay-docs.factor @@ -0,0 +1,27 @@ +USING: help.syntax help.markup assocs ; +IN: trees.splay + +HELP: SPLAY{ +{ $syntax "SPLAY{ { key value }... }" } +{ $values { "key" "a key" } { "value" "a value" } } +{ $description "Literal syntax for an splay tree." } ; + +HELP: +{ $values { "tree" splay } } +{ $description "Creates an empty splay tree" } ; + +HELP: >splay +{ $values { "assoc" assoc } { "tree" splay } } +{ $description "Converts any " { $link assoc } " into an splay tree." } ; + +HELP: splay +{ $class-description "This is the class for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These conform to the assoc protocol." } ; + +ARTICLE: "trees.splay" "Splay trees" +"This is a library for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These trees conform to the assoc protocol." +{ $subsection splay } +{ $subsection } +{ $subsection >splay } +{ $subsection POSTPONE: SPLAY{ } ; + +ABOUT: "trees.splay" diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor new file mode 100644 index 0000000000..c07357fbdf --- /dev/null +++ b/extra/trees/splay/splay-tests.factor @@ -0,0 +1,33 @@ +! Copyright (c) 2005 Mackenzie Straight. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel tools.test trees.splay math namespaces assocs +sequences random sets make grouping ; +IN: trees.splay.tests + +: randomize-numeric-splay-tree ( splay-tree -- ) + 100 [ drop 100 random swap at drop ] with each ; + +: make-numeric-splay-tree ( n -- splay-tree ) + [ [ conjoin ] curry each ] keep ; + +[ t ] [ + 100 make-numeric-splay-tree dup randomize-numeric-splay-tree + [ [ drop , ] assoc-each ] { } make [ < ] monotonic? +] unit-test + +[ 10 ] [ 10 make-numeric-splay-tree keys length ] unit-test +[ 10 ] [ 10 make-numeric-splay-tree values length ] unit-test + +[ f ] [ f 4 pick set-at 4 swap at ] unit-test + +! Ensure that f can be a value +[ t ] [ f 4 pick set-at 4 swap key? ] unit-test + +[ +{ { 1 "a" } { 2 "b" } { 3 "c" } { 4 "d" } { 5 "e" } { 6 "f" } } +] [ +{ + { 4 "d" } { 5 "e" } { 6 "f" } + { 1 "a" } { 2 "b" } { 3 "c" } +} >splay >alist +] unit-test diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor new file mode 100755 index 0000000000..adcf0a2522 --- /dev/null +++ b/extra/trees/splay/splay.factor @@ -0,0 +1,140 @@ +! Copyright (c) 2005 Mackenzie Straight. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel math namespaces sequences assocs parser +prettyprint.backend trees generic math.order accessors ; +IN: trees.splay + +TUPLE: splay < tree ; + +: ( -- tree ) + \ splay new-tree ; + +: rotate-right ( node -- node ) + dup left>> + [ right>> swap (>>left) ] 2keep + [ (>>right) ] keep ; + +: rotate-left ( node -- node ) + dup right>> + [ left>> swap (>>right) ] 2keep + [ (>>left) ] keep ; + +: link-right ( left right key node -- left right key node ) + swap [ [ swap (>>left) ] 2keep + nip dup left>> ] dip swap ; + +: link-left ( left right key node -- left right key node ) + swap [ rot [ (>>right) ] 2keep + drop dup right>> swapd ] dip swap ; + +: cmp ( key node -- obj node -1/0/1 ) + 2dup key>> key-side ; + +: lcmp ( key node -- obj node -1/0/1 ) + 2dup left>> key>> key-side ; + +: rcmp ( key node -- obj node -1/0/1 ) + 2dup right>> key>> key-side ; + +DEFER: (splay) + +: splay-left ( left right key node -- left right key node ) + dup left>> [ + lcmp 0 < [ rotate-right ] when + dup left>> [ link-right (splay) ] when + ] when ; + +: splay-right ( left right key node -- left right key node ) + dup right>> [ + rcmp 0 > [ rotate-left ] when + dup right>> [ link-left (splay) ] when + ] when ; + +: (splay) ( left right key node -- left right key node ) + cmp dup 0 < + [ drop splay-left ] [ 0 > [ splay-right ] when ] if ; + +: assemble ( head left right node -- root ) + [ right>> swap (>>left) ] keep + [ left>> swap (>>right) ] keep + [ swap left>> swap (>>right) ] 2keep + [ swap right>> swap (>>left) ] keep ; + +: splay-at ( key node -- node ) + [ T{ node } clone dup dup ] 2dip + (splay) nip assemble ; + +: splay ( key tree -- ) + [ root>> splay-at ] keep (>>root) ; + +: splay-split ( key tree -- node node ) + 2dup splay root>> cmp 0 < [ + nip dup left>> swap f over (>>left) + ] [ + nip dup right>> swap f over (>>right) swap + ] if ; + +: get-splay ( key tree -- node ? ) + 2dup splay root>> cmp 0 = [ + nip t + ] [ + 2drop f f + ] if ; + +: get-largest ( node -- node ) + dup [ dup right>> [ nip get-largest ] when* ] when ; + +: splay-largest ( node -- node ) + dup [ dup get-largest key>> swap splay-at ] when ; + +: splay-join ( n2 n1 -- node ) + splay-largest [ + [ (>>right) ] keep + ] [ + drop f + ] if* ; + +: remove-splay ( key tree -- ) + tuck get-splay nip [ + dup dec-count + dup right>> swap left>> splay-join + swap (>>root) + ] [ drop ] if* ; + +: set-splay ( value key tree -- ) + 2dup get-splay [ 2nip (>>value) ] [ + drop dup inc-count + 2dup splay-split rot + [ [ swapd ] dip node boa ] dip (>>root) + ] if ; + +: new-root ( value key tree -- ) + 1 >>count + [ swap ] dip (>>root) ; + +M: splay set-at ( value key tree -- ) + dup root>> [ set-splay ] [ new-root ] if ; + +M: splay at* ( key tree -- value ? ) + dup root>> [ + get-splay [ dup [ value>> ] when ] dip + ] [ + 2drop f f + ] if ; + +M: splay delete-at ( key tree -- ) + dup root>> [ remove-splay ] [ 2drop ] if ; + +M: splay new-assoc + 2drop ; + +: >splay ( assoc -- tree ) + T{ splay f f 0 } assoc-clone-like ; + +: SPLAY{ + \ } [ >splay ] parse-literal ; parsing + +M: splay assoc-like + drop dup splay? [ >splay ] unless ; + +! M: splay pprint-delims drop \ SPLAY{ \ } ; diff --git a/extra/trees/splay/summary.txt b/extra/trees/splay/summary.txt new file mode 100644 index 0000000000..46391bbd28 --- /dev/null +++ b/extra/trees/splay/summary.txt @@ -0,0 +1 @@ +Splay trees diff --git a/extra/trees/splay/tags.txt b/extra/trees/splay/tags.txt new file mode 100644 index 0000000000..fb6cea7147 --- /dev/null +++ b/extra/trees/splay/tags.txt @@ -0,0 +1,2 @@ +collections +trees diff --git a/extra/trees/summary.txt b/extra/trees/summary.txt new file mode 100644 index 0000000000..18ad35db8f --- /dev/null +++ b/extra/trees/summary.txt @@ -0,0 +1 @@ +Binary search trees diff --git a/extra/trees/tags.txt b/extra/trees/tags.txt new file mode 100644 index 0000000000..fb6cea7147 --- /dev/null +++ b/extra/trees/tags.txt @@ -0,0 +1,2 @@ +collections +trees diff --git a/extra/trees/trees-docs.factor b/extra/trees/trees-docs.factor new file mode 100644 index 0000000000..24af961a0b --- /dev/null +++ b/extra/trees/trees-docs.factor @@ -0,0 +1,27 @@ +USING: help.syntax help.markup assocs ; +IN: trees + +HELP: TREE{ +{ $syntax "TREE{ { key value }... }" } +{ $values { "key" "a key" } { "value" "a value" } } +{ $description "Literal syntax for an unbalanced tree." } ; + +HELP: +{ $values { "tree" tree } } +{ $description "Creates an empty unbalanced binary tree" } ; + +HELP: >tree +{ $values { "assoc" assoc } { "tree" tree } } +{ $description "Converts any " { $link assoc } " into an unbalanced binary tree." } ; + +HELP: tree +{ $class-description "This is the class for unbalanced binary search trees. It is not usually intended to be used directly but rather as a basis for other trees." } ; + +ARTICLE: "trees" "Binary search trees" +"This is a library for unbalanced binary search trees. It is not intended to be used directly in most situations but rather as a base class for new trees, because performance can degrade to linear time storage/retrieval by the number of keys. These binary search trees conform to the assoc protocol." +{ $subsection tree } +{ $subsection } +{ $subsection >tree } +{ $subsection POSTPONE: TREE{ } ; + +ABOUT: "trees" diff --git a/extra/trees/trees-tests.factor b/extra/trees/trees-tests.factor new file mode 100644 index 0000000000..99d3734b3e --- /dev/null +++ b/extra/trees/trees-tests.factor @@ -0,0 +1,27 @@ +USING: trees assocs tools.test kernel sequences ; +IN: trees.tests + +: test-tree ( -- tree ) + TREE{ + { 7 "seven" } + { 9 "nine" } + { 4 "four" } + { 4 "replaced four" } + { 7 "replaced seven" } + } clone ; + +! test set-at, at, at* +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test +[ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test +[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test +[ "replacement" ] [ "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test +[ "replaced four" ] [ test-tree 4 swap at ] unit-test +[ "nine" ] [ test-tree 9 swap at ] unit-test + +! test delete-at +[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test +[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test +[ "replaced four" ] [ test-tree 9 over delete-at 4 swap at ] unit-test +[ "nine" "replaced four" ] [ test-tree 7 over delete-at 9 over at 4 rot at ] unit-test +[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor new file mode 100755 index 0000000000..892b3b3944 --- /dev/null +++ b/extra/trees/trees.factor @@ -0,0 +1,197 @@ +! Copyright (C) 2007 Alex Chapman +! 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 accessors deques make +prettyprint.custom ; +IN: trees + +TUPLE: tree root count ; + +: new-tree ( class -- tree ) + new + f >>root + 0 >>count ; inline + +: ( -- tree ) + tree new-tree ; + +INSTANCE: tree assoc + +TUPLE: node key value left right ; + +: new-node ( key value class -- node ) + new swap >>value swap >>key ; + +: ( key value -- node ) + node new-node ; + +SYMBOL: current-side + +: 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 ; + +: dec-count ( tree -- ) [ 1- ] change-count drop ; + +: node-link@ ( node ? -- node ) + go-left? xor [ left>> ] [ right>> ] if ; +: set-node-link@ ( left parent ? -- ) + go-left? xor [ (>>left) ] [ (>>right) ] if ; + +: node-link ( node -- child ) f node-link@ ; +: set-node-link ( child node -- ) f set-node-link@ ; +: node+link ( node -- child ) t node-link@ ; +: 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 + +: leaf? ( node -- ? ) + [ left>> ] [ right>> ] bi or not ; + +: random-side ( -- side ) left right 2array random ; + +: choose-branch ( key node -- key node-left/right ) + 2dup key>> key-side [ node-link ] with-side ; + +: node-at* ( key node -- value ? ) + [ + 2dup key>> = [ + nip value>> t + ] [ + choose-branch node-at* + ] if + ] [ drop f f ] if* ; + +M: tree at* ( key tree -- value ? ) + root>> node-at* ; + +: node-set ( value key node -- node ) + 2dup key>> key-side dup 0 eq? [ + drop nip swap >>value + ] [ + [ + [ node-link [ node-set ] [ swap ] if* ] keep + [ set-node-link ] keep + ] with-side + ] if ; + +M: tree set-at ( value key tree -- ) + [ [ node-set ] [ swap ] if* ] change-root drop ; + +: valid-node? ( node -- ? ) + [ + dup dup left>> [ key>> swap key>> before? ] when* + [ + dup dup right>> [ key>> swap key>> after? ] when* ] dip and swap + dup left>> valid-node? swap right>> valid-node? and and + ] [ t ] if* ; + +: valid-tree? ( tree -- ? ) root>> valid-node? ; + +: (node>alist) ( node -- ) + [ + [ left>> (node>alist) ] + [ [ key>> ] [ value>> ] bi 2array , ] + [ right>> (node>alist) ] + tri + ] when* ; + +M: tree >alist [ root>> (node>alist) ] { } make ; + +M: tree clear-assoc + 0 >>count + f >>root drop ; + +: copy-node-contents ( new old -- new ) + [ key>> >>key ] + [ value>> >>value ] bi ; + +! Deletion +DEFER: delete-node + +: (prune-extremity) ( parent node -- new-extremity ) + dup node-link [ + rot drop (prune-extremity) + ] [ + tuck delete-node swap set-node-link + ] if* ; + +: prune-extremity ( node -- new-extremity ) + #! remove and return the leftmost or rightmost child of this node. + #! assumes at least one child + dup node-link (prune-extremity) ; + +: replace-with-child ( node -- node ) + dup node-link copy-node-contents dup node-link delete-node over set-node-link ; + +: replace-with-extremity ( node -- node ) + dup node-link dup node+link [ + ! predecessor/successor is not the immediate child + [ prune-extremity ] with-other-side copy-node-contents + ] [ + ! node-link is the predecessor/successor + drop replace-with-child + ] if ; + +: delete-node-with-two-children ( node -- node ) + #! randomised to minimise tree unbalancing + random-side [ replace-with-extremity ] with-side ; + +: delete-node ( node -- node ) + #! delete this node, returning its replacement + dup left>> [ + dup right>> [ + delete-node-with-two-children + ] [ + left>> ! left but no right + ] if + ] [ + dup right>> [ + right>> ! right but not left + ] [ + drop f ! no children + ] if + ] if ; + +: delete-bst-node ( key node -- node ) + 2dup key>> key-side dup 0 eq? [ + drop nip delete-node + ] [ + [ tuck node-link delete-bst-node over set-node-link ] with-side + ] if ; + +M: tree delete-at + [ delete-bst-node ] change-root drop ; + +M: tree new-assoc + 2drop ; + +M: tree clone dup assoc-clone-like ; + +: >tree ( assoc -- tree ) + T{ tree f f 0 } assoc-clone-like ; + +M: tree assoc-like drop dup tree? [ >tree ] unless ; + +: TREE{ + \ } [ >tree ] parse-literal ; parsing + +M: tree assoc-size count>> ; +! M: tree pprint-delims drop \ TREE{ \ } ; +! M: tree >pprint-sequence >alist ; +! M: tree pprint-narrow? drop t ; From 33a1a269f529e036e6058653ba590e4964d1d638 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 4 Mar 2009 16:02:40 -0600 Subject: [PATCH 009/543] delete unmaintained trees --- unmaintained/trees/authors.txt | 2 - unmaintained/trees/avl/authors.txt | 2 - unmaintained/trees/avl/avl-docs.factor | 27 --- unmaintained/trees/avl/avl-tests.factor | 116 ------------ unmaintained/trees/avl/avl.factor | 157 ---------------- unmaintained/trees/avl/summary.txt | 1 - unmaintained/trees/avl/tags.txt | 1 - unmaintained/trees/splay/authors.txt | 2 - unmaintained/trees/splay/splay-docs.factor | 27 --- unmaintained/trees/splay/splay-tests.factor | 33 ---- unmaintained/trees/splay/splay.factor | 140 -------------- unmaintained/trees/splay/summary.txt | 1 - unmaintained/trees/splay/tags.txt | 2 - unmaintained/trees/summary.txt | 1 - unmaintained/trees/tags.txt | 2 - unmaintained/trees/trees-docs.factor | 28 --- unmaintained/trees/trees-tests.factor | 28 --- unmaintained/trees/trees.factor | 194 -------------------- 18 files changed, 764 deletions(-) delete mode 100644 unmaintained/trees/authors.txt delete mode 100644 unmaintained/trees/avl/authors.txt delete mode 100644 unmaintained/trees/avl/avl-docs.factor delete mode 100755 unmaintained/trees/avl/avl-tests.factor delete mode 100755 unmaintained/trees/avl/avl.factor delete mode 100644 unmaintained/trees/avl/summary.txt delete mode 100644 unmaintained/trees/avl/tags.txt delete mode 100644 unmaintained/trees/splay/authors.txt delete mode 100644 unmaintained/trees/splay/splay-docs.factor delete mode 100644 unmaintained/trees/splay/splay-tests.factor delete mode 100755 unmaintained/trees/splay/splay.factor delete mode 100644 unmaintained/trees/splay/summary.txt delete mode 100644 unmaintained/trees/splay/tags.txt delete mode 100644 unmaintained/trees/summary.txt delete mode 100644 unmaintained/trees/tags.txt delete mode 100644 unmaintained/trees/trees-docs.factor delete mode 100644 unmaintained/trees/trees-tests.factor delete mode 100755 unmaintained/trees/trees.factor diff --git a/unmaintained/trees/authors.txt b/unmaintained/trees/authors.txt deleted file mode 100644 index 39c1f37d37..0000000000 --- a/unmaintained/trees/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Alex Chapman -Daniel Ehrenberg diff --git a/unmaintained/trees/avl/authors.txt b/unmaintained/trees/avl/authors.txt deleted file mode 100644 index 39c1f37d37..0000000000 --- a/unmaintained/trees/avl/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Alex Chapman -Daniel Ehrenberg diff --git a/unmaintained/trees/avl/avl-docs.factor b/unmaintained/trees/avl/avl-docs.factor deleted file mode 100644 index 46f647470a..0000000000 --- a/unmaintained/trees/avl/avl-docs.factor +++ /dev/null @@ -1,27 +0,0 @@ -USING: help.syntax help.markup assocs ; -IN: trees.avl - -HELP: AVL{ -{ $syntax "AVL{ { key value }... }" } -{ $values { "key" "a key" } { "value" "a value" } } -{ $description "Literal syntax for an AVL tree." } ; - -HELP: -{ $values { "tree" avl } } -{ $description "Creates an empty AVL tree" } ; - -HELP: >avl -{ $values { "assoc" assoc } { "avl" avl } } -{ $description "Converts any " { $link assoc } " into an AVL tree." } ; - -HELP: avl -{ $class-description "This is the class for AVL trees. These conform to the assoc protocol and have efficient (logarithmic time) storage and retrieval operations." } ; - -ARTICLE: { "avl" "intro" } "AVL trees" -"This is a library for AVL trees, with logarithmic time storage and retrieval operations. These trees conform to the assoc protocol." -{ $subsection avl } -{ $subsection } -{ $subsection >avl } -{ $subsection POSTPONE: AVL{ } ; - -ABOUT: { "avl" "intro" } diff --git a/unmaintained/trees/avl/avl-tests.factor b/unmaintained/trees/avl/avl-tests.factor deleted file mode 100755 index 5cb6606ce4..0000000000 --- a/unmaintained/trees/avl/avl-tests.factor +++ /dev/null @@ -1,116 +0,0 @@ -USING: kernel tools.test trees trees.avl math random sequences assocs ; -IN: trees.avl.tests - -[ "key1" 0 "key2" 0 ] [ - T{ avl-node f "key1" f f T{ avl-node f "key2" f f 1 } 2 } - [ single-rotate ] go-left - [ node-left dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance -] unit-test - -[ "key1" 0 "key2" 0 ] [ - T{ avl-node f "key1" f f T{ avl-node f "key2" f f f 1 } 2 } - [ select-rotate ] go-left - [ node-left dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance -] unit-test - -[ "key1" 0 "key2" 0 ] [ - T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 } - [ single-rotate ] go-right - [ node-right dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance -] unit-test - -[ "key1" 0 "key2" 0 ] [ - T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 } - [ select-rotate ] go-right - [ node-right dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance -] unit-test - -[ "key1" -1 "key2" 0 "key3" 0 ] -[ T{ avl-node f "key1" f f - T{ avl-node f "key2" f - T{ avl-node f "key3" f f f 1 } f -1 } 2 } - [ double-rotate ] go-left - [ node-left dup node-key swap avl-node-balance ] keep - [ node-right dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" 0 "key3" 0 ] -[ T{ avl-node f "key1" f f - T{ avl-node f "key2" f - T{ avl-node f "key3" f f f 0 } f -1 } 2 } - [ double-rotate ] go-left - [ node-left dup node-key swap avl-node-balance ] keep - [ node-right dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" 1 "key3" 0 ] -[ T{ avl-node f "key1" f f - T{ avl-node f "key2" f - T{ avl-node f "key3" f f f -1 } f -1 } 2 } - [ double-rotate ] go-left - [ node-left dup node-key swap avl-node-balance ] keep - [ node-right dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test - -[ "key1" 1 "key2" 0 "key3" 0 ] -[ T{ avl-node f "key1" f - T{ avl-node f "key2" f f - T{ avl-node f "key3" f f f -1 } 1 } f -2 } - [ double-rotate ] go-right - [ node-right dup node-key swap avl-node-balance ] keep - [ node-left dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" 0 "key3" 0 ] -[ T{ avl-node f "key1" f - T{ avl-node f "key2" f f - T{ avl-node f "key3" f f f 0 } 1 } f -2 } - [ double-rotate ] go-right - [ node-right dup node-key swap avl-node-balance ] keep - [ node-left dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test -[ "key1" 0 "key2" -1 "key3" 0 ] -[ T{ avl-node f "key1" f - T{ avl-node f "key2" f f - T{ avl-node f "key3" f f f 1 } 1 } f -2 } - [ double-rotate ] go-right - [ node-right dup node-key swap avl-node-balance ] keep - [ node-left dup node-key swap avl-node-balance ] keep - dup node-key swap avl-node-balance ] unit-test - -[ "eight" ] [ - "seven" 7 pick set-at - "eight" 8 pick set-at "nine" 9 pick set-at - tree-root node-value -] unit-test - -[ "another eight" ] [ ! ERROR! - "seven" 7 pick set-at - "another eight" 8 pick set-at 8 swap at -] unit-test - -: test-tree ( -- tree ) - AVL{ - { 7 "seven" } - { 9 "nine" } - { 4 "four" } - { 4 "replaced four" } - { 7 "replaced seven" } - } clone ; - -! test set-at, at, at* -[ t ] [ test-tree avl? ] unit-test -[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test -[ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test -[ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test -[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test -[ "replacement" ] [ "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test -[ "nine" ] [ test-tree 9 swap at ] unit-test -[ "replaced four" ] [ test-tree 4 swap at ] unit-test -[ "replaced seven" ] [ test-tree 7 swap at ] unit-test - -! test delete-at--all errors! -[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test -[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test -[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test diff --git a/unmaintained/trees/avl/avl.factor b/unmaintained/trees/avl/avl.factor deleted file mode 100755 index 866e035a21..0000000000 --- a/unmaintained/trees/avl/avl.factor +++ /dev/null @@ -1,157 +0,0 @@ -! Copyright (C) 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel generic math math.functions -math.parser namespaces io prettyprint.backend sequences trees -assocs parser accessors math.order ; -IN: trees.avl - -TUPLE: avl < tree ; - -: ( -- tree ) - avl new-tree ; - -TUPLE: avl-node < node balance ; - -: ( key value -- node ) - avl-node new-node - 0 >>balance ; - -: increase-balance ( node amount -- ) - swap [ + ] change-balance drop ; - -: rotate ( node -- node ) - dup node+link dup node-link pick set-node+link - tuck set-node-link ; - -: single-rotate ( node -- node ) - 0 over (>>balance) 0 over node+link - (>>balance) rotate ; - -: pick-balances ( a node -- balance balance ) - balance>> { - { [ dup zero? ] [ 2drop 0 0 ] } - { [ over = ] [ neg 0 ] } - [ 0 swap ] - } cond ; - -: double-rotate ( node -- node ) - [ - node+link [ - node-link current-side get neg - over pick-balances rot 0 swap (>>balance) - ] keep (>>balance) - ] keep swap >>balance - dup node+link [ rotate ] with-other-side - over set-node+link rotate ; - -: select-rotate ( node -- node ) - dup node+link balance>> current-side get = - [ double-rotate ] [ single-rotate ] if ; - -: balance-insert ( node -- node taller? ) - dup avl-node-balance { - { [ dup zero? ] [ drop f ] } - { [ dup abs 2 = ] - [ sgn neg [ select-rotate ] with-side f ] } - { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller - } cond ; - -DEFER: avl-set - -: avl-insert ( value key node -- node taller? ) - 2dup node-key before? left right ? [ - [ node-link avl-set ] keep swap - >r tuck set-node-link r> - [ dup current-side get increase-balance balance-insert ] - [ f ] if - ] with-side ; - -: (avl-set) ( value key node -- node taller? ) - 2dup node-key = [ - -rot pick set-node-key over set-node-value f - ] [ avl-insert ] if ; - -: avl-set ( value key node -- node taller? ) - [ (avl-set) ] [ swap t ] if* ; - -M: avl set-at ( value key node -- node ) - [ avl-set drop ] change-root drop ; - -: delete-select-rotate ( node -- node shorter? ) - dup node+link avl-node-balance zero? [ - current-side get neg over set-avl-node-balance - current-side get over node+link set-avl-node-balance rotate f - ] [ - select-rotate t - ] if ; - -: rebalance-delete ( node -- node shorter? ) - dup avl-node-balance { - { [ dup zero? ] [ drop t ] } - { [ dup abs 2 = ] [ sgn neg [ delete-select-rotate ] with-side ] } - { [ drop t ] [ f ] } ! balance is -1 or 1, tree is not shorter - } cond ; - -: balance-delete ( node -- node shorter? ) - current-side get over balance>> { - { [ dup zero? ] [ drop neg over set-avl-node-balance f ] } - { [ dupd = ] [ drop 0 >>balance t ] } - [ dupd neg increase-balance rebalance-delete ] - } cond ; - -: avl-replace-with-extremity ( to-replace node -- node shorter? ) - dup node-link [ - swapd avl-replace-with-extremity >r over set-node-link r> - [ balance-delete ] [ f ] if - ] [ - tuck copy-node-contents node+link t - ] if* ; - -: replace-with-a-child ( node -- node shorter? ) - #! assumes that node is not a leaf, otherwise will recurse forever - dup node-link [ - dupd [ avl-replace-with-extremity ] with-other-side - >r over set-node-link r> [ balance-delete ] [ f ] if - ] [ - [ replace-with-a-child ] with-other-side - ] if* ; - -: avl-delete-node ( node -- node shorter? ) - #! delete this node, returning its replacement, and whether this subtree is - #! shorter as a result - dup leaf? [ - drop f t - ] [ - left [ replace-with-a-child ] with-side - ] if ; - -GENERIC: avl-delete ( key node -- node shorter? deleted? ) - -M: f avl-delete ( key f -- f f f ) nip f f ; - -: (avl-delete) ( key node -- node shorter? deleted? ) - tuck node-link avl-delete >r >r over set-node-link r> - [ balance-delete r> ] [ f r> ] if ; - -M: avl-node avl-delete ( key node -- node shorter? deleted? ) - 2dup node-key key-side dup zero? [ - drop nip avl-delete-node t - ] [ - [ (avl-delete) ] with-side - ] if ; - -M: avl delete-at ( key node -- ) - [ avl-delete 2drop ] change-root drop ; - -M: avl new-assoc 2drop ; - -: >avl ( assoc -- avl ) - T{ avl f f 0 } assoc-clone-like ; - -M: avl assoc-like - drop dup avl? [ >avl ] unless ; - -: AVL{ - \ } [ >avl ] parse-literal ; parsing - -M: avl pprint-delims drop \ AVL{ \ } ; diff --git a/unmaintained/trees/avl/summary.txt b/unmaintained/trees/avl/summary.txt deleted file mode 100644 index c2360c2ed3..0000000000 --- a/unmaintained/trees/avl/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Balanced AVL trees diff --git a/unmaintained/trees/avl/tags.txt b/unmaintained/trees/avl/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/unmaintained/trees/avl/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/unmaintained/trees/splay/authors.txt b/unmaintained/trees/splay/authors.txt deleted file mode 100644 index 06a7cfb215..0000000000 --- a/unmaintained/trees/splay/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Mackenzie Straight -Daniel Ehrenberg diff --git a/unmaintained/trees/splay/splay-docs.factor b/unmaintained/trees/splay/splay-docs.factor deleted file mode 100644 index 253d3f4aec..0000000000 --- a/unmaintained/trees/splay/splay-docs.factor +++ /dev/null @@ -1,27 +0,0 @@ -USING: help.syntax help.markup assocs ; -IN: trees.splay - -HELP: SPLAY{ -{ $syntax "SPLAY{ { key value }... }" } -{ $values { "key" "a key" } { "value" "a value" } } -{ $description "Literal syntax for an splay tree." } ; - -HELP: -{ $values { "tree" splay } } -{ $description "Creates an empty splay tree" } ; - -HELP: >splay -{ $values { "assoc" assoc } { "tree" splay } } -{ $description "Converts any " { $link assoc } " into an splay tree." } ; - -HELP: splay -{ $class-description "This is the class for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These conform to the assoc protocol." } ; - -ARTICLE: { "splay" "intro" } "Splay trees" -"This is a library for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These trees conform to the assoc protocol." -{ $subsection splay } -{ $subsection } -{ $subsection >splay } -{ $subsection POSTPONE: SPLAY{ } ; - -ABOUT: { "splay" "intro" } diff --git a/unmaintained/trees/splay/splay-tests.factor b/unmaintained/trees/splay/splay-tests.factor deleted file mode 100644 index e54e3cd538..0000000000 --- a/unmaintained/trees/splay/splay-tests.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (c) 2005 Mackenzie Straight. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test trees.splay math namespaces assocs -sequences random sets ; -IN: trees.splay.tests - -: randomize-numeric-splay-tree ( splay-tree -- ) - 100 [ drop 100 random swap at drop ] with each ; - -: make-numeric-splay-tree ( n -- splay-tree ) - [ [ conjoin ] curry each ] keep ; - -[ t ] [ - 100 make-numeric-splay-tree dup randomize-numeric-splay-tree - [ [ drop , ] assoc-each ] { } make [ < ] monotonic? -] unit-test - -[ 10 ] [ 10 make-numeric-splay-tree keys length ] unit-test -[ 10 ] [ 10 make-numeric-splay-tree values length ] unit-test - -[ f ] [ f 4 pick set-at 4 swap at ] unit-test - -! Ensure that f can be a value -[ t ] [ f 4 pick set-at 4 swap key? ] unit-test - -[ -{ { 1 "a" } { 2 "b" } { 3 "c" } { 4 "d" } { 5 "e" } { 6 "f" } } -] [ -{ - { 4 "d" } { 5 "e" } { 6 "f" } - { 1 "a" } { 2 "b" } { 3 "c" } -} >splay >alist -] unit-test diff --git a/unmaintained/trees/splay/splay.factor b/unmaintained/trees/splay/splay.factor deleted file mode 100755 index 923df4b6e3..0000000000 --- a/unmaintained/trees/splay/splay.factor +++ /dev/null @@ -1,140 +0,0 @@ -! Copyright (c) 2005 Mackenzie Straight. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math namespaces sequences assocs parser -prettyprint.backend trees generic math.order ; -IN: trees.splay - -TUPLE: splay < tree ; - -: ( -- tree ) - \ splay new-tree ; - -: rotate-right ( node -- node ) - dup node-left - [ node-right swap set-node-left ] 2keep - [ set-node-right ] keep ; - -: rotate-left ( node -- node ) - dup node-right - [ node-left swap set-node-right ] 2keep - [ set-node-left ] keep ; - -: link-right ( left right key node -- left right key node ) - swap >r [ swap set-node-left ] 2keep - nip dup node-left r> swap ; - -: link-left ( left right key node -- left right key node ) - swap >r rot [ set-node-right ] 2keep - drop dup node-right swapd r> swap ; - -: cmp ( key node -- obj node -1/0/1 ) - 2dup node-key key-side ; - -: lcmp ( key node -- obj node -1/0/1 ) - 2dup node-left node-key key-side ; - -: rcmp ( key node -- obj node -1/0/1 ) - 2dup node-right node-key key-side ; - -DEFER: (splay) - -: splay-left ( left right key node -- left right key node ) - dup node-left [ - lcmp 0 < [ rotate-right ] when - dup node-left [ link-right (splay) ] when - ] when ; - -: splay-right ( left right key node -- left right key node ) - dup node-right [ - rcmp 0 > [ rotate-left ] when - dup node-right [ link-left (splay) ] when - ] when ; - -: (splay) ( left right key node -- left right key node ) - cmp dup 0 < - [ drop splay-left ] [ 0 > [ splay-right ] when ] if ; - -: assemble ( head left right node -- root ) - [ node-right swap set-node-left ] keep - [ node-left swap set-node-right ] keep - [ swap node-left swap set-node-right ] 2keep - [ swap node-right swap set-node-left ] keep ; - -: splay-at ( key node -- node ) - >r >r T{ node } clone dup dup r> r> - (splay) nip assemble ; - -: splay ( key tree -- ) - [ tree-root splay-at ] keep set-tree-root ; - -: splay-split ( key tree -- node node ) - 2dup splay tree-root cmp 0 < [ - nip dup node-left swap f over set-node-left - ] [ - nip dup node-right swap f over set-node-right swap - ] if ; - -: get-splay ( key tree -- node ? ) - 2dup splay tree-root cmp 0 = [ - nip t - ] [ - 2drop f f - ] if ; - -: get-largest ( node -- node ) - dup [ dup node-right [ nip get-largest ] when* ] when ; - -: splay-largest ( node -- node ) - dup [ dup get-largest node-key swap splay-at ] when ; - -: splay-join ( n2 n1 -- node ) - splay-largest [ - [ set-node-right ] keep - ] [ - drop f - ] if* ; - -: remove-splay ( key tree -- ) - tuck get-splay nip [ - dup dec-count - dup node-right swap node-left splay-join - swap set-tree-root - ] [ drop ] if* ; - -: set-splay ( value key tree -- ) - 2dup get-splay [ 2nip set-node-value ] [ - drop dup inc-count - 2dup splay-split rot - >r >r swapd r> node boa r> set-tree-root - ] if ; - -: new-root ( value key tree -- ) - [ 1 swap set-tree-count ] keep - >r swap r> set-tree-root ; - -M: splay set-at ( value key tree -- ) - dup tree-root [ set-splay ] [ new-root ] if ; - -M: splay at* ( key tree -- value ? ) - dup tree-root [ - get-splay >r dup [ node-value ] when r> - ] [ - 2drop f f - ] if ; - -M: splay delete-at ( key tree -- ) - dup tree-root [ remove-splay ] [ 2drop ] if ; - -M: splay new-assoc - 2drop ; - -: >splay ( assoc -- tree ) - T{ splay f f 0 } assoc-clone-like ; - -: SPLAY{ - \ } [ >splay ] parse-literal ; parsing - -M: splay assoc-like - drop dup splay? [ >splay ] unless ; - -M: splay pprint-delims drop \ SPLAY{ \ } ; diff --git a/unmaintained/trees/splay/summary.txt b/unmaintained/trees/splay/summary.txt deleted file mode 100644 index 46391bbd28..0000000000 --- a/unmaintained/trees/splay/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Splay trees diff --git a/unmaintained/trees/splay/tags.txt b/unmaintained/trees/splay/tags.txt deleted file mode 100644 index fb6cea7147..0000000000 --- a/unmaintained/trees/splay/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -collections -trees diff --git a/unmaintained/trees/summary.txt b/unmaintained/trees/summary.txt deleted file mode 100644 index 18ad35db8f..0000000000 --- a/unmaintained/trees/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Binary search trees diff --git a/unmaintained/trees/tags.txt b/unmaintained/trees/tags.txt deleted file mode 100644 index fb6cea7147..0000000000 --- a/unmaintained/trees/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -collections -trees diff --git a/unmaintained/trees/trees-docs.factor b/unmaintained/trees/trees-docs.factor deleted file mode 100644 index df04f1cb40..0000000000 --- a/unmaintained/trees/trees-docs.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: help.syntax help.markup assocs ; -IN: trees - -HELP: TREE{ -{ $syntax "TREE{ { key value }... }" } -{ $values { "key" "a key" } { "value" "a value" } } -{ $description "Literal syntax for an unbalanced tree." } ; - -HELP: -{ $values { "tree" tree } } -{ $description "Creates an empty unbalanced binary tree" } ; - -HELP: >tree -{ $values { "assoc" assoc } { "tree" tree } } -{ $description "Converts any " { $link assoc } " into an unbalanced binary tree." } ; - -HELP: tree -{ $class-description "This is the class for unbalanced binary search trees. It is not usually intended to be used directly but rather as a basis for other trees." } ; - -ARTICLE: { "trees" "intro" } "Binary search trees" -"This is a library for unbalanced binary search trees. It is not intended to be used directly in most situations but rather as a base class for new trees, because performance can degrade to linear time storage/retrieval by the number of keys. These binary search trees conform to the assoc protocol." -{ $subsection tree } -{ $subsection } -{ $subsection >tree } -{ $subsection POSTPONE: TREE{ } ; - -IN: trees -ABOUT: { "trees" "intro" } diff --git a/unmaintained/trees/trees-tests.factor b/unmaintained/trees/trees-tests.factor deleted file mode 100644 index fd26b37c70..0000000000 --- a/unmaintained/trees/trees-tests.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: trees assocs tools.test kernel sequences ; -IN: trees.tests - -: test-tree ( -- tree ) - TREE{ - { 7 "seven" } - { 9 "nine" } - { 4 "four" } - { 4 "replaced four" } - { 7 "replaced seven" } - } clone ; - -! test set-at, at, at* -[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test -[ "seven" t ] [ "seven" 7 pick set-at 7 swap at* ] unit-test -[ f f ] [ "seven" 7 pick set-at 8 swap at* ] unit-test -[ "seven" ] [ "seven" 7 pick set-at 7 swap at ] unit-test -[ "replacement" ] [ "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test -[ "replaced four" ] [ test-tree 4 swap at ] unit-test -[ "nine" ] [ test-tree 9 swap at ] unit-test - -! test delete-at -[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test -[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test -[ "replaced four" ] [ test-tree 9 over delete-at 4 swap at ] unit-test -[ "nine" "replaced four" ] [ test-tree 7 over delete-at 9 over at 4 rot at ] unit-test -[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test - diff --git a/unmaintained/trees/trees.factor b/unmaintained/trees/trees.factor deleted file mode 100755 index d22dfdb7f1..0000000000 --- a/unmaintained/trees/trees.factor +++ /dev/null @@ -1,194 +0,0 @@ -! Copyright (C) 2007 Alex Chapman -! 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 accessors ; -IN: trees - -TUPLE: tree root count ; - -: new-tree ( class -- tree ) - new - f >>root - 0 >>count ; inline - -: ( -- tree ) - tree new-tree ; - -INSTANCE: tree assoc - -TUPLE: node key value left right ; - -: new-node ( key value class -- node ) - new swap >>value swap >>key ; - -: ( key value -- node ) - node new-node ; - -SYMBOL: current-side - -: 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 ; - -: dec-count ( tree -- ) [ 1- ] change-count drop ; - -: node-link@ ( node ? -- node ) - go-left? xor [ left>> ] [ right>> ] if ; -: set-node-link@ ( left parent ? -- ) - go-left? xor [ set-node-left ] [ set-node-right ] if ; - -: node-link ( node -- child ) f node-link@ ; -: set-node-link ( child node -- ) f set-node-link@ ; -: node+link ( node -- child ) t node-link@ ; -: 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 - -: leaf? ( node -- ? ) - [ left>> ] [ right>> ] bi or not ; - -: random-side ( -- side ) left right 2array random ; - -: choose-branch ( key node -- key node-left/right ) - 2dup node-key key-side [ node-link ] with-side ; - -: node-at* ( key node -- value ? ) - [ - 2dup node-key = [ - nip node-value t - ] [ - choose-branch node-at* - ] if - ] [ drop f f ] if* ; - -M: tree at* ( key tree -- value ? ) - root>> node-at* ; - -: node-set ( value key node -- node ) - 2dup key>> key-side dup 0 eq? [ - drop nip swap >>value - ] [ - [ - [ node-link [ node-set ] [ swap ] if* ] keep - [ set-node-link ] keep - ] with-side - ] if ; - -M: tree set-at ( value key tree -- ) - [ [ node-set ] [ swap ] if* ] change-root drop ; - -: valid-node? ( node -- ? ) - [ - 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 -- ? ) root>> valid-node? ; - -: (node>alist) ( node -- ) - [ - [ left>> (node>alist) ] - [ [ node-key ] [ node-value ] bi 2array , ] - [ right>> (node>alist) ] - tri - ] when* ; - -M: tree >alist [ root>> (node>alist) ] { } make ; - -M: tree clear-assoc - 0 >>count - f >>root drop ; - -: copy-node-contents ( new old -- ) - dup node-key pick set-node-key node-value swap set-node-value ; - -! Deletion -DEFER: delete-node - -: (prune-extremity) ( parent node -- new-extremity ) - dup node-link [ - rot drop (prune-extremity) - ] [ - tuck delete-node swap set-node-link - ] if* ; - -: prune-extremity ( node -- new-extremity ) - #! remove and return the leftmost or rightmost child of this node. - #! assumes at least one child - dup node-link (prune-extremity) ; - -: replace-with-child ( node -- node ) - dup dup node-link copy-node-contents dup node-link delete-node over set-node-link ; - -: replace-with-extremity ( node -- node ) - dup node-link dup node+link [ - ! predecessor/successor is not the immediate child - [ prune-extremity ] with-other-side dupd copy-node-contents - ] [ - ! node-link is the predecessor/successor - drop replace-with-child - ] if ; - -: delete-node-with-two-children ( node -- node ) - #! randomised to minimise tree unbalancing - random-side [ replace-with-extremity ] with-side ; - -: delete-node ( node -- node ) - #! delete this node, returning its replacement - dup left>> [ - dup right>> [ - delete-node-with-two-children - ] [ - left>> ! left but no right - ] if - ] [ - 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 0 eq? [ - drop nip delete-node - ] [ - [ tuck node-link delete-bst-node over set-node-link ] with-side - ] if ; - -M: tree delete-at - [ delete-bst-node ] change-root drop ; - -M: tree new-assoc - 2drop ; - -M: tree clone dup assoc-clone-like ; - -: >tree ( assoc -- tree ) - T{ tree f f 0 } assoc-clone-like ; - -M: tree assoc-like drop dup tree? [ >tree ] unless ; - -: TREE{ - \ } [ >tree ] parse-literal ; parsing - -M: tree pprint-delims drop \ TREE{ \ } ; -M: tree assoc-size count>> ; -M: tree >pprint-sequence >alist ; -M: tree pprint-narrow? drop t ; From d9184fbf240bb31a3263bf062e731dda950cc3b3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 4 Mar 2009 16:14:16 -0600 Subject: [PATCH 010/543] re-enable tree prettyprinting code. trees need refactoring or a rewrite someday --- extra/trees/avl/avl.factor | 6 +++--- extra/trees/splay/splay.factor | 4 ++-- extra/trees/trees.factor | 30 ++++++++++++++++++++---------- 3 files changed, 25 insertions(+), 15 deletions(-) diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index c37448fc1f..264db53a9e 100755 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel generic math math.functions -math.parser namespaces io prettyprint.backend sequences trees -assocs parser accessors math.order ; +math.parser namespaces io sequences trees +assocs parser accessors math.order prettyprint.custom ; IN: trees.avl TUPLE: avl < tree ; @@ -155,4 +155,4 @@ M: avl assoc-like : AVL{ \ } [ >avl ] parse-literal ; parsing -! M: avl pprint-delims drop \ AVL{ \ } ; +M: avl pprint-delims drop \ AVL{ \ } ; diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index adcf0a2522..c47b6b5d07 100755 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces sequences assocs parser -prettyprint.backend trees generic math.order accessors ; +trees generic math.order accessors prettyprint.custom ; IN: trees.splay TUPLE: splay < tree ; @@ -137,4 +137,4 @@ M: splay new-assoc M: splay assoc-like drop dup splay? [ >splay ] unless ; -! M: splay pprint-delims drop \ SPLAY{ \ } ; +M: splay pprint-delims drop \ SPLAY{ \ } ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 892b3b3944..41a8a21c1d 100755 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -2,8 +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 accessors deques make -prettyprint.custom ; +parser math.order accessors deques make prettyprint.custom ; IN: trees TUPLE: tree root count ; @@ -21,15 +20,17 @@ INSTANCE: tree assoc TUPLE: node key value left right ; : new-node ( key value class -- node ) - new swap >>value swap >>key ; + new + swap >>value + swap >>key ; : ( key value -- node ) node new-node ; SYMBOL: current-side -: left ( -- symbol ) -1 ; inline -: right ( -- symbol ) 1 ; inline +CONSTANT: left -1 +CONSTANT: right 1 : key-side ( k1 k2 -- n ) <=> { @@ -46,24 +47,33 @@ SYMBOL: current-side : node-link@ ( node ? -- node ) go-left? xor [ left>> ] [ right>> ] if ; + : set-node-link@ ( left parent ? -- ) go-left? xor [ (>>left) ] [ (>>right) ] if ; : node-link ( node -- child ) f node-link@ ; + : set-node-link ( child node -- ) f set-node-link@ ; + : node+link ( node -- child ) t node-link@ ; + : set-node+link ( child node -- ) t set-node-link@ ; -: with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline +: 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 : leaf? ( node -- ? ) [ left>> ] [ right>> ] bi or not ; -: random-side ( -- side ) left right 2array random ; +: random-side ( -- side ) + left right 2array random ; : choose-branch ( key node -- key node-left/right ) 2dup key>> key-side [ node-link ] with-side ; @@ -192,6 +202,6 @@ M: tree assoc-like drop dup tree? [ >tree ] unless ; \ } [ >tree ] parse-literal ; parsing M: tree assoc-size count>> ; -! M: tree pprint-delims drop \ TREE{ \ } ; -! M: tree >pprint-sequence >alist ; -! M: tree pprint-narrow? drop t ; +M: tree pprint-delims drop \ TREE{ \ } ; +M: tree >pprint-sequence >alist ; +M: tree pprint-narrow? drop t ; From 1f25cf5b12b4f132b13c6361a74d6f6a3ce3dddd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 4 Mar 2009 16:24:17 -0600 Subject: [PATCH 011/543] remove old id3 parser --- unmaintained/id3/authors.txt | 1 - unmaintained/id3/id3-docs.factor | 29 ------- unmaintained/id3/id3.factor | 142 ------------------------------- unmaintained/id3/summary.txt | 1 - 4 files changed, 173 deletions(-) delete mode 100644 unmaintained/id3/authors.txt delete mode 100644 unmaintained/id3/id3-docs.factor delete mode 100755 unmaintained/id3/id3.factor delete mode 100644 unmaintained/id3/summary.txt diff --git a/unmaintained/id3/authors.txt b/unmaintained/id3/authors.txt deleted file mode 100644 index bbc876e7b6..0000000000 --- a/unmaintained/id3/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Adam Wendt diff --git a/unmaintained/id3/id3-docs.factor b/unmaintained/id3/id3-docs.factor deleted file mode 100644 index 8083514c0d..0000000000 --- a/unmaintained/id3/id3-docs.factor +++ /dev/null @@ -1,29 +0,0 @@ -! Coyright (C) 2007 Adam Wendt -! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup ; -IN: id3 - -ARTICLE: "id3-tags" "ID3 Tags" -"The " { $vocab-link "id3" } " vocabulary is used to read ID3 tags from MP3 audio streams." -{ $subsection id3v2 } -{ $subsection read-tag } -{ $subsection id3v2? } -{ $subsection read-id3v2 } ; - -ABOUT: "id3-tags" - -HELP: id3v2 -{ $values { "filename" "a pathname string" } { "tag/f" "a tag or f" } } -{ $description "Outputs a " { $link tag } " or " { $link f } " if file does not start with an ID3 tag." } ; - -HELP: read-tag -{ $values { "stream" "a stream" } { "tag/f" "a tag or f" } } -{ $description "Outputs a " { $link tag } " or " { $link f } " if stream does not start with an ID3 tag." } ; - -HELP: id3v2? -{ $values { "?" "a boolean" } } -{ $description "Tests if the current input stream begins with an ID3 tag." } ; - -HELP: read-id3v2 -{ $values { "tag/f" "a tag or f" } } -{ $description "Outputs a " { $link tag } " or " { $link f } " if the current input stream does not start with an ID3 tag." } ; diff --git a/unmaintained/id3/id3.factor b/unmaintained/id3/id3.factor deleted file mode 100755 index 7f39025c4c..0000000000 --- a/unmaintained/id3/id3.factor +++ /dev/null @@ -1,142 +0,0 @@ -! Copyright (C) 2007 Adam Wendt. -! See http://factorcode.org/license.txt for BSD license. - -USING: arrays combinators io io.binary io.files io.paths -io.encodings.utf16 kernel math math.parser namespaces sequences -splitting strings assocs unicode.categories io.encodings.binary ; - -IN: id3 - -TUPLE: tag header frames ; -C: tag - -TUPLE: header version revision flags size extended-header ; -C:
header - -TUPLE: frame id size flags data ; -C: frame - -TUPLE: extended-header size flags update crc restrictions ; -C: extended-header - -: debug-stream ( msg -- ) -! global [ . flush ] bind ; - drop ; - -: >hexstring ( str -- hex ) - >array [ >hex 2 CHAR: 0 pad-left ] map concat ; - -: good-frame-id? ( id -- ? ) - [ [ LETTER? ] keep digit? or ] all? ; - -! 4 byte syncsafe integer (28 effective bits) -: >syncsafe ( seq -- int ) - 0 [ >r 7 shift r> bitor ] reduce ; - -: read-size ( -- size ) - 4 read >syncsafe ; - -: read-frame-id ( -- id ) - 4 read ; - -: read-frame-flags ( -- flags ) - 2 read ; - -: read-frame-size ( -- size ) - 4 read be> ; - -: text-frame? ( id -- ? ) - "T" head? ; - -: read-text ( size -- text ) - read1 swap 1 - read swap 1 = [ decode-utf16 ] [ ] if - "\0" ?tail drop ; ! remove null terminator - -: read-popm ( size -- popm ) - read-text ; - -: read-frame-data ( id size -- data ) - swap - { - { [ dup text-frame? ] [ drop read-text ] } - { [ "POPM" = ] [ read-popm ] } - { [ t ] [ read ] } - } cond ; - -: (read-frame) ( id -- frame ) - read-frame-size read-frame-flags 2over read-frame-data ; - -: read-frame ( -- frame/f ) - read-frame-id dup good-frame-id? [ (read-frame) ] [ drop f ] if ; - -: (read-frames) ( vector -- frames ) - read-frame [ over push (read-frames) ] when* ; - -: read-frames ( -- frames ) - V{ } clone (read-frames) ; - -: read-eh-flags ( -- flags ) - read1 read le> ; - -: read-eh-data ( size -- data ) - 6 - read ; - -: read-crc ( flags -- crc ) - 5 bit? [ read1 read >syncsafe ] [ f ] if ; - -: tag-is-update? ( flags -- ? ) - 6 bit? dup [ read1 drop ] [ ] if ; - -: (read-tag-restrictions) ( -- restrictions ) - read1 dup read le> ; - -: read-tag-restrictions ( flags -- restrictions/f ) - 4 bit? [ (read-tag-restrictions) ] [ f ] if ; - -: (read-extended-header) ( -- extended-header ) - read-size read-eh-flags dup tag-is-update? over dup - read-crc swap read-tag-restrictions ; - -: read-extended-header ( flags -- extended-header/f ) - 6 bit? [ (read-extended-header) ] [ f ] if ; - -: read-header ( version -- header ) - read1 read1 read-size over read-extended-header
; - -: (read-id3v2) ( version -- tag ) - read-header read-frames ; - -: supported-version? ( version -- ? ) - { 3 4 } member? ; - -: read-id3v2 ( -- tag/f ) - read1 dup supported-version? - [ (read-id3v2) ] [ drop f ] if ; - -: id3v2? ( -- ? ) - 3 read "ID3" sequence= ; - -: read-tag ( stream -- tag/f ) - id3v2? [ read-id3v2 ] [ f ] if ; - -: id3v2 ( filename -- tag/f ) - binary [ read-tag ] with-file-reader ; - -: file? ( path -- ? ) - stat 3drop not ; - -: files ( paths -- files ) - [ file? ] subset ; - -: mp3? ( path -- ? ) - ".mp3" tail? ; - -: mp3s ( paths -- mp3s ) - [ mp3? ] subset ; - -: id3? ( file -- ? ) - binary [ id3v2? ] with-file-reader ; - -: id3s ( files -- id3s ) - [ id3? ] subset ; - diff --git a/unmaintained/id3/summary.txt b/unmaintained/id3/summary.txt deleted file mode 100644 index 62016172bd..0000000000 --- a/unmaintained/id3/summary.txt +++ /dev/null @@ -1 +0,0 @@ -ID3 music file tag parser From 04c29c0a975148b92c9fd4100a21968da0ee9cc4 Mon Sep 17 00:00:00 2001 From: Maxim Savchenko Date: Mon, 9 Mar 2009 16:33:20 -0400 Subject: [PATCH 012/543] ECDSA OpenSSL interface --- basis/openssl/libcrypto/libcrypto.factor | 64 +++++++++++++++++- extra/ecdsa/authors.txt | 1 + extra/ecdsa/ecdsa-tests.factor | 30 +++++++++ extra/ecdsa/ecdsa.factor | 86 ++++++++++++++++++++++++ extra/ecdsa/summary.txt | 1 + 5 files changed, 181 insertions(+), 1 deletion(-) create mode 100644 extra/ecdsa/authors.txt create mode 100644 extra/ecdsa/ecdsa-tests.factor create mode 100644 extra/ecdsa/ecdsa.factor create mode 100644 extra/ecdsa/summary.txt diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor index 9cbed1f752..1a25b4d019 100644 --- a/basis/openssl/libcrypto/libcrypto.factor +++ b/basis/openssl/libcrypto/libcrypto.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Elie CHAFTARI +! Copyright (C) 2007 Elie CHAFTARI, 2009 Maxim Savchenko ! See http://factorcode.org/license.txt for BSD license. ! ! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC @@ -159,3 +159,65 @@ FUNCTION: int RSA_check_key ( void* rsa ) ; FUNCTION: void RSA_free ( void* rsa ) ; FUNCTION: int RSA_print_fp ( void* fp, void* x, int offset ) ; + +! =============================================== +! objects.h +! =============================================== + +FUNCTION: int OBJ_sn2nid ( char* s ) ; + +! =============================================== +! bn.h +! =============================================== + +FUNCTION: int BN_num_bits ( void* a ) ; + +FUNCTION: void* BN_bin2bn ( void* s, int len, void* ret ) ; + +FUNCTION: int BN_bn2bin ( void* a, void* to ) ; + +FUNCTION: void BN_clear_free ( void* a ) ; + +! =============================================== +! ec.h +! =============================================== + +CONSTANT: POINT_CONVERSION_COMPRESSED 2 +CONSTANT: POINT_CONVERSION_UNCOMPRESSED 4 +CONSTANT: POINT_CONVERSION_HYBRID 6 + +FUNCTION: int EC_GROUP_get_degree ( void* group ) ; + +FUNCTION: void* EC_POINT_new ( void* group ) ; + +FUNCTION: void EC_POINT_clear_free ( void* point ) ; + +FUNCTION: int EC_POINT_point2oct ( void* group, void* point, int form, void* buf, int len, void* ctx ) ; + +FUNCTION: int EC_POINT_oct2point ( void* group, void* point, void* buf, int len, void* ctx ) ; + +FUNCTION: void* EC_KEY_new_by_curve_name ( int nid ) ; + +FUNCTION: void EC_KEY_free ( void* r ) ; + +FUNCTION: int EC_KEY_set_private_key ( void* key, void* priv_key ) ; + +FUNCTION: int EC_KEY_set_public_key ( void* key, void* pub_key ) ; + +FUNCTION: int EC_KEY_generate_key ( void* eckey ) ; + +FUNCTION: void* EC_KEY_get0_group ( void* key ) ; + +FUNCTION: void* EC_KEY_get0_private_key ( void* key ) ; + +FUNCTION: void* EC_KEY_get0_public_key ( void* key ) ; + +! =============================================== +! ecdsa.h +! =============================================== + +FUNCTION: int ECDSA_size ( void* eckey ) ; + +FUNCTION: int ECDSA_sign ( int type, void* dgst, int dgstlen, void* sig, void* siglen, void* eckey ) ; + +FUNCTION: int ECDSA_verify ( int type, void* dgst, int dgstlen, void* sig, int siglen, void* eckey ) ; diff --git a/extra/ecdsa/authors.txt b/extra/ecdsa/authors.txt new file mode 100644 index 0000000000..f97e1bfbf9 --- /dev/null +++ b/extra/ecdsa/authors.txt @@ -0,0 +1 @@ +Maxim Savchenko diff --git a/extra/ecdsa/ecdsa-tests.factor b/extra/ecdsa/ecdsa-tests.factor new file mode 100644 index 0000000000..897ee63a95 --- /dev/null +++ b/extra/ecdsa/ecdsa-tests.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2009 Maxim Savchenko +! See http://factorcode.org/license.txt for BSD license. + +USING: namespaces ecdsa tools.test checksums checksums.openssl ; +IN: ecdsa.tests + +SYMBOLS: priv-key pub-key signature ; + +: message ( -- msg ) "Hello world!" ; + +[ ] ! Generating keys +[ + "prime256v1" [ generate-key get-private-key get-public-key ] with-ec + pub-key set priv-key set +] unit-test + +[ ] ! Signing message +[ + message "sha256" checksum-bytes + priv-key get + "prime256v1" [ set-private-key ecdsa-sign ] with-ec + signature set +] unit-test + +[ t ] ! Verifying signature +[ + message "sha256" checksum-bytes + signature get pub-key get + "prime256v1" [ set-public-key ecdsa-verify ] with-ec +] unit-test \ No newline at end of file diff --git a/extra/ecdsa/ecdsa.factor b/extra/ecdsa/ecdsa.factor new file mode 100644 index 0000000000..78b528d4ad --- /dev/null +++ b/extra/ecdsa/ecdsa.factor @@ -0,0 +1,86 @@ +! Copyright (C) 2009 Maxim Savchenko +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel accessors sequences sequences.private destructors math namespaces + locals openssl openssl.libcrypto byte-arrays bit-arrays.private + alien.c-types ; + +IN: ecdsa + + ( curve -- key ) + OBJ_sn2nid dup zero? [ "Unknown curve name" throw ] when + EC_KEY_new_by_curve_name dup ssl-error ec-key boa ; + +: ec-key-handle ( -- handle ) + ec-key get dup handle>> [ nip ] [ already-disposed ] if* ; + +TUPLE: openssl-bignum < openssl-object ; + +M: openssl-bignum free-handle BN_clear_free ; + +TUPLE: ec-point < openssl-object ; + +M: ec-point free-handle EC_POINT_clear_free ; + +PRIVATE> + +: with-ec ( curve quot -- ) + swap [ ec-key rot with-variable ] with-disposal ; inline + +: generate-key ( -- ) + ec-key get handle>> EC_KEY_generate_key ssl-error ; + +: set-private-key ( bin -- ) + ec-key-handle swap + dup length f BN_bin2bn dup ssl-error dup openssl-bignum boa + [ drop EC_KEY_set_private_key ssl-error ] with-disposal ; + +:: set-public-key ( BIN -- ) + ec-key-handle :> KEY + KEY EC_KEY_get0_group :> GROUP + GROUP EC_POINT_new dup ssl-error :> POINT + POINT ec-point boa + [ + drop + GROUP POINT BIN dup length f EC_POINT_oct2point ssl-error + KEY POINT EC_KEY_set_public_key ssl-error + ] with-disposal ; + +: get-private-key ( -- bin/f ) + ec-key-handle EC_KEY_get0_private_key + dup [ dup BN_num_bits bits>bytes tuck BN_bn2bin drop ] when ; + +:: get-public-key ( -- bin/f ) + ec-key-handle :> KEY + KEY EC_KEY_get0_public_key dup + [| PUB | + KEY EC_KEY_get0_group :> GROUP + GROUP EC_GROUP_get_degree bits>bytes 1+ :> LEN + LEN :> BIN + GROUP PUB POINT_CONVERSION_COMPRESSED BIN LEN f + EC_POINT_point2oct ssl-error + BIN + ] when ; + +:: ecdsa-sign ( DGST -- sig ) + ec-key-handle :> KEY + KEY ECDSA_size dup ssl-error :> SIG + "uint" :> LEN + 0 DGST dup length SIG LEN KEY ECDSA_sign ssl-error + LEN *uint SIG resize ; + +: ecdsa-verify ( dgst sig -- ? ) + ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ; \ No newline at end of file diff --git a/extra/ecdsa/summary.txt b/extra/ecdsa/summary.txt new file mode 100644 index 0000000000..8f952c36a5 --- /dev/null +++ b/extra/ecdsa/summary.txt @@ -0,0 +1 @@ +Elliptic Curve Digital Signature Algorithm (OpenSSL realisation) From 5a14faecd6f7352a5556dc3a91e368721d164b22 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Mon, 9 Mar 2009 20:13:17 -0500 Subject: [PATCH 013/543] added rendering functions --- basis/ui/utils/utils.factor | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 basis/ui/utils/utils.factor diff --git a/basis/ui/utils/utils.factor b/basis/ui/utils/utils.factor new file mode 100644 index 0000000000..468af45150 --- /dev/null +++ b/basis/ui/utils/utils.factor @@ -0,0 +1,6 @@ +USING: accessors sequences namespaces ui.render opengl fry ; +IN: ui.utils +SYMBOLS: width height ; +: store-dim ( gadget -- ) dim>> [ first width set ] [ second height set ] bi ; +: with-dim ( gadget quot -- ) '[ _ store-dim @ ] with-scope ; +: with-w/h ( gadget quot -- ) '[ origin get _ with-translation ] with-dim ; \ No newline at end of file From 4d453923ae1f7c65d7274b8f2ea83b4f3b160497 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Mon, 9 Mar 2009 20:34:56 -0500 Subject: [PATCH 014/543] added simple dialogs for the ui --- basis/ui/gadgets/alerts/alerts.factor | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 basis/ui/gadgets/alerts/alerts.factor diff --git a/basis/ui/gadgets/alerts/alerts.factor b/basis/ui/gadgets/alerts/alerts.factor new file mode 100644 index 0000000000..3a4120b3de --- /dev/null +++ b/basis/ui/gadgets/alerts/alerts.factor @@ -0,0 +1,4 @@ +USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences io.styles ; +IN: ui.gadgets.alerts +:: alert ( quot string -- ) { 10 10 } >>gap 1 >>align string