"======================================================================
|
|   Smalltalk Tk-based GUI building blocks (abstract 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.  
|
 ======================================================================"

"----------------------------------- Gui class ---------------------------"

Object subclass: #Gui
    instanceVariableNames: 'blox'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Graphics-Windows'
!

Gui comment: '
I am a small class which serves as a base for complex objects which
expose an individual protocol but internally use a Blox widget for
creating their user interface.'!

!Gui methodsFor: 'accessing' !

blox
    "Return instance of blox subclass which implements window"
    ^blox.
!

blox: aBlox
    "Set instance of blox subclass which implements window"
    blox := aBlox. 
! !

"------------------------------ Event handling ------------------------"

Object subclass: #BEventTarget
       instanceVariableNames: 'eventReceivers'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BEventTarget comment: '
I track all the event handling procedures that you apply to an object.'!

!BEventTarget methodsFor: 'intercepting events'!

addEventSet: aBEventSetSublass
    "Add to the receiver the event handlers implemented by an instance of
    aBEventSetSubclass. Answer the new instance of aBEventSetSublass"
    ^self registerEventReceiver: (aBEventSetSublass new: self)
!

onAsciiKeyEventSend: aSelector to: anObject
    "When an ASCII key is pressed and the receiver has the focus, send
     the 1-argument message identified by aSelector to anObject,
     passing to it a Character"

    aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<KeyPress>'
	to: #sendKeyEvent:oop:selector:
	of: self
	parameters: '*%A* ', anObject asOop printString, ' ', aSelector asTkString
!

onDestroySend: aSelector to: anObject
    "When the receiver is destroyed, send the unary message identified
     by aSelector to anObject."

    aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ].
    ^self
	bind: '<Destroy>'
	to: aSelector
	of: anObject
	parameters: ''
!

onFocusEnterEventSend: aSelector to: anObject
    "When the focus enters the receiver, send the unary message identified
     by aSelector to anObject."

    aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ].
    ^self
	bind: '<FocusIn>'
	to: aSelector
	of: anObject
	parameters: ''
!

onFocusLeaveEventSend: aSelector to: anObject
    "When the focus leaves the receiver, send the unary message identified
     by aSelector to anObject."

    aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ].
    ^self
	bind: '<FocusOut>'
	to: aSelector
	of: anObject
	parameters: ''
!

onKeyEvent: key send: aSelector to: anObject
    "When the given key is pressed and the receiver has the focus,
     send the unary message identified by aSelector to anObject.
     Examples for key are:  'Ctrl-1', 'Alt-X', 'Meta-plus', 'enter'.
     The last two cases include example of special key identifiers;
     these include: 'backslash', 'exclam', 'quotedbl', 'dollar',
     'asterisk', 'less', 'greater', 'asciicircum' (caret), 'question',
     'equal', 'parenleft', 'parenright', 'colon', 'semicolon', 'bar' (pipe
     sign), 'underscore', 'percent', 'minus', 'plus', 'BackSpace', 'Delete',
     'Insert', 'Return', 'End', 'Home', 'Prior' (Pgup), 'Next' (Pgdn),
     'F1'..'F24', 'Caps_Lock', 'Num_Lock', 'Tab', 'Left', 'Right', 'Up',
     'Down'.  There are in addition four special identifiers which map
     to platform-specific keys: '<Cut>', '<Copy>', '<Paste>', '<Clear>'
     (all with the angular brackets!)."

    aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ].

    ^self
	bind: (self getKeyPressEventName: key)
	to: aSelector
	of: anObject
	parameters: ''
!

onKeyEventSend: aSelector to: anObject
    "When a key is pressed and the receiver has the focus, send the
     1-argument message identified by aSelector to anObject. The pressed
     key will be passed as a String parameter; some of the keys will
     send special key identifiers such as those explained in the
     documentation for #onKeyEvent:send:to: Look at the #eventTest
     test program in the BloxTestSuite to find out the parameters
     passed to such an event procedure"

    aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ].
    ^self
	bind: '<KeyPress>'
	to: aSelector
	of: anObject
	parameters: '%K'
!

onKeyUpEventSend: aSelector to: anObject
    "When a key has been released and the receiver has the focus, send
     the 1-argument message identified by aSelector to anObject. The
     released key will be passed as a String parameter; some of the keys
     will send special key identifiers such as those explained in the
     documentation for #onKeyEvent:send:to: Look at the #eventTest
     test program in the BloxTestSuite to find out the parameters
     passed to such an event procedure"

    aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ].
    ^self
	bind: '<KeyRelease>'
	to: aSelector
	of: anObject
	parameters: '%K'
!

onMouseDownEvent: button send: aSelector to: anObject
    "When the given button is pressed on the mouse, send the
     1-argument message identified by aSelector to anObject. The
     mouse position will be passed as a Point."

    aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<ButtonPress-', button printString, '>'
	to: #sendPointEvent:y:oop:selector:
	of: self
	parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString
!

onMouseDownEventSend: aSelector to: anObject
    "When a button is pressed on the mouse, send the 2-argument
     message identified by aSelector to anObject. The mouse
     position will be passed as a Point in the first parameter,
     the button number will be passed as an Integer in the second
     parameter."

    aSelector numArgs = 2 ifFalse: [ ^self invalidArgsError: '2' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<ButtonPress>'
	to: #sendPointEvent:y:button:oop:selector:
	of: self
	parameters: '%x %y %b ', anObject asOop printString, ' ', aSelector asTkString
!

onMouseDoubleEvent: button send: aSelector to: anObject
    "When the given button is double-clicked on the mouse, send the
     1-argument message identified by aSelector to anObject. The
     mouse position will be passed as a Point."

    aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<Double-', button printString, '>'
	to: #sendPointEvent:y:oop:selector:
	of: self
	parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString
!

onMouseDoubleEventSend: aSelector to: anObject
    "When a button is double-clicked on the mouse, send the 2-argument
     message identified by aSelector to anObject. The mouse
     position will be passed as a Point in the first parameter,
     the button number will be passed as an Integer in the second
     parameter."

    aSelector numArgs = 2 ifFalse: [ ^self invalidArgsError: '2' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<Double>'
	to: #sendPointEvent:y:button:oop:selector:
	of: self
	parameters: '%x %y %b ', anObject asOop printString, ' ', aSelector asTkString
!

onMouseEnterEventSend: aSelector to: anObject
    "When the mouse enters the widget, send the unary message
     identified by aSelector to anObject."

    aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ].
    ^self
	bind: '<Enter>'
	to: aSelector
	of: anObject
	parameters: ''
!

onMouseLeaveEventSend: aSelector to: anObject
    "When the mouse leaves the widget, send the unary message
     identified by aSelector to anObject."

    aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ].
    ^self
	bind: '<Leave>'
	to: aSelector
	of: anObject
	parameters: ''
!

onMouseMoveEvent: button send: aSelector to: anObject
    "When the mouse is moved while the given button is pressed 
     on the mouse, send the 1-argument message identified by aSelector
     to anObject. The mouse position will be passed as a Point."

    aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<B', button printString, '-Motion>'
	to: #sendPointEvent:y:oop:selector:
	of: self
	parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString
!

onMouseMoveEventSend: aSelector to: anObject
    "When the mouse is moved, send the 1-argument message identified
     by aSelector to anObject. The mouse position will be passed as a Point."

    aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<Any-Motion>'
	to: #sendPointEvent:y:oop:selector:
	of: self
	parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString
!

onMouseTripleEvent: button send: aSelector to: anObject
    "When the given button is triple-clicked on the mouse, send the
     1-argument message identified by aSelector to anObject. The
     mouse position will be passed as a Point."

    aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<Triple-', button printString, '>'
	to: #sendPointEvent:y:oop:selector:
	of: self
	parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString
!

onMouseTripleEventSend: aSelector to: anObject
    "When a button is triple-clicked on the mouse, send the 2-argument
     message identified by aSelector to anObject. The mouse
     position will be passed as a Point in the first parameter,
     the button number will be passed as an Integer in the second
     parameter."

    aSelector numArgs = 2 ifFalse: [ ^self invalidArgsError: '2' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<Triple>'
	to: #sendPointEvent:y:button:oop:selector:
	of: self
	parameters: '%x %y %b ', anObject asOop printString, ' ', aSelector asTkString
!

onMouseUpEvent: button send: aSelector to: anObject
    "When the given button is released on the mouse, send the
     1-argument message identified by aSelector to anObject. The
     mouse position will be passed as a Point."

    aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<ButtonRelease-', button printString, '>'
	to: #sendPointEvent:y:oop:selector:
	of: self
	parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString
!

onMouseUpEventSend: aSelector to: anObject
    "When a button is released on the mouse, send the 2-argument
     message identified by aSelector to anObject. The mouse
     position will be passed as a Point in the first parameter,
     the button number will be passed as an Integer in the second
     parameter."

    aSelector numArgs = 2 ifFalse: [ ^self invalidArgsError: '2' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<ButtonRelease>'
	to: #sendPointEvent:y:button:oop:selector:
	of: self
	parameters: '%x %y %b ', anObject asOop printString, ' ', aSelector asTkString
!

onResizeSend: aSelector to: anObject
    "When the receiver is resized, send the 1-argument message
     identified by aSelector to anObject. The new size will be
     passed as a Point."

    aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ].
    self registerEventReceiver: anObject.
    ^self
	bind: '<Configure>'
	to: #sendPointEvent:y:oop:selector:
	of: self
	parameters: '%w %h ', anObject asOop printString, ' ', aSelector asTkString
! !

!BEventTarget methodsFor: 'private'!

bind: event to: aSymbol of: anObject parameters: params
    "Private - Register the given event, to be passed to anObject
    via the aSymbol selector with the given parameters. Also avoid
    that anObject is garbage collected as long as the receiver
    exists."
    self
	registerEventReceiver: anObject;
	primBind: event to: aSymbol of: anObject parameters: params
!

getKeyPressEventName: key
    "Private - Given the key passed to a key event installer method,
    answer the KeyPress event name as required by Tcl."
    | platform mod keySym |

    keySym := key isCharacter ifTrue: [ String with: key ] ifFalse: [ key ].
    (keySym at: 1) = $<   ifTrue: [ ^'<', keySym, '>' ].
    (keySym includes: $-) ifFalse: [ ^'<KeyPress-', keySym, '>' ].

    mod := (ReadStream on: key) upTo: $-.
    keySym := key copyFrom: mod size + 2 to: key size.

    platform := Blox platform.
    (mod = 'Meta') & (platform ~~ #unix)      ifTrue: [ mod := 'Alt' ].
    (mod = 'Alt')  & (platform == #unix)      ifTrue: [ mod := 'Meta' ].
    (mod = 'Alt')  & (platform == #macintosh) ifTrue: [ mod := 'Option' ].
    (mod = 'Ctrl') & (platform == #macintosh) ifTrue: [ mod := 'Cmd' ].
    ^'<', mod, '-KeyPress-', keySym, '>'
!

invalidArgsError: expected
    "Private - Raise an error (as one could expect...) What is not
    so expected is that the expected argument is a string."
    ^self error: 'invalid number of arguments, expected ', expected
!

primBind: event to: aSymbol of: anObject parameters: params
    "Private - Register the given event, to be passed to anObject
    via the aSymbol selector with the given parameters"
    self subclassResponsibility
!

registerEventReceiver: anObject
    "Private - Avoid that anObject is garbage collected as long as
    the receiver exists."
    eventReceivers isNil ifTrue: [ eventReceivers := IdentitySet new ].
    ^eventReceivers add: anObject
!

sendKeyEvent: key oop: oop selector: sel
    "Private - Filter ASCII events from Tcl to Smalltalk. We receive
     either *{}* for a non-ASCII char or *A* for an ASCII char, where
     A is the character. In the first case the event is eaten, in the
     second it is passed to a Smalltalk method"

    "key printNl.
    oop asInteger asObject printNl.
    '---' printNl."

    key size = 3 ifTrue: [
	oop asInteger asObject
	    perform: sel asSymbol
	    with: (key at: 2)
    ]
!

sendPointEvent: x y: y oop: oop selector: sel
    "Private - Filter mouse events from Tcl to Smalltalk. We receive two
     strings, we convert them to a Point and then pass them to a Smalltalk
     method"

    "oop printNl.
    oop asInteger asObject printNl.
    '---' printNl."

    oop asInteger asObject
	perform: sel asSymbol
	with: (x asInteger @ y asInteger)
!


sendPointEvent: x y: y button: button oop: oop selector: sel
    "Private - Filter mouse events from Tcl to Smalltalk. We receive three
     strings, we convert them to a Point and a Number, then pass them to a
     Smalltalk method"

    "oop printNl.
    oop asInteger asObject printNl.
    '---' printNl."

    oop asInteger asObject
	perform: sel asSymbol
	with: (x asInteger @ y asInteger)
	with: button asInteger
! !

"------------------------------ Event sets ----------------------------"

BEventTarget subclass: #BEventSet
       instanceVariableNames: 'widget'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BEventSet comment: '
I combine event handlers and let you apply them to many objects.
Basically, you derive a class from me, override the #initialize:
method to establish the handlers, then use the #addEventSet: method
understood by every Blox class to add the event handlers specified
by the receiver to the object.'!

!BEventSet class methodsFor: 'initializing'!

new
    self shouldNotImplement
!

new: widget
    "Private - Create a new event set object that will
     attach to the given widget. Answer the object. Note: this
     method should be called by #addEventSet:, not directly"
    ^self basicNew initialize: widget; yourself
! !

!BEventSet methodsFor: 'accessing'!

widget
    "Answer the widget to which the receiver is attached."
    ^widget
! !

!BEventSet methodsFor: 'initializing'!

initialize: aBWidget
    "Initialize the receiver's event handlers to attach to aBWidget.
     You can override this of course, but don't forget to call the
     superclass implementation first."
    widget := aBWidget.
! !

!BEventSet methodsFor: 'private'!

primBind: event to: aSymbol of: anObject parameters: params
    "Private - Register the given event, to be passed to anObject
    via the aSymbol selector with the given parameters; this method
    is simply forwarded to the attached widget"

    ^self widget
	primBind: event
	to: aSymbol
	of: anObject
	parameters: params
! !

" -------------------------------- Tcl interface ---------------------"

BEventTarget subclass: #Blox
       instanceVariableNames: 'primitive properties parent children'
       classVariableNames: 'DoDispatchEvents Interp ClipStatus Debug Platform'
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

Blox comment: '
I am the superclass for every visible user interface object (excluding
canvas items, which are pretty different). I provide common methods and
a simple Tcl interface for internal use. In addition, I expose class
methods that do many interesting event-handling things.

NOTE: some of the methods (notably geometry methods) may not be suitable for
all Blox subclasses and may be included only for backwards compatibility
towards 1.1.5 BLOX. You should use geometry methods only for subclasses of
BWidget.'!


Blox class
	defineCFunc: 'tclInit'
	withSelectorArgs: 'tclInit'
	returning: #cObject
	args: #()
!

Blox class
	defineCFunc: 'Tcl_Eval'
	withSelectorArgs: 'evalIn: interp tcl: cmd'
	returning: #int
	args: #(cObject string)
! 

Blox class
	defineCFunc: 'Tcl_GetStringResult'
	withSelectorArgs: 'resultIn: interp'
	returning: #string
	args: #(cObject)
! 

Blox class
	defineCFunc: 'bloxIdle'
	withSelectorArgs: 'idle'
	returning: #void
	args: #()
! 

!Blox class methodsFor: 'private - Tcl'!

debug
    "Private - Answer whether Tcl code is output on the standard output"
    ^Debug
!

debug: aBoolean
    "Private - Set whether Tcl code is output on the standard output"
    Debug := aBoolean
!

tclEval: tclCode
    "Private - Evaluate the given Tcl code; if it raises an exception,
     raise it as a Smalltalk error"
    self debug ifTrue: [ stdout nextPutAll: tclCode; nl ].
    (self evalIn: Interp tcl: tclCode) = 1
	ifTrue: [ self tclResult printNl. ^self error: self tclResult ].
!

tclResult
    "Private - Return the result code for Tcl, as a Smalltalk String."
    ^self resultIn: Interp
! !

!Blox methodsFor: 'private - Tcl'!

tclEval: tclCode
    "Private - Evaluate the given Tcl code; if it raises an exception,
     raise it as a Smalltalk error"
    Blox debug ifTrue: [ stdout nextPutAll: tclCode; nl ].
    (Blox evalIn: Interp tcl: tclCode) = 1
	ifTrue: [ ^self error: self tclResult ].
!

tclEval: tclCode with: arg1
    self
	tclEval: tclCode
	withArguments: (Array with: arg1)
!

tclEval: tclCode with: arg1 with: arg2
    self
	tclEval: tclCode
	withArguments: (Array with: arg1 with: arg2)
!

tclEval: tclCode with: arg1 with: arg2 with: arg3
    self
	tclEval: tclCode
	withArguments: (Array with: arg1 with: arg2 with: arg3)
!

tclEval: tclCode with: arg1 with: arg2 with: arg3 with: arg4
    self
	tclEval: tclCode
	withArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4)
!

tclEval: tclCode withArguments: anArray
    | char result wasPercent |
    result := WriteStream on: (String new: tclCode size * 2).
    wasPercent := false.
    
    1 to: tclCode size do: [:i |
	char := tclCode at: i.
	wasPercent
	    ifTrue: [
		char = $%
		    ifTrue: [ result nextPut: char ]
		    ifFalse: [ result nextPutAll: (anArray at: char digitValue) ].
		wasPercent := false
	    ]
	    ifFalse: [
		(wasPercent := (char = $%))
		    ifFalse: [ result nextPut: char ]
	    ]
    ].
    result nextPut: 0 asCharacter.

    Blox tclEval: result collection
!

tclResult
    "Private - Return the result code for Tcl, as a Smalltalk String."
    ^Blox resultIn: Interp
! !

" -------------------------------- 'meta' methods ---------------------"

!Blox class methodsFor: 'creating Tk interface methods'!

defineMutator: keyword option: tkOption toStringCode: extraCode
    "Private - Produce code to set a widget option, like...
   
    self tclEval: self connected, ' configure -label ' , (value  asTkString).
    self properties at: #label put: value"

    self
	defineMutator: keyword
	command: '%1 configure -', tkOption, ' %3'
	key: tkOption
	toStringCode: extraCode
!

defineAccessor: keyword option: tkOption fromStringCode: extraCode
    "Private - Produce code to retrieve a widget option, like...

    self properties at: #label ifPresent: [ :value | ^value ].
    self tclEval: '%1 cget -label'
	with: self connected
	with: self container.
    ^self properties at: #label put: (self tclResult )"

    self
	defineAccessor: keyword
	command: '%1 cget -', tkOption
	key: tkOption
	fromStringCode: extraCode
!

defineMutator: keyword command: cmd key: key toStringCode: extraCode
    "Private - produce code to set a widget option; the Smalltalk
    method is named `keyword:' and refers to a property named
    `key'. The Tcl command issued is `cmd', with %1 replaced by the
    connected Tk widget, %2 by the container, %3 by the Tcl string
    obtained by the parameter through evaluation of `extraCode'."
    | s |
    s _
'%1: value
    "Please refer to OptionDocumentation for %1"
    self tclEval: %2
	with: self connected
	with: self container
	with: (value %3 asTkString).
    self properties at: #%4 put: value'

	bindWith: keyword with: cmd storeString with: extraCode with: key.

    "stdout nextPutAll: s; nl; nl."
    self compile: s classified: 'accessing'
!

defineAccessor: keyword command: cmd key: key fromStringCode: extraCode
    "Private - produce code to retrieve a widget option; the
    Smalltalk method is named like `keyword' and refers to a
    property named `key'. The Tcl command issued is `cmd', with %1 replaced
    by the connected Tk widget and %2 by the container; if the code
    is executed, its result is passed to `extraCode' (which is sent to a
    String) and then put in the properties dictionary."
    | s |
    s _
'%1
    "Please refer to OptionDocumentation for %1"
    self properties at: #%4 ifPresent: [ :value | ^value ].
    self tclEval: %2
	with: self connected
	with: self container.
    ^self properties at: #%4 put: (self tclResult %3)'

	bindWith: keyword with: cmd storeString with: extraCode with: key.

    "stdout nextPutAll: s; nl; nl."
    self compile: s classified: 'accessing'
!

defineColorProtocol
    "Private - Define the `{fore|back}groundColor:', `{fore|back}groundColor'
    methods"

    self
	defineAccessor: 'foregroundColor' option: 'foreground' fromStringCode: '';
	defineAccessor: 'backgroundColor' option: 'background' fromStringCode: '';
	defineMutator: 'foregroundColor' option: 'foreground' toStringCode: '';
	defineMutator: 'backgroundColor' option: 'background' toStringCode: ''.
!

defineColorProtocolWithActivePrefix: active tk: tkActive
    "Private - Define the `{fore|back}groundColor:', `{fore|back}groundColor',
    `xxxx{Fore|Back}ground', `xxxx{Fore|Back}ground:' methods, where xxxx
    is replaced by the contents of the `active' parameter (a String)."

    self
	defineColorProtocol;
	defineAccessor: active, 'Foreground' option: tkActive, 'foreground' fromStringCode: '';
	defineAccessor: active, 'Background' option: tkActive, 'background' fromStringCode: '';
	defineMutator: active, 'Foreground' option: tkActive, 'foreground' toStringCode: '';
	defineMutator: active, 'Background' option: tkActive, 'background' toStringCode: ''
! !


" -------------------------------- generic methods ---------------------"

!Blox class methodsFor: 'instance creation'!

new
    self shouldNotImplement
!

new: parent
    "Create a new widget of the type identified by the receiver, inside
    the given parent widget. Answer the new widget"
    ^self basicNew initialize: parent
! !

!Blox class methodsFor: 'event dispatching'!

onStartup
    "Initialize the Tcl and Blox environments; executed automatically
    on startup."
    | initResult |
    Debug isNil ifTrue: [
	Processor idleAdd: [ self idle ].
	Debug := false.
    ].

    initResult := self tclInit.
    initResult isNil ifTrue: [ ^self ].
    initResult address = 0 ifTrue: [ ^self ].
    Interp := initResult.
    DoDispatchEvents := 0.
    ClipStatus := nil.
    Blox withAllSubclassesDo: [ :each |
	(each class includesSelector: #initializeOnStartup) ifTrue: [
	    each initializeOnStartup
	]
    ].
!

dispatchEvents
    "Dispatch some events; return instantly if another dispatching loop is
    started, else loop until the number of calls to #dispatchEvents balance
    the number of calls to #terminateMainLoop."

    DoDispatchEvents := DoDispatchEvents + 1.

    (ClipStatus isKindOf: Boolean) ifTrue: [ ^self ].
    ClipStatus isString ifTrue: [ self clipboard: ClipStatus ].
    ClipStatus := ClipStatus notNil.

    [ DoDispatchEvents > 0 ] whileTrue: [ Processor idle; yield ].

    "If we're outside the event loop, Tk for Windows is unable to
     render the clipboard and locks up the clipboard viewer app.
     Anyway save the contents for the next time we'll start a
     message loop"
    ClipStatus := ClipStatus
	ifTrue: [ self clearClipboard ]
	ifFalse: [ nil ]
!

dispatchEvents: mainWindow
    "Dispatch some events; return instantly if another dispatching loop is
    started, else loop until the number of calls to #dispatchEvents balance
    the number of calls to #terminateMainLoop. In addition, set an event
    handler that will call #terminateMainLoop upon destruction of the
    `mainWindow' widget (which can be any kind of BWidget, but will be
    typically a BWindow)."

    mainWindow onDestroySend: #terminateMainLoop to: self.
    self dispatchEvents
!

terminateMainLoop
    "Terminate the event dispatching loop if this call to #terminateMainLoop
    balances the number of calls to #dispatchEvents. Answer whether the
    calls are balanced."

    DoDispatchEvents > 0
	ifTrue: [ DoDispatchEvents := DoDispatchEvents - 1 ].

    ^DoDispatchEvents == 0
! !

!Blox class methodsFor: 'utility'!

beep
    "Produce a bell"
    self tclEval: 'bell'
!

clearClipboard
    "Clear the clipboard, answer its old contents."
    | contents |
    contents := self tclEval: 'selection get -selection CLIPBOARD'.
    self tclEval: 'clipboard clear'.
    ClipStatus := ClipStatus isString ifTrue: [ nil ] ifFalse: [ false ].
    ^contents
!

clipboard
    "Retrieve the text in the clipboard."
    self tclEval: 'selection get -selection CLIPBOARD'.
    ^self tclResult
!

clipboard: aString
    "Set the contents of the clipboard to aString (or empty the clipboard
    if aString is nil)."
    self tclEval: 'clipboard clear'.
    (ClipStatus isKindOf: Boolean) ifTrue: [ ClipStatus := aString. ^self ].
    aString isNil ifTrue: [ ClipStatus := false. ^self ].
    self tclEval: 'clipboard append ', aString asTkString.
    ClipStatus := true
!

createColor: cyan magenta: magenta yellow: yellow
    "Answer a color that can be passed to methods such as `backgroundColor:'.
    The color will have the given CMY components (range is 0~65535)."
    ^self
	createColor: 65535 - cyan
	green: 65535 - magenta
	blue: 65535 - yellow
!

createColor: cyan magenta: magenta yellow: yellow black: black
    "Answer a color that can be passed to methods such as `backgroundColor:'.
    The color will have the given CMYK components (range is 0~65535)."
    | base |
    base := 65535 - black.
    ^self
	createColor: (base - cyan max: 0)
	green: (base - magenta max: 0)
	blue: (base - yellow max: 0)
!

createColor: hue saturation: sat value: value
    "Answer a color that can be passed to methods such as `backgroundColor:'.
    The color will have the given HSV components (range is 0~65535)."

    | hue6 f val index components |
    hue6 := (hue \\ 1) * 6.
    index := hue6 truncated + 1.  "Which of the six slices of the hue circle"
    f := hue6 fractionPart.	  "Where in the slice of the hue circle"
    val := 65535 * value.

    components := Array
        with: val				"v"
        with: val * (1 - sat)			"p"
        with: val * (1 - (sat * f))		"q"
        with: val * (1 - (sat * (1 - f))).	"t"

    ^self
	createColor:	(components at: (#(1 3 2 2 4 1) at: index)) floor
	green:		(components at: (#(4 1 1 3 2 2) at: index)) floor
	blue:		(components at: (#(2 2 4 1 1 3) at: index)) floor
!

createColor: red green: green blue: blue
    "Answer a color that can be passed to methods such as `backgroundColor:'.
    The color will have the given RGB components (range is 0~65535)."

    "The answer is actually a String with an X color name, like
     '#FFFFC000C000' for pink"
    ^(String new: 13)
	at:  1 put: $#;
	at:  2 put: (Character digitValue: ((red   bitShift: -12) bitAnd: 15));
	at:  3 put: (Character digitValue: ((red   bitShift:  -8) bitAnd: 15));
	at:  4 put: (Character digitValue: ((red   bitShift:  -4) bitAnd: 15));
	at:  5 put: (Character digitValue: ( red		  bitAnd: 15));
	at:  6 put: (Character digitValue: ((green bitShift: -12) bitAnd: 15));
	at:  7 put: (Character digitValue: ((green bitShift:  -8) bitAnd: 15));
	at:  8 put: (Character digitValue: ((green bitShift:  -4) bitAnd: 15));
	at:  9 put: (Character digitValue: ( green		  bitAnd: 15));
	at: 10 put: (Character digitValue: ((blue  bitShift: -12) bitAnd: 15));
	at: 11 put: (Character digitValue: ((blue  bitShift:  -8) bitAnd: 15));
	at: 12 put: (Character digitValue: ((blue  bitShift:  -4) bitAnd: 15));
	at: 13 put: (Character digitValue: ( blue		  bitAnd: 15));
	yourself
!

fonts
    "Answer the names of the font families in the system. Additionally,
     `Times', `Courier' and `Helvetica' are always made available."
    | stream result font ch |
    self tclEval: 'lsort [font families]'.
    stream := ReadStream on: self tclResult.
    result := WriteStream on: (Array new: stream size // 10).
    [ stream atEnd ] whileFalse: [
	(ch := stream next) isSeparator
	    ifFalse: [
		ch = ${
		    ifTrue: [ font := stream upTo: $} ]
		    ifFalse: [ font := ch asString, (stream upTo: $ ) ].
		
		result nextPut: font.
	    ]
    ].

    ^result contents
!

platform
    "Answer the platform on which Blox is running; it can be either
    #unix, #macintosh or #windows."
    Platform isNil ifTrue: [
	self tclEval: 'return $tcl_platform(platform)'.
	Platform := self tclResult asSymbol
    ].
    ^Platform
!

active
    "Answer the currently active Blox, or nil if the focus does not
     belong to a Smalltalk window."
    self tclEval: 'focus'.
    ^self fromString: self tclResult
!

at: aPoint
    "Answer the Blox containing the given point on the screen, or
     nil if no Blox contains the given point (either because
     no Smalltalk window is there or because it is covered by
     another window)."
    self
	tclEval: 'winfo containing %1 %2'
	with: aPoint x printString
	with: aPoint y printString.

    ^self fromString: self tclResult
!

atMouse
    "Answer the Blox under the mouse cursor's hot spot, or nil
     if no Blox contains the given point (either because no
     Smalltalk window is there or because it is covered by
     another window)."
    self tclEval: 'eval winfo containing [winfo pointerxy .]'.
    ^self fromString: self tclResult
!

mousePointer
    "If the mouse pointer is on the same screen as the application's windows,
     returns a Point containing the pointer's x and y coordinates measured
     in pixels in the screen's root window (under X, if a virtual root window
     is in use on the screen, the position is computed in the whole desktop,
     not relative to the top-left corner of the currently shown portion).
     If the mouse pointer isn't on the same screen as window then answer nil."
    | stream x |
    self tclEval: 'winfo pointerxy .'.
    stream := ReadStream on: self tclResult.
    (stream peekFor: $-) ifTrue: [ ^nil ].
    x := (stream upTo: $ ) asInteger.
    ^x @ stream upToEnd asInteger
!

screenResolution
    "Answer a Point containing the resolution in dots per inch of the screen,
     in the x and y directions."
    | stream x |
    self tclEval: 'return "
	[expr [winfo screenwidth  .] * 25.4 / [winfo screenmmwidth  .]]
	[expr [winfo screenheight .] * 25.4 / [winfo screenmmheight .]]" '.

    stream := ReadStream on: self tclResult.
    x := (stream upTo: $ ) asNumber rounded.
    ^x @ stream upToEnd asNumber rounded
!

screenOrigin
    "Answer a Point indicating the coordinates of the upper left point of the
     screen in the virtual root window on which the application's windows are
     drawn (under Windows and the Macintosh, that's always 0 @ 0)"
    | stream x |
    self tclEval: 'return "[winfo vrootx .] [winfo vrooty .]"'.
    stream := ReadStream on: self tclResult.
    x := (stream upTo: $ ) asInteger negated.
    ^x @ stream upToEnd asInteger negated
!

screenSize
    "Answer a Point containing the size of the virtual root window on which the
     application's windows are drawn (under Windows and the Macintosh, that's
     the size of the screen)"
    | stream x |
    self tclEval: 'return "[winfo vrootwidth .] [winfo vrootheight .]"'.
    stream := ReadStream on: self tclResult.
    x := (stream upTo: $ ) asInteger.
    ^x @ stream upToEnd asInteger
! !

!Blox class methodsFor: 'private'!

fromString: aString
    "Convert from Tk widget path name to Blox object. Answer nil
     if it isn't possible."

    | first last oopString oopInteger |
    last := aString size.
    aString size to: 1 by: -1 do: [ :i |
        (aString at: i) = $. ifTrue: [ last := i - 1 ].
        (aString at: i) = $w
	    ifTrue: [
		oopString := aString copyFrom: i + 1 to: last.
		oopInteger := 0.
		oopInteger := oopString inject: 0 into: [ :val :ch |
		    val * 36 + ch digitValue
		].
		^oopInteger asObjectNoFail
	    ]
    ].
    ^nil
! !

!Blox methodsFor: 'basic'!

deepCopy
    "It does not make sense to make a copy, because it would
     make data inconsistent across different objects; so answer
     the receiver"
    ^self
!

shallowCopy
    "It does not make sense to make a copy, because it would
     make data inconsistent across different objects; so answer
     the receiver"
    ^self
!

release
    "Destroy the receiver if it still exists, then perform the
    usual task of removing the dependency links"
    primitive isNil ifFalse: [ self destroy ].
    super release.
! ! 

!Blox methodsFor: 'widget protocol'!

asPrimitiveWidget
    "Answer the primitive widget that implements the receiver."
    self subclassResponsibility
!

boundingBox
    "Answer a Rectangle containing the bounding box of the receiver"
    ^(self x @ self y) extent: (self width @ self height)
!

boundingBox: rect
    "Set the bounding box of the receiver to rect (a Rectangle)."
    self
	left: rect left
	top: rect top
	right: rect right
	bottom: rect bottom
!

childrenDo: aBlock
    "Evaluate aBlock once for each of the receiver's child widgets, passing
    the widget to aBlock as a parameter"
    children do: aBlock
!

childrenCount
    "Answer how many children the receiver has"
    ^children size
!

destroy
    "Destroy the receiver"
    self tclEval: 'destroy ', self container
!

fontWidth: aString
    "Answer the width of aString in pixels, when displayed in the same
     font as the receiver.  Although defined here, this method is only
     used for widgets that define a #font method"

    self tclEval: 'font measure %1 %2'
	with: self font asTkString
	with: aString asTkString.

    ^self tclResult asNumber
!

fontHeight: aString
    "Answer the height of aString in pixels, when displayed in the same
     font as the receiver.  Although defined here, this method is only
     used for widgets that define a #font method"

    self tclEval: 'font metrics %1 -linespace' with: self font asTkString.
    ^((aString occurrencesOf: Character nl) + 1) * self tclResult asNumber
!

enabled
    "Answer whether the receiver is enabled to input. Although defined
     here, this method is only used for widgets that define a
     #state method"
    ^self state ~= #disabled
!

enabled: enabled
    "Set whether the receiver is enabled to input (enabled is a boolean).
     Although defined here, this method is only used for widgets that
     define a #state: method"

    self state: (enabled ifTrue: [ #normal ] ifFalse: [ #disabled ])
!

exists
    "Answer whether the receiver has been destroyed or not (answer false
    in the former case, true in the latter)."
    ^primitive notNil
!

drawingArea
    "Answer a Rectangle identifying the receiver's drawing area.  The 
     rectangle's corners specify the upper-left and lower-right corners
     of the client area.  Because coordinates are relative to the
     upper-left corner of a window's drawing area, the coordinates of
     the rectangle's corner are (0,0). "
    ^(0 @ 0) corner: (self widthAbsolute @ self heightAbsolute)
!

extent
    "Answer a Point containing the receiver's size"
    ^(self width @ self height)
!

extent: extent
    "Set the receiver's size to the width and height contained in extent
    (a Point)."
    self
	width: extent x
	height: extent y
!

isWindow
    "Answer whether the receiver represents a window on the screen."
    ^false
!

left: left top: top right: right bottom: bottom
    "Set the bounding box of the receiver through its components."
    self
	x: left
	y: top
	width: right - left + 1
	height: bottom - top + 1
!

parent
    "Answer the receiver's parent (or nil for a top-level window)."
    ^parent
!

pos: position
    "Set the receiver's origin to the width and height contained in position
    (a Point)."
    self
	x: position x
	y: position y
!

posVert: aBlox
    "Position the receiver just below aBlox."
    self
	x: aBlox x
	y: aBlox y + aBlox height
!

posHoriz: aBlox
    "Position the receiver immediately to the right of aBlox."
    self
	x: aBlox x + aBlox width
	y: aBlox y
!

toplevel
    "Answer the top-level object (typically a BWindow or BPopupWindow)
    connected to the receiver."
    self parent isNil ifTrue: [ ^self ].
    ^self parent toplevel
!

window
    "Answer the window in which the receiver stays. Note that while
    #toplevel won't answer a BTransientWindow, this method will."
    ^self parent window
!

width: xSize height: ySize
    "Set the size of the receiver through its components xSize and ySize."
    self 
	width: xSize;
	height: ySize
!

withChildrenDo: aBlock
    "Evaluate aBlock passing the receiver, and then once for each of the
    receiver's child widgets."
    self value: aBlock.
    self childrenDo: aBlock
!

x: xPos y: yPos
    "Set the origin of the receiver through its components xPos and yPos."
    self
	x: xPos;
	y: yPos
!

x: xPos y: yPos width: xSize height: ySize
    "Set the bounding box of the receiver through its origin and
    size."
    self
	x: xPos y: yPos;
	width: xSize height: ySize
! !

!Blox methodsFor: 'creating children'!

make: array
    "Create children of the receiver. Answer a Dictionary of the children.
     Each element of array is an Array with the form:
	 - first element = name, becomes the Dictionary's key
	 - second element = class name symbol
	 - third element = parameter setting array, for example
	   #(width: 50 height: 30 backgroundColor: 'blue')
	 - from the fourth element = children of the widget; each element has
	   the same format described here"
    ^self make: array on: LookupTable new
!

make: array on: result
    "Private - Create children of the receiver, adding them to result;
     answer result. array has the format described in the comment to #make:"
    array do: [ :each | self makeChild: each on: result ].
    ^result
!

makeChild: each on: result 
    "Private - Create a child of the receiver, adding them to result;
     each is a single element of the array described in the comment to #make:"
    | current selector |
    current := result
	at: (each at: 1)
	put: ((Smalltalk classAt: (each at: 2)) new: self).

    each at: 3 do: [ :param |
	selector isNil
	    ifTrue: [ selector := param ]
	    ifFalse: [ current perform: selector with: param. selector := nil ]
    ].
    each size > 3 ifFalse: [ ^result ].
    each from: 4 to: each size do: [ :child |
	current makeChild: child on: result
    ].
! !

!Blox methodsFor: 'customization'!

addChild: child
    "The widget identified by child has been added to the receiver.
     This method is public not because you can call it, but because
     it can be useful to override it, not forgetting the call to
     either the superclass implementation or #basicAddChild:, to
     perform some initialization on the children just added. Answer
     the new child."
    ^children addLast: child
!

basicAddChild: child
    "The widget identified by child has been added to the receiver.
     Add it to the children collection and answer the new child.
     This method is public because you can call it from #addChild:."
    ^children addLast: child
! !

!Blox methodsFor: 'private'!

primBind: event to: aSymbol of: anObject parameters: params
    "Private - Register the given event, to be passed to anObject
    via the aSymbol selector with the given parameters"

    ^self
	bind: event
	to: aSymbol
	of: anObject
	parameters: params
	prefix: 'bind ', self connected
!

bind: event to: aSymbol of: anObject parameters: params prefix: prefix
    "Private - Low level event binding - execute a Tcl command like
     `<prefix> <event> {+callback <anObject OOP> <aSymbol> <params>}'.
     Prefix is typically some kind of the Tcl `bind' command."
    | stream |
    stream := WriteStream with: prefix copy.
    stream
	space;
	nextPutAll: event;
	nextPutAll: ' {+callback ';
	print:      anObject asOop;
	space;
	nextPutAll: aSymbol asTkString;
	space;
	nextPutAll: params;
	nextPut:    $}.

    self tclEval: stream contents.
    ^event
!

properties
    "Private - Answer the properties dictionary"
    ^properties
!

container
    "Private - Answer the name of Tk widget for the container widget.
    This widget is used when handling geometry and by a few methods
    such as #effect and #borderWidth."
    ^self asPrimitiveWidget container
!

connected
    "Private - Answer the name of Tk widget for the connected widget.
    This widget is used for most options and for event binding."
    ^self asPrimitiveWidget connected
!

initialize: parentWidget
    "This is called by #new: to initialize the widget (as the name
     says...). The default implementation initializes the receiver's
     instance variables. This method is public not because you can
     call it, but because it might be useful to override it. Always
     answer the receiver."
    parent := parentWidget.
    properties := IdentityDictionary new.
    children := OrderedCollection new.
!

guiObject
    "Private - Left for backward compatibility; answer the `primitive'
    instance variable which can either be another widget or it can be
    related to the names returned by #connected and #container."
    ^primitive
!

primitive
    "Private - Answer the `primitive' instance variable which can
    either be another widget or it can be related to the names
    returned by #connected and #container."
    ^primitive
!

destroyed
    "Private - The receiver has been destroyed, clear the instance
    variables to release some memory."
    children := primitive := parent := nil
! !

Blox
    "#normal, #disabled, sometimes #active."
    defineMutator: 'state'
    command: '%1 configure -state %3'
    key: 'state'
    toStringCode: '';

    defineAccessor: 'state'
    command: '%1 cget -state'
    key: 'state'
    fromStringCode: 'asSymbol'!

"------------------- Generic UI elements -------------------------"

Blox subclass: #BWidget
       instanceVariableNames: ''
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BWidget comment: '
I am the superclass for every widget except those related to
menus. I provide more common methods and geometry management'!

!BWidget class methodsFor: 'popups'!

new
    "Create an instance of the receiver inside a BPopupWindow; do
    not map the window, answer the new widget.  The created widget
    will become a child of the window and be completely attached
    to it (e.g. the geometry methods will modify the window's geometry).
    Note that while the widget *seems* to be directly painted on
    the root window, it actually belongs to the BPopupWindow; so
    don't send #destroy to the widget to remove it, but rather
    to the window."
    ^self new: BPopupWindow new
!

popup: initializationBlock
    "Create an instance of the receiver inside a BPopupWindow; before
    returning, pass the widget to the supplied initializationBlock, 
    then map the window.  Answer the new widget.  The created widget
    will become a child of the window and be completely attached
    to it (e.g. the geometry methods will modify the window's geometry).
    Note that while the widget *seems* to be directly painted on
    the root window, it actually belongs to the BPopupWindow; so
    don't send #destroy to the widget to remove it, but rather
    to the window."
    | widget window |
    window := BPopupWindow new.
    widget := self new: window.
    initializationBlock value: widget.
    window map.
    ^widget
!

!BWidget class methodsFor: 'creating Tk interface methods'!

defineFontProtocol
    "e.g. 'Helvetica 18 bold' or '{Zapf Chancery} 14' (braces are
     mandatory if the font family is made of two or more words."
    self
	defineAccessor: 'font' option: 'font' fromStringCode: '';
	defineMutator: 'font' option: 'font' toStringCode: ''
!

defineGeometryMethods: keyword relativeTo: parentSelector
    
    | s |
    #(
'%1Absolute
    "Force a recalculation of the layout of widgets in the receiver''s
     parent, then answer the current %1 of the receiver in pixels."

    Blox idle.
    self tclEval: ''winfo %1 '', self container.
    ^self tclResult asInteger'

'%1
    "Answer the `variable'' part of the receiver''s %1 within the parent
    widget. The value returned does not include any fixed amount of
    pixels indicated by #%1Offset: and must be interpreted in a relative
    fashion: the ratio of the returned value to the current size of the
    parent will be preserved upon resize. This apparently complicated
    method is known as `rubber sheet'' geometry management."
    ^self parent %1Child: self.'

'%1: value
    "Set to `value'' the %1 of the widget within the parent widget. The
     value is specified in a relative fashion as an integer, so that the
     ratio of `value'' to the current size of the parent will be
     preserved upon resize. This apparently complicated method is known
     as `rubber sheet'' geometry management."
    self parent child: self %1: value.'

'%1Offset: value
    "Add or subtract to the %1 of the receiver a fixed amount of `value''
    pixels, with respect to the value set in a relative fashion through
    the #%1: method."
    self parent child: self %1Offset: value.'

'%1Pixels: value
    "Set the current %1 of the receiver to `value'' pixels. Note that,
    after calling this method, #%1 will answer 0, which is logical
    considering that there is no `variable'' part of the size (refer
    to #%1 and #%1: for more explanations)."
    self %1: 0; %1Offset: value'
    
'%1Child: child
    "Answer the given child''s %1.  The default implementation of this
     method uses `rubber-sheet'' geometry management as explained in
     the comment to BWidget''s #%1 method.  You should not use this
     method, which is automatically called by the child''s #%1 method,
     but you might want to override.  The child''s property slots whose
     name ends with `Geom'' are reserved for this method.  This method
     should never fail -- if it doesn''t apply to the kind of geometry
     management that the receiver does, just return 0."
    ^(child properties at: #%1Geom ifAbsentPut: [0]) * self %2'

'child: child %1: value
    "Set the given child''s %1 to value.  The default implementation of
     this method uses `rubber-sheet'' geometry management as explained in
     the comment to BWidget''s #%1 method.  You should not use this
     method, which is automatically called by the child''s #%1: method,
     but you might want to override it.  The child''s property slots whose
     name ends with `Geom'' are reserved for this method. This method
     should never fail -- if it doesn''t apply to the kind of geometry
     management that the receiver does, just do nothing."
    | relative %2Parent |
    %2Parent := self %2.
    %2Parent = 0 ifTrue: [ ^self ].
    child properties at: #%1Geom put: (relative := value / %2Parent).
    self tclEval:
	''place '', child container, '' -rel%1 '', relative asFloat printString'

'child: child %1Offset: value
    "Adjust the given child''s %1 by a fixed amount of value pixel.  This
     is meaningful for the default implementation, using `rubber-sheet''
     geometry management as explained in the comment to BWidget''s #%1 and
     #%1Offset: methods.  You should not use this method, which is 
     automatically called by the child''s #%1Offset: method, but you
     might want to override it.  if it doesn''t apply to the kind of
     geometry management that the receiver does, just add value to the
     current %1 of the widget."
    self tclEval:
	''place '', child container, '' -%1 '', value asFloat printString'
)

    do: [ :code |
	self
	    compile: (code bindWith: keyword with: parentSelector)
	    classified: 'geometry management'
    ]
! !

BWidget
    defineGeometryMethods: 'width' relativeTo: 'width';
    defineGeometryMethods: 'height' relativeTo: 'height';
    defineGeometryMethods: 'x' relativeTo: 'width';
    defineGeometryMethods: 'y' relativeTo: 'height';

    defineAccessor: 'tabStop' option: 'takefocus' fromStringCode: '== ''1''';
    defineMutator: 'tabStop' option: 'takefocus' toStringCode: 'asCBooleanValue printString';

    "e.g. hand2 or left_ptr"
    defineAccessor: 'cursor' option: 'cursor' fromStringCode: 'asSymbol';
    defineMutator: 'cursor' option: 'cursor' toStringCode: '';

    "#raised, #sunken, #flat, #ridge, #solid, #groove.
     #solid means 2-D.
     #groove means 3-D, with only the border sunken.
     #ridge means 3-D, with only the border raised.
     Note: these work on the container, not on the connected object! !"
    defineMutator: 'effect'
    command: '%2 configure -relief %3'
    key: 'effect'
    toStringCode: '';

    defineAccessor: 'effect'
    command: '%2 cget -relief'
    key: 'effect'
    fromStringCode: 'asSymbol';

    defineMutator: 'borderWidth'
    command: '%2 configure -borderwidth %3'
    key: 'border'
    toStringCode: 'printString';

    defineAccessor: 'borderWidth'
    command: '%2 cget -borderwidth'
    key: 'border'
    fromStringCode: 'asInteger'
!

!BWidget methodsFor: 'geometry management'!

xRoot
    "Answer the x position of the receiver with respect to the
    top-left corner of the desktop (including the offset of the
    virtual root window under X)."
    self
	tclEval: 'expr [winfo rootx %1] + [winfo vrootx %1]'
	with: self container.

    ^self tclResult asInteger
!

yRoot
    "Answer the y position of the receiver with respect to the
    top-left corner of the desktop (including the offset of the
    virtual root window under X)."
    self
	tclEval: 'expr [winfo rooty %1] + [winfo vrooty %1]'
	with: self container.

    ^self tclResult asInteger
! !

!BWidget methodsFor: 'widget protocol'!

activate
    "At any given time, one window on each display is designated
     as the focus window; any key press or key release events for
     the display are sent to that window. This method allows one
     to choose which window will have the focus in the receiver's
     display
     
     If the application currently has the input focus on the receiver's
     display, this method resets the input focus for the receiver's
     display to the receiver. If the application doesn't currently have the
     input focus on the receiver's display, Blox will remember the receiver
     as the focus for its top-level; the next time the focus arrives at the
     top-level, it will be redirected to the receiver (this is because
     most window managers will set the focus only to top-level windows,
     leaving it up to the application to redirect the focus among the
     children of the top-level)."
    self tclEval: 'focus ', self connected
!

activatePrevious
    "Activate the previous widget in the focus `tabbing' order.  The focus
     order depends on the widget creation order; you can set which widgets
     are in the order with the #tabStop: method."
    self tclEval: 'focus [ tk_focusPrev %1 ]' with: self connected
!

activateNext
    "Activate the next widget in the focus `tabbing' order.  The focus
     order depends on the widget creation order; you can set which widgets
     are in the order with the #tabStop: method."
    self tclEval: 'focus [ tk_focusNext %1 ]' with: self connected
!

bringToTop
    "Raise the receiver so that it is above all of its siblings in the
    widgets' z-order; the receiver will not be obscured by any siblings and
    will obscure any siblings that overlap it."
    self tclEval: 'raise ', self container
!

isActive
    "Return whether the receiver is the window that currently owns the focus
     on its display."
    self tclEval: 'focus'.
    ^self tclResult = self connected
!

sendToBack
    "Lower the receiver so that it is below all of its siblings in the
    widgets' z-order; the receiver will be obscured by any siblings that
    overlap it and will not obscure any siblings."
    self tclEval: 'lower ', self container
! !

!BWidget methodsFor: 'customization'!

addChild: child
    "The widget identified by child has been added to the receiver.
     This method is public not because you can call it, but because
     it can be useful to override it, not forgetting the call to
     basicAddChild, to perform some initialization on the children
     just added. Answer the new child."
    child isWindow ifFalse: [
	self tclEval: 'place %1 -in %2' with: child container with: self container
    ].
    ^self basicAddChild: child
!

create
    "Make the receiver able to respond to its widget protocol.
     This method is public not because you can call it, but because
     it can be useful to override it, not forgetting the call to
     super, to perform some initialization on the primitive
     widget just created; for an example of this, see the
     implementation of BButtonLike."
    self subclassResponsibility
!

setInitialSize
    "This is called by #initialize: to set the widget's initial size.
     The whole area is occupied by default. This method is public
     not because you can call it, but because it can be useful to
     override it, not forgetting to call *all* of #x:, #y:,
     #width: and #height:."
     
    "Make the Tk placer's status, the receiver's properties and the
     window status (as returned by winfo) consistent."
    self
	x: 0
	y: 0
	width: self parent width
	height: self parent height
!

initialize: parentWidget
    "This is called by #new: to initialize the widget (as the name
     says...). The default implementation calls all the other
     methods in the `customization' protocol and some private
     ones that take care of making the receiver's status consistent,
     so you should usually call it instead of doing everything by
     hand. This method is public not because you can call it, but
     because it might be useful to override it. Always answer the
     receiver."
    super initialize: parentWidget.
    self create.
    self bind: '<Destroy>' to: #destroyed of: self parameters: ''.
    self setInitialSize.
    self parent notNil ifTrue: [ self parent addChild: self ].
! !

"------------------- Primitives --------------------------------------"

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

BPrimitive comment: '
I am the superclass for every widget (except menus) directly
provided by the underlying GUI system.'!

!BPrimitive methodsFor: 'accessing'!

asPrimitiveWidget
    "Answer the primitive widget that implements the receiver."
    ^self
! !

!BPrimitive methodsFor: 'private'!

container
    "Private - Answer the name of Tk widget for the container widget."
    ^primitive
!

connected
    "Private - Answer the name of Tk widget for the connected widget."
    ^primitive
!

create
    "Private - Make the receiver able to respond to its widget protocol."
    self create: ''
!

create: options
    "Private - Make the receiver able to respond to its widget protocol,
     initializing the Tk widget with the options passed in the parameter."
    self tclEval: '%1 %2 %3'
	    with: self widgetType
	    with: self connected
	    with: options.
!

initialize: parentWidget
    "Private - This is called by #new: to initialize the widget (as the
     name says...). This implementation creates a unique Tk path name for
     the widget, then calls the superclass implementation."
    primitive := self setWidgetName: parentWidget.
    super initialize: parentWidget.
!

setWidgetName: parentWidget
    "Private - Create and answer a unique Tk path name for the widget"
    | name |
    name := '.w', (self asOop printString: 36).
    ^parentWidget isNil
	ifTrue: [ name ]
	ifFalse: [ parentWidget container, name ].
!

widgetType
    "Private - Answer the Tk command to create the widget"
    self subclassResponsibility
! !

"------------------------------ vs. extended -------------------------"

BWidget subclass: #BExtended
       instanceVariableNames: ''
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Windows'
! 

BExtended comment: '
Just like Gui, I serve as a base for complex objects which expose
an individual protocol but internally use a Blox widget for
creating their user interface. Unlike Gui, however, the
instances of my subclasses understand the standard widget protocol.
Just override my newPrimitive method to return another widget,
and you''ll get a class which interacts with the user like that
widget (a list box, a text box, or even a label) but exposes a
different protocol.'!


!BExtended methodsFor: 'accessing'!

asPrimitiveWidget
    "Answer the primitive widget that implements the receiver."
    ^primitive asPrimitiveWidget
! !

!BExtended methodsFor: 'customization'!

newPrimitive
    "Create and answer a new widget on which the implementation of the
     receiver will be based. You should not call this method directly;
     instead you must override it in BExtended's subclasses."
    self subclassResponsibility
!

create
    "After this method is called (the call is made automatically)
     the receiver will be attached to a `primitive' widget (which
     can be in turn another extended widget).
     This method is public not because you can call it, but because
     it can be useful to override it, not forgetting the call to
     super (which only calls #newPrimitive and saves the result),
     to perform some initialization on the primitive widget
     just created; overriding #create is in fact more generic than
     overriding #newPrimitive. For an example of this, see the
     implementation of BButtonLike."
    
    primitive := self newPrimitive
! !

"------------------------------ Viewport controls --------------------------"

BPrimitive subclass: #BViewport
       instanceVariableNames: 'connected'
       classVariableNames: 'InitializedVP'
       poolDictionaries: ''
       category: 'Graphics-Windows'
!

BViewport comment: '
I represent an interface which is common to widgets that can be
scrolled, like list boxes or text widgets.'!

!BViewport class methodsFor: 'initialization'!

initializeOnStartup
     InitializedVP := false
!

!BViewport methodsFor: 'accessing'!

connected
    "Private - Answer the name of Tk widget for the connected widget."
    ^connected
! !

!BViewport methodsFor: 'private'!

create: options
    "Private - Create an instance of the receiver which sports two
    beautiful scrollbars, in the same way as BPrimitive's implementation
    of #create:."
    InitializedVP ifFalse: [ self defineViewportProcedures ].
    self tclEval: 'createViewport %1 %2 {%3}'
	with: self widgetType
	with: self container
	with: options.

    connected := self tclResult.
!

defineViewportProcedures
    InitializedVP := true.
    self tclEval: '
      ## Procedures that handle automatic show/hide of scrollbars
      ##
      set horizSB {-row 1 -column 0 -sticky ew}
      set vertSB {-row 0 -column 1 -sticky ns}
      proc scrollbarSet {w gridArgs first last} {
        if { $first == 0 && $last == 1 } {
          grid forget $w
        } else {
          eval grid $w $gridArgs
        }
        $w set $first $last
      }
      proc createViewport {type cnt opt} {
	frame $cnt -relief sunken
	eval $type $cnt.ctl $opt
	scrollbar $cnt.hs -orient horiz -command "$cnt.ctl xview"
	scrollbar $cnt.vs -orient vert -command "$cnt.ctl yview"
	grid $cnt.ctl -column 0 -row 0 -sticky news
	grid propagate $cnt off
	grid rowconfigure $cnt 0 -minsize 1 -weight 1
	grid rowconfigure $cnt 1 -weight 0
	grid columnconfigure $cnt 0 -minsize 1 -weight 1
	grid columnconfigure $cnt 1 -weight 0
	return $cnt.ctl
      }'
! !

!BViewport methodsFor: 'scrollbars'!

horizontal
    ^self properties at: #horizontal ifAbsent: [ false ]
!

horizontalNeeded
    self
	tclEval: 'expr [lindex [%1 xview] 0] > 0 || [lindex [%1 xview] 1] < 1'
	with: self connected.

    ^self tclResult = '1'
!

horizontalShown
    ^self horizontal and: [ self horizontalNeeded ]
!

horizontal: aBoolean
    | code |
    (self properties at: #horizontal ifAbsent: [ false ]) == aBoolean
	ifTrue: [ ^self ].

    code := (self properties at: #horizontal put: aBoolean)
	ifTrue: [
	    '%1.ctl configure -xscrollcommand "scrollbarSet %1.hs {$horizSB}"
	    eval scrollbarSet %1.hs {$horizSB} [%1.ctl xview]' ]
	ifFalse: [
	    '%1.ctl configure -xscrollcommand "concat" # do nothing
	    eval scrollbarSet %1.hs {$horizSB} 0 1' ].

    self tclEval: code with: self container
!

vertical
    ^self properties at: #vertical ifAbsent: [ false ]
!

verticalNeeded
    self
	tclEval: 'expr [lindex [%1 yview] 0] > 0 || [lindex [%1 yview] 1] < 1'
	with: self connected.

    ^self tclResult = '1'
!

verticalShown
    ^self vertical and: [ self verticalNeeded ]
!

vertical: aBoolean
    | code |
    (self properties at: #vertical ifAbsent: [ false ]) == aBoolean
	ifTrue: [ ^self ].

    code := (self properties at: #horizontal put: aBoolean)
	ifTrue: [
	    '%1.ctl configure -yscrollcommand "scrollbarSet %1.vs {$vertSB}"
	    eval scrollbarSet %1.vs {$vertSB} [%1.ctl yview]' ]
	ifFalse: [
	    '%1.ctl configure -yscrollcommand "concat" # do nothing
	    eval scrollbarSet %1.vs {$vertSB} 0 1' ].

    self tclEval: code with: self container
! !

"------------------------------ Menu superclass -----------------------"

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

BMenuObject comment: '
I am an abstract superclass for widgets which make up a menu structure.'!


"Define position methods as dummy"
#('x' 'x: value' 'y' 'y: value' 'width' 'width: value' 'height' 'height: value')
    do: [ :each | BMenuObject
        compile: each, '
    "This method is deprecated and will disappear in a future version."'
        classified: 'disabled methods' ]!

BMenuObject defineColorProtocolWithActivePrefix: 'active' tk: 'active'!

!BMenuObject methodsFor: 'accessing'!

asPrimitiveWidget
    "Answer the primitive widget that implements the receiver."
    ^self
! !

"----------------------------------- ADDS TO THE STANDARD IMAGE ----------"


!String methodsFor: 'private - Tk interface'!

asTkString
    "Private, Blox - Answer a copy of the receiver enclosed in
    double-quotes and in which all the characters that Tk cannot read
    are escaped through a backslash"

    | i stream ch crFound |
    stream := WriteStream on: (self copyEmpty: self size + 10).
    stream nextPut: $".
    crFound := false.
    i := 1.
    [ i <= self size ] whileTrue: [
	ch := self at: i.
	ch = $" ifTrue: [ stream nextPut: $\ ].
	ch = $\ ifTrue: [ stream nextPut: $\ ].
	ch = $[ ifTrue: [ stream nextPut: $\ ].
	ch = $] ifTrue: [ stream nextPut: $\ ].
	ch = $$ ifTrue: [ stream nextPut: $\ ].

	ch = Character nl
	    ifTrue: [
		"Under Windows, CR/LF-separated lines are common. Turn a
		 CR/LF pair into a single \n"
		crFound ifTrue: [ stream skip: -2 ].
		stream nextPut: $\.
		ch := $n
	    ].

	"On Macs, CR-separated lines are common. Turn 'em into \n"
	(crFound := (ch == Character cr))
	    ifTrue: [
		stream nextPut: $\.
		ch := $n
	    ].

	(ch < $ ) | (ch > $~)
	    ifFalse: [ stream nextPut: ch ]
	    ifTrue: [
		stream
		    nextPutAll: '\';
		    nextPut: (Character value: ch value // 64 \\ 8 + 48);
		    nextPut: (Character value: ch value //  8 \\ 8 + 48);
		    nextPut: (Character value: ch value       \\ 8 + 48)
	    ].

	i := i + 1
    ].
    stream nextPut: $".
    ^stream contents
!

asTkImageString
    "Private, Blox - Look for GIF images; for those, since Base-64 data does
     not contain { and }, is better to use the {} syntax."
    
    "R0lG is `GIF' in Base-64 encoding."
    ^(self match: 'R0lG*')
	ifTrue: [ '{%1}' bindWith: self ]
	ifFalse: [ self asTkString ]
! !