"======================================================================
|
|   Smalltalk Tk-based GUI building blocks, extended widgets.
|   This is 100% Smalltalk!
|
|   $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.  
|
 ======================================================================"

"------------------------------- Icon XPMs/GIFs --------------------------"

!BImage class methodsFor: 'small icons'!

directory
    "Answer the Base-64 GIF representation of a `directory folder' icon."
^'R0lGODdhEAAQAPIAAAAAAHh4eLi4uPj4+P///wAAAAAAAAAAACwAAAAAEAAQAAADPkixzPOD
yADrWE8qC8WN0+BZAmBq1GMOqwigXFXCrGk/cxjjr27fLtout6n9eMIYMTXsFZsogXRKJf6u
P0kCADv/'!

file
    "Answer the Base-64 GIF representation of a `file' icon."
^'R0lGODdhEAAQAPIAAAAAAHh4eLi4uPj4APj4+P///wAAAAAAACwAAAAAEAAQAAADPVi63P4w
LkKCtTTnUsXwQqBtAfh910UU4ugGAEucpgnLNY3Gop7folwNOBOeiEYQ0acDpp6pGAFArVqt
hQQAO///'! !

!BImage class methodsFor: 'GNU'!

gnu
    "Answer the XPM representation of a 48x48 GNU."
^'/* XPM */
/*****************************************************************************/
/* GNU Emacs bitmap conv. to pixmap by Przemek Klosowski (przemek@nist.gov)  */
/*****************************************************************************/
static char * image_name [] = {
/* width height ncolors chars_per_pixel */
"48 48 7 1",
/* colors */
" 	s mask	c none",
"B      c blue",
"x      c black",          	    
":      c SandyBrown",  	    
"+      c SaddleBrown",
"o      c grey",		       	    
".      c white",
/* pixels */
"                                                ",
"                                   x            ",
"                                    :x          ",
"                                    :::x        ",
"                                      ::x       ",
"          x                             ::x     ",
"         x:                xxx          :::x    ",
"        x:           xxx xxx:xxx         x::x   ",
"       x::       xxxx::xxx:::::xx        x::x   ",
"      x::       x:::::::xx::::::xx       x::x   ",
"      x::      xx::::::::x:::::::xx     xx::x   ",
"     x::      xx::::::::::::::::::x    xx::xx   ",
"    x::x     xx:::::xxx:::::::xxx:xxx xx:::xx   ",
"   x:::x    xx:::::xx...xxxxxxxxxxxxxxx:::xx    ",
"   x:::x   xx::::::xx..xxx...xxxx...xxxxxxxx    ",
"   x:::x   x::::::xx.xxx.......x.x.......xxxx   ",
"   x:::xx x:::x::xx.xx..........x.xx.........x  ",
"   x::::xx::xx:::x.xx....ooooxoxoxoo.xxx.....x  ",
"   xx::::xxxx::xx.xx.xxxx.ooooooo.xxx    xxxx   ",
"    xx::::::::xx..x.xxx..ooooooooo.xx           ",
"    xxx:::::xxx..xx.xx.xx.xxx.ooooo.xx          ",
"      xxx::xx...xx.xx.BBBB..xxooooooxx          ",
"       xxxx.....xx.xxBB:BB.xxoooooooxx          ",
"        xx.....xx...x.BBBx.xxxooooooxx          ",
"       x....xxxx..xx...xxxooooooooooxx          ",
"       x..xxxxxx..x.......x..ooooooooxx         ",
"       x.x xxx.x.x.x...xxxx.oooooooooxx         ",
"        x  xxx.x.x.xx...xx..oooooooooxx         ",
"          xx.x..x.x.xx........oooooooox         ",
"         xxo.xx.x.x.x.x.......ooooooooox        ",
"         xxo..xxxx..x...x.......ooooooox        ",
"         xxoo.xx.x..xx...x.......ooo.xxx        ",
"         xxoo..x.x.x.x.x.xx.xxxxx.o.xx+xx       ",
"         xxoo..x.xx..xx.x.x.x+++xxxxx+++x       ",
"         xxooo.x..xxx.x.x.x.x+++++xxx+xxx       ",
"          xxoo.xx..x..xx.xxxx++x+++x++xxx       ",
"          xxoo..xx.xxx.xxx.xxx++xx+x++xx        ",
"           xxooo.xx.xx..xx.xxxx++x+++xxx        ",
"           xxooo.xxx.xx.xxxxxxxxx++++xxx        ",
"            xxoo...xx.xx.xxxxxx++xxxxxxx        ",
"            xxoooo..x..xxx..xxxx+++++xx         ",
"             xxoooo..x..xx..xxxx++++xx          ",
"              xxxooooox.xx.xxxxxxxxxxx          ",
"               xxxooooo..xxx    xxxxx           ",
"                xxxxooooxxxx                    ",
"                  xxxoooxxx                     ",
"                    xxxxx                       ",
"                                                "
};'! !


!BImage class methodsFor: 'arrows'!

upArrow
    "Answer the XPM representation of a 12x12 arrow pointing upwards."
^'/* XPM */
static char * uparrow_xpm[] = {
/* width height ncolors chars_per_pixel */
"12 12 2 1",
/* colors */
" 	c None    m None   s None",
"o	c black   m black",
/* pixels */
"            ",
"            ",
"            ",
"            ",
"     o      ",
"    ooo     ",
"   ooooo    ",
"  ooooooo   ",
"            ",
"            ",
"            ",
"            "};
'!

downArrow
    "Answer the XPM representation of a 12x12 arrow pointing downwards."
^'/* XPM */
static char * downarrow_xpm[] = {
/* width height ncolors chars_per_pixel */
"12 12 2 1",
/* colors */
" 	c None    m None   s None",
"o	c black   m black",
/* pixels */
"            ",
"            ",
"            ",
"            ",
"  ooooooo   ",
"   ooooo    ",
"    ooo     ",
"     o      ",
"            ",
"            ",
"            ",
"            "};
'!


leftArrow
    "Answer the XPM representation of a 12x12 arrow pointing leftwards."
^'/* XPM */
static char * leftarrow_xpm[] = {
/* width height ncolors chars_per_pixel */
"12 12 2 1",
/* colors */
" 	c None    m None   s None",
"o	c black   m black",
/* pixels */
"            ",
"            ",
"       o    ",
"      oo    ",
"     ooo    ",
"    oooo    ",
"     ooo    ",
"      oo    ",
"       o    ",
"            ",
"            ",
"            "};
'!

rightArrow
    "Answer the XPM representation of a 12x12 arrow pointing rightwards."
^'/* XPM */
static char * rightarrow_xpm[] = {
/* width height ncolors chars_per_pixel */
"12 12 2 1",
/* colors */
" 	c None    m None   s None",
"o	c black   m black",
/* pixels */
"            ",
"            ",
"    o       ",
"    oo      ",
"    ooo     ",
"    oooo    ",
"    ooo     ",
"    oo      ",
"    o       ",
"            ",
"            ",
"            "};
'! !

!BImage class methodsFor: 'icons'!

exclaim
    "Answer the XPM representation of a 32x32 exclamation mark icon."
^'/* XPM */
static char * exclaim_xpm[] = {
/* width height ncolors chars_per_pixel */
"32 32 6 1",
/* colors */
" 	c None    m None   s None",
".	c yellow  m white",
"X	c black   m black",
"x	c gray50  m black",
"o	c gray    m white",
"b	c yellow4 m black",
/* pixels */
"             bbb                ",
"            b..oX               ",
"           b....oXx             ",
"           b.....Xxx            ",
"          b......oXxx           ",
"          b.......Xxx           ",
"         b........oXxx          ",
"         b.........Xxx          ",
"        b..........oXxx         ",
"        b...oXXXo...Xxx         ",
"       b....XXXXX...oXxx        ",
"       b....XXXXX....Xxx        ",
"      b.....XXXXX....oXxx       ",
"      b.....XXXXX.....Xxx       ",
"     b......XXXXX.....oXxx      ",
"     b......bXXXb......Xxx      ",
"    b.......oXXXo......oXxx     ",
"    b........XXX........Xxx     ",
"   b.........bXb........oXxx    ",
"   b.........oXo.........Xxx    ",
"  b...........X..........oXxx   ",
"  b.......................Xxx   ",
" b...........oXXo.........oXxx  ",
" b...........XXXX..........Xxx  ",
"b............XXXX..........oXxx ",
"b............oXXo...........Xxx ",
"b...........................Xxxx",
"b..........................oXxxx",
" b........................oXxxxx",
"  bXXXXXXXXXXXXXXXXXXXXXXXXxxxxx",
"    xxxxxxxxxxxxxxxxxxxxxxxxxxx ",
"     xxxxxxxxxxxxxxxxxxxxxxxxx  "};
'!

info
    "Answer the XPM representation of a 32x32 `information' icon."
^'/* XPM */
static char * info_xpm[] = {
/* width height ncolors chars_per_pixel */
"32 32 6 1",
/* colors */
" 	c None    m None   s None",
".	c white   m white",
"X	c black   m black",
"x	c gray50  m black",
"o	c gray    m white",
"b	c blue    m black",
/* pixels */
"           xxxxxxxx             ",
"        xxxo......oxxx          ",
"      xxo............oxx        ",
"     xo................ox       ",
"    x.......obbbbo.......X      ",
"   x........bbbbbb........X     ",
"  x.........bbbbbb.........X    ",
" xo.........obbbbo.........oX   ",
" x..........................Xx  ",
"xo..........................oXx ",
"x..........bbbbbbb...........Xx ",
"x............bbbbb...........Xxx",
"x............bbbbb...........Xxx",
"x............bbbbb...........Xxx",
"x............bbbbb...........Xxx",
"xo...........bbbbb..........oXxx",
" x...........bbbbb..........Xxxx",
" xo..........bbbbb.........oXxxx",
"  x........bbbbbbbbb.......Xxxx ",
"   X......................Xxxxx ",
"    X....................Xxxxx  ",
"     Xo................oXxxxx   ",
"      XXo............oXXxxxx    ",
"       xXXXo......oXXXxxxxx     ",
"        xxxXXXo...Xxxxxxxx      ",
"          xxxxX...Xxxxxx        ",
"             xX...Xxx           ",
"               X..Xxx           ",
"                X.Xxx           ",
"                 XXxx           ",
"                  xxx           ",
"                   xx           "};
'!

question
    "Answer the XPM representation of a 32x32 question mark icon."
^'/* XPM */
static char * question_xpm[] = {
/* width height ncolors chars_per_pixel */
"32 32 6 1",
/* colors */
" 	c None    m None   s None",
".	c white   m white",
"X	c black   m black",
"x	c gray50  m black",
"o	c gray    m white",
"b	c blue    m black",
/* pixels */
"           xxxxxxxx             ",
"        xxxo......oxxx          ",
"      xxo............oxx        ",
"     xo................ox       ",
"    x....................X      ",
"   x.......obbbbbbo.......X     ",
"  x.......obo..bbbbo.......X    ",
" xo.......bb....bbbb.......oX   ",
" x........bbbb..bbbb........Xx  ",
"xo........bbbb.obbbb........oXx ",
"x.........obbo.bbbb..........Xx ",
"x.............obbb...........Xxx",
"x.............bbb............Xxx",
"x.............bbo............Xxx",
"x.............bb.............Xxx",
"xo..........................oXxx",
" x...........obbo...........Xxxx",
" xo..........bbbb..........oXxxx",
"  x..........bbbb..........Xxxx ",
"   X.........obbo.........Xxxxx ",
"    X....................Xxxxx  ",
"     Xo................oXxxxx   ",
"      XXo............oXXxxxx    ",
"       xXXXo......oXXXxxxxx     ",
"        xxxXXXo...Xxxxxxxx      ",
"          xxxxX...Xxxxxx        ",
"             xX...Xxx           ",
"               X..Xxx           ",
"                X.Xxx           ",
"                 XXxx           ",
"                  xxx           ",
"                   xx           "};
'!

stop
    "Answer the XPM representation of a 32x32 `critical stop' icon."
^'/* XPM */
static char * stop_xpm[] = {
/* width height ncolors chars_per_pixel */
"32 32 5 1",
/* colors */
" 	c None    m None   s None",
".	c red     m white",
"o	c DarkRed m black",
"X	c white   m black",
"x	c gray50  m black",
/* pixels */
"           oooooooo             ",
"        ooo........ooo          ",
"       o..............o         ",
"     oo................oo       ",
"    o....................o      ",
"   o......................o     ",
"   o......................ox    ",
"  o......X..........X......ox   ",
" o......XXX........XXX......o   ",
" o.....XXXXX......XXXXX.....ox  ",
" o......XXXXX....XXXXX......oxx ",
"o........XXXXX..XXXXX........ox ",
"o.........XXXXXXXXXX.........ox ",
"o..........XXXXXXXX..........oxx",
"o...........XXXXXX...........oxx",
"o...........XXXXXX...........oxx",
"o..........XXXXXXXX..........oxx",
"o.........XXXXXXXXXX.........oxx",
"o........XXXXX..XXXXX........oxx",
" o......XXXXX....XXXXX......oxxx",
" o.....XXXXX......XXXXX.....oxxx",
" o......XXX........XXX......oxx ",
"  o......X..........X......oxxx ",
"   o......................oxxxx ",
"   o......................oxxx  ",
"    o....................oxxx   ",
"     oo................ooxxxx   ",
"      xo..............oxxxxx    ",
"       xooo........oooxxxxx     ",
"         xxooooooooxxxxxx       ",
"          xxxxxxxxxxxxxx        ",
"             xxxxxxxx           "};
'! !

"------------------------------- Progress widget -------------------------"

BExtended subclass: #BProgress
    instanceVariableNames: 'value filled label1 label2'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Graphics-Examples'!

BProgress comment: '
I show how much of a task has been completed.'!

!BProgress methodsFor: 'accessing'!

backgroundColor
    ^label1 backgroundColor
!

backgroundColor: aColor
    label1 backgroundColor: aColor.
    label2 foregroundColor: aColor.
!

filledColor
    ^label2 backgroundColor
!

filledColor: aColor
    label2 backgroundColor: aColor.
!

foregroundColor
    ^label1 foregroundColor
!

foregroundColor: aColor
    label1 foregroundColor: aColor.
!

value
    "Answer the filled percentage of the receiver (0..1)"
    ^value
!

value: newValue
    "Set the filled percentage of the receiver and update the appearance."
    value := newValue.
    filled width: self value * self primitive widthAbsolute.
    label1 label: (value * 100) rounded printString, '%'.
    label2 label: (value * 100) rounded printString, '%'.
! !

!BProgress methodsFor: 'private - gui'!

create
    "Private - Create the widget"
    | hgt |
    super create.
    self primitive onResizeSend: #resize: to: self.

    label1 := BLabel new: self primitive.
    filled := BForm new: self primitive.
    label2 := BLabel new: filled.
    hgt := self primitive height.
    label1 alignment: #center; width: self primitive width height: hgt.
    label2 alignment: #center; width: 0 height: hgt.
    self
	backgroundColor: 'white';
	foregroundColor: 'black';
	filledColor: 'blue';
	resize: nil;
	value: 0.
!

newPrimitive
    "Private - Create the BForm in which the receiver is drawn"
    ^BForm new: self parent
!

resize: newSize
    label2 widthOffset: self primitive widthAbsolute.
! !

"---------------------------- Button-like widgets ------------------------"

BExtended subclass: #BButtonLike
    instanceVariableNames: 'callback down'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Graphics-Examples'!

BButtonLike comment: '
I sink when you press me, I raise when you release me; I
am an abstract class that implements this behavior for
easier programming of button-like widgets (as my name
says).'!

!BButtonLike methodsFor: 'accessing'!

callback
    "Answer the receiver's callback as a DirectedMessage"
    ^callback
!

callback: aReceiver message: aString
    "Inform the receiver that the given message has to be sent to
     aString when the button is clicked."
    callback := DirectedMessage
	selector: aString asSymbol
	arguments: #()
	receiver: aReceiver
!

invokeCallback
    "Manually trigger a callback."
    self callback isNil ifFalse: [ self callback send ]
!

pressed
    "This is the default callback for the widget; it does
    nothing if you don't override it. Of course if a subclass
    overriddes this you (user of the class) might desire to
    call this method from your own callback."
! !

!BButtonLike methodsFor: 'private'!

create
    "Ask myself to create the primitive widget and set up its
     event handlers."
    super create.
    self primitive
	borderWidth: 2;
	effect: #raised;
	onMouseEnterEventSend: #enter to: self;
	onMouseLeaveEventSend: #leave to: self;
	onMouseDownEvent: 1 send: #down: to: self;
	onMouseUpEvent: 1 send: #up: to: self.

    down := false.
    callback := DirectedMessage
	selector: #pressed
	arguments: #()
	receiver: self
! !

!BButtonLike methodsFor: 'events'!

enter
    "Private - Make the widget go down when the mouse enters with
     the left button pressed."
    down ifTrue: [ self primitive effect: #sunken ]
!

leave
    "Private - Make the widget go up when the mouse leaves"
    down ifTrue: [ self primitive effect: #raised ]
!

down: point
    "Private - Make the widget go down when the left button is
     pressed inside it."
    down := true.
    self enter
!

up: point
    "Private - Make the widget go up when the left button is released
     after being pressed inside it, and trigger the callback if the
     button was released inside the widget."
    | inside |
    inside := self primitive effect == #sunken.
    inside ifTrue: [ self leave ].
    down := false.
    inside ifTrue: [ self invokeCallback ]
! !

"-------------------------- Button with a color --------------------------"

BButtonLike subclass: #BColorButton
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Graphics-Examples'!

BButtonLike comment: '
I am a button that lets you choose a color.'

!BColorButton methodsFor: 'accessing'!

color
    "Set the color that the receiver is painted in."
    ^self primitive backgroundColor
!

color: aString
    "Set the color that the receiver is painted in."
    self primitive backgroundColor: aString
!

pressed
    "This is the default callback; it brings up a `choose-a-color'
    window and, if `Ok' is pressed in the window, sets the receiver
    to be painted in the chosen color."
    | newColor |
    newColor := BDialog
	chooseColor: self window
	label: 'Choose a color'
	default: self color.

    newColor isNil ifFalse: [ self color: newColor ]
! !

!BColorButton methodsFor: 'private - gui'!

newPrimitive
    "Private - A BColorButton is implemented through a BLabel. (!)"
    "Make it big enough if no width is specified."
    ^BLabel new: self parent label: '        '
! !

"-------------------------- Balloon event set ----------------------------"

BEventSet subclass: #BBalloon
	instanceVariableNames: 'text'
	classVariableNames: 'Popup MyProcess Owner BalloonDelayTime'
	poolDictionaries: ''
	category: 'Graphics-Examples'!

BBalloon comment: '
This event set allows a widget to show explanatory information when
the mouse lingers over it for a while.'!

!BBalloon class methodsFor: 'accessing'!

balloonDelayTime
    "Answer the time after which the balloon is shown (default is
    half a second)."
    BalloonDelayTime isNil ifTrue: [ BalloonDelayTime := 500 ].
    ^BalloonDelayTime
!

balloonDelayTime: milliseconds
    "Set the time after which the balloon is shown."
    BalloonDelayTime := milliseconds
!

shown
    "Answer whether a balloon is displayed"
    ^Popup notNil
! !

!BBalloon methodsFor: 'initializing'!

initialize: aBWidget
    "Initialize the event sets for the receiver"
    super initialize: aBWidget.
    self text: '<not set>'.
    self
	onMouseEnterEventSend: #queue to: self;
	onMouseLeaveEventSend: #unqueue to: self;
	onMouseDownEventSend: #unqueue:button: to: self
! !

!BBalloon methodsFor: 'accessing'!

text
    "Answer the text displayed in the balloon"
    ^text
!

text: aString
    "Set the text displayed in the balloon to aString"
    text := aString
!

shown
    "Answer whether the receiver's balloon is displayed"
    ^self class shown and: [ Owner == self ]
! !

!BBalloon methodsFor: 'private'!

queue
    "Private - Queue a balloon to be shown in BalloonDelayTime milliseconds"
    self shown ifTrue: [ ^self ].
    MyProcess isNil ifTrue: [
	MyProcess := [
	    (Delay forMilliseconds: self class balloonDelayTime) wait.
	    MyProcess := nil.
	    self popup.
	] fork
    ]
!

unqueue
    "Private - Prevent the balloon from being displayed if we were waiting
     for it to appear, or delete it if it was already there."
    MyProcess isNil ifFalse: [ MyProcess terminate. MyProcess := nil ].
    self shown ifTrue: [ Popup window destroy. Owner := Popup := nil ]
!

unqueue: point button: button
    "Private - Same as #unqueue: but the event handler for mouse-down
     events needs two parameters."
    self unqueue
!

popup
    "Private - Create the popup window showing the balloon."
    Popup := BLabel popup: [ :widget |
	widget
	    label: self text;
	    backgroundColor: '#FFFFAA';

	    x: self widget yRoot + (self widget widthAbsolute // 2)
	    y: self widget yRoot + self widget heightAbsolute + 4.
    ].
    
    "Set the owner *now*. Otherwise, the mouse-leave event generated
    by mapping the new popup window will destroy the popup window
    itself (see #unqueue)."
    Owner := self.
! !

"-------------------- Drop down lists abstract class ---------------------"

BExtended subclass: #BDropDown
	instanceVariableNames: 'list button control callback'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Examples'!

BDropDown comment: '
This class is an abstract class for widgets that show a button which
makes a list pop up below it, and allow the user to choose an item.'!

!BDropDown methodsFor: 'list box accessing'!

add: string afterIndex: index
    ^list add: string afterIndex: index
!

add: string element: element afterIndex: index
    ^list add: string element: element afterIndex: index
!

addLast: anObject
    ^list addLast: anObject
!

addLast: string element: element
    ^list addLast: string element: element
!

at: anIndex
    ^list at: anIndex
!

contents: stringCollection
    list contents: stringCollection
!

contents: stringCollection elements: elementList
    list contents: stringCollection elements: elementList
!

do: aBlock
    list do: aBlock
!

elements: elementList
    list elements: elementList
!

index: newIndex
    list highlight: newIndex.
    self text: self listText
!

numberOfStrings
    ^list numberOfStrings
!

labelAt: anIndex
    ^list labelAt: anIndex
!

labelsDo: aBlock
    list labelsDo: aBlock
!

removeAtIndex: index
    ^list removeAtIndex: index
!

size
    ^list size
! !

!BDropDown methodsFor: 'accessing'!

backgroundColor
    ^list backgroundColor
!

backgroundColor: aColor
    list backgroundColor: aColor.
!

highlightBackground
    ^list highlightBackground
!

highlightBackground: aColor
    list highlightBackground: aColor.
!

foregroundColor
    ^list foregroundColor
!

foregroundColor: aColor
    list foregroundColor: aColor.
!

highlightForeground
    ^list highlightForeground
!

highlightForeground: aColor
    list highlightForeground: aColor.
!

droppedRows
    ^(list height - 8) / self itemHeight
!

droppedRows: anInteger
    list height: anInteger * self itemHeight + 8
! !

!BDropDown methodsFor: 'widget protocol'!

dropdown
    "Always reset the geometry -- it is harmless and *may*
     actually get better appearance in some weird case."
    list window boundingBox: self dropRectangle.

    self isDropdownVisible ifTrue: [ ^self ].
    list window map.
!

dropRectangle
    | screen rectangle spaceBelow |
    screen := Rectangle
	origin: Blox screenOrigin
	extent: Blox screenSize.

    rectangle := Rectangle
	origin: self xRoot @ (self yRoot + self heightAbsolute)
	extent: self widthAbsolute @ list height.

    spaceBelow := screen bottom - rectangle top.
    rectangle bottom > screen bottom ifFalse: [ ^rectangle ].

    "Fine. Pop it up above the entry widget instead of below."
    rectangle moveTo: self xRoot @ self yRoot - rectangle extent.
    rectangle top < screen top ifFalse: [ ^rectangle ].

    "How annoying, it doesn't fit in the screen.  Now we'll try 
     to be real clever and either pop it up or down, depending
     on which way gives us the biggest list."
    spaceBelow < (rectangle bottom - screen top)
	ifTrue: [ rectangle top: 0 ]
	ifFalse: [
	    rectangle
		moveTo: self xRoot @ (self yRoot + self heightAbsolute);
		bottom: screen bottom
	].

    ^rectangle
!

isDropdownVisible
    ^list window isMapped
!

text
    self subclassResponsibility
!

toggle
    control activate.
    self isDropdownVisible
	ifTrue: [ self unmapList ]
	ifFalse: [ self dropdown ]
!

unmapList
    list window unmap.
    self text: self listText.
    self invokeCallback
! !

!BDropDown methodsFor: 'initialization'!

create
    super create.
    list := self createList.

    self primitive
    	effect: #sunken; borderWidth: 2;
    	backgroundColor: 'white'.

    list borderWidth: 0.

    (control := self createTextControl)
	xPixels: 1; yPixels: 1; widthOffset: -17;
	width: self primitive widthAbsolute; heightPixels: self itemHeight;
	borderWidth: 0; backgroundColor: 'white';
	tabStop: true.

    (button := BImage new: self primitive data: BImage downArrow)
	effect: #raised; borderWidth: 2;
	xOffset: -15; yOffset: 0.

    self droppedRows: 8.
    self setEvents
!

newPrimitive
    ^(BContainer new: self parent)
	setVerticalLayout: false;	"Set layout as early as possible"
	yourself
!

setEvents
    button onMouseDownEvent: 1 send: #value: to: [ :pnt | self toggle ].
    list onKeyEvent: 'Tab' send: #value to: [
	self unmapList. control activateNext ].
	    
    list onKeyEvent: 'Shift-Tab' send: #value to: [
	self unmapList. control activatePrevious ].

    list onKeyEvent: 'Return' send: #unmapList to: self.
    list onKeyEvent: 'Escape' send: #unmapList to: self.
    list onMouseUpEvent: 1 send: #value: to: [ :pnt | self unmapList ].
    list onMouseMoveEventSend: #listSelectAt: to: self.
    list onFocusLeaveEventSend: #unmapList to: self.
    list callback: self message: #listCallback
!

setInitialSize
    self primitive
    	x: 0 y: 0;
    	heightPixels: (control heightAbsolute + 6 max: button heightAbsolute + 4).
! !

!BDropDown methodsFor: 'callbacks'!

callback
    ^callback
!

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

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

!BDropDown methodsFor: 'flexibility'!

createList
    "Private - Create the popup widget to be used for the
     `drop-down list'.  It is a BList by default, but you can
     use any other widget, overriding the `list box accessing'
     methods if necessary."
    ^BList new
!

createTextControl
    "Private - Create the control that will hold the string chosen from
     the list box and answer it. The control must be a child of `self
     primitive'."
    self subclassResponsibility
!

itemHeight
    "Private - Answer the height of an item in the drop-down list. The
     default implementation assumes that the receiver understands
     #font, but you can modify it if you want."
    ^1 + (self fontHeight: 'M')
!

listCallback
    "Private - Called when an item of the listbox is highlighted. Do
    nothing by default"
!

listSelectAt: aPoint
    "Private - Select the item lying at the given position in the list
     box. The default implementation assumes that list is a BList, but 
     you can modify it if you want."
    | newIndex |
    (list drawingArea containsPoint: aPoint) ifFalse: [ ^self ].
    newIndex := list indexAt: aPoint.
    newIndex = list index ifTrue: [ ^self ].
    self index: newIndex
!

listText
    "Private - Answer the text currently chosen in the list box. The
     default implementation assumes that list is a BList, but you can
     modify it if you want."
    ^list labelAt: list index
!

text: aString
    "Private - Set the text widget to aString"
    self subclassResponsibility
! !


"-------------------------- Drop down concrete classes -------------------"

BDropDown subclass: #BDropDownList
	instanceVariableNames: 'callback'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Examples'!

BDropDownList comment: '
This class resembles a list box widget, but its actual list shows up
only when you click the arrow button beside the currently selected item.'!

!BDropDownList methodsFor: 'list box accessing'!

index
    ^list index
! !

!BDropDownList methodsFor: 'private-overrides'!

createTextControl
    ^BLabel new: self primitive
!

listCallback
    self text: self listText
!

setEvents
    super setEvents.

    "If we did not test whether the list box is focus, we would toggle
     twice (once in the control's mouseDownEvent, once in the list's
     focusLeaveEvent)"
    control onMouseDownEvent: 1 send: #value: to: [ :pnt |
	list isActive ifFalse: [ self toggle ] ].

    control onFocusEnterEventSend: #highlight to: self.
    control onFocusLeaveEventSend: #highlight to: self.
    control onKeyEvent: 'Down' send: #dropdown to: self.
!

text: aString
    control label: aString.
! !

!BDropDownList methodsFor: 'accessing'!

backgroundColor: aColor
    super backgroundColor: aColor.
    self highlight.
!

highlightBackground: aColor
    super highlightBackground: aColor.
    self highlight.
!

foregroundColor: aColor
    super foregroundColor: aColor.
    self highlight.
!

highlightForeground: aColor
    super highlightForeground: aColor.
    self highlight.
!

font
    ^list font
!

font: aString
    control font: aString
    list font: aString
! !

!BDropDownList methodsFor: 'callbacks'!

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 isNil ifTrue: [ ^self ].
    self callback arguments isEmpty ifFalse: [
	self callback arguments
	    at: self callback arguments size
	    put: self index
    ].
    self callback send
! !

!BDropDownList methodsFor: 'accessing-overrides'!

text
    ^control label
! !

!BDropDownList methodsFor: 'private'!

highlight
    | bg fg |
    control isActive
	ifTrue: [ bg := list highlightBackground. fg := list highlightForeground ]
	ifFalse: [ bg := list backgroundColor. fg := list foregroundColor ].

    control backgroundColor: bg; foregroundColor: fg
! !


BDropDown subclass: #BDropDownEdit
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Examples'!

BDropDown comment: '
This class resembles an edit widget, but it has an arrow button that 
allows the user to pick an item from a pre-built list.'!

!BDropDownEdit methodsFor: 'private'!

editCallback
    self isDropdownVisible ifFalse: [ self invokeCallback ]
!

!BDropDownEdit methodsFor: 'private-overrides'!

createTextControl
    ^(BEdit new: self primitive)
	callback: self message: #editCallback
! !

!BDropDownEdit methodsFor: 'accessing'!

backgroundColor: aColor
    super backgroundColor: aColor.
    control backgroundColor: aColor
!

foregroundColor: aColor
    super foregroundColor: aColor.
    control foregroundColor: aColor
!

highlightBackground: aColor
    super highlightBackground: aColor.
    control selectBackground: aColor
!

highlightForeground: aColor
    super highlightForeground: aColor.
    control selectForeground: aColor
!

font
    ^list font
!

font: aString
    control font: aString
    list font: aString
! !

!BDropDownEdit methodsFor: 'text accessing'!

insertAtEnd: aString
    "Insert the given text at the end of the edit widget"
    control insertAtEnd: aString
!

replaceSelection: aString
    "Replace the selection in the edit widget with aString"
    control replaceSelection: aString
!

selectAll
    "Select the whole contents of the edit widget"
    control selectAll
!

selectFrom: first to: last
    "Select the given range of characters in the edit widget"
    control selectFrom: first to: last
!

selection
    "Answer the selected text in the receiver (an empty string if there is
     no selection)"
    ^control selection
!

selectionRange
    "Answer the range of the selected characters in the receiver, or nil
     if there is no selection"
    ^control selectionRange
!

text: aString
    control contents: aString; selectAll.
! !

!BDropDownEdit methodsFor: 'accessing-overrides'!

text
    "Answer the text shown in the widget"
    ^control contents
! !
