assocs.extra: Add a word to keep only certain keys in an assoc to the same assoc...

diff --git a/extra/assocs/extras/extras-tests.factor b/extra/assocs/extras/extras-tests.factor
index 3034a01784382694f81252b7c4b0e1f55a64c4c7..23dd663aff2cf6793a9c34644478ad641fa21ac5 100644 (file)
--- a/extra/assocs/extras/extras-tests.factor
+++ b/extra/assocs/extras/extras-tests.factor
@@ -54,4 +54,30 @@ USING: assocs.extras kernel math sequences tools.test ;
     H{ { 1 [ sq ] } { 2 [ sq ] } }
 } [
     { { { 1 2 { 1 } { 2 } { 1 1 } } [ sq ] } } flatten-keys
+] unit-test
+
+{
+    H{ { "1" 1 } { "2" 2 } }
+} [
+    H{ { "1" 1 } { "2" 2 } { "3" 3 } }
+    { "1" "2" "2" }
+    rekey-new-assoc
+] unit-test
+
+{ f } [
+    H{ { "1" 1 } { "2" 2 } { "3" 3 } }
+    [ { "1" "2" "2" } rekey-new-assoc ] keep eq?
+] unit-test
+
+{
+    H{ { "1" 1 } { "2" 2 } }
+} [
+    H{ { "1" 1 } { "2" 2 } { "3" 3 } }
+    { "1" "2" "2" }
+    rekey-assoc
+] unit-test
+
+{ t } [
+    H{ { "1" 1 } { "2" 2 } { "3" 3 } }
+    [ { "1" "2" "2" } rekey-assoc ] keep eq?
 ] unit-test
\ No newline at end of file

diff --git a/extra/assocs/extras/extras.factor b/extra/assocs/extras/extras.factor
index e0f78dbdd1f0d5b2722b20a92044db4b13a35719..472f1b94a58f3792cb93b9b2dbc8e50f281898dc 100644 (file)
--- a/extra/assocs/extras/extras.factor
+++ b/extra/assocs/extras/extras.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2012 John Benediktsson, Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license
 USING: arrays assocs assocs.private fry generalizations kernel
-math math.statistics sequences sequences.extras ;
+math math.statistics sequences sequences.extras sets ;
 IN: assocs.extras
 
 : deep-at ( assoc seq -- value/f )
@@ -41,6 +41,12 @@ IN: assocs.extras
 : reject-values ( assoc quot: ( value -- value' ) -- assoc' )
     '[ nip @ ] assoc-reject ; inline
 
+: rekey-new-assoc ( assoc keys -- newassoc )
+    [ [ of ] keep swap ] with H{ } map>assoc ; inline
+
+: rekey-assoc ( assoc keys -- assoc )
+    [ dup keys ] dip diff over [ delete-at ] curry each ; inline
+
 : if-assoc-empty ( ..a assoc quot1: ( ..a -- ..b ) quot2: ( ..a assoc -- ..b ) -- ..b )
     [ dup assoc-empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline