assocs: adding assoc-reject, assoc-reject-as, assoc-reject!.
							parent
							
								
									b366a06c41
								
							
						
					
					
						commit
						016e03410d
					
				| 
						 | 
				
			
			@ -151,6 +151,8 @@ $nl
 | 
			
		|||
    assoc-map
 | 
			
		||||
    assoc-filter
 | 
			
		||||
    assoc-filter-as
 | 
			
		||||
    assoc-reject
 | 
			
		||||
    assoc-reject-as
 | 
			
		||||
    assoc-partition
 | 
			
		||||
    assoc-any?
 | 
			
		||||
    assoc-all?
 | 
			
		||||
| 
						 | 
				
			
			@ -169,6 +171,7 @@ $nl
 | 
			
		|||
"Destructive combinators:"
 | 
			
		||||
{ $subsections
 | 
			
		||||
    assoc-filter!
 | 
			
		||||
    assoc-reject!
 | 
			
		||||
    cache
 | 
			
		||||
    2cache
 | 
			
		||||
} ;
 | 
			
		||||
| 
						 | 
				
			
			@ -300,6 +303,21 @@ HELP: assoc-filter!
 | 
			
		|||
 | 
			
		||||
{ assoc-filter assoc-filter-as assoc-filter! } related-words
 | 
			
		||||
 | 
			
		||||
HELP: assoc-reject
 | 
			
		||||
{ $values { "assoc" assoc } { "quot" { $quotation ( ... key value -- ... ? ) } } { "subassoc" "a new assoc" } }
 | 
			
		||||
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields false." } ;
 | 
			
		||||
 | 
			
		||||
HELP: assoc-reject-as
 | 
			
		||||
{ $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 false." } ;
 | 
			
		||||
 | 
			
		||||
HELP: assoc-reject!
 | 
			
		||||
{ $values { "assoc" assoc } { "quot" { $quotation ( ... key value -- ... ? ) } } }
 | 
			
		||||
{ $description "Removes all entries for which the predicate quotation yields false." }
 | 
			
		||||
{ $side-effects "assoc" } ;
 | 
			
		||||
 | 
			
		||||
{ assoc-reject assoc-reject-as assoc-reject! } related-words
 | 
			
		||||
 | 
			
		||||
HELP: assoc-partition
 | 
			
		||||
{ $values
 | 
			
		||||
    { "assoc" assoc } { "quot" quotation }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -50,6 +50,16 @@ IN: assocs.tests
 | 
			
		|||
    [ drop 3 >= ] assoc-filter! drop
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ H{ { 1 2 } { 2 3 } } ] [
 | 
			
		||||
    H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
 | 
			
		||||
    [ drop 3 >= ] assoc-reject
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ H{ { 1 2 } { 2 3 } } ] [
 | 
			
		||||
    H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } } clone
 | 
			
		||||
    [ drop 3 >= ] assoc-reject!
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ 21 ] [
 | 
			
		||||
    0 H{
 | 
			
		||||
        { 1 2 }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -74,12 +74,21 @@ PRIVATE>
 | 
			
		|||
: assoc-filter ( ... assoc quot: ( ... key value -- ... ? ) -- ... subassoc )
 | 
			
		||||
    over assoc-filter-as ; inline
 | 
			
		||||
 | 
			
		||||
: assoc-reject-as ( ... assoc quot: ( ... key value -- ... ? ) exemplar -- ... subassoc )
 | 
			
		||||
    [ [ not ] compose ] [ assoc-filter-as ] bi* ; inline
 | 
			
		||||
 | 
			
		||||
: assoc-reject ( ... assoc quot: ( ... key value -- ... ? ) -- ... subassoc )
 | 
			
		||||
    over assoc-reject-as ; inline
 | 
			
		||||
 | 
			
		||||
: assoc-filter! ( ... assoc quot: ( ... key value -- ... ? ) -- ... assoc )
 | 
			
		||||
    [
 | 
			
		||||
        over [ [ [ drop ] 2bi ] dip [ delete-at ] 2curry unless ] 2curry
 | 
			
		||||
        assoc-each
 | 
			
		||||
    ] [ drop ] 2bi ; inline
 | 
			
		||||
 | 
			
		||||
: assoc-reject! ( ... assoc quot: ( ... key value -- ... ? ) -- ... assoc )
 | 
			
		||||
    [ not ] compose assoc-filter! ; inline
 | 
			
		||||
 | 
			
		||||
: sift-keys ( assoc -- assoc' )
 | 
			
		||||
    [ drop ] assoc-filter ; inline
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue