"======================================================================
|
|   Smalltalk Tk-based GUI building blocks (basic widget classes).
|
|   $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.  
|
 ======================================================================"

"-------------------------- Edit boxes ---------------------------"

BPrimitive subclass: #BEdit
       instanceVariableNames: 'callback'
       classVariableNames: 'Initialized'
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BEdit comment: '
I am a control showing one line of modifiable text.'!

BEdit
    defineFontProtocol;
    defineColorProtocolWithActivePrefix: 'select' tk: 'select'!

!BEdit class methodsFor: 'private'!

initializeOnStartup
    Initialized := false
! !

!BEdit class methodsFor: 'instance creation'!

new: parent contents: aString
    "Answer a new BEdit widget laid inside the given parent widget,
    with a default content of aString"
    ^(self new: parent)
	contents: aString;
	yourself
! !

!BEdit methodsFor: 'accessing'!

callback
    ^callback
!

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

contents
    self tclEval: 'return ${var', self connected, '}'.
    ^self tclResult
!

contents: newText
    self tclEval: 'set var', self connected, ' ', newText asTkString
! !

!BEdit methodsFor: 'widget protocol'!

destroyed
    self tclEval: 'unset var', self connected.
    super destroyed.
!

hasSelection
    self tclEval: self connected, ' selection present'.
    ^self tclResult = '1'
!

insertText: aString
    self tclEval:
	'catch { %1 delete sel.first sel.last }
	%1 insert insert %2
	%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
!

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

insertAtEnd: aString
    self tclEval:
	'%1 selection clear
	%1 insert end %2
	%1 see end'
	with: self connected
	with: aString asTkString
!

replaceSelection: aString
    self tclEval:
	'catch {
	  %1 icursor sel.first
	  %1 delete sel.first sel.last
	}
	%1 insert insert %2
	%1 select insert [expr %3 + [%1 index insert]]
	%1 see insert'
	with: self connected
	with: aString asTkString
	with: aString size printString
!

selection
    | stream first |
    self tclEval:
	'if [%1 selection present] {
	   return [string range ${var%1} [%1 index sel.first] [%1 index sel.last]]"
	 }'
	 with: self connected.

    ^self tclResult
!

selectionRange
    | stream first |
    self tclEval:
	'if [%1 selection present] {
	   return "[%1 index sel.first] [%1 index sel.last]"
	 }'
	 with: self connected.

    stream := ReadStream on: self tclResult.
    stream atEnd ifTrue: [ ^nil ].
    first := (stream upTo: $ ) asInteger + 1.
    ^first to: stream upToEnd asInteger + 1
!

selectAll
    self tclEval: self connected, ' selection range 0 end'
!

selectFrom: first to: last
    self tclEval: '%1 selection range %2 %3'
	with: self connected
	with: (first - 1) printString
	with: (last - 1) printString
!

space
    self insertAtEnd: ' '
! !

!BEdit methodsFor: 'private'!

create
    super create.
    Initialized ifFalse: [ self defineCallbackProcedure ].
    self tclEval: '
	set var%1 {}
	bind %1 <<Changed>> {callback %2 invokeCallback}
	trace variable var%1 w doEditCallback
	%1 configure -textvariable var%1 -highlightthickness 0 -takefocus 1'
	with: self connected
	with: self asOop printString.
!

defineCallbackProcedure
    Initialized := true.
    self tclEval: '
      proc doEditCallback { name el op } {
	regsub ^var $name {} widgetName
	event generate $widgetName <<Changed>>
      }'
!

setInitialSize
    "Make the Tk placer's status, the receiver's properties and the
     window status (as returned by winfo) consistent. Occupy the
     height indicated by the widget itself and the whole of the
     parent's width, at the top left corner"
    self x: 0 y: 0; width: self parent width.
!

widgetType
    ^'entry'
! !


"---------------------------- Labels -----------------------------"

BPrimitive subclass: #BLabel
       instanceVariableNames: ''
       classVariableNames: 'AnchorPoints'
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BLabel comment: '
I am a label showing static text.'!

BLabel
    defineFontProtocol;
    defineColorProtocol;
    defineAccessor: 'label' option: 'text' fromStringCode: '';
    defineMutator: 'label' option: 'text' toStringCode: '';
    defineMutator: 'anchor' option: 'anchor' toStringCode: ''!

!BLabel class methodsFor: 'initialization'!

initialize
    (AnchorPoints := IdentityDictionary new: 15)
	at: #topLeft put: 'nw';
	at: #topCenter put: 'n';
	at: #topRight put: 'ne';
	at: #leftCenter put: 'w';
	at: #center put: 'center';
	at: #rightCenter put: 'e';
	at: #bottomLeft put: 'sw';
	at: #bottomCenter put: 's';
	at: #bottomRight put: 'se'
! !

!BLabel class methodsFor: 'instance creation'!

new: parent label: label
    "Answer a new BLabel widget laid inside the given parent widget,
    showing by default the `label' String."
    ^(self new: parent)
	label: label;
	yourself
! !

!BLabel methodsFor: 'accessing'!

alignment
    ^self properties at: #alignment ifAbsent: [ #topLeft ]
!

alignment: aSymbol
    self anchor: (AnchorPoints at: aSymbol).
    self properties at: #alignment put: aSymbol.
! !


!BLabel methodsFor: 'private'!

create
    self create: '-anchor nw -takefocus 0'.
    self tclEval: 'bind %1 <Configure> "+%1 configure -wraplength %%w"'
	with: self connected
!

initialize: parentWidget
    super initialize: parentWidget.
    parentWidget isNil ifFalse: [
	self backgroundColor: parentWidget backgroundColor
    ].
!

setInitialSize
    "Make the Tk placer's status, the receiver's properties and the
     window status (as returned by winfo) consistent. Occupy the
     area indicated by the widget itself, at the top left corner"
    self x: 0 y: 0.
!

widgetType
    ^'label'
! !

BLabel initialize!

"---------------------------- Buttons ----------------------------"

BPrimitive subclass: #BButton
       instanceVariableNames: 'callback'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BButton comment: '
I am a button that a user can click. In fact I am at the head
of a small hierarchy of objects which exhibit button-like look
and behavior'!

BButton
    defineFontProtocol;
    defineColorProtocol;
    defineAccessor: 'label' option: 'text' fromStringCode: '';
    defineMutator: 'label' option: 'text' toStringCode: ''!


!BButton class methodsFor: 'instance creation'!

new: parent label: label
    "Answer a new BButton widget laid inside the given parent widget,
    showing by default the `label' String."
    ^(self new: parent)
	label: label;
	yourself
! !


!BButton methodsFor: 'accessing'!

callback
    ^callback
!

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

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

!BButton methodsFor: 'private'!

create
    self create: ('-highlightthickness 0 -takefocus 1 -command {callback %1 invokeCallback}'
	bindWith: self asOop printString)
!

setInitialSize
    "Make the Tk placer's status, the receiver's properties and the
     window status (as returned by winfo) consistent. Occupy the
     area indicated by the widget itself, at the top left corner"
    self x: 0 y: 0.
!

widgetType
    ^'button'
! !

"---------------------------- Forms ------------------------------"

BPrimitive subclass: #BForm
       instanceVariableNames: ''
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BForm comment: '
I am used to group many controls together. I leave the heavy
task of managing their position to the user.'!

BForm
    defineAccessor: 'defaultHeight' option: 'height' fromStringCode: 'asNumber';
    defineAccessor: 'defaultWidth' option: 'width' fromStringCode: 'asNumber';
    defineMutator: 'defaultHeight' option: 'height' toStringCode: 'printString';
    defineMutator: 'defaultWidth' option: 'width' toStringCode: 'printString';

    defineAccessor: 'backgroundColor' option: 'background' fromStringCode: '';
    defineMutator: 'backgroundColor' option: 'background' toStringCode: ''!

!BForm methodsFor: 'private'!

create
    self create: '-highlightthickness 0 -takefocus 0 -width 1 -height 1'
!

initialize: parentWidget
    super initialize: parentWidget.
    parentWidget isNil ifFalse: [
	self backgroundColor: parentWidget backgroundColor
    ].
!

widgetType
    ^'frame'
! !

"---------------------------- Containers -------------------------"

BForm subclass: #BContainer
       instanceVariableNames: 'vertical'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BContainer comment: '
I am used to group many controls together. I can perform simple
management by putting controls next to each other, from left to
right or from top to bottom.'!


!BContainer methodsFor: 'accessing'!

setVerticalLayout: aBoolean
    children isEmpty ifFalse: [
	^self error: 'cannot set layout after the first child is created'
    ].
    vertical := aBoolean.
! !

!BContainer methodsFor: 'flexibility'!

position: child below: last
    child posVert: last
!

position: child toTheRightOf: last
    child posHoriz: last
! !

!BContainer methodsFor: 'private'!

addChild: child
    | last |
    vertical isNil ifTrue: [ self setVerticalLayout: true ].

    last := children isEmpty
	ifTrue: [ nil ]
	ifFalse: [ children at: children size ].

    super addChild: child.
    last isNil ifFalse: [
	vertical
	    ifTrue:  [ self position: child below:	  last ]
	    ifFalse: [ self position: child toTheRightOf: last ]
    ].
    ^child
! !


"------------------------------ Radio Groups ------------------------------"

BContainer subclass: #BRadioGroup
     instanceVariableNames: 'lastValue lastAssignedValue'
     classVariableNames: ''
     poolDictionaries: ''
     category: 'Graphics-Windows'
!

BRadioGroup comment: '
I am used to group many mutually-exclusive radio buttons together.
In addition, just like every BContainer I can perform simple management
by putting controls next to each other, from left to right or (which is
more useful in this particular case...) from top to bottom.'!


!BRadioGroup methodsFor: 'accessing'!

value
   self tclEval: 'return ${var', self connected, '}'.
   ^self tclResult asInteger
!

value: value
    self tclEval: 'set var', self connected, ' ', value printString
! !

!BRadioGroup methodsFor: 'widget protocol'!

destroyed
    self tclEval: 'unset var', self connected.
    super destroyed.
! !


!BRadioGroup methodsFor: 'private'!

initialize: parentWidget
    super initialize: parentWidget.
    lastAssignedValue := lastValue := 0.
    self tclEval: 'set ', self variable, ' 1'.
!

lastValue
    ^lastValue
!

lastValue: value
    lastValue := value
!

newButtonValue
    ^lastAssignedValue := lastAssignedValue + 1
!

variable
    ^'var', self connected
! !


"------------------------------ Radio buttons ------------------------------"

BButton subclass: #BRadioButton
       instanceVariableNames: 'variableValue'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BRadioButton comment: '
I am just one in a group of mutually exclusive buttons.'!

BRadioButton
    defineMutator: 'variableValue' option: 'value' toStringCode: 'printString';
    defineMutator: 'variable' option: 'variable' toStringCode: ''!

!BRadioButton methodsFor: 'accessing'!

callback: aReceiver message: aString
    super callback: aReceiver message: aString.
    self callback arguments: (Array with: true)
!

value
    ^self parent value = variableValue
!

value: aBoolean
    aBoolean
	ifTrue: [ self parent value: variableValue ].

    "aBoolean is false - unhighlight everything if we're active"
    self value
	ifTrue: [ self parent value: 0 ]
! !


!BRadioButton methodsFor: 'private'!

initialize: parentWidget
    super initialize: parentWidget.
    variableValue := self parent newButtonValue.
    self
	tclEval: self connected, ' configure -anchor nw';
	variableValue: variableValue;
	variable: self parent variable;
	backgroundColor: parentWidget backgroundColor.

    variableValue = 1 ifTrue: [self parent value: 1]
!

widgetType
   ^'radiobutton'
! !

"------------------------------ Toggles ------------------------------------"

BButton subclass: #BToggle
       instanceVariableNames: 'value variableReturn'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BToggle comment: '
I represent a button whose choice can be included (by checking
me) or excluded (by leaving me unchecked).'!

BToggle
    defineMutator: 'variable' option: 'variable' toStringCode: ''!

!BToggle methodsFor: 'accessing'!

callback: aReceiver message: aString
    super callback: aReceiver message: aString.
    self callback arguments: (Array with: nil)
!

invokeCallback
    self callback isNil ifTrue: [ ^self ].
    self callback arguments at: 1 put: self value.
    super invokeCallback
!

value
    self tclEval: 'return ${var', self connected, '}'.
    ^self tclResult = '1'
!

value: aBoolean
    aBoolean
	ifTrue: [ self tclEval: 'set var', self connected, ' 1' ]
	ifFalse: [ self tclEval: 'set var', self connected, ' 0' ].
! !

!BToggle methodsFor: 'private'!

initialize: parentWidget
    | variable |
    super initialize: parentWidget.
    self tclEval: self connected, ' configure -anchor nw'.
    self tclEval: 'variable var', self connected.
    self variable: 'var', self connected.
    self backgroundColor: parentWidget backgroundColor
!

widgetType
    ^'checkbutton'
! !

"---------------------------- Images ----------------------------"

BPrimitive subclass: #BImage
       instanceVariableNames: ''
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BImage comment: '
I can display colorful images.'!

BImage
    defineColorProtocol;
    defineAccessor: 'gamma' command: 'img%1 cget -gamma'
	key: #gamma fromStringCode: 'asNumber';

    defineMutator: 'gamma' command: 'img%1 configure -gamma %3'
	key: #gamma toStringCode: 'asFloat printString';

    defineAccessor: 'displayWidth' command: 'img%1 cget -width'
	key: #displayWidth fromStringCode: 'asNumber';

    defineMutator: 'displayWidth' command: 'img%1 configure -width %3'
	key: #displayWidth toStringCode: 'asFloat printString';

    defineAccessor: 'displayHeight' command: 'img%1 cget -width'
	key: #displayHeight fromStringCode: 'asNumber';

    defineMutator: 'displayHeight' command: 'img%1 configure -width %3'
	key: #displayHeight toStringCode: 'asFloat printString'!

!BImage class methodsFor: 'instance creation'!

new: parent size: aPoint
    "Answer a new BImage widget laid inside the given parent widget,
    showing by default a transparent image of aPoint size."
    ^(self new: parent)
	displayWidth: aPoint x;
	displayHeight: aPoint y;
	blank;
	yourself
!

new: parent image: aFileStream
    "Answer a new BImage widget laid inside the given parent widget,
    loading data from the given file (GIF, XPM, PPM are supported)."
    ^(self new: parent)
	image: aFileStream;
	yourself
!

new: parent data: aString
    "Answer a new BImage widget laid inside the given parent widget,
    loading data from the given string (Base-64 encoded GIF, XPM,
    PPM are supported)."
    ^(self new: parent)
	data: aString;
	yourself
! !

!BImage methodsFor: 'image management'!

blank
    self tclEval: 'img', self connected, ' blank'
!

data: aString
    self tclEval: 'img', self connected, ' configure -data ',
	aString asTkImageString
!

dither
    self tclEval: 'img', self connected, ' redither'
!

fillRectangle: rectangle color: color
    self fillFrom: rectangle origin to: rectangle corner color: color
!

fillFrom: origin to: corner color: color
    self tclEval: 'img%1 put { %2 } -to %3 %4'
	with: self connected
	with: color
	with: (origin x printString, ' ', origin y printString)
	with: (corner x printString, ' ', corner y printString)
!

fillFrom: origin extent: extent color: color
    self fillFrom: origin to: origin + extent color: color
!

image: aFileStream
    self tclEval: 'img', self connected, ' read ', aFileStream name asTkString
!

imageHeight
    self tclEval: 'image height img', self connected.
    ^self tclResult asInteger
!

imageWidth
    self tclEval: 'image width img', self connected.
    ^self tclResult asInteger
!

lineFrom: origin extent: extent color: color
    self lineFrom: origin to: origin + extent color: color
!

lineFrom: origin to: corner color: color
    self notYetImplemented
!

lineFrom: origin toX: endX color: color
    self tclEval: 'img%1 put { %2 } -to %3 %4'
	with: self connected
	with: color
	with: (origin x printString, ' ', origin y printString)
	with: (endX printString, ' ', origin y printString)
!

lineFrom: origin toY: endY color: color
    self tclEval: 'img%1 put { %2 } -to %3 %4'
	with: self connected
	with: color
	with: (origin x printString, ' ', origin y printString)
	with: (origin x printString, ' ', endY printString)
!

lineInside: rectangle color: color
    self lineFrom: rectangle origin to: rectangle corner color: color
! !

!BImage methodsFor: 'widget protocol'!

destroyed
    primitive isNil ifFalse: [
	self tclEval: 'image delete img', self connected.
    ].
    super destroyed
! !

!BImage methodsFor: 'private'!

create
    self tclEval: 'image create photo img', self connected.
    self create: '-anchor nw -image img', self connected
!

setInitialSize
    "Make the Tk placer's status, the receiver's properties and the
     window status (as returned by winfo) consistent. Occupy the
     area indicated by the widget itself, at the top left corner"
    self x: 0 y: 0.
!

widgetType
    ^'label'
! !

"------------------------------ List box -----------------------------------"

BViewport subclass: #BList
       instanceVariableNames: 'labels items callback'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BList comment: '
I represent a list box from which you can choose one or more
elements.'!

BList
    defineFontProtocol;
    defineColorProtocolWithActivePrefix: 'highlight' tk: 'select';

    "#single, #browse, #extended, #multiple"
    defineAccessor: 'mode' option: 'selectmode' fromStringCode: 'asSymbol';
    defineMutator: 'mode' option: 'selectmode' toStringCode: '';

    defineAccessor: 'index'
	command: '%1 index active'
	key: #index
	fromStringCode: 'asInteger'!

!BList methodsFor: 'callbacks'!

itemSelected: receiver at: index 
    stdout nextPutAll: 'List item '; print: index;
	nextPutAll: ' selected!'; nl.
    stdout nextPutAll: 'Contents: '; nextPutAll: (items at: index + 1); nl.
! !


!BList methodsFor: 'accessing'!

at: anIndex
    ^items isNil
	ifTrue: [ labels at: anIndex + 1 ]
	ifFalse: [ items at: anIndex + 1 ]
!

add: string afterIndex: index
    labels isNil
	ifTrue: [
	    index > 0 ifTrue: [ ^self error: 'index out of bounds' ].
	    labels := OrderedCollection with: string.
	    items := nil
	]
	ifFalse: [
	    labels add: string afterIndex: index.
	    items notNil ifTrue: [ items add: nil afterIndex: index ].
	].
    self tclEval:
	self connected, ' insert ', index printString, ' ', string asTkString.
    ^string
!

add: string element: element afterIndex: index
    labels isNil
	ifTrue: [
	    index > 0 ifTrue: [ ^self error: 'index out of bounds' ].
	    labels := OrderedCollection with: string.
	    element isNil ifFalse: [
		items := OrderedCollection with: element.
	    ].
	]
	ifFalse: [
	    labels add: string afterIndex: index.
	    element notNil | items notNil ifTrue: [
		items add: element afterIndex: index
	    ].
	].
    self tclEval:
	self connected, ' insert ', index printString, ' ', string asTkString.
    ^element isNil ifTrue: [ element ] ifFalse: [ string ]
!

addLast: anObject
    | representation |
    representation := anObject displayString.
    labels isNil
	ifTrue: [
	    labels := OrderedCollection with: representation.
	    items := anObject isString
		ifTrue: [ nil ]
		ifFalse: [ OrderedCollection with: anObject ].
	]
	ifFalse: [
	    labels addLast: representation.
	    anObject isString & items isNil
		ifFalse: [ items addLast: anObject ]
	].

    self tclEval: self connected, ' insert end ', representation asTkString.
    ^anObject
!

addLast: string element: element
    labels isNil
	ifTrue: [
	    labels := OrderedCollection with: string.
	    element isNil ifFalse: [
		items := OrderedCollection with: element
	    ].
	]
	ifFalse: [
	    labels addLast: string.
	    element notNil | items notNil ifTrue: [
		items addLast: element
	    ].
	].
    self tclEval: self connected, ' insert end ', string asTkString.
    ^element isNil ifTrue: [ element ] ifFalse: [ string ]
!

contents: stringCollection
    ^self contents: stringCollection elements: nil
!

contents: stringCollection elements: elementList
    | stream | 
    (elementList notNil and: [ elementList size ~= stringCollection size ])
	ifTrue: [ ^self error: 'label collection must have the same size as element collection' ].

    labels := stringCollection asOrderedCollection.
    items := elementList.
    items isNil ifFalse: [ items := items asOrderedCollection ].

    self tclEval: self connected, ' delete 0 end'.

    stream := WriteStream on: (String new: 1000).
    stream nextPutAll: self connected; nextPutAll: ' insert 0'.

    stringCollection do: [ :each |
	stream space.
	stream nextPutAll: each asTkString
    ].

    self tclEval: stream contents.
!

do: aBlock
    items notNil
	ifTrue: [ items do: aBlock ]
	ifFalse: [ labels do: aBlock ]
!

elements: elementList
    | stream | 
    labels := elementList collect: [ :each | each displayString ].
    items := elementList asOrderedCollection.

    self tclEval: self connected, ' delete 0 end'.

    stream := WriteStream on: (String new: 1000).
    stream nextPutAll: self connected; nextPutAll: ' insert 0'.

    labels do: [ :each |
	stream space.
	stream nextPutAll: each asTkString
    ].

    self tclEval: stream contents.
!

isSelected: index
    self tclEval: self connected, ' selection includes ', index printString.
    ^self tclResult = '1'
!

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

    ^self tclResult asInteger + 1
!

labelAt: anIndex
    ^labels at: anIndex + 1
!

labelsDo: aBlock
    labels do: aBlock
!

numberOfStrings
    ^labels size
!

removeAtIndex: index
    | result |
    result := labels removeAtIndex: index.
    items isNil ifFalse: [
	result := items removeAtIndex: index.
    ].
    self tclEval: self connected, 'delete ', index printString.
    ^result
!

size
    ^labels size
! !

!BList methodsFor: 'disabled operations'!

rowSpacing: spacing
!

columnSpacing: spacing
!

numberOfColumns: numCols
!

usingVerticalLayout
    ^true
!

useVerticalLayout: verticalBool
! !

!BList methodsFor: 'widget protocol'!

highlight: index
    (self mode = #single or: [ self mode = #browse ])
	ifTrue: [ self unhighlight ].

    self select: index
!

select: index
    self tclEval:
	'%1 selection set %2
	%1 activate %2
	%1 see %2'
	with: self connected
	with: (index - 1) printString
!

show: index
    self tclEval: self connected, ' see ', (index - 1) printString
!

unselect: index
    self tclEval: self connected, ' selection clear ', (index - 1) printString
!

unhighlight
    self tclEval: self connected, ' selection clear 0 end'
!

callback
    ^callback
!

callback: aReceiver message: aString
    | arguments selector numArgs |
    selector := aString asSymbol.
    numArgs := aString asSymbol numArgs.
    arguments := #().
    numArgs = 1 ifTrue: [ arguments := Array new: 1 ].
    numArgs = 2 ifTrue: [ arguments := Array with: self with: nil ].

    callback := DirectedMessage
	selector: selector
	arguments: arguments
	receiver: aReceiver
!

invokeCallback
    self callback notNil ifTrue: [
	self callback arguments isEmpty ifFalse: [
	    self callback arguments
		at: self callback arguments size
		put: (self properties at: #index).
	].
	self callback send
    ]
! !


!BList methodsFor: 'private'!

create
    self
	create: '-highlightthickness 0 -takefocus 1 -bg white -exportselection no';
	horizontal: true; vertical: true.

    "Tcl hack to get the callback upon activate. See analogous
     trick for text boxes in BText>>#initialize:."

    self tclEval: '
      rename %1 .%1
      proc %1 args {
	if [regexp {^a.*} [lindex $args 0]] {
	  callback %2 invokeCallback: [%1 index [lindex $args 1]]
	}
	uplevel .%1 $args
      }' with: self connected with: self asOop printString.
!

initialize: parentWidget
    super initialize: parentWidget.
    self properties at: #index put: nil.
    labels := OrderedCollection new.
!

invokeCallback: indexString
    | index |
    index := indexString asInteger.

    "Tk allows a single/browse-selection list box to have no element
     selected by clicking on the selected item. Thwart its intentions by 
     reselecting that item. This behavior (which is e.g. the one adopted
     by Windows) seemed more reasonable to me when using a list box in a
     browser"

    (self isSelected: index) ifFalse: [
	(self mode = #single) | (self mode = #browse) ifTrue: [
	    (self properties at: #index) isNil ifFalse: [
		self tclEval: self connected, ' selection set ',
		    (self properties at: #index) printString.
		^self
	    ]
	]
    ].
    self properties at: #index put: index.
    self invokeCallback
!

widgetType
    ^'listbox'
! !


"------------------------------ Window ------------------------------"

BForm subclass: #BWindow		"Top level container"
      instanceVariableNames: 'isMapped callback x y width height'
      classVariableNames: 'TopLevel Grab'
      poolDictionaries: ''
      category: 'Graphics-Windows'
! 

BWindow comment: '
I am the boss. Nothing else could be viewed or interacted with if
it wasn''t for me... )):->'!

BWindow
    defineMutator: 'menu' option: 'menu' toStringCode: 'container';

    defineAccessor: 'label' command: 'wm title %1'
	key: #label fromStringCode: '';

    defineMutator: 'label' command: 'wm title %1 %3'
	key: #label toStringCode: '';

    defineAccessor: 'resizable' command: 'wm resizable %1'
	key: #resizable fromStringCode: ' = ''{1 1}'' ';

    defineMutator: 'resizable' command: 'wm resizable %1 %3 %3'
	key: #resizable toStringCode: ' asCBooleanValue printString'!

!BWindow class methodsFor: 'initialization'!

initializeOnStartup
    self tclEval: 'wm withdraw .'.
    TopLevel := OrderedCollection new.
    Grab := nil.
! !

!BWindow class methodsFor: 'instance creation'!

new
    "Answer a new top-level window."
    ^TopLevel add: (super new: nil)
!

new: label
    "Answer a new top-level window with `label' as its title bar caption."
    ^self new
	label: label
!

popup: initializationBlock
    self shouldNotImplement
! !


!BWindow methodsFor: 'accessing'!

callback
    ^callback
!

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

invokeCallback
    | result |
    result := self callback isNil or: [ self callback send ].
    result ifTrue: [ self destroy ].
    isMapped := result not.
! !

!BWindow methodsFor: 'widget protocol'!

centerIn: view
    self
	x: view x + (view width  // 2) - (self parent width  // 2)
	y: view x + (view height // 2) - (self parent height // 2)
!

center
    | screenSize |
    screenSize := Blox screenSize.
    self
	x: (screenSize x // 2) - (self width  // 2)
	y: (screenSize y // 2) - (self height // 2)
!

createToplevelWindow: dummy
    "for backward compatibility"
!

height
    height isNil ifTrue: [ self cacheWindowSize ].
    ^height
!

heightAbsolute
    height isNil ifTrue: [ self cacheWindowSize ].
    ^height
!

height: anInteger
    width isNil ifTrue: [ self cacheWindowSize ].
    self
	resetGeometry: '=%1x%2'
	x: x
	y: y
	width: width
	height: anInteger
!

isWindow
    ^true
!

map
    self isMapped ifTrue: [ self bringToTop. ^self ].

    self tclEval: '
	wm deiconify %1
	update
	focus [ tk_focusNext %1 ]
	raise %1' with: self container.
	
    self isMapped: true.
!

modalMap
    | previousGrab terminate |
    previousGrab := Grab.
    Grab := self connected.
    self
	map;
	tclEval: 'grab set ', Grab.

    terminate := false.
    self onDestroySend: #value to: [ terminate := true ].
    [ terminate ] whileFalse: [ Processor idle; yield ].

    previousGrab isNil
	ifTrue: [ self tclEval: 'grab release ', Grab ]
	ifFalse: [ self tclEval: 'grab set ', previousGrab ].

    Grab := previousGrab
!

isMapped
    ^isMapped
!

state
    self tclEval: 'wm state ', self connected.
    ^self tclResult asSymbol
!

state: aSymbol
    self error: 'To set a BWindow''s state, use #map and #unmap.'
!

unmap
    self isMapped ifFalse: [ ^self ].
    self tclEval: 'wm withdraw ', self connected.
    self isMapped: false.
!

width
    width isNil ifTrue: [ self cacheWindowSize ].
    ^width
!

widthAbsolute
    width isNil ifTrue: [ self cacheWindowSize ].
    ^width
!

width: anInteger
    height isNil ifTrue: [ self cacheWindowSize ].
    self resetGeometry: '=%1x%2' x: x y: y width: anInteger height: height
!

width: xSize height: ySize
    self resetGeometry: '=%1x%2' x: x y: y width: xSize height: ySize
!

window
    ^self
!

xAbsolute
    x isNil ifTrue: [ self cacheWindowSize ].
    ^x
!

x
    x isNil ifTrue: [ self cacheWindowSize ].
    ^x
!

x: anInteger
    y isNil ifTrue: [ self cacheWindowSize ].
    self resetGeometry: '+%3+%4' x: anInteger y: y width: width height: height
!

x: xPos y: yPos
    self resetGeometry: '+%3+%4' x: xPos y: yPos width: width height: height
!

x: xPos y: yPos width: xSize height: ySize
    self
	resetGeometry: '=%1x%2+%3+%4'
	x: xPos
	y: yPos
	width: xSize
	height: ySize
!

yAbsolute
    y isNil ifTrue: [ self cacheWindowSize ].
    ^y
!

y
    y isNil ifTrue: [ self cacheWindowSize ].
    ^y
!

y: anInteger
    x isNil ifTrue: [ self cacheWindowSize ].
    self resetGeometry: '+%3+%4' x: x y: anInteger width: width height: height
!

heightOffset: value
    self shouldNotImplement
!

widthOffset: value
    self shouldNotImplement
!

xOffset: value
    self shouldNotImplement
!

yOffset: value
    self shouldNotImplement
! !

!BWindow methodsFor: 'private'!

create
    self create: '-takefocus 0'.
!

create: options
    super create: options.
    self isMapped: false.
    self bind: '<Configure>' to: #resized of: self parameters: ''.
    self tclEval: '
	wm withdraw %1
	wm protocol %1 WM_DELETE_WINDOW { callback %2 invokeCallback }'

	with: self connected
	with: self asOop printString
!

destroyed
    super destroyed.
    TopLevel remove: self ifAbsent: [ ]
!

isMapped: aBoolean
    isMapped := aBoolean
!

resetGeometry: pattern x: xPos y: yPos width: xSize height: ySize
    | s mapped |
    s := WriteStream on: (String new: 50).
    (mapped := self isMapped) ifTrue: [
        s nextPutAll: 'wm withdraw ', self connected; nl.
        self isMapped: false.
    ].
    s
	nextPutAll: 'wm geometry ';
	nextPutAll: self connected;
	space;
	nextPutAll: pattern;
	nl;
	nextPutAll: 'update'.

    self tclEval: s contents
	with: xSize printString
	with: ySize printString
	with: xPos printString
	with: yPos printString.

    x := xPos. y := yPos.
    width := xSize. height := ySize.
    mapped ifTrue: [ self map ].
!

cacheWindowSize
    | stream |
    self tclEval: 'update; wm geometry ', self container.
    stream := ReadStream on: self tclResult.
    width := (stream upTo: $x) asInteger.
    height := (stream upTo: $+) asInteger.
    x := (stream upTo: $+) asInteger.
    y := stream upToEnd asInteger.
!

resized
    self isMapped ifFalse: [ ^self ].
    x := y := width := height := nil.
!

setInitialSize
    self x: 0 y: 0 width: 300 height: 300.
!

widgetType
    ^'toplevel'
! !

"Blox extensions "
"Written by Brad Diller June 3, 1995"

"------------------------------ Transient windows ----------------------"

BWindow subclass: #BTransientWindow	
       instanceVariableNames: ''
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BTransientWindow comment: '
I am almost a boss. I represent a window which is logically linked
to another which sits higher in the widget hierarchy, e.g. a dialog
box'!

!BTransientWindow class methodsFor: 'instance creation'!

new
    self shouldNotImplement
!

new: parentWindow
    "Answer a new transient window attached to the given
     parent window and with nothing in its title bar caption."
    ^self basicNew
	initialize: parentWindow;
	yourself
!

new: label in: parentWindow
    "Answer a new transient window attached to the given
     parent window and with `label' as its title bar caption."
    ^self basicNew
	initialize: parentWindow;
	label: label;
	yourself
! !

!BTransientWindow methodsFor: 'widget protocol'!

map
    super map.
    self tclEval: 'wm transient ', self connected, ' ', self parent connected.
    self tclEval: 'wm group     ', self connected, ' ', self parent connected
! !

!BTransientWindow methodsFor: 'private'!

setWidgetName: parentWidget
    | unique |
    unique := '.w', (self asOop printString: 36).
    parentWidget isNil
	ifTrue: [ ^unique ].

    ^parentWidget parent isNil
	ifTrue: [ unique ]
	ifFalse: [ parentWidget parent container copy, unique ].
! !


"------------------------------ Transient windows ----------------------"

BWindow subclass: #BPopupWindow
       instanceVariableNames: ''
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BPopupWindow comment: '
I am a pseudo-window that has no decorations and no ability to interact
with the user.  My main usage, as my name says, is to provide pop-up
functionality for other widgets.  Actually there should be no need to
directly use me - always rely on the #new and #popup: class methods.'!

!BPopupWindow methodsFor: 'geometry management'!

addChild: w
    self tclEval: 'place forget ', w container.
    self tclEval: 'pack ', w container, ' -fill both -side left -padx 1 -pady 1'.
    ^self basicAddChild: w
!

xChild: child
    ^self x!

child: child x: value
    self x: value!

child: child xOffset: value
    self shouldNotImplement!

yChild: child
    ^self y!

child: child y: value
    self y: value!

child: child yOffset: value
    self shouldNotImplement!

widthChild: child
    "Answer the given child's width in pixels."
    ^self width!

child: child width: value
    "Set the given child's width."
    "Only act after #addChild:"
    self childrenCount = 0 ifTrue: [ ^self ].
    self tclEval: 'pack ', child container, ' -expand 1'.
    self width: value!

child: child widthOffset: value
    self shouldNotImplement!

heightChild: child
    "Answer the given child's height."
    ^self height!

child: child height: value
    "Set the given child's height."
    "Only act after #addChild:"
    self childrenCount = 0 ifTrue: [ ^self ].
    self tclEval: 'pack ', child container, ' -expand 1'.
    self height: value!

child: child heightOffset: value
    self shouldNotImplement! !

!BPopupWindow methodsFor: 'private'!

create
    self
	create: '-takefocus 0 -background black';
	tclEval: 'wm overrideredirect ', self connected, ' 1';
	resizable: false
!

setInitialSize
    self cacheWindowSize
! !


"------------------------------ Auto dialog widgets --------------------"

BForm subclass: #BDialog
       instanceVariableNames: 'callbacks initInfo'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BDialog comment: '
I am a facility for implementing dialogs with many possible choices
and requests. In addition I provide support for a few platform native
common dialog boxes, such as choose-a-file and choose-a-color.'!


!BDialog class methodsFor: 'prompters'!

chooseColor: parent label: aLabel default: color
    | result |
    parent map.
    self tclEval: 'tk_chooseColor -parent %1 -title %2 -initialcolor %3'
	with: parent container
	with: aLabel asTkString
	with: color asTkString.

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

chooseFileToOpen: parent label: aLabel default: name defaultExtension: ext types: typeList
    "e.g.
	fileName := BDialog
	    chooseFileToOpen: aWindow
	    label: 'Open file'
	    default: nil
	    defaultExtension: 'gif'
	    types: #(
	       ('Text Files'       '.txt' '.diz')
	       ('Smalltalk files'  '.st')
	       ('C source files'   '.c')
	       ('GIF files'	'.gif'))	   "

    ^self
	chooseFile: 'Open'
	parent: parent
	label: aLabel
	default: name
	defaultExtension: ext
	types: typeList
!

chooseFileToSave: parent label: aLabel default: name defaultExtension: ext types: typeList
    "example: see chooseFileToOpen..."

    ^self
	chooseFile: 'Save'
	parent: parent
	label: aLabel
	default: name
	defaultExtension: ext
	types: typeList
! !

!BDialog class methodsFor: 'private'!

chooseFile: operation parent: parent label: aLabel default: name
    defaultExtension: ext types: typeList

    | stream strictMotif file |
    stream := WriteStream on: String new.

    stream
       nextPutAll: 'tk_get';
       nextPutAll: operation;
       nextPutAll: 'File -parent ';
       nextPutAll: parent container;
       nextPutAll: ' -title ';
       nextPutAll: aLabel asTkString;
       nextPutAll: ' -defaultextension ';
       nextPutAll: ext asTkString;
       nextPutAll: ' -filetypes {'.

    typeList do: [ :each |
	stream
	    nextPut: ${;
	    nextPutAll: (each at: 1) asTkString;
	    nextPutAll: ' {'.

	each size > 1
	    ifTrue: [
		each from: 2 to: each size do: [ :type |
		    stream nextPutAll: type; space.
		]
	    ].
	stream nextPutAll: '}} '.
    ].
    stream nextPutAll: '{"All files" * }}'.

    (name notNil and: [ name notEmpty ]) ifTrue: [
       stream
	   nextPutAll: ' -initialfile ';
	   nextPutAll: name asTkString
    ].

    strictMotif := BText emacsLike.
    BText emacsLike: (Blox platform ~= 'unix').

    parent map.
    self tclEval: stream contents.
    file := self tclResult.
    file isEmpty ifTrue: [ file := nil ].

    BText emacsLike: strictMotif.
    ^file
! !


!BDialog class methodsFor: 'instance creation'!

new: parent
    "Answer a new dialog handler (containing a label widget and
    some button widgets) laid out within the given parent window.
    The label widget, when it is created, is empty."
    ^self basicNew initInfo: '' -> nil; initialize: parent
!

new: parent label: aLabel
    "Answer a new dialog handler (containing a label widget and
    some button widgets) laid out within the given parent window.
    The label widget, when it is created, contains aLabel."
    ^self basicNew initInfo: aLabel -> nil; initialize: parent
!

new: parent label: aLabel prompt: aString
    "Answer a new dialog handler (containing a label widget, some
    button widgets, and an edit window showing aStrnig by default)
    laid out within the given parent window.
    The label widget, when it is created, contains aLabel."
    ^self basicNew initInfo: aLabel -> aString; initialize: parent
! !

!BDialog methodsFor: 'accessing'!

addButton: aLabel receiver: anObject index: anInt
    callbacks addLast: (DirectedMessage
	selector: #dispatch:
	arguments: (Array with: anInt)
	receiver: anObject).
    self addButton: aLabel.
!

addButton: aLabel receiver: anObject message: aSymbol
    callbacks addLast: (DirectedMessage
	selector: aSymbol
	arguments: #()
	receiver: anObject).
    self addButton: aLabel.
!

contents
    self tclEval: 'return ${var', self connected, '}'.
    ^self tclResult
!

contents: newText
    self tclEval: 'set var', self connected, ' ', newText asTkString
! !


!BDialog methodsFor: 'widget protocol'!

center
    self parent center
!

centerIn: view
    self parent centerIn: view
!

destroyed
    self tclEval: 'catch { unset var', self connected, '}'.
    super destroyed.
!

invokeCallback: index
    (callbacks at: index asInteger) send.
    self parent destroy
!

loop
    self parent width: (self parent width min: 200).
    self parent modalMap.
! !

!BDialog methodsFor: 'private'!

addButton: aLabel
    self tclEval: 'button %1.buttons.b%2 -text %3 -highlightthickness 0 -takefocus 1 -command {
	callback %4 "invokeCallback:" %2
	destroy %1
    }
    pack %1.buttons.b%2 -side left -expand 1'
	with: self container
	with: callbacks size printString
	with: aLabel asTkString
	with: self asOop printString.
!

create
    super create.
    self tclEval: '
	label %1.msg -padx 5 -pady 5 -anchor nw -text ', initInfo key asTkString, '
	place %1.msg -x 0.0 -y 0.0 -relwidth 1.0
	%1.msg configure -background [ %1 cget -background ]
	frame %1.buttons -highlightthickness 0 -takefocus 0
	%1.buttons configure -background [ %1 cget -background ]
	place %1.buttons -anchor sw -x 0.0 -rely 1.0 -relwidth 1.0 -height 14m
	lower %1.buttons
	lower %1.msg' with: self connected.

    initInfo value isNil ifTrue: [ ^self ].

    self tclEval: '
	set var%1 %2
	entry %1.text -textvariable var%1 -highlightthickness 0 -takefocus 1
	place %1.text -in %1.msg -x 5 -y 5 -width -10 -rely 1.0 -relwidth 1.0
	raise %1.text'
	with: self connected with: initInfo value asTkString.
!

initialize: parentWidget
    super initialize: parentWidget.
    callbacks := OrderedCollection new.
!

initInfo: assoc
    initInfo := assoc
! !

"------------------------------ Menu Bar ------------------------------"

BMenuObject subclass: #BMenuBar
     instanceVariableNames: ''
     classVariableNames: ''
     poolDictionaries: ''
     category: 'Graphics-Windows'
! 

BMenuBar comment: '
I am the Menu Bar, the top widget in a full menu structure.'!

!BMenuBar methodsFor: 'accessing'!

add: aMenu
    aMenu create.
    ^self addChild: aMenu
!

remove: aMenu
    self tclEval: 'delete ', aMenu connected
! !

!BMenuBar methodsFor: 'private'!

container
    ^primitive
!

connected
    ^primitive
!

initialize: parentWidget
    super initialize: parentWidget.
    primitive := self parent isNil
	ifTrue: [ '.popup' ]
	ifFalse: [ self parent container, '.menu' ].

    "BMenuBar is NOT a BPrimitive, so it has to explicitly create itself"
    self tclEval: 'menu ', self connected, ' -tearoff 0'.
    self parent isNil ifFalse: [ self parent menu: self ]
! !


"------------------------------ Menu ------------------------------"

BMenuObject subclass: #BMenu
     instanceVariableNames: 'label exists childrensUnderline'
     classVariableNames: ''
     poolDictionaries: ''
     category: 'Graphics-Windows'
! 

BMenu comment: '
I am the Menu, which groups together commands in a menu structure.'!

!BMenu class methodsFor: 'instance creation'!

new: parent label: label
    "Add a new menu to the parent window's menu bar, with `label' as
    its caption (for popup menus, parent is the widget over which the
    menu pops up as the right button is pressed)."
    ^self basicNew initialize: parent; label: label; yourself
! !

!BMenu methodsFor: 'accessing'!

exists
    ^exists
!

label: value
    label := value.
    exists ifTrue: [
	self tclEval: self connected, ' configure -title ', (value asTkString)
    ].
!

label
    ^label
! !

!BMenu methodsFor: 'callback registration'!

addLine
    ^self addMenuItemFor: #() notifying: self    "self is dummy"
!

addMenuItemFor: anArray notifying: receiver
    "Receiver will be sent the callback messages.  anArray
     is something that responds to at: and size.  Possible types are:
     #()		insert a seperator line
     #(name)	        create a menu item with name, but no callback
     #(name symbol)     create a menu item with the given name and
			no parameter callback.
     #(name symbol arg) create a menu item with the given name and
			one parameter callback."

    | item |
    item := self newMenuItemFor: anArray notifying: receiver.
!

callback: receiver using: selectorPairs
    "Receiver will be sent the callback messages.  Selector pairs
     is a collection of Arrays (or something that responds to at:
     and size). Possible types are:
     #()		insert a seperator line
     #(name)		create a menu item with name, but no callback
     #(name symbol)     create a menu item with the given name and
			no parameter callback.
     #(name symbol arg) create a menu item with the given name and
			one parameter callback."

    | item |
    selectorPairs do: [ :pair |
	item := self newMenuItemFor: pair notifying: receiver.
	exists ifTrue: [ item create ].
    ].
!

destroy
    self parent remove: self.
! !

!BMenu methodsFor: 'private'!

addChild: menuItem
    menuItem menuIndex: self childrenCount.
    super addChild: menuItem.
    self exists ifTrue: [ menuItem create ].
    ^menuItem
!

container
    ^primitive
!

connected
    ^primitive
!

create
    | s |
    s := WriteStream on: (String new: 80).
    s
	nextPutAll: 'menu ';
	nextPutAll: self connected;
	nextPutAll: ' -tearoff 0';
	nl;
	nextPutAll: self parent container;
	nextPutAll: ' add cascade -label ';
	nextPutAll: self label asTkString;
	nextPutAll: ' -underline 0 -menu ';
	nextPutAll: self connected.

    self tclEval: s contents.
    
    "Set the title for torn-off menus"
    self label: self label.
    self childrenDo: [ :each | each create ].
    exists := true.
!

initialize: parentWidget
    super initialize: parentWidget.
    label := ''.
    exists := false.
    primitive := '%1.w%2'
	bindWith: self parent container
	with: (self asOop printString: 36).
!

newMenuItemFor: pair notifying: receiver
    | item |
    pair size = 0 ifTrue: [ ^BMenuItem new: self ].

    item := BMenuItem new: self label: (pair at: 1).

    pair size = 1
	ifTrue: [ ^item ].

    pair size = 2
	ifTrue: [ ^item callback: receiver message: (pair at: 2) ].
    
    ^item callback: receiver message: (pair at: 2) argument: (pair at: 3)
!

underline: label
    childrensUnderline isNil
	ifTrue: [ childrensUnderline := ByteArray new: 256 ].

    label doWithIndex: [ :each :index || ascii |
	ascii := each asUppercase value + 1.
	(childrensUnderline at: ascii) = 0 ifTrue: [
	    childrensUnderline at: ascii put: 1.
	    ^index - 1
	]
    ].
    ^0
! !

"------------------------------ Popup Menu ------------------------------"

BMenu subclass: #BPopupMenu
       instanceVariableNames: ''
       classVariableNames: 'PopupMenuBar'
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BMenu comment: '
I am a Menu that pops up on another window. A handy shortcut, surely'!

!BPopupMenu class methodsFor: 'accessing'!

initializeOnStartup
    PopupMenuBar := nil
!

popupMenuBar
    PopupMenuBar isNil ifTrue: [ PopupMenuBar := BMenuBar new: nil ].
    ^PopupMenuBar
! !

!BPopupMenu methodsFor: 'widget protocol'!

popup
    self tclEval: 'event generate %1 <Shift-F10>'
	with: self parent connected
! !

!BPopupMenu methodsFor: 'private'!

initialize: parentWindow
    super initialize: self class popupMenuBar.
    self parent add: self.
    parentWindow
	bind: '<Button-3>'
	to: #popup:y:
	of: self
	parameters: '%X %Y'.

    parentWindow
	bind: '<Shift-F10>'
	to: #popup:y:
	of: self
	parameters: '[expr 2+[winfo rootx %W]] [expr 2+[winfo rooty %W]]'.
!

popup: x y: y
    "Note that x and y are strings!"
    self tclEval: 'tk_popup ', self connected, ' ', x, ' ', y
! !


"------------------------------ Menu Item ------------------------------"

BMenuObject subclass: #BMenuItem
       instanceVariableNames: 'index callback createCode'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
!

BMenuItem comment: '
I am the tiny and humble Menu Item, a single command choice in the
menu structure. But if it wasn''t for me, nothing could be done...
eh eh eh!!'!

!BMenuItem class methodsFor: 'instance creation'!

new: parent label: label
    "Add a new menu item to the specified menu (parent) , with `label'
    as its caption."
    ^self basicNew initialize: parent label: label
!

new: parent
    "Add a new separator item to the specified menu."
    ^self basicNew initialize: parent
! !


!BMenuItem methodsFor: 'accessing'!

callback
    ^callback
!

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

callback: aReceiver message: aSymbol argument: anObject
    callback := DirectedMessage
	selector: aSymbol asSymbol
	arguments: (Array with: anObject)
	receiver: aReceiver
!

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

label: value
    (self properties at: #label) isNil
	ifTrue: [ ^self error: 'no label for separator lines' ].

    self parent exists ifTrue: [
	self tclEval:
	    self container, ' entryconfigure ', self connected,
	    ' -label ', value asTkString
    ].
    self properties at: #label put: value
!

label
    ^self properties at: #label
! !


!BMenuItem methodsFor: 'private'!

connected
    ^index
!

container
    ^self parent container
!

create
    | label |
    label := self label ifNil: [ '' ] ifNotNil: [ :lab | lab asTkString ].
    self tclEval: createCode with: label with: self widgetType.
    createCode := ''       "free some memory"
!

initialize: parentWidget label: label
    | s |
    super initialize: parentWidget.

    s := WriteStream on: (String new: 80).
    s
	nextPutAll: self container;
	nextPutAll: ' add %2 -label %1 -underline ';
	print:	    (self parent underline: label);
	nextPutAll: ' -command { callback ';
	print:      self asOop;
	nextPutAll: ' invokeCallback }'.

    createCode := s contents.
    self properties at: #label put: label.
    parent addChild: self.
    parent exists ifTrue: [ self create ].
!

initialize: parentWidget
    super initialize: parentWidget.
    createCode := self container, ' add separator'.
    self properties at: #label put: nil.
    parent addChild: self.
!

widgetType
    ^'command'
!

menuIndex: anIndex
    index := anIndex printString
! !

"-------------------------- Checkbox menu item -------------------------"

BMenuItem subclass: #BCheckMenuItem
       instanceVariableNames: 'status'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
!

!BCheckMenuItem class methodsFor: 'instance creation'!

new: parent
    self shouldNotImplement
! !


!BCheckMenuItem methodsFor: 'accessing'!

invokeCallback
    self properties removeKey: #value ifAbsent: [ ].
    self callback isNil ifFalse: [ self callback send ]
!

value: aBoolean
    self properties at: #value put: aBoolean.
    self tclEval: 'set ', self variable, self valueString.
!

value
    ^self properties at: #value ifAbsentPut: [ false ]
! !

!BCheckMenuItem methodsFor: 'private'!

create
    super create.
    self
	tclEval: '%1 entryconfigure %2 -onvalue 1 -offvalue 0 -variable %3'
	    with: self container
	    with: self connected
	    with: self variable
!

destroyed
    self tclEval: 'unset var', self container, self connected.
    super destroyed.
!

widgetType
    ^'checkbutton'
!

variable
    ^('var', self connected, self container) copyWithout: $.
!

valueString
    ^self value ifTrue: [ ' 1' ] ifFalse: [ ' 0' ]
! !

