From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 29 Aug 2020 23:43:10 +0000 (-0500)
Subject: assocs.extra: Add a word to keep only certain keys in an assoc to the same assoc... 
X-Git-Tag: 0.99~3105
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=ce3049decd51de1739cc25d59334869ef4bd4679

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

diff --git a/extra/assocs/extras/extras-tests.factor b/extra/assocs/extras/extras-tests.factor
index 3034a01784..23dd663aff 100644
--- 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 e0f78dbdd1..472f1b94a5 100644
--- 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