home *** CD-ROM | disk | FTP | other *** search
/ MacWorld UK 2000 March / MW_UK_2000_03.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / textManip.tcl < prev    next >
Encoding:
Text File  |  1999-10-27  |  11.6 KB  |  430 lines  |  [TEXT/ALFA]
  1. #===========================================================================
  2. # Information about a selection or window.
  3. #===========================================================================
  4. proc wordCount {{text ""}} {
  5.     if {$text == ""} {
  6.     if {[set chars [string length [set text [getSelect]]]]} {
  7.         set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
  8.         set text [getSelect]
  9.     } else {
  10.     set chars [maxPos]
  11.         set lines [lindex [posToRowCol $chars] 0]
  12.         set text [getText [minPos] [maxPos]]
  13.     }
  14.     }
  15.     regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " text
  16.     set words [llength $text]
  17.     alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
  18. }
  19.  
  20.  
  21. # FILE: sortLines.tcl
  22. #
  23. # This version of sortLines has the option of ignoring blanks/whitespace (-b)
  24. # and case-insensitive sorting (-i), or reverse sorting, and removing duplicates
  25. # if desired [-d]
  26. #     sortLines [-b] [-i] [-r] [-d]
  27.  
  28. # COPYRIGHT:
  29. #
  30. #    Copyright © 1992,1993 by David C. Black All rights reserved.
  31. #    Portions copyright © 1990, 1991, 1992 Pete Keleher. All Rights Reserved.
  32. #   Portions copyright (c) 1999 Vince Darley, no rights reserved.
  33. #
  34. #    Redistribution and use in source and binary forms are permitted
  35. #    provided that the above copyright notice and this paragraph are
  36. #    duplicated in all such forms and that any documentation,
  37. #    advertising materials, and other materials related to such
  38. #    distribution and use acknowledge that the software was developed
  39. #    by David C. Black.
  40. #
  41. #    THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
  42. #    IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
  43. #    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  44. #
  45. ################################################################################
  46.  
  47. # AUTHOR
  48. #
  49. #    David C. Black
  50. #    GEnie:    D.C.Black
  51. #    Internet: black@mpd.tandem.com (preferred)
  52. #    USnail:   6217 John Chisum Lane, Austin, TX 78749
  53. #
  54. ################################################################################
  55.  
  56. proc reverseSort {} {sortLines -r}
  57.  
  58. proc sortLines {args} {
  59.     getOpts
  60.     
  61.     if {[info exists opts(-r)]} {
  62.     set mode "-decreas"
  63.     } else {
  64.     set mode "-increas"
  65.     }
  66.     
  67.     set start [getPos]
  68.     set end  [selEnd]
  69.     if {[pos::compare $start == $end]} {
  70.     alertnote "You must highlight the section you wish to sort."
  71.     return
  72.     }
  73.     if {[lookAt [pos::math $end - 1]] != "\r"} {
  74.     alertnote "The selection must consist only of complete lines."
  75.     return
  76.     }
  77.     set text [split [getText $start [pos::math $end - 1]] "\r"]
  78.     if {[info exists opts(-b)] || [info exists opts(-i)] || [info exists opts(-d)]} {
  79.     foreach line $text {
  80.         if {[info exists opts(-i)]} {
  81.         set key [string tolower $line]
  82.         } else {
  83.         set key $line
  84.         }
  85.         if {[info exists opts(-b)]} {
  86.         regsub -all "\[ \t\]+" $key " " key
  87.         }
  88.         if {[info exists opts(-d)]} {
  89.         if {![info exists orig($key)]} {
  90.             set orig($key) $line
  91.             lappend list $key
  92.         }
  93.         } else {
  94.         while {[info exists orig($key)]} {
  95.             append key "z"
  96.         }
  97.         set orig($key) $line
  98.         lappend list $key
  99.         }
  100.     }
  101.     unset text
  102.     foreach key [lsort $mode $list] {
  103.         lappend text $orig($key)
  104.     }
  105.     } else {
  106.     set text [lsort $mode $text]
  107.     }
  108.     set text [join $text "\r"]
  109.     replaceText $start [pos::math $end - 1] $text
  110.     select $start [pos::math $start + [string length $text] +1]
  111. }
  112. # Test case:
  113. #
  114. # a  black
  115. # A  black dog
  116. # a black cat
  117. # A  Black dog
  118. # A  black dog
  119.  
  120.  
  121. ## 
  122.  # -------------------------------------------------------------------------
  123.  # 
  124.  # "sortParagraphs" --
  125.  # 
  126.  #  Sorts selected paragraphs according to their first 30 characters,
  127.  #  it's case insensitive and removes all non alpha-numeric characters
  128.  #  before the sort.
  129.  # -------------------------------------------------------------------------
  130.  ##
  131. proc sortParagraphs {args} {
  132.     set start [getPos]
  133.     set end  [selEnd]
  134.     if {[pos::compare $start == $end]} {
  135.     alertnote "You must highlight the section you wish to sort."
  136.     return
  137.     }
  138.     if {[lookAt [pos::math $end - 1]] != "\r"} {
  139.     alertnote "The selection must consist only of complete lines."
  140.     return
  141.     }
  142.     set text [getText $start $end]
  143.     if {[string first "•" $text] != -1} {
  144.     alertnote "Sorry, can't sort paragraphs with bullets '•'."
  145.     return
  146.     }
  147.     regsub -all "\[\r\n\]\[ \t\]*\[\r\n]" $text "\r•" text
  148.     set paras [split $text "•"]
  149.     unset text
  150.     # now each paragraph ends in \r
  151.     foreach para $paras {
  152.     set key [string tolower [string range $para 0 30]]
  153.     regsub -all {[^-a-z0-9]} $key "" key
  154.     # so we don't clobber duplicates!
  155.     while {[info exists orig($key)]} {append key "z"}
  156.     set orig($key) $para
  157.     }
  158.     unset para
  159.     foreach key [lsort [array names orig]] {
  160.     lappend text $orig($key)
  161.     }
  162.     replaceText $start $end [join $text "\r"]
  163.     select $start $end
  164. }
  165.  
  166.  
  167.  
  168. #================================================================================
  169. # Block shift left and right.
  170. #================================================================================
  171.  
  172. proc shiftBy {amount} {
  173.     set start [lineStart [getPos]]
  174.     set end [nextLineStart [pos::math [selEnd] - 1]]
  175.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  176.     set text [text::indentBy [getText $start $end] $amount]
  177.     replaceText $start $end $text
  178.     set end [pos::math $start + [string length $text]]
  179.     if {[pos::compare [nextLineStart $start] == $end]} {
  180.     goto [pos::math $start + [string length $text] - [string length [string trimleft $text]]]
  181.     } else {
  182.     select $start $end
  183.     }
  184. }
  185.  
  186. proc shiftRight {} {
  187.     global indentationAmount
  188.     shiftBy $indentationAmount
  189. }
  190.  
  191. proc shiftLeft {} {
  192.     global indentationAmount
  193.     shiftBy -$indentationAmount
  194. }
  195.  
  196. proc shiftLeftSpace {} {
  197.     shiftBy -1
  198. }
  199.  
  200. proc shiftRightSpace {} {
  201.     shiftBy 1
  202. }
  203.  
  204. proc doShiftLeft {shiftChar} {
  205.     set start [lineStart [getPos]]
  206.     set end [nextLineStart [pos::math [selEnd] - 1]]
  207.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  208.     
  209.     set text [split [getText $start [pos::math $end - 1]] "\r\n"]
  210.     
  211.     set textout ""
  212.     
  213.     foreach line $text {
  214.     if {[regexp "($shiftChar)(.*)$" $line "" "" c]} {
  215.         lappend textout $c
  216.     } else {
  217.         lappend textout $line
  218.     }
  219.     }
  220.     
  221.     set text [join $textout "\r"]    
  222.     replaceText $start [pos::math $end - 1] $text
  223.     select $start [pos::math $start + [expr {1 + [string length $text]}]]
  224. }
  225.  
  226. proc doShiftRight {shiftChar} {
  227.     set start [lineStart [getPos]]
  228.     set end [nextLineStart [pos::math [selEnd] - 1]]
  229.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  230.     
  231.     set text [split [getText $start [pos::math $end - 1]] "\r\n"]
  232.     
  233.     set text "$shiftChar[join $text \r${shiftChar}]"
  234.     replaceText $start [pos::math $end - 1] $text
  235.     select $start [pos::math $start + [expr {1 + [string length $text]}]]
  236. }
  237.  
  238. proc selectAll {} {
  239.     select [minPos] [maxPos]
  240. }
  241.  
  242. # Select the next or current word. If word already selected, will go to next.
  243. proc hiliteWord {} {
  244.     if {[pos::compare [getPos] != [selEnd]]} forwardChar
  245.     forwardWord
  246.     set start [getPos]
  247.     backwardWord
  248.     select $start [getPos] 
  249. }
  250.  
  251. ## 
  252.  # -------------------------------------------------------------------------
  253.  # 
  254.  # "togglePrefix" --
  255.  # 
  256.  #  Useful for e.g. Tcl mode to add/remove a '$', TeX to add/remove 
  257.  #  a backslash, etc.  Only works for single character prefixes.
  258.  # -------------------------------------------------------------------------
  259.  ##
  260. proc togglePrefix {pref} {
  261.     set p [getPos]
  262.     backwardWord
  263.     if {[lookAt [getPos]] == $pref} {
  264.     deleteChar
  265.     goto [pos::math $p -1]
  266.     } else {
  267.     insertText $pref
  268.     goto [pos::math $p +1]
  269.     }
  270. }
  271.  
  272. proc twiddle {} {
  273.     set orSelStart [getPos]
  274.     set orPos [selEnd]
  275.     if {[pos::compare $orPos < [pos::math [minPos] + 2]]} return
  276.  
  277.     set pos $orPos
  278.     set one [lookAt [pos::math $pos -1]]
  279.     
  280.     if {[string first $one " \r\n\t"] > -1} {
  281.     set searchResult [search -s -n -f 0 -m 0 -i 1 -r 1 {[^\s]} [pos::math $pos - 1]]
  282.     if {[llength $searchResult] != 0} then {
  283.         set pos [pos::math [lindex $searchResult 0] + 1]
  284.         set one [lookAt [pos::math $pos - 1]]
  285.     }
  286.     }
  287.     set two [lookAt [pos::math $pos - 2]]
  288.     if {[string first $two " \r\n\t"] > -1} {
  289.     message "transposeChars aborted. A space is involved"
  290.     select $orSelStart $orPos
  291.     return
  292.     }
  293.     replaceText [pos::math $pos -2] $pos "$one$two"
  294.     select $orSelStart $orPos
  295.     message "transposed chars: ‘$one$two’"
  296. }
  297.  
  298.  
  299. # transposeWords transpose correctly the two words before the cursor
  300. # taking into account any other chars in between.  We must be after a word, then
  301. # the proc will be reversible.  
  302.  
  303. proc twiddleWords {} {
  304.     set orSelStart [getPos]
  305.     set pos [selEnd]
  306.     if {[pos::compare $orSelStart != $pos]} {
  307.     goto $pos; # deselect
  308.     }
  309.     
  310.     backwardWord; backwardWord;
  311.     set start1 [getPos]
  312.     forwardWord;
  313.     set end1 [getPos]
  314.     forwardWord;
  315.     set end2 [getPos]
  316.     backwardWord;
  317.     set start2 [getPos]
  318.     
  319.     if {[pos::compare $end2 > $pos] || [pos::compare $start2 > $pos] \
  320.       || [pos::compare $end1 > $pos]} {
  321.     message "transposeWords error: two words must be before"
  322.     select $orSelStart $pos
  323.     return
  324.     }
  325.     if {[pos::compare $start1 != $start2]} {
  326.     set mid [getText $end1 $start2]
  327.     set one [getText $start2 $end2]
  328.     set two [getText $start1 $end1]
  329.     replaceText $start1 $end2 "$one$mid$two"
  330.     # the original selection could be shorter than the words interchanged
  331.     goto $pos
  332.     message "transposed words “$one” with “$two”"
  333.     }
  334. }
  335.  
  336.  
  337. proc insertPrefix {} {doPrefix insert}
  338. proc removePrefix {} {doPrefix remove}
  339. proc doPrefix {which} {
  340.     global prefixString
  341.     if {[pos::compare [set start [getPos]] == [set end [selEnd]]]} {
  342.     set end [nextLineStart $start]
  343.     }
  344.     set start [lineStart $start]
  345.     set text [getText $start $end]
  346.     replaceText $start $end [doPrefixText $which $prefixString $text]
  347.     goto $start
  348.     endOfLine
  349. }
  350.  
  351. proc quoteChar {} {
  352.     message "Literal keystroke to be inserted:"
  353.     insertText [getChar]
  354. }
  355.  
  356. proc setPrefix {} {
  357.     global prefixString
  358.     if {[catch {prompt "New Prefix String:" $prefixString} res] == 1} return
  359.     set prefixString $res
  360. }
  361.  
  362. proc setSuffix {} {
  363.     global suffixString
  364.     if {[catch {prompt "New Suffix String:" $suffixString} res] == 1} return
  365.     set suffixString $res
  366. }
  367.  
  368. proc insertSuffix {} {doSuffix insert}
  369. proc removeSuffix {} {doSuffix remove}
  370. proc doSuffix {which} {
  371.     global suffixString
  372.     set pts [getEndpts]
  373.     set start [lindex $pts 0]
  374.     set end [lindex $pts 1]
  375.     set start [lineStart $start]
  376.     set end [nextLineStart [pos::math $end - 1]]
  377.     set text [getText $start $end]
  378.     set text [doSuffixText $which $suffixString $text]
  379.     replaceText $start $end $text
  380.     select $start [getPos]
  381. }
  382.  
  383. proc prevLineStart { pos } {
  384.     return [lineStart [pos::math [lineStart $pos] - 1]]
  385. }
  386.  
  387.  
  388. proc frontTabsToSpaces { start end } {
  389.     select $start $end
  390.     tabsToSpaces
  391. }
  392.  
  393. proc frontSpacesToTabs { start end } {
  394.     getWinInfo a
  395.     set sp [string range "              " 1 $a(tabsize) ]
  396.     set from [lindex [posToRowCol $start] 0]
  397.     set to [lindex [posToRowCol $end] 0]
  398.     while {$from <= $to} {
  399.     set pos [rowColToPos $from 0]
  400.     # get the leading whitespace of the current line
  401.     set res [search -s -n -f 1 -r 1 "^\[ \t\]*" $pos]
  402.     if {![llength $res]} {
  403.         # end of the file
  404.         return
  405.     }
  406.     regsub -all "($sp| +\t)" [eval getText $res] "\t" front
  407.     eval replaceText $res [list $front]
  408.     incr from
  409.     }
  410. }
  411.  
  412. proc forwardDeleteUntil {{c ""}} {
  413.     if {$c == ""} {
  414.     message "Forward delete up to next:"
  415.     set c [getChar]
  416.     }
  417.     set p [lindex [search -s -n -f 1 -r 1 [quote::Regfind $c] [getPos]] 0]
  418.     if {$p != ""} {
  419.     deleteText [getPos] [pos::math $p + 1]
  420.     }
  421. }
  422.  
  423. proc forwardDeleteWhitespace {} {
  424.     set p [lindex [search -s -n -f 1 -r 1 "\[^ \t\r\n\]" [getPos]] 0]
  425.     if {$p != ""} {
  426.     deleteText [getPos] $p
  427.     }
  428. }
  429.  
  430.