new -> new-sequence
construct-empty -> new construct-boa -> boa diff -> assoc-diff union -> assoc-union intersect -> assoc-intersectdb4
parent
72080fda4a
commit
2edd0fefc9
|
@ -69,10 +69,10 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
|
|||
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
|
||||
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
|
||||
{ $subsection subassoc? }
|
||||
{ $subsection intersect }
|
||||
{ $subsection assoc-intersect }
|
||||
{ $subsection update }
|
||||
{ $subsection union }
|
||||
{ $subsection diff }
|
||||
{ $subsection assoc-union }
|
||||
{ $subsection assoc-diff }
|
||||
{ $subsection remove-all }
|
||||
{ $subsection substitute }
|
||||
{ $subsection substitute-here }
|
||||
|
@ -260,7 +260,7 @@ HELP: values
|
|||
|
||||
{ keys values } related-words
|
||||
|
||||
HELP: intersect
|
||||
HELP: assoc-intersect
|
||||
{ $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } }
|
||||
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." }
|
||||
{ $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ;
|
||||
|
@ -270,11 +270,11 @@ HELP: update
|
|||
{ $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
|
||||
{ $side-effects "assoc1" } ;
|
||||
|
||||
HELP: union
|
||||
HELP: assoc-union
|
||||
{ $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } }
|
||||
{ $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ;
|
||||
|
||||
HELP: diff
|
||||
HELP: assoc-diff
|
||||
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
|
||||
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." }
|
||||
;
|
||||
|
|
|
@ -58,24 +58,24 @@ H{ } clone "cache-test" set
|
|||
] [
|
||||
H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
|
||||
H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
|
||||
intersect
|
||||
assoc-intersect
|
||||
] unit-test
|
||||
|
||||
[
|
||||
H{ { 1 2 } { 2 3 } { 6 5 } }
|
||||
] [
|
||||
H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } }
|
||||
union
|
||||
assoc-union
|
||||
] unit-test
|
||||
|
||||
[ H{ { 1 2 } { 2 3 } } t ] [
|
||||
f H{ { 1 2 } { 2 3 } } [ union ] 2keep swap union dupd =
|
||||
f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
H{ { 1 f } }
|
||||
] [
|
||||
H{ { 1 f } } H{ { 1 f } } intersect
|
||||
H{ { 1 f } } H{ { 1 f } } assoc-intersect
|
||||
] unit-test
|
||||
|
||||
[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test
|
||||
|
|
|
@ -109,17 +109,17 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
>r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
|
||||
] { } assoc>map hashcode* ;
|
||||
|
||||
: intersect ( assoc1 assoc2 -- intersection )
|
||||
: assoc-intersect ( assoc1 assoc2 -- intersection )
|
||||
swap [ nip key? ] curry assoc-subset ;
|
||||
|
||||
: update ( assoc1 assoc2 -- )
|
||||
swap [ swapd set-at ] curry assoc-each ;
|
||||
|
||||
: union ( assoc1 assoc2 -- union )
|
||||
: assoc-union ( assoc1 assoc2 -- union )
|
||||
2dup [ assoc-size ] bi@ + pick new-assoc
|
||||
[ rot update ] keep [ swap update ] keep ;
|
||||
|
||||
: diff ( assoc1 assoc2 -- diff )
|
||||
: assoc-diff ( assoc1 assoc2 -- diff )
|
||||
swap [ nip key? not ] curry assoc-subset ;
|
||||
|
||||
: remove-all ( assoc seq -- subseq )
|
||||
|
|
|
@ -36,4 +36,4 @@ tag-numbers get H{
|
|||
{ word 17 }
|
||||
{ byte-array 18 }
|
||||
{ tuple-layout 19 }
|
||||
} union type-numbers set
|
||||
} assoc-union type-numbers set
|
||||
|
|
|
@ -89,7 +89,7 @@ M: word reset-class drop ;
|
|||
dup reset-class
|
||||
dup deferred? [ dup define-symbol ] when
|
||||
dup word-props
|
||||
r> union over set-word-props
|
||||
r> assoc-union over set-word-props
|
||||
dup predicate-word
|
||||
[ 1quotation "predicate" set-word-prop ]
|
||||
[ swap "predicating" set-word-prop ]
|
||||
|
|
|
@ -202,7 +202,7 @@ M: #dispatch generate-node
|
|||
: define-if>boolean-intrinsics ( word intrinsics -- )
|
||||
[
|
||||
>r [ if>boolean-intrinsic ] curry r>
|
||||
{ { f "if-scratch" } } +scratch+ associate union
|
||||
{ { f "if-scratch" } } +scratch+ associate assoc-union
|
||||
] assoc-map "intrinsics" set-word-prop ;
|
||||
|
||||
: define-if-intrinsics ( word intrinsics -- )
|
||||
|
|
|
@ -45,7 +45,7 @@ C: <ignore-close-stream> ignore-close-stream
|
|||
TUPLE: style-stream < filter-writer style ;
|
||||
|
||||
: do-nested-style ( style style-stream -- style stream )
|
||||
[ style>> swap union ] [ stream>> ] bi ; inline
|
||||
[ style>> swap assoc-union ] [ stream>> ] bi ; inline
|
||||
|
||||
C: <style-stream> style-stream
|
||||
|
||||
|
|
|
@ -17,7 +17,7 @@ SYMBOL: optimizer-changed
|
|||
GENERIC: optimize-node* ( node -- node/t changed? )
|
||||
|
||||
: ?union ( assoc/f assoc -- hash )
|
||||
over [ union ] [ nip ] if ;
|
||||
over [ assoc-union ] [ nip ] if ;
|
||||
|
||||
: add-node-literals ( assoc node -- )
|
||||
over assoc-empty? [
|
||||
|
@ -82,7 +82,7 @@ M: node optimize-node* drop t f ;
|
|||
2dup at* [ swap follow nip ] [ 2drop ] if ;
|
||||
|
||||
: union* ( assoc1 assoc2 -- assoc )
|
||||
union [ keys ] keep
|
||||
assoc-union [ keys ] keep
|
||||
[ dupd follow ] curry
|
||||
H{ } map>assoc ;
|
||||
|
||||
|
|
|
@ -501,14 +501,14 @@ SYMBOL: interactive-vocabs
|
|||
] if ;
|
||||
|
||||
: filter-moved ( assoc1 assoc2 -- seq )
|
||||
diff [
|
||||
assoc-diff [
|
||||
drop where dup [ first ] when
|
||||
file get source-file-path =
|
||||
] assoc-subset keys ;
|
||||
|
||||
: removed-definitions ( -- assoc1 assoc2 )
|
||||
new-definitions old-definitions
|
||||
[ get first2 union ] bi@ ;
|
||||
[ get first2 assoc-union ] bi@ ;
|
||||
|
||||
: removed-classes ( -- assoc1 assoc2 )
|
||||
new-definitions old-definitions
|
||||
|
|
|
@ -19,6 +19,6 @@ IN: sbufs.tests
|
|||
|
||||
[ SBUF" x" ] [ 1 <sbuf> CHAR: x >bignum over push ] unit-test
|
||||
|
||||
[ fixnum ] [ 1 >bignum SBUF" " new length class ] unit-test
|
||||
[ fixnum ] [ 1 >bignum SBUF" " new-sequence length class ] unit-test
|
||||
|
||||
[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test
|
||||
|
|
|
@ -240,7 +240,7 @@ unit-test
|
|||
|
||||
[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test
|
||||
|
||||
[ V{ f f f } ] [ 3 V{ } new ] unit-test
|
||||
[ V{ f f f } ] [ 3 V{ } new-sequence ] unit-test
|
||||
[ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test
|
||||
|
||||
[ 0 ] [ f length ] unit-test
|
||||
|
|
|
@ -69,7 +69,7 @@ M: pathname forget*
|
|||
pathname-string forget-source ;
|
||||
|
||||
: rollback-source-file ( file -- )
|
||||
dup source-file-definitions new-definitions get [ union ] 2map
|
||||
dup source-file-definitions new-definitions get [ assoc-union ] 2map
|
||||
swap set-source-file-definitions ;
|
||||
|
||||
SYMBOL: file
|
||||
|
|
|
@ -94,6 +94,6 @@ IN: vectors.tests
|
|||
100 >array dup >vector <reversed> >array >r reverse r> =
|
||||
] unit-test
|
||||
|
||||
[ fixnum ] [ 1 >bignum V{ } new length class ] unit-test
|
||||
[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
|
||||
|
||||
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
|
||||
|
|
|
@ -139,7 +139,7 @@ H{
|
|||
{ "NSRect" "{_NSRect=ffff}" }
|
||||
{ "NSSize" "{_NSSize=ff}" }
|
||||
{ "NSRange" "{_NSRange=II}" }
|
||||
} union alien>objc-types set-global
|
||||
} assoc-union alien>objc-types set-global
|
||||
|
||||
: objc-struct-type ( i string -- ctype )
|
||||
2dup CHAR: = -rot index* swap subseq
|
||||
|
|
|
@ -5,7 +5,7 @@ io definitions kernel continuations ;
|
|||
IN: delegate.protocols
|
||||
|
||||
PROTOCOL: sequence-protocol
|
||||
clone clone-like like new new-resizable nth nth-unsafe
|
||||
clone clone-like like new-sequence new-resizable nth nth-unsafe
|
||||
set-nth set-nth-unsafe length set-length lengthen ;
|
||||
|
||||
PROTOCOL: assoc-protocol
|
||||
|
|
|
@ -79,7 +79,7 @@ M: f print-element drop ;
|
|||
[ strong-style get print-element* ] ($heading) ;
|
||||
|
||||
: ($code-style) ( presentation -- hash )
|
||||
presented associate code-style get union ;
|
||||
presented associate code-style get assoc-union ;
|
||||
|
||||
: ($code) ( presentation quot -- )
|
||||
[
|
||||
|
|
|
@ -40,7 +40,7 @@ TUPLE: action init display submit get-params post-params ;
|
|||
M: action call-responder ( path action -- response )
|
||||
'[
|
||||
, ,
|
||||
[ +append-path associate request-params union params set ]
|
||||
[ +append-path associate request-params assoc-union params set ]
|
||||
[ action set ] bi*
|
||||
request get method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
|
|
|
@ -84,7 +84,7 @@ TUPLE: url-sessions ;
|
|||
[ drop ] [ get-session ] 2bi ;
|
||||
|
||||
: add-session-id ( query -- query' )
|
||||
session-id get [ session-id-key associate union ] when* ;
|
||||
session-id get [ session-id-key associate assoc-union ] when* ;
|
||||
|
||||
: session-form-field ( -- )
|
||||
<input
|
||||
|
|
|
@ -85,8 +85,8 @@ M: process hashcode* process-handle hashcode* ;
|
|||
: get-environment ( process -- env )
|
||||
dup environment>>
|
||||
swap environment-mode>> {
|
||||
{ +prepend-environment+ [ os-envs union ] }
|
||||
{ +append-environment+ [ os-envs swap union ] }
|
||||
{ +prepend-environment+ [ os-envs assoc-union ] }
|
||||
{ +append-environment+ [ os-envs swap assoc-union ] }
|
||||
{ +replace-environment+ [ ] }
|
||||
} case ;
|
||||
|
||||
|
|
|
@ -65,7 +65,7 @@ SYMBOL: deploy-image
|
|||
{ deploy-c-types? f }
|
||||
! default value for deploy.macosx
|
||||
{ "stop-after-last-window?" t }
|
||||
} union ;
|
||||
} assoc-union ;
|
||||
|
||||
: deploy-config-path ( vocab -- string )
|
||||
vocab-dir "deploy.factor" append-path ;
|
||||
|
@ -73,7 +73,7 @@ SYMBOL: deploy-image
|
|||
: deploy-config ( vocab -- assoc )
|
||||
dup default-config swap
|
||||
dup deploy-config-path vocab-file-contents
|
||||
parse-fresh dup empty? [ drop ] [ first union ] if ;
|
||||
parse-fresh dup empty? [ drop ] [ first assoc-union ] if ;
|
||||
|
||||
: set-deploy-config ( assoc vocab -- )
|
||||
>r unparse-use string-lines r>
|
||||
|
|
|
@ -9,14 +9,14 @@ global [
|
|||
[ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
|
||||
|
||||
! Only keeps those methods that we actually call
|
||||
sent-messages get super-sent-messages get union
|
||||
objc-methods [ intersect ] change
|
||||
sent-messages get super-sent-messages get assoc-union
|
||||
objc-methods [ assoc-intersect ] change
|
||||
|
||||
sent-messages get
|
||||
super-sent-messages get
|
||||
[ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
|
||||
super-message-senders [ intersect ] change
|
||||
message-senders [ intersect ] change
|
||||
super-message-senders [ assoc-intersect ] change
|
||||
message-senders [ assoc-intersect ] change
|
||||
|
||||
sent-messages off
|
||||
super-sent-messages off
|
||||
|
|
|
@ -11,7 +11,7 @@ TUPLE: tuple-array example ;
|
|||
swap tuple>array length over length - ;
|
||||
|
||||
: <tuple-array> ( length example -- tuple-array )
|
||||
prepare-example [ rot * { } new ] keep
|
||||
prepare-example [ rot * { } new-sequence ] keep
|
||||
<sliced-groups> tuple-array construct-delegate
|
||||
[ set-tuple-array-example ] keep ;
|
||||
|
||||
|
|
|
@ -66,7 +66,7 @@ M: word command-description ( word -- str )
|
|||
H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
|
||||
|
||||
: define-command ( word hash -- )
|
||||
default-flags swap union >r word-props r> update ;
|
||||
default-flags swap assoc-union >r word-props r> update ;
|
||||
|
||||
: command-quot ( target command -- quot )
|
||||
dup 1quotation swap +nullary+ word-prop
|
||||
|
|
|
@ -54,7 +54,7 @@ SYMBOL: operations
|
|||
H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
|
||||
|
||||
: define-operation ( pred command flags -- )
|
||||
default-flags swap union
|
||||
default-flags swap assoc-union
|
||||
dupd define-command <operation>
|
||||
operations get push ;
|
||||
|
||||
|
|
|
@ -135,7 +135,7 @@ load-data
|
|||
dup process-names \ name-map set-value
|
||||
13 over process-data \ simple-lower set-value
|
||||
12 over process-data tuck \ simple-upper set-value
|
||||
14 over process-data swapd union \ simple-title set-value
|
||||
14 over process-data swapd assoc-union \ simple-title set-value
|
||||
dup process-combining \ class-map set-value
|
||||
dup process-canonical \ canonical-map set-value
|
||||
\ combine-map set-value
|
||||
|
|
|
@ -62,7 +62,7 @@ M: attrs set-at
|
|||
] if* ;
|
||||
|
||||
M: attrs assoc-size attrs-alist length ;
|
||||
M: attrs new-assoc drop V{ } new <attrs> ;
|
||||
M: attrs new-assoc drop V{ } new-sequence <attrs> ;
|
||||
M: attrs >alist attrs-alist ;
|
||||
|
||||
: >attrs ( assoc -- attrs )
|
||||
|
|
Loading…
Reference in New Issue