util/src/TclTk/blt2.5/demos/htext1.tcl

   1 #!../src/bltwish
   2
   3 package require BLT
   4 # --------------------------------------------------------------------------
   5 # Starting with Tcl 8.x, the BLT commands are stored in their own
   6 # namespace called "blt".  The idea is to prevent name clashes with
   7 # Tcl commands and variables from other packages, such as a "table"
   8 # command in two different packages.
   9 #
  10 # You can access the BLT commands in a couple of ways.  You can prefix
  11 # all the BLT commands with the namespace qualifier "blt::"
  12 #
  13 #    blt::graph .g
  14 #    blt::table . .g -resize both
  15 #
  16 # or you can import all the command into the global namespace.
  17 #
  18 #    namespace import blt::*
  19 #    graph .g
  20 #    table . .g -resize both
  21 #
  22 # --------------------------------------------------------------------------
  23 if { $tcl_version >= 8.0 } {
  24     namespace import blt::*
  25     namespace import -force blt::tile::*
  26 }
  27 source scripts/demo.tcl
  28
  29 set visual [winfo screenvisual .]
  30 if { $visual == "staticgray"  || $visual == "grayscale" } {
  31     set activeBg black
  32     set normalBg white
  33     set bitmapFg black
  34     set bitmapBg white
  35     option add *top.background          white
  36 } else {
  37     option add *htext.foreground navyblue
  38     if { $tk_version >= 4.0 } {
  39         set file1 ./images/clouds.gif
  40         set file2 ./images/chalk.gif
  41         image create photo bgTexture1 -file $file1
  42         image create photo bgTexture2 -file $file2
  43 #       option add *htext.tile bgTexture1
  44         option add *htext.foreground black
  45         option add *htext.background white
  46         option add *htext.selectBackground gold1
  47     }
  48 }
  49 option add *highlightThickness 0
  50
  51 proc Blt_FindPattern { htext } {
  52     toplevel .search
  53     wm title .search "Text search"
  54     label .search.label1 -text "Enter Pattern"
  55     entry .search.entry -relief sunken
  56     button .search.clear -text "Clear" \
  57         -command ".search.entry delete 0 end"
  58     button .search.cancel -text "Cancel" \
  59         -command "destroy .search; focus $htext"
  60     button .search.search -text "Search" -command "Blt_Search&Move $htext"
  61     bind .search.entry <Return> "Blt_Search&Move $htext"
  62     table .search \
  63         .search.label1  0,0 -padx 4 \
  64         .search.entry   0,1 -cspan 2 -pady 4 -padx 4 -reqwidth 3i \
  65         .search.search  3,0 -reqwidth .75i -anchor w -padx 10 -pady 5  \
  66         .search.clear   3,1 -reqwidth .75i -anchor center -padx 10 -pady 5 \
  67         .search.cancel  3,2 -reqwidth .75i -anchor e -padx 10 -pady 5
  68     focus .search.entry
  69     bind .search <Visibility> { raise .search }
  70 }
  71
  72 set last 0
  73 set lastPattern {}
  74
  75 proc Blt_Search&Move { h } {
  76     global last
  77     global lastPattern
  78
  79
  80     set pattern [.search.entry get]
  81     if { [string compare $pattern $lastPattern] != 0 } {
  82         set last 0
  83         set lastPattern $pattern
  84     }
  85     if { $pattern == "" } {
  86         return
  87     }
  88
  89     set indices [$h search $pattern $last end]
  90     if { $indices == "" } {
  91         bell
  92     } else {
  93         set first [lindex $indices 0]
  94         set last [lindex $indices 1]
  95         $h selection range $first $last
  96         $h gotoline $first
  97         incr last
  98     }
  99 }
 100
 101 # Create horizonatal and vertical scrollbars
 102 scrollbar .vscroll -command { .htext yview } -orient vertical
 103 scrollbar .hscroll -command { .htext xview } -orient horizontal
 104
 105 # Create the hypertext widget
 106 htext .htext -file ./htext.txt  \
 107     -yscrollcommand { .vscroll set } \
 108     -xscrollcommand { .hscroll set } \
 109     -yscrollunits 10m -xscrollunits .25i \
 110     -height 6i
 111
 112
 113 table . \
 114     .htext 0,0 -fill both \
 115     .vscroll 0,1 -fill y \
 116     .hscroll 1,0 -fill x
 117
 118 table configure . r1 c1 -resize none
 119
 120 bind .htext <B1-Motion> {
 121     %W select to @%x,%y
 122 }
 123 bind .htext <1> {
 124     %W select from @%x,%y
 125     %W select to @%x,%y
 126 }
 127
 128 bind .htext <Shift-1> {
 129     %W select word @%x,%y
 130 }
 131 bind .htext <Meta-1> {
 132     %W select line @%x,%y
 133 }
 134 bind .htext <Control-1> {
 135     puts stderr [%W select index @%x,%y]
 136 }
 137
 138 bind .htext <B2-Motion> {
 139     %W scan dragto @%x,%y
 140 }
 141 bind .htext <2> {
 142     %W scan mark @%x,%y
 143 }
 144
 145 bind .htext <3> {
 146     %W select adjust @%x,%y
 147 }
 148
 149 bind .htext <Control-p> {
 150     set line [%W gotoline]
 151     if { $line == 0 } {
 152         bell
 153     } else {
 154         set line [expr $line-1]
 155         %W gotoline $line.0
 156     }
 157 }
 158 bind .htext <Control-n> {
 159     set line [%W gotoline]
 160     incr line
 161     if { [%W gotoline $line.0] != $line } {
 162         bell
 163     }
 164 }
 165
 166 bind .htext <Control-v> {
 167     %W yview [expr [%W yview]+10]
 168 }
 169
 170 bind .htext <Meta-v> {
 171     %W yview [expr [%W yview]-10]
 172 }
 173
 174 bind .htext <Alt-v> {
 175     %W yview [expr [%W yview]-10]
 176 }
 177
 178 bind .htext <Any-q> {
 179     exit 0
 180 }
 181 bind .htext <Control-s> {
 182     Blt_FindPattern %W
 183 }
 184
 185 wm min . 0 0
 186 focus .htext