adjoin and conjoin words added

db4
Slava Pestov 2008-05-25 19:44:37 -05:00
parent 0dc90434e2
commit 5cb13132af
11 changed files with 37 additions and 33 deletions

View File

@ -95,10 +95,10 @@ M: hashtable hashcode*
: (distribute-buckets) ( buckets pair keys -- )
dup t eq? [
drop [ swap push-new ] curry each
drop [ swap adjoin ] curry each
] [
[
>r 2dup r> hashcode pick length rem rot nth push-new
>r 2dup r> hashcode pick length rem rot nth adjoin
] each 2drop
] if ;

View File

@ -14,7 +14,7 @@ TUPLE: redefine-error def ;
{ { "Continue" t } } throw-restarts drop ;
: add-once ( key assoc -- )
2dup key? [ over redefine-error ] when dupd set-at ;
2dup key? [ over redefine-error ] when conjoin ;
: (remember-definition) ( definition loc assoc -- )
>r over set-where r> add-once ;

View File

@ -102,13 +102,13 @@ M: frame-required fixup* drop ;
M: integer fixup* , ;
: push-new* ( obj table -- n )
: adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop
[ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get push-new* ;
: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;

View File

@ -191,7 +191,6 @@ $nl
"Other destructive words:"
{ $subsection move }
{ $subsection exchange }
{ $subsection push-new }
{ $subsection copy }
{ $subsection replace-slice }
{ $see-also set-nth push pop "sequences-stacks" } ;
@ -624,22 +623,7 @@ HELP: replace-slice
{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." }
{ $side-effects "seq" } ;
HELP: push-new
{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
{ $examples
{ $example
"USING: namespaces prettyprint sequences ;"
"V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
"\"nachos\" \"v\" get push-new"
"\"salsa\" \"v\" get push-new"
"\"v\" get ."
"V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
}
}
{ $side-effects "seq" } ;
{ push push-new prefix suffix } related-words
{ push prefix suffix } related-words
HELP: suffix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }

View File

@ -216,10 +216,10 @@ unit-test
] unit-test
[ V{ 1 2 3 } ]
[ 3 V{ 1 2 } clone [ push-new ] keep ] unit-test
[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
[ V{ 1 2 3 } ]
[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
! erg's random tester found this one
[ SBUF" 12341234" ] [

View File

@ -499,8 +499,6 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
: push-new ( elt seq -- ) [ delete ] 2keep push ;
: prefix ( seq elt -- newseq )
over >r over length 1+ r> [
[ 0 swap set-nth-unsafe ] keep

View File

@ -16,10 +16,28 @@ $nl
{ $subsection set= }
"A word used to implement the above:"
{ $subsection unique }
"Adding elements to sets:"
{ $subsection adjoin }
{ $subsection conjoin }
{ $see-also member? memq? contains? all? "assocs-sets" } ;
ABOUT: "sets"
HELP: adjoin
{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
{ $examples
{ $example
"USING: namespaces prettyprint sequences ;"
"V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
"\"nachos\" \"v\" get adjoin"
"\"salsa\" \"v\" get adjoin"
"\"v\" get ."
"V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
}
}
{ $side-effects "seq" } ;
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." }

View File

@ -3,10 +3,14 @@
USING: assocs hashtables kernel sequences vectors ;
IN: sets
: adjoin ( elt seq -- ) [ delete ] [ push ] 2bi ;
: conjoin ( elt assoc -- ) dupd set-at ;
: (prune) ( elt hash vec -- )
3dup drop key?
[ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
3drop ; inline
3dup drop key? [ 3drop ] [
[ drop conjoin ] [ nip push ] 3bi
] if ; inline
: prune ( seq -- newseq )
[ ] [ length <hashtable> ] [ length <vector> ] tri
@ -16,7 +20,7 @@ IN: sets
[ dup ] H{ } map>assoc ;
: (all-unique?) ( elt hash -- ? )
2dup key? [ 2drop f ] [ dupd set-at t ] if ;
2dup key? [ 2drop f ] [ conjoin t ] if ;
: all-unique? ( seq -- ? )
dup length <hashtable> [ (all-unique?) ] curry all? ;

View File

@ -25,7 +25,7 @@ SYMBOL: total
]
[
[ pair? ] filter
[ keys [ hooks get push-new ] each ] keep
[ keys [ hooks get adjoin ] each ] keep
] bi append ;
: canonicalize-specializer-2 ( specializer -- specializer' )

View File

@ -8,7 +8,7 @@ IN: trees.splay.tests
100 [ drop 100 random swap at drop ] with each ;
: make-numeric-splay-tree ( n -- splay-tree )
<splay> [ [ dupd set-at ] curry each ] keep ;
<splay> [ [ conjoin ] curry each ] keep ;
[ t ] [
100 make-numeric-splay-tree dup randomize-numeric-splay-tree

View File

@ -76,7 +76,7 @@ M: interactor model-changed
] with-output-stream* ;
: add-interactor-history ( str interactor -- )
over empty? [ 2drop ] [ interactor-history push-new ] if ;
over empty? [ 2drop ] [ interactor-history adjoin ] if ;
: interactor-continue ( obj interactor -- )
mailbox>> mailbox-put ;