From 3bc557467e7b01b472bc4372927634a84489847a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 11:40:05 -0600
Subject: [PATCH] shuffle( -- ) arbitrary stack shuffling word

---
 basis/shuffle/shuffle-tests.factor |  2 ++
 basis/shuffle/shuffle.factor       | 23 +++++++++++++++++++++--
 2 files changed, 23 insertions(+), 2 deletions(-)

diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor
index f190544e19..8202146b3d 100644
--- a/basis/shuffle/shuffle-tests.factor
+++ b/basis/shuffle/shuffle-tests.factor
@@ -3,3 +3,5 @@ USING: shuffle tools.test ;
 [ 8 ] [ 5 6 7 8 3nip ] unit-test
 [ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test
 [ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test
+
+[ 4 2 3 ] [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test
diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor
index b195e4abf9..632c09e338 100644
--- a/basis/shuffle/shuffle.factor
+++ b/basis/shuffle/shuffle.factor
@@ -1,9 +1,28 @@
 ! Copyright (C) 2007 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generalizations ;
-
+USING: accessors assocs effects.parser generalizations
+hashtables kernel locals locals.backend macros make math
+parser sequences ;
 IN: shuffle
 
+<PRIVATE
+
+: >locals-assoc ( sequence -- assoc )
+    dup length dup 1- [ - ] curry map zip >hashtable ;
+
+PRIVATE>
+
+MACRO: shuffle-effect ( effect -- )
+    [ out>> ] [ in>> >locals-assoc ] bi
+    [
+        [ nip assoc-size , \ load-locals , ]
+        [ [ at , \ get-local , ] curry each ]
+        [ nip assoc-size , \ drop-locals , ] 2tri
+    ] [ ] make ;
+
+: shuffle(
+    ")" parse-effect parsed \ shuffle-effect parsed ; parsing
+
 : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
 
 : nipd ( a b c -- b c ) rot drop ; inline