CREATE string.txt  \ Leo Wong  4 April 02003 fyj +
\ -leading -trailing-white /char <scan <word alpha? append args c!+
\ c+! cappend cexchange digit? flip icompare insert lower lower? place
\ s/r scan scan-white skip skip-white slower split squeeze sscan
\ string string, string.txt supper trim turn upper upper? white? word>

1 CHARS CONSTANT /char  ( -- n )  \ Length of a character

: c+!  ( c ca -- )  \ Character +!
   DUP >R C@ + R> C! ;

: c!+  ( ca1 c -- ca2 )  \ Store c; bump ca1
   OVER C! CHAR+ ;

: place  ( ca u s -- )  \ Put ca u as the counted string at s
   2DUP 2>R CHAR+ SWAP CHARS MOVE 2R> C! ;

: string,  ( ca u -- )  \ Compile ca u
   HERE  OVER 1+ CHARS ALLOT place ;

: string  ( ca u -- )  ( -- ca u )  \ Define a string constant
   CREATE  ( ca u -- )  string, DOES>  ( -- ca u )  COUNT ;

: append  ( ca u s -- )  \ Add ca u to the counted string s
   2DUP 2>R  COUNT CHARS +  SWAP CMOVE  2R> c+! ;

: cappend  ( c s -- )  \ Add c to the counted string s
   1 OVER c+! COUNT 1- CHARS + C! ;

: cexchange  ( ca1 ca2 -- )  \ Swap characters of ca1 and ca2
   2DUP 2>R  C@ SWAP C@  R> C!  R> C! ;

: squeeze  ( a1 a2 n -- a1+n a2-n )  \ Add/subtract n to/from a1/a2  
   TUCK - >R + R> ;

: turn  ( ca u -- )  \ Reverse string ca u
   1- CHARS  OVER +  ( start-addr end-addr )
   BEGIN  2DUP U< WHILE  2DUP cexchange /char squeeze REPEAT 2DROP ;

: flip  ( ca u n -- )  \ Divide ca u at n; exchange places
   >R 2DUP OVER R@  turn R> /STRING  turn turn ;

: insert  ( ca u s n -- )  \ Put ca u in the counted string s at n
   OVER C@ OVER - >R >R DUP >R append R> COUNT R> /STRING R> flip ;

: skip  ( ca1 u1 c -- ca2 u2 )  \ Bypass leading c's in ca1 u1
   >R BEGIN DUP WHILE OVER C@ R@ = WHILE 1 /STRING REPEAT THEN
   R> DROP ;

: scan  ( ca1 u1 c -- ca2 u2 )  \ Look for first c in ca1 u1
   >R
   BEGIN DUP WHILE OVER C@ R@ <> WHILE 1 /STRING REPEAT THEN
   R> DROP ;

: <scan ( ca u1 c -- ca u2|0 )  \ Scan ca1 u backwards for c
   >R  BEGIN  DUP WHILE 1- 2DUP CHARS + C@ R@ = UNTIL 1+ THEN
   R> DROP  ;

: white?  ( c -- bool )  \ True if c <= space
   BL 1+ U< ;

: skip-white  ( ca1 u1 -- ca2 u2 )  \ Skip leading white characters
   BEGIN DUP WHILE OVER C@ white? WHILE 1 /STRING REPEAT THEN ;

: scan-white  ( ca u -- ca1 u1 )  \ Look for first white character
   BEGIN DUP WHILE OVER C@ white? 0= WHILE 1 /STRING REPEAT THEN ;

: -trailing-white ( ca u1 -- ca u2 )  \ Cut trailing white characters
   BEGIN  DUP WHILE 1- 2DUP CHARS + C@ white? 0= UNTIL 1+ THEN ;

: split  ( ca u c -- ca1 u1 ca2 u2 )  \ Divide ca u at c; ca2 u2 has c
   >R 2DUP R> scan 2SWAP 2 PICK - ;

: upper? ( c -- bool )  \ True if c is an uppercase letter
   [CHAR] A - 26 U< ;

: lower? ( c -- bool )  \ True if c is a lowercase letter
   [CHAR] a - 26 U< ;

: alpha?  ( c -- bool )  \ True if c a letter of either case
   DUP upper? SWAP lower? OR ;

: digit?  ( c -- bool )  \ True if c is a decimal digit
   [CHAR] 0 - 10 U< ;

: upper  ( c1 -- c2 )  \ If c is lowercase, make it upper
   DUP lower? BL AND XOR ;

: supper  ( ca u -- )  \ Make ca u uppercase
   0 ?DO DUP C@ upper C!+  LOOP DROP ;

: lower  ( c1 -- c2 )  \ If c is uppercase, make it lower
   DUP upper?  BL AND XOR ;

: slower  ( ca u -- )  \ Make ca u lowercase
   0 ?DO DUP C@ lower C!+  LOOP DROP ;

: icompare  ( ca1 u1 ca2 u2 -- -1|0|1 )  \ Case-insensitive COMPARE
   ROT 2DUP - >R MIN
   BEGIN DUP
   WHILE >R >R COUNT upper R> COUNT upper ROT -
   ?DUP R> 1- SWAP UNTIL DROP THEN NIP NIP
   R> OVER IF SWAP THEN NIP DUP IF 0> -1 AND 1 OR THEN ;

: -leading  ( ca1 u1 -- ca2 u2 )  BL skip ;  \ Bypass leading spaces

: trim  ( ca1 u1 -- ca2 u2 )  \ Cut leading and trailing spaces
   -leading -TRAILING ;   

: word>  ( ca u -- ca1 u1 ca2 u2 )  \ Get next space-delimited string
   BL skip 2DUP 2>R BL scan DUP 2R> ROT - ;

: <word  ( ca u -- ca u1 ca2 u2 )  \ Backwards word>
   -TRAILING 2DUP 2>R BL <scan DUP 2R> ROT /STRING ;

: sscan  ( ca1 n1 ca2 n2 -- ca3|ca1 n3|0 )  \ Find 1st ca2 n2 in ca1 n1
   SEARCH AND ;

: s/r  ( ca1 u1 ca2 u2 ca3 u3 -- ca1 u4 )  \ ca2's u2's --> ca3's u3's
   2>R R@ OVER - >R  2OVER
   BEGIN  2OVER DUP >R SEARCH
   WHILE  2DUP R> /STRING  SWAP DUP R@ CHARS + ROT CHARS MOVE
          R@ + OVER R> SWAP  2R@ ROT SWAP CMOVE
          R@ SWAP >R /STRING
   REPEAT  2R> 2DROP  2R> 2DROP
   CHARS + NIP NIP NIP OVER - 1 CHARS / ;

: args  ( ca u -- ca1 u1 ... can un n ) \ Return space-delimited args
   0 >R BEGIN DUP WHILE <word 2SWAP R> 1+ >R REPEAT 2DROP R> ;