home *** CD-ROM | disk | FTP | other *** search
/ Info-Mac 3 / Info_Mac_1994-01.iso / Text Processing / Alpha 5.63 / Tcl / SystemCode / misc.tcl < prev    next >
Encoding:
Text File  |  1993-01-25  |  8.9 KB  |  341 lines  |  [TEXT/ALFA]
  1. #===========================================================================
  2. # Information about a selection or window.
  3. #===========================================================================
  4. proc wordCount {} {
  5.     if {[set chars [expr {[selEnd] - [getPos]}]]} {
  6.         set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
  7.         set text [getSelect]
  8.     } else {
  9.         set chars [maxPos]
  10.         set lines [lindex [posToRowCol $chars] 0]
  11.         set text [getText 0 [maxPos]]
  12.     }
  13.     if {[regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " ret]} {
  14.         set words [llength $ret]
  15.     } else {
  16.         set words [llength $text]
  17.     }
  18.     alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
  19. }
  20.  
  21. proc matchingLines {} {
  22.     if [catch {prompt "Regular expression:" ""} reg] return
  23.     if {![string length $reg]} return
  24.     set reg ^.*$reg.*$
  25.     set pos [getPos]
  26.     set matches 0
  27.     while {![catch {search -f 1 -r 1 -m 0 -i 1 $reg $pos} mtch]} {
  28.         append lines "\r" [format "%4d: " [lindex [posToRowCol [lindex $mtch 0]] 0]] [eval getText $mtch]
  29.         set pos [lindex $mtch 1]
  30.         incr matches
  31.     }
  32.     new
  33.     insertText [format "%d matching lines\r-----" $matches] $lines "\r"
  34. }
  35.  
  36.  
  37. #=============================================================================
  38. # Random functions.
  39. #=============================================================================
  40.  
  41. #***********************************************************************
  42. #                                                                      *
  43. #   Comment box and uncomment box courtesy of Igor Mikolic-Torreira.   *
  44. #                                                                      *
  45. #**********************************************************************/
  46.  
  47. proc commentBox {} {
  48. # Set what the comment block will look like
  49.  
  50.     if {[getPos] == [selEnd]} {
  51.         alertnote "Must select region to be commented."
  52.         return
  53.     }
  54.     watchCursor
  55.     set begComment "/*"
  56.     set begComLen 2
  57.     set endComment "*/"
  58.     set endComLen 2
  59.     set fillChar "*"
  60.     set spaceOffset 3
  61.     set aSpace " "
  62.  
  63. # First make sure we grab a full block of lines and adjust highlight
  64.  
  65.     set start [getPos]
  66.     set start [lineStart $start]
  67.     set end [selEnd]
  68.     set end [nextLineStart [expr $end-1]]
  69.     set text [getText $start $end]
  70.     select $start $end
  71.  
  72. # Next turn it into a list of lines--possibly drop an empty 'last line'
  73.  
  74.     set lineList [split $text "\r"]
  75.     set emptyLine [lsearch $lineList {}]
  76.     if { $emptyLine != -1 } then {
  77.         set numLines [llength $lineList]
  78.         set lineList [lrange $lineList 0 [expr $numLines-2]]
  79.     }
  80.     set numLines [llength $lineList]
  81.     
  82. # Find the longest line length and determine the new line length
  83.  
  84.     set maxLength 0
  85.     foreach thisLine $lineList {
  86.         set thisLength [string length $thisLine]
  87.         if { $thisLength > $maxLength } then { 
  88.             set maxLength $thisLength 
  89.         }
  90.     }
  91.     set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]
  92.     
  93. # Now create the top & bottom bars and a blank line
  94.  
  95.     set topBar $begComment
  96.     for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
  97.         set topBar $topBar$fillChar
  98.     }
  99.     set botBar ""
  100.     for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
  101.         set botBar $botBar$fillChar
  102.     }
  103.     set botBar $botBar$endComment
  104.     set blankLine $fillChar
  105.     for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
  106.         set blankLine $blankLine$aSpace
  107.     }
  108.     set blankLine $blankLine$fillChar
  109.     
  110. # For each line add stuff on left and spaces and stuff on right for box sides
  111. # and concatenate everything into 'text'.  Start with topBar; end with botBar
  112.  
  113.     set text $topBar\r$blankLine\r
  114.     
  115.     set frontStuff $fillChar
  116.     set backStuff $fillChar
  117.     for { set i 0 } { $i < $spaceOffset } { incr i } {
  118.         set frontStuff $frontStuff$aSpace  
  119.         set backStuff $aSpace$backStuff
  120.     }
  121.     set backStuffLen [string length $backStuff]
  122.     
  123.     for { set i 0 } { $i < $numLines } { incr i } {
  124.         set thisLine [lindex $lineList $i ]
  125.         set thisLine $frontStuff$thisLine
  126.         set thisLength [string length $thisLine]
  127.         set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
  128.         for { set j 0 } { $j < $howMuchPad } { incr j } {
  129.             set thisLine $thisLine$aSpace 
  130.         }
  131.         set thisLine $thisLine$backStuff
  132.         set text $text$thisLine\r
  133.     }
  134.     
  135.     set text $text$blankLine\r$botBar\r
  136.     
  137. # Now replace the old stuff
  138.  
  139.     replaceText    $start $end    $text
  140.     select $start [expr {$start+[string    length $text]}]
  141. }
  142.  
  143.  
  144.  
  145. proc uncommentBox {} {
  146.  
  147.     if {[getPos] == [selEnd]} {
  148.         alertnote "Must select region to be uncommented."
  149.         return
  150.     }
  151.  
  152. # Set what the comment block will look like
  153.     watchCursor
  154.     set begComment "/*"
  155.     set endComment "*/"
  156.     set fillChar "*"
  157.     set aSpace " "
  158.     set aTab \t
  159.  
  160. # First make sure we grab a full block of lines
  161.  
  162.     set start [getPos]
  163.     set start [lineStart $start]
  164.     set end [selEnd]
  165.     set end [nextLineStart [expr $end-1]]
  166.     set text [getText $start $end]
  167.  
  168. # Make sure we're at the start and end of the box
  169.  
  170.     set startOK [string first $begComment $text]
  171.     set endOK [string last $endComment $text]
  172.     set textLength [string length $text]
  173.     if { $startOK != 0 && $endOK != [expr {$textLength-3}] } then {
  174.         alertnote "You must highlight the entire comment box, including the borders."
  175.         return
  176.     }
  177.     
  178. # Next turn it into a list of lines--possibly drop an empty 'last line'
  179.  
  180.     set lineList [split $text "\r"]
  181.     set emptyLine [lsearch $lineList {}]
  182.     if { $emptyLine != -1 } then {
  183.         set numLines [llength $lineList]
  184.         set lineList [lrange $lineList 0 [expr $numLines-2]]
  185.     }
  186.     set numLines [llength $lineList]
  187.     
  188. # Delete the first and last lines, recompute number of lines
  189.  
  190.     set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  191.     set lineList [lreplace $lineList 0 0 ]
  192.     set numLines [llength $lineList]
  193.     
  194. # Eliminate 2nd and 2nd-to-last lines if they are empty
  195.  
  196.     set eliminate $fillChar$aSpace$aTab
  197.     set thisLine [lindex $lineList [expr $numLines-1]]
  198.     set thisLine [string trim $thisLine $eliminate]
  199.     if { [string length $thisLine] == 0 } then {
  200.         set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  201.     }
  202.     set thisLine [lindex $lineList 0]
  203.     set thisLine [string trim $thisLine $eliminate]
  204.     if { [string length $thisLine] == 0 } then {
  205.         set lineList [lreplace $lineList 0 0 ]
  206.     }
  207.     set numLines [llength $lineList]    
  208.     
  209. # For each line trim stuff on left and spaces and stuff on right
  210.  
  211.     for { set i 0 } { $i < $numLines } { incr i } {
  212.         set thisLine [lindex $lineList $i]
  213.         set thisLine [string trim $thisLine $eliminate]
  214.         set lineList [lreplace $lineList $i $i $thisLine]
  215.     }
  216.     
  217. # Now splice the lines back together, separating by carriage return...
  218.  
  219.     set text [join $lineList "\r"]
  220.     set text $text\r
  221.     
  222. # Now replace the old stuff
  223.  
  224.     replaceText    $start $end    $text
  225.     select $start [expr {$start+[string    length $text]}]
  226. }
  227. #================================================================================
  228.  
  229. proc transposeWords {} {
  230.         forwardWord
  231.         setMark
  232.         backwardWord
  233.         cut
  234.         deleteChar
  235.         forwardWord
  236.         insertText "\ "
  237.         paste
  238. }
  239.  
  240. proc transposeChars {} {
  241.         setMark
  242.         forwardChar
  243.         cut
  244.         backwardChar
  245.         paste
  246.         forwardChar
  247. }
  248.  
  249. proc nextFunc {} {
  250.     searchFunc 1
  251. }
  252.  
  253. proc prevFunc {} {
  254.     searchFunc 0
  255. }
  256.  
  257. proc searchFunc {dir} {
  258.     global funcExpr
  259.     set pos [getPos]
  260.     select $pos
  261.     if ($dir==1) {
  262.         incr pos
  263.     } else {
  264.         set pos [expr $pos-1]
  265.     }
  266.     if {![catch {search -f $dir -i 1 -r 1 $funcExpr $pos} res]} {
  267.         eval select $res
  268.     }
  269. }
  270.  
  271. #===========================================================================
  272. # Comment routines.
  273. #===========================================================================
  274. proc commentPara {} {
  275. }
  276.  
  277.  
  278.  
  279. #===========================================================================
  280. # Sorting the selection.
  281. # AUTHOR: David C. Black     black@mpd.tandem.com
  282. #===========================================================================
  283. proc sortLines {} {
  284.     set start [getPos]
  285.     set end  [selEnd]
  286.     if {$start == $end} {
  287.         alertnote "You must highlight the section you wish to sort."
  288.         return
  289.     }
  290.     if {[lookAt [expr $end-1]] != "\r"} {
  291.         alertnote "The selection must consist only of complete lines."
  292.         return
  293.     }
  294.     set text [getText $start [expr {$end-1}]]
  295.     set text [join [lsort [split $text "\r"]] "\r"]
  296.     replaceText $start [expr {$end-1}] $text
  297.     select $start $end
  298. }
  299.  
  300.  
  301.  
  302. proc compareWindows {} {
  303.     set one [listpick [lsort [winNames -f]]]
  304.     set two [listpick [lsort [winNames -f]]]
  305.     compare-windows $one $two
  306. }
  307.  
  308.  
  309. #===========================================================================
  310. # Dump all current settings into a file.
  311. #===========================================================================
  312. proc insertGlobalSettings {} {
  313.     uplevel #0 {
  314.         foreach var [info globals] {
  315.             if {![catch {set $var}]} {
  316.                 insertText "set " $var " \{" [set $var] "\}\r"
  317.             }
  318.         }
  319.     }
  320. }
  321.  
  322.  
  323. #================================================================================
  324. # Substitute global variables in possibly nested list.
  325. #================================================================================
  326. proc subVars {words} {
  327.     global silly
  328.     global a
  329.     set silly $words
  330.     set out {}
  331.     foreach a $words {
  332.         if {[llength $a] == 1} {
  333.             lappend out [uplevel #0 {eval set x $a}]
  334.         } else {
  335.             lappend out [subVars $a]
  336.         }
  337.     }
  338.     return $out
  339. }
  340.  
  341.