Posted to tcl by kbk at Tue Aug 13 21:42:30 GMT 2019view raw

  1. package require Tk 8.6
  2.  
  3. set quote {I don't really care how time is reckoned so long as there is some agreement about it, but I object to being told that I am saving daylight when my reason tells me that I am doing nothing of the kind. I even object to the implication that I am wasting something valuable if I stay in bed after the sun has risen. As an admirer of moonlight I resent the bossy insistence of those who want to reduce my time for enjoying it. At the back of the Daylight Saving scheme I detect the bony, blue-fingered hand of Puritanism, eager to push people into bed earlier, and get them up earlier, to make them healthy, wealthy and wise in spite of themselves.}
  4.  
  5.  
  6.  
  7. proc makequote {t quote} {
  8. variable quoteseq
  9. variable quotes
  10. set f .t.f[incr quoteseq($t)]
  11. set bg [.t cget -background]
  12. frame $f -background $bg -borderwidth 0 -relief flat
  13. grid [frame $f.bar -width 2 -background black] \
  14. -row 0 -column 0 -sticky ns -padx {5 10}
  15. set t2 $f.t
  16. text $t2 -background $bg -font quotefont \
  17. -relief flat -borderwidth 0 -highlightthickness 0 -wrap word
  18. bind $t2 <<WidgetViewSync>> "adjustquote %W %d"
  19. grid $t2 -row 0 -column 1 -sticky nsew
  20. $t2 insert 1.0 $quote\n
  21. lappend quotes($t) $t2
  22. set inspt [.t index insert]
  23. .t insert $inspt \n blockquote
  24. .t window create $inspt -window $f
  25. }
  26.  
  27. proc configuretext {t w} {
  28. variable quotes
  29. if {$t ne $w} return
  30. set en [font measure [.t cget -font] n]
  31. set ewidth [expr {[winfo width .t] / $en - 4}]
  32. if {$ewidth <= 0} {
  33. set ewidth 5
  34. }
  35. foreach q $quotes($t) {
  36. $q configure -width $ewidth
  37. }
  38.  
  39. }
  40.  
  41. proc adjustquote {w insync} {
  42. if {!$insync} return
  43. set ft [$w cget -font]
  44. set ls [font metrics $ft -linespace]
  45. set ph [$w count -ypixels 1.0 end-1l]
  46. set lc [expr {$ph / $ls}]
  47. $w configure -height $lc
  48. }
  49.  
  50. font create quotefont -family Helvetica -size 12
  51.  
  52. grid [text .t -width 80 -height 25 -background white -font {Helvetica 12}\
  53. -yscrollcommand [list .y set]] \
  54. -row 0 -column 0 -sticky nsew
  55. set quotes(.t) {}
  56. bind .t <Configure> "configuretext .t %W"
  57. grid [scrollbar .y -orient vertical -command [list .t yview]] \
  58. -row 0 -column 1 -sticky nsew
  59. grid rowconfigure . 0 -weight 1
  60. grid columnconfigure . 0 -weight 1
  61.  
  62. .t insert insert "Here is an interesting quote:\n"
  63. makequote .t $quote
  64. .t insert insert " -- Robertson Davies\n"
  65.