From 4b4d93dddd09f6ec3ec3dc04988eee7e512299ff Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 20 Jan 2009 15:27:14 -0600
Subject: [PATCH] Move at-default from unicode.case to assocs, move 2cache from
 classes.algebra to assocs, clean up some code to no longer use -rot, rot,
 pick

---
 basis/unicode/case/case.factor      |  2 --
 core/assocs/assocs-tests.factor     | 12 ++++++++++++
 core/assocs/assocs.factor           | 26 +++++++++++++++-----------
 core/classes/algebra/algebra.factor |  3 ---
 core/splitting/splitting.factor     | 26 +++++++++++++++-----------
 5 files changed, 42 insertions(+), 27 deletions(-)

diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor
index 555a39ac88..7566138e11 100644
--- a/basis/unicode/case/case.factor
+++ b/basis/unicode/case/case.factor
@@ -8,8 +8,6 @@ QUALIFIED: ascii
 IN: unicode.case
 
 <PRIVATE
-: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; inline
-
 : ch>lower ( ch -- lower ) simple-lower at-default ; inline
 : ch>upper ( ch -- upper ) simple-upper at-default ; inline
 : ch>title ( ch -- title ) simple-title at-default ; inline
diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index 969c7249a9..ac82da7b9b 100644
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -118,3 +118,15 @@ unit-test
         { "nachos" "cheese" }
     } extract-keys
 ] unit-test
+
+[ f ] [
+    "a" H{ { "a" f } } at-default
+] unit-test
+
+[ "b" ] [
+    "b" H{ { "a" f } } at-default
+] unit-test
+
+[ "x" ] [
+    "a" H{ { "a" "x" } } at-default
+] unit-test
\ No newline at end of file
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 748300ef0f..7f34c3b19d 100644
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov
+! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences arrays math sequences.private vectors
 accessors ;
@@ -41,8 +41,7 @@ GENERIC: >alist ( assoc -- newassoc )
     over assoc-map-as ; inline
 
 : assoc-push-if ( key value quot accum -- )
-    [ 2keep rot ] dip swap
-    [ [ 2array ] dip push ] [ 3drop ] if ; inline
+    [ 2keep ] dip [ [ 2array ] dip push ] 3curry when ; inline
 
 : assoc-pusher ( quot -- quot' accum )
     V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
@@ -62,9 +61,12 @@ GENERIC: >alist ( assoc -- newassoc )
 : at ( key assoc -- value/f )
     at* drop ; inline
 
+: at-default ( key assoc -- value/key )
+    2dup at* [ 2nip ] [ 2drop ] if ; inline
+
 M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     over assoc-size swap new-assoc
-    swap [ swap pick set-at ] assoc-each ;
+    [ [ swapd set-at ] curry assoc-each ] keep ;
 
 : keys ( assoc -- keys )
     [ drop ] { } assoc>map ;
@@ -76,7 +78,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     [ at* ] 2keep delete-at ;
 
 : rename-at ( newkey key assoc -- )
-    tuck delete-at* [ -rot set-at ] [ 3drop ] if ;
+    [ delete-at* ] keep [ swapd set-at ] curry [ 2drop ] if ;
 
 : assoc-empty? ( assoc -- ? )
     assoc-size zero? ;
@@ -132,14 +134,16 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     substituter map ;
 
 : cache ( key assoc quot -- value )
-    2over at* [
-        [ 3drop ] dip
-    ] [
-        drop pick rot [ call dup ] 2dip set-at
-    ] if ; inline
+    [ [ at* ] 2keep ] dip
+    [ [ nip call dup ] [ drop ] 3bi set-at ] 3curry
+    [ drop ] prepose
+    unless ; inline
+
+: 2cache ( key1 key2 assoc quot -- value )
+    [ 2array ] 2dip [ first2 ] prepose cache ; inline
 
 : change-at ( key assoc quot -- )
-    [ [ at ] dip call ] 3keep drop set-at ; inline
+    [ [ at ] dip call ] [ drop ] 3bi set-at ; inline
 
 : at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
 
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 1b86ce0b0a..4625c665bf 100644
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -17,9 +17,6 @@ TUPLE: anonymous-complement class ;
 
 C: <anonymous-complement> anonymous-complement
 
-: 2cache ( key1 key2 assoc quot -- value )
-    [ 2array ] 2dip [ first2 ] prepose cache ; inline
-
 GENERIC: valid-class? ( obj -- ? )
 
 M: class valid-class? drop t ;
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
index a2a302d995..e31a25b687 100644
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math make strings arrays vectors sequences
 sets math.order accessors ;
@@ -16,19 +16,23 @@ IN: splitting
 : ?tail-slice ( seq end -- newseq ? )
     2dup tail? [ length head-slice* t ] [ drop f ] if ;
 
+: (split1) ( seq subseq -- start end ? )
+    tuck swap start dup
+    [ swap [ drop ] [ length + ] 2bi t ]
+    [ 2drop f f f ]
+    if ;
+
 : split1 ( seq subseq -- before after )
-    dup pick start dup [
-        [ [ over ] dip head -rot length ] keep + tail
-    ] [
-        2drop f
-    ] if ;
+    [ drop ] [ (split1) ] 2bi
+    [ [ over ] dip [ head ] [ tail ] 2bi* ]
+    [ 2drop f ]
+    if ;
 
 : split1-slice ( seq subseq -- before-slice after-slice )
-    dup pick start dup [
-        [ [ over ] dip head-slice -rot length ] keep + tail-slice
-    ] [
-        2drop f
-    ] if ;
+    [ drop ] [ (split1) ] 2bi
+    [ [ over ] dip [ head-slice ] [ tail-slice ] 2bi* ]
+    [ 2drop f ]
+    if ;
 
 : split1-last ( seq subseq -- before after )
     [ <reversed> ] bi@ split1 [ reverse ] bi@
-- 
2.11.4.GIT