home *** CD-ROM | disk | FTP | other *** search
/ MacWorld UK 2000 March / MW_UK_2000_03.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / alphaCommands.tcl < prev    next >
Encoding:
Text File  |  1999-09-17  |  6.1 KB  |  244 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "alphaCommands.tcl"
  6.  #                                    created: 03/18/1998 {01:13:44 AM} 
  7.  #                                last update: 11/7/1999 {9:45:24 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: vince@santafe.edu
  10.  #  
  11.  # Copyright (c) 1999 Vince Darley
  12.  # 
  13.  # All rights reserved.
  14.  # 
  15.  # See the file "license.terms" for information on usage and redistribution of
  16.  # this file, and for a DISCLAIMER OF ALL WARRANTIES.
  17.  #  
  18.  #  Description: 
  19.  # 
  20.  #   Mostly procedures which would really help Alpha if they were
  21.  #   hard-coded.  Some other procedures for convenience are here too.
  22.  #  History
  23.  # 
  24.  #  modified by  rev reason
  25.  #  -------- --- --- -----------
  26.  #  03/18/19 VMD 1.0 original
  27.  # ###################################################################
  28.  ##
  29.  
  30. if {${alpha::platform} != "alpha"} {
  31.     alertnote "Shouldn't load this code!"
  32.     return
  33. }
  34.  
  35. namespace eval tmark {}
  36.  
  37. ## 
  38.  # -------------------------------------------------------------------------
  39.  # 
  40.  # "tmark::getPos" --
  41.  # 
  42.  #  This procedure is pretty slow, due to limitations in Alpha.  Hopefully
  43.  #  one day we'll have a hard-wired quick version.  It also works around
  44.  #  a bug in which Alpha tells us that windows which aren't files (e.g.
  45.  #  just created with 'new -n') are located in Alpha's 'pwd' directory.
  46.  #  
  47.  #  The stupid thing is that Alpha knows exactly where each stop is, but
  48.  #  it won't tell us!  'gotoTMark $m' goes to exactly the position we
  49.  #  want, but we can't find it out some other way.
  50.  # -------------------------------------------------------------------------
  51.  ##
  52. if {[info tclversion] < 8.0} {
  53.     proc tmark::getPos {m {f ""}} {
  54.     if {$f == ""} {set f [win::Current]}
  55.     regsub { <[0-9]+>$} $f "" f
  56.     if {[file exists $f]} {
  57.         if {[regexp "\{$m \{[quote::Regfind $f]\} (\[0-9\]+) \[0-9\]+\}" [getTMarks] "" where]} {
  58.         return $where
  59.         }
  60.     } else {
  61.         if {[regexp "\{$m \{[quote::Regfind [pwd]$f]\} (\[0-9\]+) \[0-9\]+\}" [getTMarks] "" where]} {
  62.         return $where
  63.         }
  64.     }
  65.     error "No such mark"
  66.     }
  67. } else {
  68.     proc tmark::getPos {m {f ""}} { 
  69.     if {$f == ""} {
  70.         return [lindex [getPosOfTMark $m] 0] 
  71.     } else {
  72.         return [lindex [getPosOfTMark -w $f $m] 0] 
  73.     }
  74.     }
  75.  
  76. }
  77. if {[info tclversion] < 8.0} {
  78.     proc tmark::getRange {m {f ""}} {
  79.     if {$f == ""} {set f [win::Current]}
  80.     regsub { <[0-9]+>$} $f "" df
  81.     if {[file exists $df]} {
  82.         if {[regexp "\{ \{$m\} \{[quote::Regfind $df]\} (\[0-9\]+ \[0-9\]+ \[0-9\]+) \}" [getNamedMarks -w $f] "" where]} {
  83.         return $where
  84.         }
  85.     } else {
  86.         if {[regexp "\{ \{$m\} \{[quote::Regfind [pwd]$df]\} (\[0-9\]+ \[0-9\]+ \[0-9\]+) \}" [getNamedMarks -w $f] "" where]} {
  87.         return $where
  88.         }
  89.     }
  90.     error "No such mark"
  91.     }
  92. } else {
  93.     proc tmark::getRange {m {f ""}} { 
  94.     if {$f == ""} {
  95.         return [getPosOfTMark $m]
  96.     } else {
  97.         return [getPosOfTMark -w $f $m]
  98.     }
  99.     }
  100.  
  101. }
  102. namespace eval mark {}
  103. if {[info tclversion] < 8.0} {
  104.     proc mark::getRange {m {f ""}} {
  105.     if {$f == ""} {set f [win::Current]}
  106.     regsub { <[0-9]+>$} $f "" df
  107.     if {[file exists $df]} {
  108.         if {[regexp "\{ \{$m\} \{[quote::Regfind $df]\} (\[0-9\]+ \[0-9\]+ \[0-9\]+)" [getNamedMarks -w $f] "" where]} {
  109.         return $where
  110.         }
  111.     } else {
  112.         if {[regexp "\{ \{$m\} \{[quote::Regfind [pwd]$df]\} (\[0-9\]+ \[0-9\]+ \[0-9\]+)" [getNamedMarks -w $f] "" where]} {
  113.         return $where
  114.         }
  115.     }
  116.     error "No such mark"
  117.     }
  118. } else {
  119.     proc mark::getRange {m {f ""}} { 
  120.     if {$f == ""} {
  121.         return [getPosOfMark $m]
  122.     } else {
  123.         return [getPosOfMark -w $f $m]
  124.     }
  125.     }
  126.  
  127. }
  128.  
  129. ## 
  130.  # -------------------------------------------------------------------------
  131.  # 
  132.  # "tmark::getPositions" --
  133.  # 
  134.  #  For speed you can ask for a bunch of positions at once.
  135.  # -------------------------------------------------------------------------
  136.  ##
  137. if {[info tclversion] < 8.0} {
  138.     proc tmark::getPositions {mm} {
  139.     regexp {(.*) <[0-9]+>$} [set f [win::Current]] "" f
  140.     if {[file exists $f]} {
  141.         set reg " \{[quote::Regfind $f]\} (\[0-9\]+) \[0-9\]+\}"
  142.     } else {
  143.         set reg " \{[quote::Regfind [pwd]$f]\} (\[0-9\]+) \[0-9\]+\}"
  144.     }
  145.     set marks [getTMarks]
  146.     foreach m $mm {
  147.         if {[regexp "\{$m$reg" $marks "" where]} {
  148.         lappend res $where
  149.         } else {
  150.         error "No such mark"
  151.         }
  152.     }
  153.     return $res
  154.     }
  155. } else {
  156.     proc tmark::getPositions {mm} {
  157.     foreach m $mm {
  158.         lappend res [lindex [getPosOfTMark $m] 0]
  159.     }
  160.     return $res
  161.     }
  162. }
  163.  
  164. if {[info tclversion] < 8.0} {
  165.  
  166. proc tmark::isAt {p} {
  167.     regexp {(.*) <[0-9]+>$} [set f [win::Current]] "" f
  168.     if {[file exists $f]} {
  169.     if {[regexp "\{(stop\[0-9\]+:\[0-9\]+) \{[quote::Regfind $f]\} $p $p\}" [getTMarks] "" which]} {
  170.         return $which
  171.     }
  172.     } else {
  173.     if {[regexp "\{(stop\[0-9\]+:\[0-9\]+) \{[quote::Regfind [pwd]$f]\} $p $p\}" [getTMarks] "" which]} {
  174.         return $which
  175.     }
  176.     }
  177.     return ""
  178. }
  179.  
  180. } else {
  181.     proc tmark::isAt {p} { return [isTMarkAt $p] }
  182. }
  183.  
  184. # Thanks to Johan Linde:
  185. proc refresh {{w ""}} {
  186.     if {$w == ""} {
  187.     eval sizeWin [lrange [getGeometry] 2 end]
  188.     } else {
  189.     eval sizeWin [list $w] [lrange [getGeometry $w] 2 end]
  190.     }
  191. }
  192.  
  193.  
  194. namespace eval text {}
  195.  
  196. proc text::hyper {from to hyper} {
  197.     text::color $from $to 15 $hyper
  198. }
  199.  
  200. proc text::color {from to colour {hyper ""}} {
  201.     if {$colour > 7} {
  202.     if {$colour == 15} {
  203.         insertColorEscape $from $colour $hyper
  204.     } else {
  205.         insertColorEscape $from $colour
  206.     }
  207.     insertColorEscape $to 12
  208.     } else {
  209.     insertColorEscape $from $colour
  210.     insertColorEscape $to 0
  211.     }
  212. }
  213.  
  214. namespace eval status {}
  215.  
  216. proc status::prompt {prompt {func ""} {type "key"}} {
  217.     global status::proc status::add
  218.     set status::proc $func
  219.     set status::add $type
  220.     return [uplevel [list statusPrompt $prompt status::helper]]
  221. }
  222.  
  223. proc status::helper {args} {
  224.     global status::add status::proc
  225.     switch -- ${status::add} {
  226.     "modifiers" -
  227.     "anything" {
  228.         lappend args [getModifiers]
  229.     } 
  230.     }
  231.     return [uplevel ${status::proc} $args]
  232. }
  233.  
  234. namespace eval pos {}
  235.  
  236. proc pos::compare {args} {uplevel expr $args}
  237. proc pos::math {args} {uplevel expr $args}
  238. proc pos::diff {p1 p2} {uplevel [list expr abs($p1 - $p2)]}
  239. proc minPos {} { return 0 }
  240.  
  241.  
  242.  
  243.  
  244.