From f9886da504740a4f760530d9b9e7d09722155270 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 7 Oct 2004 03:34:22 +0000
Subject: [PATCH] some code cleanups, remove usages of deprecated combinators

---
 library/combinators.factor          | 96 +++++++++++++++--------------
 library/httpd/url-encoding.factor   |  8 +--
 library/math/namespace-math.factor  |  8 +--
 library/math/pow.factor             |  4 +-
 library/math/quadratic.factor       |  4 +-
 library/namespaces.factor           | 13 ++--
 library/random.factor               | 23 +++----
 library/sbuf.factor                 |  4 +-
 library/strings.factor              | 28 ++++-----
 library/test/math/namespaces.factor | 14 +++++
 library/test/random.factor          | 15 ++++-
 library/test/strings.factor         | 12 ++++
 library/test/test.factor            |  1 +
 library/vector-combinators.factor   |  8 +--
 14 files changed, 134 insertions(+), 104 deletions(-)
 create mode 100644 library/test/math/namespaces.factor

diff --git a/library/combinators.factor b/library/combinators.factor
index eb01315e8f..7ca1d1c1cf 100644
--- a/library/combinators.factor
+++ b/library/combinators.factor
@@ -30,18 +30,6 @@ USE: kernel
 USE: lists
 USE: stack
 
-: 2apply ( x y quot -- )
-    #! First applies the code to x, then to y.
-    #!
-    #! If the quotation compiles, this combinator compiles.
-    2dup >r >r nip call r> r> call ; inline interpret-only
-
-: cleave ( x quot quot -- )
-    #! Executes each quotation, with x on top of the stack.
-    #!
-    #! If the quotation compiles, this combinator compiles.
-    >r over >r call r> r> call ; inline interpret-only
-
 : slip ( quot x -- x )
     >r call r> ; inline interpret-only
 
@@ -51,30 +39,15 @@ USE: stack
 : 3slip ( quot x y z -- x y z )
     >r >r >r call r> r> r> ; inline interpret-only
 
-: dip ( a [ b ] -- b a )
-    #! Call b as if b was not present on the stack.
-    #!
-    #! If the quotation compiles, this combinator compiles.
-    swap >r call r> ; inline interpret-only
-
-: 2dip ( a b [ c ] -- c a b )
-    #! Call c as if a and b were not present on the stack.
-    #!
-    #! If the quotation compiles, this combinator compiles.
-    -rot >r >r call r> r> ; inline interpret-only
-
-: forever ( quot -- )
-    #! The code is evaluated in an infinite loop. Typically, a
-    #! continuation is used to escape the infinite loop.
-    #!
-    #! This combinator will not compile.
-    dup dip forever ; interpret-only
-
 : keep ( a quot -- a )
     #! Execute the quotation with a on the stack, and restore a
     #! after the quotation returns.
     over >r call r> ;
 
+: apply ( code input -- code output )
+    #! Apply code to input.
+    swap dup >r call r> swap ;
+
 : cond ( x list -- )
     #! The list is of this form:
     #!
@@ -111,20 +84,6 @@ USE: stack
     pick [ drop call ] [ nip nip call ] ifte ;
     inline interpret-only
 
-: interleave ( X quot -- )
-    #! Evaluate each element of the list with X on top of the
-    #! stack. When done, X is popped off the stack.
-    #!
-    #! To avoid unexpected results, each element of the list
-    #! must have stack effect ( X -- ).
-    #!
-    #! This combinator will not compile.
-    dup [
-        over [ unswons dip ] dip swap interleave
-    ] [
-        2drop
-    ] ifte ; interpret-only
-
 : unless ( cond quot -- )
     #! Execute a quotation only when the condition is f. The
     #! condition is popped off the stack.
@@ -158,6 +117,53 @@ USE: stack
     #! value than it produces.
     over [ call ] [ 2drop ] ifte ; inline interpret-only
 
+: forever ( quot -- )
+    #! The code is evaluated in an infinite loop. Typically, a
+    #! continuation is used to escape the infinite loop.
+    #!
+    #! This combinator will not compile.
+    dup dip forever ; interpret-only
+
+! DEPRECATED
+
+: 2apply ( x y quot -- )
+    #! First applies the code to x, then to y.
+    #!
+    #! If the quotation compiles, this combinator compiles.
+    2dup >r >r nip call r> r> call ; inline interpret-only
+
+: cleave ( x quot quot -- )
+    #! Executes each quotation, with x on top of the stack.
+    #!
+    #! If the quotation compiles, this combinator compiles.
+    >r over >r call r> r> call ; inline interpret-only
+
+: dip ( a [ b ] -- b a )
+    #! Call b as if b was not present on the stack.
+    #!
+    #! If the quotation compiles, this combinator compiles.
+    swap >r call r> ; inline interpret-only
+
+: 2dip ( a b [ c ] -- c a b )
+    #! Call c as if a and b were not present on the stack.
+    #!
+    #! If the quotation compiles, this combinator compiles.
+    -rot >r >r call r> r> ; inline interpret-only
+
+: interleave ( X quot -- )
+    #! Evaluate each element of the list with X on top of the
+    #! stack. When done, X is popped off the stack.
+    #!
+    #! To avoid unexpected results, each element of the list
+    #! must have stack effect ( X -- ).
+    #!
+    #! This combinator will not compile.
+    dup [
+        over [ unswons dip ] dip swap interleave
+    ] [
+        2drop
+    ] ifte ; interpret-only
+
 : while ( cond body -- )
     #! Evaluate cond. If it leaves t on the stack, evaluate
     #! body, and recurse.
diff --git a/library/httpd/url-encoding.factor b/library/httpd/url-encoding.factor
index 3a657ace23..e8aa7ff004 100644
--- a/library/httpd/url-encoding.factor
+++ b/library/httpd/url-encoding.factor
@@ -47,14 +47,14 @@ USE: unparser
     ] [
         ! Note that hex> will push f if there is an invalid
         ! hex literal
-        [ succ dup 2 + ] dip substring hex> [ >char % ]  when*
+        >r succ dup 2 + r> substring hex> [ >char % ] when*
     ] ifte ;
 
 : url-decode-% ( index str -- index str )
-    2dup url-decode-hex [ 3 + ] dip ;
+    2dup url-decode-hex >r 3 + r> ;
 
-: url-decode-+-or-other ( index str -- index str )
-    CHAR: + CHAR: \s replace % [ succ ] dip ;
+: url-decode-+-or-other ( index str ch -- index str )
+    CHAR: + CHAR: \s replace % >r succ r> ;
 
 : url-decode-iter ( index str -- )
     2dup str-length >= [
diff --git a/library/math/namespace-math.factor b/library/math/namespace-math.factor
index 3283946428..93f7248c47 100644
--- a/library/math/namespace-math.factor
+++ b/library/math/namespace-math.factor
@@ -31,10 +31,10 @@ USE: logic
 USE: namespaces
 USE: stack
 
-: +@ ( num var -- ) dup [ get + ] dip set ;
-: -@ ( num var -- ) dup [ get swap - ] dip set ;
-: *@ ( num var -- ) dup [ get * ] dip set ;
-: /@ ( num var -- ) dup [ get / ] dip set ;
+: +@ ( num var -- ) tuck get + put ;
+: -@ ( num var -- ) tuck get swap - put ;
+: *@ ( num var -- ) tuck get * put ;
+: /@ ( num var -- ) tuck get swap / put ;
 : neg@ ( var -- ) dup get neg put ;
 : pred@ ( var -- ) dup get pred put ;
 : succ@ ( var -- ) dup get succ put ;
diff --git a/library/math/pow.factor b/library/math/pow.factor
index a8ffae1d47..031633212b 100644
--- a/library/math/pow.factor
+++ b/library/math/pow.factor
@@ -47,10 +47,10 @@ USE: logic
     ] ifte ;
 
 : ^mag ( w abs arg -- magnitude )
-    [ [ >rect swap ] dip swap fpow ] dip rot * fexp / ;
+    >r >r >rect swap r> swap fpow r> rot * fexp / ;
 
 : ^theta ( w abs arg -- theta )
-    [ [ >rect ] dip flog * swap ] dip * + ;
+    >r >r >rect r> flog * swap r> * + ;
 
 : ^ ( z w -- z^w )
     over real? over integer? and [
diff --git a/library/math/quadratic.factor b/library/math/quadratic.factor
index 8200316bda..8ed80ff3c4 100644
--- a/library/math/quadratic.factor
+++ b/library/math/quadratic.factor
@@ -31,7 +31,7 @@ USE: math
 USE: stack
 
 : quadratic-complete ( a b c -- a b c a b )
-    [ 2dup ] dip -rot ;
+    >r 2dup r> -rot ;
 
 : quadratic-d ( c a b -- sqrt[b^2 - 4*a*c] )
     sq -rot 4 * * - sqrt ;
@@ -40,7 +40,7 @@ USE: stack
     neg swap / 2 / ;
 
 : quadratic-roots ( a b d -- alpha beta )
-    3dup - quadratic-root [ + quadratic-root ] dip ;
+    3dup - quadratic-root >r + quadratic-root r> ;
 
 : quadratic ( a b c -- alpha beta )
     #! Finds both roots of the polynomial a*x^2 + b*x + c using
diff --git a/library/namespaces.factor b/library/namespaces.factor
index 987e4283ed..0c59a67b49 100644
--- a/library/namespaces.factor
+++ b/library/namespaces.factor
@@ -96,7 +96,7 @@ USE: vectors
 : lazy ( var [ a ] -- value )
     #! If the value of the variable is f, set the value to the
     #! result of evaluating [ a ].
-    over get [ drop get ] [ dip dupd set ] ifte ;
+    over get [ drop get ] [ swap >r call dup r> set ] ifte ;
 
 : alist> ( alist namespace -- )
     #! Set each key in the alist to its value in the
@@ -106,20 +106,17 @@ USE: vectors
 : alist>namespace ( alist -- namespace )
     <namespace> tuck alist> ;
 
-: object-path-traverse ( name object -- object )
+: traverse-path ( name object -- object )
     dup has-namespace? [ get* ] [ 2drop f ] ifte ;
 
-: object-path-iter ( object list -- object )
-    [
-        uncons [ swap object-path-traverse ] dip
-        object-path-iter
-    ] when* ;
+: (object-path) ( object list -- object )
+    [ uncons >r swap traverse-path r> (object-path) ] when* ;
 
 : object-path ( list -- object )
     #! An object path is a list of strings. Each string is a
     #! variable name in the object namespace at that level.
     #! Returns f if any of the objects are not set.
-    this swap object-path-iter ;
+    this swap (object-path) ;
 
 : on ( var -- ) t put ;
 : off ( var -- ) f put ;
diff --git a/library/random.factor b/library/random.factor
index ef31058884..1e0c28ec17 100644
--- a/library/random.factor
+++ b/library/random.factor
@@ -65,7 +65,7 @@ USE: stack
 
 : random-element-iter ( list index -- elem )
     #! Used by random-element*. Do not call directly.
-    [ unswons unswons ] dip ( list elem probability index )
+    >r unswons unswons r>   ( list elem probability index )
     swap -                  ( list elem index )
     dup 0 <= [
         drop nip
@@ -84,16 +84,13 @@ USE: stack
     #! Returns a random subset of the given list of comma pairs.
     #! The car of each pair is a probability, the cdr is the
     #! item itself. Only the cdr of the comma pair is returned.
-    dup [ [ [ ] ] dip car+ ] dip ( [ ] probabilitySum list )
-    [
-        [ 1 over random-int ] dip ( [ ] probabilitySum probability elem )
-        uncons ( [ ] probabilitySum probability elema elemd )
-        -rot ( [ ] probabilitySum elemd probability elema )
-        > ( [ ] probabilitySum elemd boolean )
+    [,
+        [ car+ ] keep ( probabilitySum list )
         [
-            drop
-        ] [
-            -rot ( elemd [ ] probabilitySum )
-            [ cons ] dip ( [ elemd ] probabilitySum )
-        ] ifte
-    ] each drop ;
+            >r 1 over random-int r> ( probabilitySum probability elem )
+            uncons ( probabilitySum probability elema elemd )
+            -rot ( probabilitySum elemd probability elema )
+            > ( probabilitySum elemd boolean )
+            [ drop ] [ , ] ifte
+        ] each drop
+    ,] ;
diff --git a/library/sbuf.factor b/library/sbuf.factor
index 145ca7255e..809558ce49 100644
--- a/library/sbuf.factor
+++ b/library/sbuf.factor
@@ -67,7 +67,9 @@ USE: stack
     #! Apply a quotation to each character in the string, and
     #! push a new string constructed from return values.
     #! The quotation must have stack effect ( X -- X ).
-    <% swap [ swap dup >r call % r> ] str-each drop %> ;
+    over str-length <sbuf> rot [
+        swap >r apply r> tuck sbuf-append
+    ] str-each nip sbuf>str ;
 
 : split-next ( index string split -- next )
     3dup index-of* dup -1 = [
diff --git a/library/strings.factor b/library/strings.factor
index 06cdbb10bf..30e7bff038 100644
--- a/library/strings.factor
+++ b/library/strings.factor
@@ -80,45 +80,39 @@ USE: stack
 : str/ ( str index -- str str )
     #! Returns 2 strings, that when concatenated yield the
     #! original string.
-    2dup str-tail [ str-head ] dip ;
+    2dup str-tail >r str-head r> ;
 
 : str// ( str index -- str str )
     #! Returns 2 strings, that when concatenated yield the
     #! original string, without the character at the given
     #! index.
-    2dup succ str-tail [ str-head ] dip ;
+    2dup succ str-tail >r str-head r> ;
 
 : >title ( str -- str )
-    1 str/ [ >upper ] dip >lower cat2 ;
+    1 str/ >r >upper r> >lower cat2 ;
 
 : str-headcut ( str begin -- str str )
     str-length str/ ;
 
+: =? ( x y z -- z/f )
+    #! Push z if x = y, otherwise f.
+    -rot = [ drop f ] unless ;
+
 : str-head? ( str begin -- str )
     #! If the string starts with begin, return the rest of the
     #! string after begin. Otherwise, return f.
-    2dup str-length< [
-        2drop f
-    ] [
-        tuck str-headcut
-        [ = ] dip f ?
-    ] ifte ;
+    2dup str-length< [ 2drop f ] [ tuck str-headcut =? ] ifte ;
 
 : ?str-head ( str begin -- str ? )
     dupd str-head? dup [ nip t ] [ drop f ] ifte ;
 
 : str-tailcut ( str end -- str str )
-    str-length [ dup str-length ] dip - str/ ;
+    str-length >r dup str-length r> - str/ swap ;
 
 : str-tail? ( str end -- str )
     #! If the string ends with end, return the start of the
     #! string before end. Otherwise, return f.
-    2dup str-length< [
-        2drop f
-    ] [
-        tuck str-tailcut swap
-        [ = ] dip f ?
-    ] ifte ;
+    2dup str-length< [ 2drop f ] [ tuck str-tailcut =? ] ifte ;
 
 : ?str-tail ( str end -- str ? )
     dupd str-tail? dup [ nip t ] [ drop f ] ifte ;
@@ -143,7 +137,7 @@ USE: stack
     #! Execute the code, with each character of the string
     #! pushed onto the stack.
     over str-length [
-        -rot 2dup [ [ str-nth ] dip call ] 2dip
+        -rot 2dup >r >r >r str-nth r> call r> r>
     ] times* 2drop ;
 
 : str-sort ( list -- sorted )
diff --git a/library/test/math/namespaces.factor b/library/test/math/namespaces.factor
new file mode 100644
index 0000000000..951c691370
--- /dev/null
+++ b/library/test/math/namespaces.factor
@@ -0,0 +1,14 @@
+IN: scratchpad
+USE: namespaces
+USE: test
+USE: math
+
+5 "x" set
+
+[ 6 ] [ 1 "x" +@ "x" get ] unit-test
+[ 5 ] [ 1 "x" -@ "x" get ] unit-test
+[ 10 ] [ 2 "x" *@ "x" get ] unit-test
+[ 2 ] [ 5 "x" /@ "x" get ] unit-test
+[ -2 ] [ "x" neg@ "x" get ] unit-test
+[ -3 ] [ "x" pred@ "x" get ] unit-test
+[ -2 ] [ "x" succ@ "x" get ] unit-test
diff --git a/library/test/random.factor b/library/test/random.factor
index 2373f05df5..915573ad1a 100644
--- a/library/test/random.factor
+++ b/library/test/random.factor
@@ -16,15 +16,28 @@ unit-test
     [ 10 | t ]
     [ 20 | f ]
     [ 30 | "monkey" ]
+    [ 24 | 1/2 ]
+    [ 13 | { "Hello" "Banana" } ]
 ] "random-pairs" set
 
+"random-pairs" get [ cdr ] map "random-values" set
+
 [ f ]
 [
     "random-pairs" get
-    random-element* [ t f "monkey" ] contains? not
+    random-element* "random-values" get contains? not
 ] unit-test
 
 : check-random-int ( min max -- )
     2dup random-int -rot between? assert ;
 
 [ ] [ 100 [ -12 674 check-random-int ] times ] unit-test
+
+: check-random-subset ( expected pairs -- )
+    random-subset* [ over contains? ] all? nip ;
+
+[ t ] [
+    "random-values" get
+    "random-pairs" get
+    check-random-subset
+] unit-test
diff --git a/library/test/strings.factor b/library/test/strings.factor
index 5c98bc8458..9e306a4dc4 100644
--- a/library/test/strings.factor
+++ b/library/test/strings.factor
@@ -91,3 +91,15 @@ unit-test
 [ f ] [ [ 0 10 "hello" substring ] [ not ] catch ] unit-test
 
 [ [ "hell" "o wo" "rld" ] ] [ 4 "hello world" split-n ] unit-test
+
+[ 4 ] [
+    0 "There are Four Upper Case characters"
+    [ LETTER? [ succ ] when ] str-each
+] unit-test
+
+[ "Replacing+spaces+with+plus" ]
+[
+    "Replacing spaces with plus"
+    [ CHAR: \s CHAR: + replace ] str-map
+]
+unit-test
diff --git a/library/test/test.factor b/library/test/test.factor
index 20ba8a397a..87d60954ed 100644
--- a/library/test/test.factor
+++ b/library/test/test.factor
@@ -98,6 +98,7 @@ USE: unparser
         "math/complex"
         "math/irrational"
         "math/simpson"
+        "math/namespaces"
         "httpd/url-encoding"
         "httpd/html"
         "httpd/httpd"
diff --git a/library/vector-combinators.factor b/library/vector-combinators.factor
index ef6e023e7d..8b13a1d05a 100644
--- a/library/vector-combinators.factor
+++ b/library/vector-combinators.factor
@@ -39,18 +39,12 @@ USE: stack
         -rot 2dup >r >r >r vector-nth r> call r> r>
     ] times* 2drop ;
 
-: (vector-map-step) ( element code -- result code )
-    dup >r call r> ;
-
-: (vector-map) ( code target element -- result code target )
-    -rot >r (vector-map-step) r> ;
-
 : vector-map ( vector code -- vector )
     #! Applies code to each element of the vector, return a new
     #! vector with the results. The code must have stack effect
     #! ( obj -- obj ).
     over vector-length <vector> rot [
-        (vector-map) swapd tuck vector-push
+        swap >r apply r> tuck vector-push
     ] vector-each nip ;
 
 : vector-and ( vector -- ? )