"====================================================================== | | 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: ''. 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 ! !