"." write flush
{
- lines prefix suffix unclip new-assoc update
+ lines prefix suffix unclip new-assoc assoc-union!
word-prop set-word-prop 1array 2array 3array ?nth
} compile-unoptimized
H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
: define-command ( word hash -- )
- [ props>> ] [ default-flags swap assoc-union ] bi* update ;
+ default-flags swap assoc-union
+ '[ _ assoc-union ] change-props drop ;
: command-quot ( target command -- quot )
[ 1quotation ] [ +nullary+ word-prop ] bi
{ $subsections
assoc-subset?
assoc-intersect
- update
assoc-union
assoc-diff
substitute
extract-keys
}
+"Destructive operations:"
+{ $subsections
+ assoc-union!
+ assoc-diff!
+}
{ $see-also key? assoc-any? assoc-all? "sets" } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
assoc-map
assoc-filter
assoc-filter-as
+ assoc-partition
assoc-any?
assoc-all?
}
-"Additional combinators:"
+"Mapping between assocs and sequences:"
{ $subsections
- assoc-partition
- cache
- 2cache
map>assoc
assoc>map
assoc-map-as
+}
+"Destructive combinators:"
+{ $subsections
+ assoc-filter!
+ cache
+ 2cache
} ;
ARTICLE: "assocs" "Associative mapping operations"
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "exemplar" assoc } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "exemplar" } " consisting of all entries for which the predicate quotation yields true." } ;
-{ assoc-filter assoc-filter-as } related-words
+HELP: assoc-filter!
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } }
+{ $description "Removes all entries for which the predicate quotation yields true." }
+{ $side-effects "assoc" } ;
+
+{ assoc-filter assoc-filter-as assoc-filter! } related-words
HELP: assoc-partition
{ $values
{ $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." } ;
-HELP: update
+HELP: assoc-union!
{ $values { "assoc1" assoc } { "assoc2" assoc } }
{ $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
{ $side-effects "assoc1" } ;
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc1" } " whose key is not contained in " { $snippet "assoc2" } "." }
;
+HELP: assoc-diff!
+{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
+{ $description "Removes all entries from " { $snippet "assoc1" } " whose key is contained in " { $snippet "assoc2" } "." }
+{ $side-effects assoc-diff! } ;
+
HELP: substitute
{ $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } }
{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;
[ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test
[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-filter ] unit-test
+[ H{ } ] [ H{ { t f } { f t } } clone dup [ 2drop f ] assoc-filter! drop ] unit-test
+[ H{ } ] [ H{ { t f } { f t } } clone [ 2drop f ] assoc-filter! ] unit-test
+
[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
[ drop 3 >= ] assoc-filter
] unit-test
+[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
+ H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } } clone
+ [ drop 3 >= ] assoc-filter!
+] unit-test
+
+[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
+ H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } } clone dup
+ [ drop 3 >= ] assoc-filter! drop
+] unit-test
+
[ 21 ] [
0 H{
{ 1 2 }
assoc-union
] unit-test
+[
+ H{ { 1 2 } { 2 3 } { 6 5 } }
+] [
+ H{ { 2 4 } { 6 5 } } clone dup H{ { 1 2 } { 2 3 } }
+ assoc-union! drop
+] unit-test
+
+[
+ H{ { 1 2 } { 2 3 } { 6 5 } }
+] [
+ H{ { 2 4 } { 6 5 } } clone H{ { 1 2 } { 2 3 } }
+ assoc-union!
+] unit-test
+
[ H{ { 1 2 } { 2 3 } } t ] [
f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd =
] unit-test
H{ { 1 f } } H{ { 1 f } } assoc-intersect
] unit-test
+[
+ H{ { 3 4 } }
+] [
+ H{ { 1 2 } { 3 4 } } H{ { 1 3 } } assoc-diff
+] unit-test
+
+[
+ H{ { 3 4 } }
+] [
+ H{ { 1 2 } { 3 4 } } clone dup H{ { 1 3 } } assoc-diff! drop
+] unit-test
+
+[
+ H{ { 3 4 } }
+] [
+ H{ { 1 2 } { 3 4 } } clone H{ { 1 3 } } assoc-diff!
+] unit-test
+
[ H{ { "hi" 2 } { 3 4 } } ]
[ "hi" 1 H{ { 1 2 } { 3 4 } } clone [ rename-at ] keep ]
unit-test
: assoc-filter ( assoc quot -- subassoc )
over assoc-filter-as ; inline
+: assoc-filter! ( assoc quot -- assoc )
+ [
+ over [ [ [ drop ] 2bi ] dip [ delete-at ] 2curry unless ] 2curry
+ assoc-each
+ ] [ drop ] 2bi ; inline
+
: assoc-partition ( assoc quot -- true-assoc false-assoc )
[ (assoc-each) partition ] [ drop ] 2bi
[ assoc-like ] curry bi@ ; inline
: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-filter ;
-: update ( assoc1 assoc2 -- )
- swap [ set-at ] with-assoc assoc-each ;
+: assoc-union! ( assoc1 assoc2 -- assoc1 )
+ over [ set-at ] with-assoc assoc-each ;
: assoc-union ( assoc1 assoc2 -- union )
[ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
- [ dupd update ] bi@ ;
+ [ assoc-union! ] bi@ ;
: assoc-combine ( seq -- union )
- H{ } clone [ dupd update ] reduce ;
+ H{ } clone [ assoc-union! ] reduce ;
: assoc-refine ( seq -- assoc )
[ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
+: assoc-differ ( key -- quot )
+ [ nip key? not ] curry ; inline
+
: assoc-diff ( assoc1 assoc2 -- diff )
- [ nip key? not ] curry assoc-filter ;
+ assoc-differ assoc-filter ;
+
+: assoc-diff! ( assoc1 assoc2 -- assoc1 )
+ assoc-differ assoc-filter! ;
: substitute ( seq assoc -- newseq )
substituter map ;
over [ slot-named* ] dip check-slot-exists drop ;
: assoc>object ( class slots values -- tuple )
- [ [ [ initial>> ] map ] keep ] dip
+ [ [ [ initial>> ] map <enum> ] keep ] dip
swap [ [ slot-named-checked ] curry dip ] curry assoc-map
- [ dup <enum> ] dip update boa>object ;
+ assoc-union! seq>> boa>object ;
: parse-tuple-literal-slots ( class slots -- tuple )
scan {
: updated-definitions ( -- assoc )
H{ } clone
- dup forgotten-definitions get update
- dup new-definitions get first update
- dup new-definitions get second update
- dup changed-definitions get update
- dup maybe-changed get update
- dup dup changed-vocabs update ;
+ forgotten-definitions get assoc-union!
+ new-definitions get first assoc-union!
+ new-definitions get second assoc-union!
+ changed-definitions get assoc-union!
+ maybe-changed get assoc-union!
+ dup changed-vocabs assoc-union! ;
: process-forgotten-definitions ( -- )
forgotten-definitions get keys
[ over assumed [ compile-engine ] with-variable ] assoc-map ;
: direct-dispatch-table ( assoc n -- table )
- default get <array> [ <enum> swap update ] keep ;
+ default get <array> <enum> swap assoc-union! seq>> ;
: tag-number ( class -- n ) "type" word-prop ;
tuple assumed [
echelons>> compile-engines
dup keys supremum 1 + f <array>
- [ <enum> swap update ] keep
+ <enum> swap assoc-union! seq>>
] with-variable ;
PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
: define-typecheck ( class generic quot props -- )
[ create-method ] 2dip
- [ [ props>> ] [ drop ] [ ] tri* update ]
+ [ [ props>> ] [ drop ] [ ] tri* assoc-union! drop ]
[ drop define ]
[ 2drop make-inline ]
3tri ;