library/strings.factor

   1 ! :folding=indent:collapseFolds=1:
   2
   3 ! $Id$
   4 !
   5 ! Copyright (C) 2003, 2004 Slava Pestov.
   6 !
   7 ! Redistribution and use in source and binary forms, with or without
   8 ! modification, are permitted provided that the following conditions are met:
   9 !
  10 ! 1. Redistributions of source code must retain the above copyright notice,
  11 !    this list of conditions and the following disclaimer.
  12 !
  13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  14 !    this list of conditions and the following disclaimer in the documentation
  15 !    and/or other materials provided with the distribution.
  16 !
  17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27
  28 IN: strings
  29 USE: arithmetic
  30 USE: combinators
  31 USE: kernel
  32 USE: lists
  33 USE: logic
  34 USE: stack
  35
  36 : f-or-"" ( obj -- ? )
  37     dup not swap "" = or ;
  38
  39 : str-length< ( str str -- boolean )
  40     #! Compare string lengths.
  41     [ str-length ] 2apply < ;
  42
  43 : cat ( [ "a" "b" "c" ] -- "abc" )
  44     ! If f appears in the list, it is not appended to the
  45     ! string.
  46     80 <sbuf> swap [ [ over sbuf-append ] when* ] each sbuf>str ;
  47
  48 : cat2 ( "a" "b" -- "ab" )
  49     swap
  50     80 <sbuf>
  51     dup >r sbuf-append r>
  52     dup >r sbuf-append r>
  53     sbuf>str ;
  54
  55 : cat3 ( "a" "b" "c" -- "abc" )
  56     [ ] cons cons cons cat ;
  57
  58 : cat4 ( "a" "b" "c" "d" -- "abcd" )
  59     [ ] cons cons cons cons cat ;
  60
  61 : cat5 ( "a" "b" "c" "d" "e" -- "abcde" )
  62     [ ] cons cons cons cons cons cat ;
  63
  64 : index-of ( string substring -- index )
  65     0 -rot index-of* ;
  66
  67 : str-lexi> ( str1 str2 -- ? )
  68     ! Returns if the first string lexicographically follows str2
  69     str-compare 0 > ;
  70
  71 : str-head ( str index -- str )
  72     #! Returns a new string, from the beginning of the string
  73     #! until the given index.
  74     0 transp substring ;
  75
  76 : str-contains? ( substr str -- ? )
  77     swap index-of -1 = not ;
  78
  79 : str-tail ( str index -- str )
  80     #! Returns a new string, from the given index until the end
  81     #! of the string.
  82     over str-length rot substring ;
  83
  84 : str/ ( str index -- str str )
  85     #! Returns 2 strings, that when concatenated yield the
  86     #! original string.
  87     2dup str-tail [ str-head ] dip ;
  88
  89 : str// ( str index -- str str )
  90     #! Returns 2 strings, that when concatenated yield the
  91     #! original string, without the character at the given
  92     #! index.
  93     2dup succ str-tail [ str-head ] dip ;
  94
  95 : >title ( str -- str )
  96     1 str/ [ >upper ] dip >lower cat2 ;
  97
  98 : str-headcut ( str begin -- str str )
  99     str-length str/ ;
 100
 101 : str-head? ( str begin -- str )
 102     #! If the string starts with begin, return the rest of the
 103     #! string after begin. Otherwise, return f.
 104     2dup str-length< [
 105         2drop f
 106     ] [
 107         tuck str-headcut
 108         [ = ] dip f ?
 109     ] ifte ;
 110
 111 : str-tailcut ( str end -- str str )
 112     str-length [ dup str-length ] dip - str/ ;
 113
 114 : str-tail? ( str end -- str )
 115     #! If the string ends with end, return the start of the
 116     #! string before end. Otherwise, return f.
 117     2dup str-length< [
 118         2drop f
 119     ] [
 120         tuck str-tailcut swap
 121         [ = ] dip f ?
 122     ] ifte ;
 123
 124 : split ( string split -- list )
 125     2dup index-of dup -1 = [
 126         2drop dup str-length 0 = [
 127             drop f
 128         ] [
 129             unit
 130         ] ifte
 131     ] [
 132         swap [ str// ] dip split cons
 133     ] ifte ;
 134
 135 : split1 ( string split -- pair )
 136     #! The car of the pair is the string up to the first
 137     #! occurrence of split; the cdr is the remainder of
 138     #! the string.
 139     dupd index-of dup -1 = [
 140         drop dup str-length 0 = [
 141             drop f
 142         ] [
 143             unit
 144         ] ifte
 145     ] [
 146         str// cons
 147     ] ifte ;
 148
 149 : max-str-length ( list -- len )
 150     #! Returns the length of the longest string in the given
 151     #! list.
 152     0 swap [ str-length max ] each ;
 153
 154 : ends-with-newline? ( string -- string )
 155     #! Test if the string ends with a newline or not.
 156     "\n" str-tail? ;
 157
 158 : str-each ( str [ code ] -- )
 159     #! Execute the code, with each character of the string
 160     #! pushed onto the stack.
 161     over str-length [
 162         -rot 2dup [ [ str-nth ] dip call ] 2dip
 163     ] times* 2drop ;
 164
 165 : str-sort ( list -- sorted )
 166     #! Sorts the list into ascending lexicographical string
 167     #! order.
 168     [ str-lexi> ] sort ;
 169
 170 : blank? ( ch -- ? )
 171     " \t\n\r" str-contains? ;