adjoin and conjoin words added
parent
0dc90434e2
commit
5cb13132af
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 } }
|
||||
|
|
|
@ -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" ] [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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." }
|
||||
|
|
|
@ -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? ;
|
||||
|
|
|
@ -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' )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue