successor: new vocab.

extra/successor/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

extra/successor/successor-docs.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2011 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: help.markup help.syntax successor strings ;
+
+IN: succesor
+
+HELP: successor
+{ $values { "str" string } }
+{ $description
+    "Returns the successor to " { $snippet "str" } ". The successor is calculated by incrementing characters starting from the rightmost alphanumeric (or the rightmost character if there are no alphanumerics) in the string. Incrementing a digit always results in another digit, and incrementing a letter results in another letter of the same case. "
+    $nl
+    "If the increment generates a carry, the character to the left of it is incremented. This process repeats until there is no carry, adding an additional character if necessary. "
+} ;
+
+

extra/successor/successor-tests.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2011 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: successor tools.test ;
+
+IN: successor
+
+[ "" ] [ "" successor ] unit-test
+[ "abce" ] [ "abcd" successor ] unit-test
+[ "THX1139" ] [ "THX1138" successor ] unit-test
+[ "<<koalb>>" ] [ "<<koala>>" successor ] unit-test
+[ "2000aaa" ] [ "1999zzz" successor ] unit-test
+[ "AAAA0000" ] [ "ZZZ9999" successor ] unit-test
+[ "**+" ] [ "***" successor ] unit-test

extra/successor/successor.factor

@@ -0,0 +1,46 @@
+! Copyright (C) 2011 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: ascii combinators combinators.short-circuit fry kernel
+math sequences ;
+
+IN: successor
+
+<PRIVATE
+
+: carry ( elt last first -- ? elt' )
+    '[ _ > dup _ ] keep ? ;
+
+: next-digit ( ch -- ? ch' )
+    1 + CHAR: 9 CHAR: 0 carry ;
+
+: next-letter ( ch -- ? ch' )
+    [ ch>lower 1 + CHAR: z CHAR: a carry ] [ LETTER? ] bi
+    [ ch>upper ] when ;
+
+: next-char ( ch -- ? ch' )
+    {
+        { [ dup digit?  ] [ next-digit  ] }
+        { [ dup Letter? ] [ next-letter ] }
+        [ t swap ]
+    } cond ;
+
+: map-until ( seq quot: ( elt -- ? elt' ) -- seq' ? )
+    [ t 0 pick length '[ 2dup _ < and ] ] dip '[
+        nip [ over _ change-nth ] keep 1 +
+    ] while drop ; inline
+
+: alphanum? ( ch -- ? )
+    { [ Letter? ] [ digit? ] } 1|| ;
+
+PRIVATE>
+
+: successor ( str -- str' )
+    dup empty? [
+        dup [ alphanum? ] any? [
+            reverse [ next-char ] map-until
+            [ dup last suffix ] when reverse
+        ] [
+            dup length 1 - over [ 1 + ] change-nth
+        ] if
+    ] unless ;