Page contents

  Commands 

  ASCII map 

  Linebreak 

  word Wrap Via Tk Text Widget 

  Occurrence Count 

  Reverse a String 

  Longest Common Prefix 

  Subscripts 

  Strictly a Floating Point Number 

  Sort a String 

  Longest String 

  String Insert 

  N-th Occurrence of a Substring 

  String to Proper English Title 

  Misc 

  Letterspacing 

  Empty string test 

Commands  edit

name	description
adjust
tcllib::textutil::adjust
tcllib::textutil::blank
tcllib::textutil::cap
tcllib::textutil::chop
tcllib::textutil::getPredefined
tcllib::textutil::indent
tcllib::textutil::listPredefined
tcllib::textutil::longestCommonPrefix
tcllib::textutil::longestCommonPrefixList
tcllib::textutil::readPatterns
tcllib::textutil::repeat
tcllib::textutil::splitn
tcllib::textutil::splitx
tcllib::textutil::tabify
tcllib::textutil::tabify2
tcllib::textutil::tail
tcllib::textutil::trim
tcllib::textutil::trimEmptyHeading
tcllib::textutil::trimleft
tcllib::textutil::trimprefix
tcllib::textutil::trimrigth
tcllib::textutil::uncap
tcllib::textutil::undent
tcllib::textutil::untabify
tcllib::textutil::untabify2
Pool	by Andreas Kupries, has various string functions, some of which are probably now included in tcllib::textutil
stringDistance	measure the similarity between two strings
findOverlap	if andhow many of the last lines in $str1 match the first lines in $str2
count	count characters in a string]
case:title	Create WP formatted title strings on the active selection
Longest common substring
ycl::string::cmp	Like the Unix cmp command, compares two strings and returns the index at which they differ, or -1 if they are identical.
ycl::string::delimit	split (partition) a string into substrings using any combination of string, match, or regular expressions, returning both the substrings and the delimiters.
ycl::string::pstring	converts non-printing characters in a string to their hexadecimal escape sequences
ycl::string::shortmatch	like [string match], but returns the index of the last character of the shortest match, or -1
ycl::tcl::armour	Convert a value into a printing string that can be pasted directly into a Tcl script as a value

ASCII map  edit

proc ascii {} {return {
    00 nul  01 soh  02 stx  03 etx  04 eot  05 enq  06 ack  07 bel
    08 bs   09 ht   0a nl   0b vt   0c np   0d cr   0e so   0f si
    10 dle  11 dc1  12 dc2  13 dc3  14 dc4  15 nak  16 syn  17 etb
    18 can  19 em   1a sub  1b esc  1c fs   1d gs   1e rs   1f us
    20 sp   21  !   22  "   23  #   24  $   25  %   26  &   27  '
    28  (   29  )   2a  *   2b  +   2c  ,   2d  -   2e  .   2f  /
    30  0   31  1   32  2   33  3   34  4   35  5   36  6   37  7
    38  8   39  9   3a  :   3b  ;   3c  <   3d  =   3e  >   3f  ?
    40  @   41  A   42  B   43  C   44  D   45  E   46  F   47  G
    48  H   49  I   4a  J   4b  K   4c  L   4d  M   4e  N   4f  O
    50  P   51  Q   52  R   53  S   54  T   55  U   56  V   57  W
    58  X   59  Y   5a  Z   5b  [   5c  \   5d  ]   5e  ^   5f  _
    60  `   61  a   62  b   63  c   64  d   65  e   66  f   67  g
    68  h   69  i   6a  j   6b  k   6c  l   6d  m   6e  n   6f  o
    70  p   71  q   72  r   73  s   74  t   75  u   76  v   77  w
    78  x   79  y   7a  z   7b  {   7c  |   7d  }   7e  ~   7f del
}} ;#RS

Linebreak  edit

proc linebreak {s {width 80}} {
   set res {}
   while {[string length $s]>$width} {
       set     pos [string wordstart $s $width]
       lappend res [string range     $s 0    [expr $pos-1]]
       set     s   [string range     $s $pos end]
   }
   lappend res $s
} ;# RS

• The file word.tcl remarks that word boundaries are platform-dependent. Is this also used in string wordstart?
• More importantly: The above fails if a word is longer than the given width! You get into an endless loop.

word Wrap Via Tk Text Widget  edit

.tx configure -width $formawid -wrap $wordwrap
wm geometry . {} ; # Make sure the toplevel shrinks or expands to fit

proc formanew {whattodo} {
    global formawid
    # Identify beginning and end of text to format:
    if {[.tx tag ranges sel] eq {}} {
        set selon 1.0
        set seloff [.tx index end]
    } else {
        set selon [.tx index sel.first]
        set seloff [.tx index sel.last]
    }
    set texin [expr int($selon)]
    set texend [expr int($seloff)]
    # Initialize variable to hold output:
    set formatext {} 
    for {set i $texin} {$i <= $texend} {incr i} {
        # Get text to newline:
        set endolin [.tx index $i.end]
        set endochar [lindex [split $endolin .] end]
        set whatline [.tx get $i.0 $endolin]
        # If line is blank, insert only newline into output:
        if {[string trim $whatline] eq {}} {
            append formatext \n
            continue
        }
        # If not, then find out where line is wrapped:
        for {set c 1} {$c <= $endochar} {incr c} {
            .tx see $i.$c
            set ceemin [expr {$c-1}]
            set boxie [.tx get $i.$ceemin]
            # Get y coordinates of bounding boxes for adjoining characters:
            set pixy [lindex [.tx bbox $i.$ceemin] 1]
            set nexy [lindex [.tx bbox $i.$c] 1]
            # If y coordinate of bounding box is greater than for
            # preceding character, line has been wrapped, so
            # insert preceding character plus newline into output:
            if {$nexy > $pixy} {
                append formatext $boxie\n
                .tx see $i.$c
            } else {
                # Otherwise, insert only the preceding character:
                append formatext $boxie
            }
        }
        # Replicate existing newline from text widget:
        if {$i < $texend} {
            append formatext \n
        }
    }
    if {$whattodo eq {print}} {
        return $formatext
    } else {
        .tx delete $selon $seloff
        .tx insert $selon $formatext
        .tx edit separator
    }
}

after 100 formanew

Occurrence Count  edit

proc scount {subs string} {
    regsub -all $subs $string $subs string
}
proc scount2 {subs string} {
    regexp -all $subs $string ;# 8.3
}

interp alias {} scount3 {} regexp -all

proc scount4 {subs string} {
    regexp -all ***=$subs $string
} 

proc scount5 {subs string} {
    set count [llength [split [string map [list $subs \uFFFF]  $string] \uFFFF]]
    incr count -1 
}

proc countstrings {data search} {
    set l [string length $search]
    set count 0
    while {[set i [string first $search $data]]>=0} {
        incr count
        incr i $l
        set data [string range $data $i end]
    }
    set count
} 

Reverse a String  edit

proc sreverse s {join [lreverse [split $s {}]] {}} ;#RS

proc sreverse s {
    set res {} 
    set i [string length $s]
    while {$i >= 0} {
        set res "$res[string index $s [incr i -1]]"
    }
    return $res
}

proc sreverse s {
    set l [string length $s]
    set res {} 
    while {$l} {append res [string index $s [incr l -1]]}
    set res
}

proc string_reverse str {
    set rts {} 
    for {set i [string length $str]; incr i -1} {$i >= 0} {incr i -1} {
        append rts [string index $str $i]
    }
    return $rts
}

proc srev s {
    return [join [::struct::list reverse [split $s {}]] {}]
}

Longest Common Prefix  edit

   "Arjen Markus" versus "Arjen Marcus" --> position: 9
   "Arjen Markus" versus "Arjan Markus" --> position: 3

proc commonPrefix {a b} {
    set res {}
    foreach i [split $a {}] j [split $b {}] {
        if {$i eq $j} {append res $i} else break
    }
    set res
}

proc longestCommonPrefix strings {
   set res {}
   set i 0
   foreach char [split [lindex $strings 0] {}] {
       foreach string [lrange $strings 1 end] {
           if {[string index $string $i] ne $char} {
               return $res
           }
       }
       append res $char
       incr i
   }
   set res
} ;# RS

proc string:common {string1 string2} {
    set i 1
    while {[string equal -length $i $string1 $string2]} {incr i}
    return [string range $string1 0 [expr {$i-2}]]
}

proc string:common:list {args} {
    if { [llength $args] < 2 } {
        return -code error "wrong # args: must be >= 2"
    }
    set list [lsort $args]
    return [string:common [lindex $list 0] [lindex $list end]]
}

proc prefix {s1 s2} {
    regexp {^(.*).*\0\1} "$s1\0$s2" all pref
    return $pref
}

proc prefix {str args} {
    set re {^(.*).*}
    foreach s $args {
        append re {\0\1.*}
        append str "\0$s"
    }
    regexp $re $str all pref
    return $pref
}

proc reprefix {str1 str2} {
    regexp -inline ^[join [split $str1 {}] ?]? $str2
}

% reprefix iamadonut iamatoilet
iamat

Subscripts  edit

proc subscript s {
    set res {} 
    foreach char [split $s {}] {
        set pos [lsearch -exact {0 1 2 3 4 5 6 7 8 9 + - = ( )} $char]
        if {$pos>=0} {set char [format %c [incr pos 0x2080]]}
        append res $char
    }
    set res
} ;# RS
% puts H[subscript 2]O
H?O

Strictly a Floating Point Number  edit

proc isFloat x {expr {[string is double -strict $x] && ![string is int $x]}} ;#RS

Sort a String  edit

proc charsort {string}  {
   return [join [lsort [split $string {}]] {}]
}

Longest String  edit

proc maxlen args {
    # Written 2003 by Ed Suominen, hereby placed in the public domain
    if {[llength $args] > 1} {
        if {
            [set x [string length [lindex $args 0]]] -
            [set y [string length [lindex $args 1]]] < 0
        } {
            return -1
        } elseif {$x == $y} {
            return 0
        } else {
            return 1
        }
    } else {
        set x [lsort -decreasing -command maxlen [lindex $args 0]]
        return [string length [lindex $x 0]]
    }
}

proc maxlen args {
    if {[llength $args] == 1} {
        set args [lindex $args 0]
    }
    set res [string length [lindex $args 0]]
    foreach i [lrange $args 1 end] {
        set l2 [string length $i]
        if {$l2 > $res} {set res $l2}
    }
    set res
} ;# RS

set words {now is the time for all good men to come to the aid of their country}
set how_long [::tcl::mathfunc::max {*}[lmap v $words {string length $v}]]
set longest_word [lindex [lsort -index 1 -integer [lmap v $words { list $v [string length $v] }]] end 0]

String Insert  edit

proc strinsert {string pos char} {
    set original [string index $string $pos]
    string replace $string $pos $pos $char$original
} ;# RS
% strinsert hello 1 x
hxello

proc strinsert {string pos insertion} {
    append insertion [string index $string $pos]
    string replace $string $pos $pos $insertion
}
namespace ensemble configure string -map\
    [dict replace [namespace ensemble configure string -map] insert strinsert]
% string insert hello 1 xxx
hxxxello

proc strinsert {string pos insertion} {
    string replace $string $pos $pos $insertion[string index $string $pos]
}

N-th Occurrence of a Substring  edit

proc mystringFirst {substring mystring ocorrencia} {
    if {!$ocorrencia} {return -1}
    set index 0

    for {set i 0} {$i < $ocorrencia} {incr i} {
        set index [string first $substring $mystring]
        set mystring [string range $mystring [expr $index + 1] [string length $mystring]]
    }

    return $index
}

% set str "foo bar baz boing sprocket banana"
% mystringFirst ba $str 1
4
% mystringFirst ba $str 2
3

proc mystringFirst2 {needle haystack count} {
        set pos -1
        while { $count && [set pos [string first $needle $haystack $pos+1]] > -1 } {
                incr count -1
        }
        return $pos
}

proc mystringFirst3 {needle haystack count} {
        set indices [regexp -all -inline -indices $needle $haystack]
        if { [llength $indices] >= $count } {
                return [lindex $indices $count-1 0]
        } else {
                return -1
        }
}

  set needle [regsub -all {([^a-zA-Z0-9 ])} $needle {\\\1}]

String to Proper English Title  edit

proc title str {
    set output {} 
    set nocaps [list a an and at but by for from in into of on or the to with]
    foreach word [split $str] {
        if {[lsearch $nocaps $word] == -1} {
            set word [string totitle $word]
        }
        append output "$word "
    }
    return [string trim $output]
}

% set bogomips "groundwork of the metaphysics of balderdash"
groundwork of the metaphysics of balderdash
% title $bogomips
Groundwork of the Metaphysics of Balderdash

proc title {str} {
    set output {} 
    set nocaps {a an and at but by for from in into of on or the to with}
    foreach word [regexp -all -inline {[\w'.]+|\W+} $str] {
        if {[string match {[A-Za-z]*} $word] && [lsearch $nocaps $word] == -1} {
            # In 8.5 should use the 'ni' operator instead of the [lsearch]
            set word [string totitle $word]
        }
        append output $word
    }
    return [string trim $output]
}

proc mp3 args {
    set _nocaps {
        a as à às ao aos de da das do dos e em na nas no nos 
        o os ou para por que sem sob
        an and are at but for from if in is it's not of on or 
        the to under vs vs. with without
        au aux avec dans des en et le la les ou par pour qui si
        con del el en la las los sin y
    }; # German and Italian, anyone?
 
    foreach _file [glob *] { 
        if { $_file eq {.:} } { continue }
        # lowercase the whole name
        set _old  $_file
        set _file [string tolower $_file]
        set _new {}              ;# empty _new in each iteration
        set _c   0               ;# zero counter in each iteration
 
        foreach _word $_file { 
            incr _c
 
            # anything right after " - " probably is the first word of a phrase.
            # if current word is "-", reset counter so next word is 1 and gets caps
            if {$_word eq {-}} {set _c 0}

            # if current word is 1, it gets caps
            if {$_c == 1} {set _word [string totitle $_word]}

            # if it is not in exceptions, it gets caps
            if {[lsearch $_nocaps $k ] < 0} { 
               set k [string totitle $k]
            }

            # add the word to the new name
            lappend _new $k
        }
 
        # UNCOMMENT the two next lines if you want files renamed automatically
        #file rename  $_old  RENAME_TEMP
        #file rename  RENAME_TEMP  $_new
        puts  "$_old\n$_new\n"
    }
}

proc title str {
    set output {} 
    set nocaps [list a an and at but by for from in into of on or the to with]
    set count 0
    foreach word [split $str] {
        # Strip quotation marks:
        if {[string index $word 0] eq "\""} {
            set quote 1
            set word [string trim $word \"]
        } else {
            set quote 0
        }
        # Always capitalize the first word; otherwise,
        # don't capitalize any words in the "nocaps" list:
        if {$count == 0 || [lsearch $nocaps $word] == -1} {
            set word [string totitle $word]
        }
        # Add word plus space, with or without quotation marks, to output:
        if {$quote} {
            append output "\"$word\" "
        } else {
            append output "$word "
        }
        # Capitalize any word after a colon:
        if {[string index $word end] eq {:}} {
            set count 0
        } else {
            incr count
        }
    }
    return [string trim $output]
}

% set wordsworth {what I say is: by gum, give me the finest "bogomips" in the universe!}
what I say is: by gum, give me the finest "bogomips" in the universe!
% title $wordsworth
What I Say Is: By Gum, Give Me the Finest "Bogomips" in the Universe!

proc mystringFirst {substring mystring ocorrencia} {
    if {!$ocorrencia} {return -1}
    set index 0
  
    for {set i 0} {$i < $ocorrencia} {incr i} {
        set index [string first $substring $mystring]
        set mystring [string range $mystring [expr $index + 1] [string length $mystring]]
    }
  
    return $index
}

proc title-case text {
    for {set index 0} {$index < [string length $text]} {incr index} {
        if { [string wordstart $text $index] == $index } {
            set text [string replace $text $index $index [string toupper [string index $text $index]]]
        } else {
            set text [string replace $text $index $index [string tolower [string index $text $index]]]
        }
    }
    return $text
}

Misc  edit

Letterspacing  edit

proc letterspace s {join [split $s {}] { }} ;# RS
% letterspace {steal sheep}
s t e a l   s h e e p

Empty string test  edit

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References