"======================================================================
|
|   Smalltalk Tk-based GUI building blocks (text widget).
|
|   $Revision: 1.7.5$
|   $Date: 2000/05/28 16:56:52$
|   $Author: pb$
|
 ======================================================================"


"======================================================================
|
| Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc.
| Written by Paolo Bonzini.
|
| This file is part of the GNU Smalltalk class library.
|
| The GNU Smalltalk class library is free software; you can redistribute it
| and/or modify it under the terms of the GNU Lesser General Public License
| as published by the Free Software Foundation; either version 2.1, or (at
| your option) any later version.
| 
| The GNU Smalltalk class library is distributed in the hope that it will be
| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
| General Public License for more details.
| 
| You should have received a copy of the GNU Lesser General Public License
| along with the GNU Smalltalk class library; see the file COPYING.LESSER.
| If not, write to the Free Software Foundation, 59 Temple Place - Suite
| 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================"

"-------------------------- Main text widget class ------------------"

BViewport subclass: #BText
     instanceVariableNames: 'callback tagInfo images'
     classVariableNames: ''
     poolDictionaries: ''
     category: 'Graphics-Windows'
! 

BText comment: '
I represent a text viewer with pretty good formatting options.'!

BText
    "#char, #word, #none"
    defineAccessor: 'wrap' option: 'wrap' fromStringCode: 'asSymbol';
    defineMutator: 'wrap' option: 'wrap' toStringCode: '';
    defineColorProtocolWithActivePrefix: 'select' tk: 'select'!

!BText class methodsFor: 'accessing'!

emacsLike
    self tclEval: 'return $tk_strictMotif'.
    ^self tclResult = '1'
!

emacsLike: aBoolean
    self tclEval:
	'set tk_strictMotif ', (aBoolean ifTrue: [ '0' ] ifFalse: [ '1' ]).
! !

!BText class methodsFor: 'instance creation'!

newReadOnly: parent
    | ctl |
    ctl := self new: parent.
    ctl tclEval: ctl connected, ' configure -state disabled'.
    ^ctl
! !

!BText methodsFor: 'geometry management'!

xChild: child
    ^0!

child: child x: value
    "Never fail"!

child: child xOffset: value
    ^0!

yChild: child
    ^0!

child: child y: value
    ^0!

child: child yOffset: value
    self shouldNotImplement!

widthChild: child
    "Answer the given child's width in pixels."
    ^child at: #widthGeom ifAbsentPut: [ child widthAbsolute ]!

child: child width: value
    | width height |
    width := self at: #widthGeom put: value asInteger.
    height := self at: #heightGeom ifAbsentPut: [ child heightAbsolute ].
    "self
	tclEval: 'wm geometry %1 =%2x%3'
	with: child container
	with: width printString
	with: height printString"!

child: child widthOffset: value
    self child: child width: (self widthChild: child) + value!

heightChild: child
    "Answer the given child's height."
    ^child at: #heightGeom ifAbsentPut: [ child heightAbsolute ]!

child: child height: value
    | width height |
    height := self at: #heightGeom put: value asInteger.
    width := self at: #widthGeom ifAbsentPut: [ self widthAbsolute ].
    "self
	tclEval: 'wm geometry %1 =%2x%3'
	with: child container
	with: width printString
	with: height printString"!

child: child heightOffset: value
    self child: child height: (self heightChild: child) + value! !

!BText methodsFor: 'accessing'!

callback
    ^callback
!

callback: aReceiver message: aString
    callback := DirectedMessage
	selector: aString asSymbol
	arguments: #()
	receiver: aReceiver
!

contents
    self tclEval: self connected, ' get 1.0 end-1c'.
    ^self tclResult
!

contents: aString
    self tclEval:
	'%1 delete 1.0 end
	%1 insert 1.0 %2
	%1 see 1.0'
	with: self connected with: aString asTkString.
!

getSelection
    | result |
    self tclEval: '
	if { [%1 tag ranges sel] == {} } then { return {} }
	%1 get sel.first sel.last' with: self connected.

    result := self tclResult.
    ^result isEmpty ifTrue: [ nil ] ifFalse: [ result ]
! !

!BText methodsFor: 'position & lines'!

numberOfLines
    | stream |
    self tclEval: self connected, ' index end-1c'.
    stream := ReadStream on: self tclResult.
    ^(stream upTo: $.) asInteger
!

charsInLine: number
    | stream |
    self tclEval: self connected, ' index ', number printString, ' lineend'.
    stream := ReadStream on: self tclResult.
    stream skipTo: $. .
    ^stream upToEnd asInteger + 1
!

indexAt: point
    self
	tclEval: self connected, ' index @%1,%2'
	with: point x printString
	with: point y printString.

    ^self parseResult
!

lineAt: number
    self tclEval: '%1 get %2.0 %2.0 lineend'
	with: self connected
	with: number printString.
    ^self tclResult
!

setToEnd
    self tclEval: '
	%1 mark set insert end-1c
	%1 see end' with: self connected
!

selectFrom: first to: last
    self tclEval:
	'%1 tag remove sel 1.0 end
	%1 tag add sel %2'
	with: self connected
	with: (self from: first to: last)
!

currentPosition
    self tclEval: self connected, ' index insert'.
    ^self parseResult
!

currentPosition: aPoint
    self tclEval: '
      %1 mark set insert %2.%3
      %1 see insert' 
	with: self connected
	with: aPoint y printString
	with: (aPoint x - 1) printString.
!

currentColumn
    | stream |
    self tclEval: self connected, ' index insert'.
    stream := ReadStream on: self tclResult.
    stream skipTo: $. .
    ^stream upToEnd asInteger + 1
!

currentLine
    | stream |
    self tclEval: self connected, ' index insert'.
    stream := ReadStream on: self tclResult.
    ^(stream upTo: $.) asInteger
!

gotoLine: line end: aBoolean

    | code |
    code := aBoolean
	ifTrue: [ '%1 mark set insert "%2.0 -1l lineend"' ]
	ifFalse: [ '%1 mark set insert %2.0' ].

    self tclEval: code with: self connected with: line printString.
    self tclEval: self connected, ' see insert'.
    ^1
! !

!BText methodsFor: 'attributes'!

removeAttributes
    tagInfo isNil ifTrue: [ ^self ].
    self removeAttributesInside: '1.0 end'.
    tagInfo initialize: self.
!

removeAttributesFrom: aPoint to: endPoint
    tagInfo isNil ifTrue: [ ^self ].
    self removeAttributesInside: (self from: aPoint to: endPoint)
!

setAttributes: attr from: aPoint to: endPoint
    attr isNil ifTrue: [ ^self ].
    tagInfo isNil ifTrue: [ tagInfo := BTextTags new: self ].
    self tclEval: 'foreach tag %2 { %1 tag add $tag %3 }'
	with: self connected
	with: (attr tags: tagInfo)
	with: (self from: aPoint to: endPoint).
!

insertText: aString attribute: attr
    attr isNil ifTrue: [ ^self insertText: aString ].
    tagInfo isNil ifTrue: [ tagInfo := BTextTags new: self ].
    self tclEval:
	'%1 delete sel.first sel.last
	%1 insert insert %2 %3
	%1 see insert'
	with: self connected
	with: aString asTkString
	with: (attr tags: tagInfo).
!

insertAtEnd: aString attribute: attr
    attr isNil ifTrue: [ ^self insertAtEnd: aString ].
    tagInfo isNil ifTrue: [ tagInfo := BTextTags new: self ].
    self tclEval:
	'%1 tag remove sel 1.0 end
	%1 insert end %2%3'
	with: self connected
	with: aString asTkString
	with: (attr tags: tagInfo).
! !

!BText methodsFor: 'images'!

insertImage: anObject
    | key |
    key := self registerImage: anObject.

    self tclEval: '%1 image create insert -align baseline -image %2'
	with: self connected
	with: key value.

    ^key
!

insertImageAtEnd: anObject
    | key |
    key := self registerImage: anObject.

    self tclEval: '%1 image create end -align baseline -image %2'
	with: self connected
	with: key value.

    ^key
!

insertImage: anObject at: position
    | key |
    key := self registerImage: anObject.

    self tclEval: '%1 image create %2.%3 -align baseline -image %4'
	with: self connected
	with: position y printString
	with: (position x - 1) printString
	with: key value.

    ^key
!

registerImage: anObject
    | imageName |
    anObject class == ValueHolder ifTrue: [ ^anObject ].

    self tclEval: 'image create photo -data ', anObject asTkImageString.
    images isNil ifTrue: [ images := OrderedCollection new ].
    imageName := images add: self tclResult.
    ^ValueHolder value: imageName
! !

!BText methodsFor: 'inserting text'!

insertText: aString at: position
    self tclEval:
	'%1 delete sel.first sel.last
	%1 insert %2.%3 %4
	%1 see insert'
	with: self connected
	with: position y printString
	with: (position x - 1) printString
	with: aString asTkString
!

insertText: aString
    self tclEval:
	'catch { %1 delete sel.first sel.last }
	%1 insert insert %2
	%1 see insert'
	with: self connected
	with: aString asTkString
!

insertSelectedText: aString
    self tclEval:
	'%1 tag remove sel 1.0 end
	%1 insert insert %2 { sel }
	%1 see insert'
	with: self connected
	with: aString asTkString
!

insertTextSelection: aString
    self tclEval:
	'catch { %1 mark set insert sel.last }
	%1 tag remove sel 1.0 end
	%1 insert insert %2 { sel }
	%1 see insert'
	with: self connected
	with: aString asTkString
!

nextPut: aCharacter
    self insertAtEnd: (String with: aCharacter)
!

nextPutAll: aString
    self insertAtEnd: aString
!

nl
    self insertAtEnd: Character nl asString
!

insertAtEnd: aString
    self tclEval:
	'%1 tag remove sel 1.0 end
	%1 insert end %2'
	with: self connected
	with: aString asTkString
!

invokeCallback
    self callback isNil ifFalse: [ self callback send ]
!

refuseTabs
    self tclEval: '
	bind %1 <Tab> {
	    focus [tk_focusNext %W]
	    break
	}
	bind %1 <Shift-Tab> {
	    focus [tk_focusPrev %W]
	    break
	}' with: self connected
!

replaceSelection: aString
    self tclEval:
	'catch { %1 delete sel.first sel.last }
	%1 insert insert %2 { sel }
	%1 see insert'
	with: self connected
	with: aString asTkString
!

searchString: aString
    | result |
    self tclEval: self connected, ' search ',
	aString asTkString, ' 1.0 end'.

    result := self tclResult.
    result isEmpty ifTrue: [ ^0 ].
    
    self tclEval: '
	%1 mark set insert %2
	%1 see insert'
	with: self connected with: result.

    "Sending asInteger removes the column"
    ^result asInteger
!

space
    self insertAtEnd: ' '
! !

!BText methodsFor: 'private'!

addChild: child
    self tclEval: '%1 window create end -window %2'
	with: self connected
	with: child container.
    ^self basicAddChild: child
!

create
    self
	create: ' -bg white -wrap word -state normal -highlightthickness 0 -takefocus 1';
	horizontal: true;
	vertical: true.

    "This hack gets the callback upon insert or delete; see Tk FAQ
     by Jeffrey Hobbs (jeff.hobbs@acm.org)"
    self tclEval: '
      rename %1 .%1
      proc %1 args {
	if [regexp {^(ins|del).*} [lindex $args 0]] { callback %2 invokeCallback }
	uplevel .%1 $args
      }' with: self connected with: self asOop printString.

!

defineTag: name as: options
    self tclEval:
	'%1 tag configure %2 %3
	%1 tag raise sel %2'
	with: self connected
	with: name
	with: options
!

destroyed
    super destroyed.
    images isNil ifTrue: [ ^self ].
    images do: [ :name |
	self tclEval: 'image delete ', name.
    ].
    images := nil
!

from: aPoint to: endPoint
    ^'%1.%2 %3.%4'
	bindWith: aPoint y printString
	with: (aPoint x - 1) printString
	with: endPoint y printString
	with: (endPoint x - 1) printString
!

parseResult
    | stream y |
    stream := ReadStream on: self tclResult.
    y := (stream upTo: $.) asInteger.
    ^stream upToEnd asInteger + 1 @ y
!

removeAttributesInside: range
    self tclEval: 'foreach tag [ %1 tag names ] {
       if { $tag != "sel" } then { %1 tag remove $tag %2 }
    }'
	with: self connected
	with: range.
!

tag: name bind: event to: aSymbol of: anObject parameters: params

    self
	bind: event
	to: aSymbol
	of: anObject
	parameters: params
	prefix: ('%1 tag bind %2' bindWith: self connected with: name)
!

widgetType
    ^'text '
! !

"--------------------------- BTextBindings --------------------------"

BEventTarget subclass: #BTextBindings
       instanceVariableNames: 'list tagName'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'!

!BTextBindings class methodsFor: 'instance creation'!

new
    ^self basicNew initialize
! !

!BTextBindings methodsFor: 'BTextTags protocol'!

defineTagFor: aBText
    list do: [ :each | each sendTo: aBText ]
!

tagName
    ^tagName
! !

!BTextBindings methodsFor: 'private'!

initialize
    tagName := 'ev', (Time millisecondClockValue printString: 36).
    list := OrderedCollection new.
!

primBind: event to: aSymbol of: anObject parameters: params
    | args |
    (args := Array new: 5)
	at: 1 put: tagName;
	at: 2 put: event;
	at: 3 put: aSymbol;
	at: 4 put: anObject;
	at: 5 put: params.
    list add: (Message
	selector: #tag:bind:to:of:parameters:
	arguments: args)
! !


"-------------------------- BTextAttributes -------------------------"

Object subclass: #BTextAttributes
       instanceVariableNames: 'bgColor fgColor font styles events'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'!

BTextAttributes comment: '
I help you creating wonderful, colorful BTexts.'!


!BTextAttributes class methodsFor: 'instance-creation shortcuts'!

backgroundColor: color
    ^self new backgroundColor: color
!

foregroundColor: color
    ^self new foregroundColor: color
!

events: aBTextBindings
    ^self new events: aBTextBindings
!

font: font
    ^self new font: font
!

strikeout
    ^self new strikeout
!

underline
    ^self new underline
!

center
    ^self new center
!

red
    ^self new foregroundColor: 'red'
!

blue
    ^self new foregroundColor: 'blue'
!

darkGreen
    ^self new foregroundColor: 'PureDarkGreen'
!

green
    ^self new foregroundColor: 'green'
!

darkCyan
    ^self new foregroundColor: 'PureDarkCyan'
!

cyan
    ^self new foregroundColor: 'cyan'
!

darkMagenta
    ^self new foregroundColor: 'PureDarkMagenta'
!

magenta
    ^self new foregroundColor: 'magenta'
!

yellow
    ^self new foregroundColor: 'yellow'
!

white
    ^self new foregroundColor: 'white'
!

black
    ^self new foregroundColor: 'black'
! !

!BTextAttributes methodsFor: 'setting attributes'!

backgroundColor
    ^bgColor
!

backgroundColor: color
    bgColor := color
!

foregroundColor
    ^bgColor
!

foregroundColor: color
    fgColor := color
!

events
    ^events
!

events: aBTextBindings
    events := aBTextBindings
!

font
    ^font
!

font: fontName
    font := fontName
!

isStruckout
    ^self hasStyle: #STYLEstrikeout
!

strikeout
    self style: #STYLEstrikeout
!

isUnderlined
    ^self hasStyle: #STYLEunderline
!

underline
    self style: #STYLEunderline
!

isCentered
    self hasStyle: #STYLEcenter
!

center
    self style: #STYLEcenter
! !

!BTextAttributes methodsFor: 'colors'!

red
    self foregroundColor: 'red'
!

blue
    self foregroundColor: 'blue'
!

darkGreen
    self foregroundColor: 'PureDarkGreen'
!

green
    self foregroundColor: 'green'
!

darkCyan
    self foregroundColor: 'PureDarkCyan'
!

cyan
    self foregroundColor: 'cyan'
!

darkMagenta
    self foregroundColor: 'PureDarkMagenta'
!

magenta
    self foregroundColor: 'magenta'
!

yellow
    self foregroundColor: 'yellow'
!

white
    self foregroundColor: 'white'
!

black
    self foregroundColor: 'black'
! !

!BTextAttributes methodsFor: 'private'!

hasStyle: aSymbol
    ^styles notNil and: [ styles includes: aSymbol ]
!

style: aSymbol
    styles isNil ifTrue: [ styles := Set new ].
    styles add: aSymbol
!

tags: aBTextTags
    | s |
    s := WriteStream on: (String new: 20).
    s nextPutAll: ' {'.

    fgColor isNil ifFalse: [ s nextPutAll: (aBTextTags fgColor: fgColor) ].
    bgColor isNil ifFalse: [ s nextPutAll: (aBTextTags bgColor: bgColor) ].
    font    isNil ifFalse: [ s nextPutAll: (aBTextTags font:    font)    ].
    events  isNil ifFalse: [ s nextPutAll: (aBTextTags events:  events)  ].

    styles isNil ifFalse: [
	styles do: [ :each | s nextPut: $ ; nextPutAll: each ]
    ].
    s nextPut: $}.
    ^s contents
! !

"-------------------------- BTextTags - private ---------------------"

Object subclass: #BTextTags
       instanceVariableNames: 'client tags'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'!

BTextTags comment: '
I am a private class. I sit between a BText and BTextAttributes, helping
the latter in telling the former which attributes to use.'!


!BTextTags class methodsFor: 'instance creation'!

new
    self shouldNotImplement
!

new: client
    ^super new initialize: client
! !

!BTextTags methodsFor: 'BTextAttributes protocol'!

bgColor: color
    ^' b_', (self color: color)
!

fgColor: color
    ^' f_', (self color: color)
!

events: aBTextBindings
    | tagName |
    tagName := aBTextBindings tagName.
    (tags includes: tagName) ifFalse: [
	 tags add: tagName.
	 aBTextBindings defineTagFor: client.
    ].
    ^' ', tagName
!

font: font
    | tagName |
    tagName := WriteStream on: (String new: 20).
    font substrings do: [ :each | tagName nextPutAll: each; nextPut: $_ ].
    tagName := tagName contents.

    (tags includes: tagName)
	ifFalse: [
	    tags add: tagName.
	    client defineTag: tagName as: ' -font {', font, '}'
	].

    ^' ', tagName
! !

!BTextTags methodsFor: 'private'!

color: color
    | tagName |
    tagName := (color at: 1) = $#
	ifTrue: [ color copy at: 1 put: $_; yourself ]
	ifFalse: [ color asLowercase ].

    (tags includes: tagName)
	ifFalse: [
	    tags add: tagName.
	    client defineTag: 'f_', tagName as: ' -foreground ', color.
	    client defineTag: 'b_', tagName as: ' -background ', color
	].
    ^tagName
!


initialize: clientBText
    client := clientBText.
    tags := Set new.
    client defineTag: 'STYLEstrikeout' as: ' -overstrike 1'.
    client defineTag: 'STYLEunderline' as: ' -underline 1'.
    client defineTag: 'STYLEcenter' as: ' -justify center'.
! !