SystemOrganization addCategory: #'OB-Polymorph-Core'! SystemOrganization addCategory: #'OB-Polymorph-Morph'! SystemOrganization addCategory: #'OB-Polymorph-Dialogs'! PluggableListMorph subclass: #OBPluggableListMorph instanceVariableNames: 'getIconSelector' classVariableNames: '' poolDictionaries: '' category: 'OB-Polymorph-Morph'! !OBPluggableListMorph commentStamp: 'dr 7/18/2007 14:27' prior: 0! I am a special kind of PluggableListMorph and provides methods to access icons for list elements. I use OBLazyListMorph as listMorphClass! !OBPluggableListMorph methodsFor: 'accessing' stamp: 'lr 12/9/2011 08:34'! getIconSelector: aSelector getIconSelector := aSelector! ! !OBPluggableListMorph methodsFor: 'model access' stamp: 'lr 12/9/2011 08:34'! iconAt: index ^ getIconSelector ifNotNil: [ model perform: getIconSelector with: index ]! ! !OBPluggableListMorph methodsFor: 'list management' stamp: 'lr 12/31/2011 10:32'! listMorphClass ^ OBLazyListMorph! ! !OBPluggableListMorph methodsFor: 'drag and drop' stamp: 'lr 12/31/2011 10:27'! startDragExtended: anEvent "Make it possible so that an item can be dropped onto the same list." super startDragExtended: anEvent. self mouseEnterDragging: anEvent ! ! !OBMultipleChoiceRequest methodsFor: '*ob-polymorph' stamp: 'lr 12/18/2011 12:16'! toggleMorphic: anObject "This seems to be somehow required to properly refresh the checkbox." self toggle: anObject. World restoreDisplay! ! DialogWindow subclass: #OBCompletionDialog instanceVariableNames: 'textMorph text listMorph listValues listLabels listIndex answer' classVariableNames: '' poolDictionaries: '' category: 'OB-Polymorph-Dialogs'! !OBCompletionDialog class methodsFor: 'instance creation' stamp: 'lr 9/22/2010 20:21'! on: aRequest ^ self basicNew initializeOn: aRequest! ! !OBCompletionDialog class methodsFor: 'instance creation' stamp: 'lr 9/22/2010 13:31'! openOn: aRequest ^ UITheme builder openModal: (self on: aRequest)! ! !OBCompletionDialog methodsFor: 'accessing' stamp: 'lr 9/23/2010 07:50'! answer "Answer the result of the dialog or nil, if this dialog has been cancelled." ^ answer! ! !OBCompletionDialog methodsFor: 'callbacks' stamp: 'lr 9/22/2010 13:37'! arrowKey: anEvent from: aMorph "Ignore this request."! ! !OBCompletionDialog methodsFor: 'actions' stamp: 'lr 9/22/2010 20:30'! cancel answer := nil. ^ super cancel! ! !OBCompletionDialog methodsFor: 'morphic' stamp: 'lr 9/22/2010 20:09'! defaultFocusMorph ^ textMorph! ! !OBCompletionDialog methodsFor: 'callbacks' stamp: 'lr 9/22/2010 13:22'! doubleClick self ok! ! !OBCompletionDialog methodsFor: 'callbacks' stamp: 'lr 3/6/2011 15:50'! editorKeyStroke: anEvent anEvent keyCharacter = Character arrowDown ifTrue: [ self listIndex: (self listIndex + 1 min: listValues size). ^ true ]. anEvent keyCharacter = Character arrowUp ifTrue: [ self listIndex: (self listIndex - 1 max: 1). ^ true ]. ^ false! ! !OBCompletionDialog methodsFor: 'callbacks' stamp: 'lr 12/31/2011 10:29'! iconAt: anIndex ^ OBInterface current iconNamed: (model iconFor: (listValues at: anIndex ifAbsent: [ ^ nil ]))! ! !OBCompletionDialog methodsFor: 'initialization' stamp: 'lr 9/22/2010 20:59'! initializeOn: aRequest model := aRequest. listValues := listLabels := #(). listIndex := 0. self initialize. self title: aRequest prompt. self text: aRequest default ! ! !OBCompletionDialog methodsFor: 'testing' stamp: 'lr 9/22/2010 21:32'! isAssisted ^ self model assisted! ! !OBCompletionDialog methodsFor: 'testing' stamp: 'lr 9/22/2010 21:32'! isEnabled ^ self model assisted ifTrue: [ self text isEmptyOrNil not ] ifFalse: [ self listIndex > 0 ]! ! !OBCompletionDialog methodsFor: 'accessing-list' stamp: 'lr 9/22/2010 11:45'! listIndex ^ listIndex! ! !OBCompletionDialog methodsFor: 'accessing-list' stamp: 'lr 9/25/2010 21:15'! listIndex: anInteger listIndex = anInteger ifTrue: [ ^ self ]. listIndex := anInteger. self listSelection ifNotNil: [ :selection | self isAssisted ifTrue: [ text := self model labelFor: self listSelection. self changed: #text ] ]. self changed: #listIndex; changed: #isEnabled! ! !OBCompletionDialog methodsFor: 'accessing-list' stamp: 'lr 9/22/2010 11:43'! listLabels ^ listLabels! ! !OBCompletionDialog methodsFor: 'accessing-list' stamp: 'lr 9/22/2010 11:46'! listSelection ^ listValues at: self listIndex ifAbsent: [ nil ]! ! !OBCompletionDialog methodsFor: 'accessing-list' stamp: 'lr 9/22/2010 11:47'! listSelection: anObject self listIndex: (listValues indexOf: anObject ifAbsent: [ 0 ])! ! !OBCompletionDialog methodsFor: 'accessing-list' stamp: 'lr 9/22/2010 11:44'! listValues ^ listValues! ! !OBCompletionDialog methodsFor: 'accessing-list' stamp: 'lr 9/22/2010 20:06'! listValues: aCollection | previous | previous := self listSelection. listValues := aCollection asArray. listLabels := listValues collect: [ :each | model labelFor: each ]. self changed: #listLabels; listSelection: previous! ! !OBCompletionDialog methodsFor: 'morphic' stamp: 'lr 3/6/2011 15:54'! newContentMorph ^ (self newColumn: (Array with: self newTextMorph with: self newListMorph)) minWidth: 320; minHeight: 200; yourself! ! !OBCompletionDialog methodsFor: 'morphic' stamp: 'lr 12/9/2011 08:38'! newListMorph listMorph := OBPluggableListMorph on: self list: #listLabels selected: #listIndex changeSelected: #listIndex:. listMorph borderStyle: (self theme listNormalBorderStyleFor: listMorph); color: (self theme listNormalFillStyleFor: listMorph); cornerStyle: self preferredCornerStyle; doubleClickSelector: #doubleClick; getIconSelector: #iconAt:; hResizing: #spaceFill; vResizing: #spaceFill; autoDeselect: false. ^ listMorph! ! !OBCompletionDialog methodsFor: 'morphic' stamp: 'lr 3/6/2011 15:55'! newOKButton ^ super newOKButton getEnabledSelector: #isEnabled; isDefault: true; yourself! ! !OBCompletionDialog methodsFor: 'morphic' stamp: 'lr 3/6/2011 15:53'! newTextMorph textMorph := self newTextEntryFor: self getText: #text setText: #text: help: nil. textMorph acceptOnCR: false; autoAccept: true; selectAll. textMorph textMorph on: #keyStroke send: #editorKeyStroke: to: self. ^ textMorph! ! !OBCompletionDialog methodsFor: 'actions' stamp: 'lr 9/22/2010 20:31'! ok answer := self model assisted ifTrue: [ self text ] ifFalse: [ self listSelection ]. ^ super ok! ! !OBCompletionDialog methodsFor: 'accessing-text' stamp: 'lr 9/22/2010 20:27'! text ^ text! ! !OBCompletionDialog methodsFor: 'accessing-text' stamp: 'lr 9/24/2010 21:44'! text: aString text = aString ifTrue: [ ^ self ]. text := aString. self listValues: (self model valuesFor: text). self isAssisted ifFalse: [ self listIndex: (self listLabels size = 1 ifTrue: [ 1 ] ifFalse: [ self listLabels findFirst: [ :each | each sameAs: text ] ]) ]. self changed: #text; changed: #isEnabled! ! DialogWindow subclass: #OBMethodNameEditor instanceVariableNames: 'methodName argumentIndex labelMorph' classVariableNames: '' poolDictionaries: '' category: 'OB-Polymorph-Dialogs'! !OBMethodNameEditor class methodsFor: 'instance creation' stamp: 'lr 6/15/2010 09:29'! on: aMethodName ^ self basicNew initializeOn: aMethodName! ! !OBMethodNameEditor class methodsFor: 'instance creation' stamp: 'lr 9/24/2010 08:09'! openOn: aMethodName ^ UITheme builder openModal: (self on: aMethodName)! ! !OBMethodNameEditor methodsFor: 'accessing' stamp: 'lr 6/15/2010 09:30'! argumentIndex ^ argumentIndex! ! !OBMethodNameEditor methodsFor: 'accessing' stamp: 'lr 6/15/2010 10:03'! argumentIndex: anInteger argumentIndex := anInteger. self update! ! !OBMethodNameEditor methodsFor: 'accessing' stamp: 'lr 6/15/2010 09:31'! argumentList ^ self methodName arguments! ! !OBMethodNameEditor methodsFor: 'actions' stamp: 'lr 9/24/2010 08:12'! cancel methodName := nil. ^ super cancel! ! !OBMethodNameEditor methodsFor: 'actions' stamp: 'lr 6/15/2010 10:09'! down self isDownEnabled ifFalse: [ ^ self ]. self argumentList swap: self argumentIndex with: self argumentIndex + 1. self argumentIndex: self argumentIndex + 1! ! !OBMethodNameEditor methodsFor: 'initialization' stamp: 'lr 9/24/2010 08:13'! initializeOn: aMethodName methodName := aMethodName. argumentIndex := 0. self initialize. self title: 'Method Name'! ! !OBMethodNameEditor methodsFor: 'testing' stamp: 'lr 6/15/2010 09:55'! isDownEnabled ^ self argumentIndex ~= 0 and: [ self argumentIndex + 1 between: 1 and: self argumentList size ]! ! !OBMethodNameEditor methodsFor: 'testing' stamp: 'lr 6/15/2010 10:30'! isOkEnabled ^ self methodName isValid! ! !OBMethodNameEditor methodsFor: 'testing' stamp: 'lr 6/15/2010 09:55'! isUpEnabled ^ self argumentIndex ~= 0 and: [ self argumentIndex - 1 between: 1 and: self argumentList size ]! ! !OBMethodNameEditor methodsFor: 'accessing' stamp: 'lr 6/15/2010 09:30'! methodName ^ methodName! ! !OBMethodNameEditor methodsFor: 'morphic' stamp: 'lr 5/7/2011 15:30'! newContentMorph ^ (self newRow: { self newLabelGroup: { 'Selector:' -> ((self newTextEntryFor: self getText: #selector setText: #selector: help: nil) autoAccept: true). 'Arguments:' -> (self newRow: { (self newListFor: self list: #argumentList selected: #argumentIndex changeSelected: #argumentIndex: help: nil) hResizing: #spaceFill; yourself. (self newColumn: { (self newButtonFor: self action: #up label: 'up' help: nil) getEnabledSelector: #isUpEnabled. (self newButtonFor: self action: #down label: 'dn' help: nil) getEnabledSelector: #isDownEnabled }) hResizing: #shrinkWrap }). 'Preview:' -> (labelMorph := self newLabel: self methodName printString) } }) minWidth: 400; yourself! ! !OBMethodNameEditor methodsFor: 'morphic' stamp: 'lr 9/24/2010 08:15'! newOKButton ^ self newOKButtonFor: self getEnabled: #isOkEnabled! ! !OBMethodNameEditor methodsFor: 'accessing' stamp: 'lr 6/15/2010 09:30'! selector ^ self methodName selector! ! !OBMethodNameEditor methodsFor: 'accessing' stamp: 'lr 6/15/2010 10:22'! selector: aString self methodName selector: aString. self update! ! !OBMethodNameEditor methodsFor: 'actions' stamp: 'lr 6/15/2010 10:03'! up self isUpEnabled ifFalse: [ ^ self ]. self argumentList swap: self argumentIndex with: self argumentIndex - 1. self argumentIndex: self argumentIndex - 1! ! !OBMethodNameEditor methodsFor: 'morphic' stamp: 'lr 6/15/2010 10:30'! update self changed: #argumentList; changed: #argumentIndex. self changed: #isUpEnabled; changed: #isDownEnabled; changed: #isOkEnabled. labelMorph contents: self methodName printString! ! !OBIcon methodsFor: '*ob-polymorph' stamp: 'lr 12/9/2011 07:52'! asPolymorphForm | form in | form := Form extent: width @ height depth: 32. in := bytes readStream. 0 to: width - 1 do: [ :x | 0 to: height - 1 do: [ :y | | color alpha | alpha := in next. color := (Color r: in next g: in next b: in next range: 255) alpha: alpha. form colorAt: x @ y put: color ] ]. ^ form! ! OBVisitor subclass: #OBPolymorphBuilder instanceVariableNames: 'currentMorph currentFrame' classVariableNames: '' poolDictionaries: '' category: 'OB-Polymorph-Core'! !OBPolymorphBuilder methodsFor: 'morphic' stamp: 'lr 12/3/2011 16:37'! append: aMorph "Adds aMorph to the currentMorph with the current frame if possible." currentFrame isNil ifFalse: [ currentMorph addMorph: aMorph fullFrame: currentFrame ] ifTrue: [ aMorph vResizing: #spaceFill; hResizing: #spaceFill. currentMorph addMorphBack: aMorph ]! ! !OBPolymorphBuilder methodsFor: 'theming' stamp: 'lr 12/3/2011 17:00'! buttonHeight ^ self theme buttonMinHeight! ! !OBPolymorphBuilder methodsFor: 'theming' stamp: 'lr 12/3/2011 10:02'! fullFrame ^ LayoutFrame new leftFraction: 0 offset: 0; topFraction: 0 offset: 0; rightFraction: 1 offset: 0; bottomFraction: 1 offset: 0; yourself! ! !OBPolymorphBuilder methodsFor: 'morphic' stamp: 'lr 12/3/2011 10:16'! inFrame: aFrame do: aBlock "Set the current frame to aFrame while evaluating aBlock." | previous result | previous := currentFrame. currentFrame := aFrame. result := aBlock value. currentFrame := previous. ^ result! ! !OBPolymorphBuilder methodsFor: 'morphic' stamp: 'lr 12/3/2011 10:17'! inMorph: aMorph do: aBlock "Set the current morph to aMorph while evaluating aBlock." | previous result | previous := currentMorph. currentMorph := aMorph. result := aBlock value. currentMorph := previous. ^ result! ! !OBPolymorphBuilder methodsFor: 'morphic' stamp: 'lr 12/3/2011 10:05'! inMorph: aMorph inFrame: aFrame do: aBlock "Set the current morph to aMorph and the current frame to aFrame while evaluating aBlock." ^ self inMorph: aMorph do: [ self inFrame: aFrame do: aBlock ]! ! !OBPolymorphBuilder methodsFor: 'creational' stamp: 'lr 12/3/2011 09:48'! newPanel ^ PanelMorph new! ! !OBPolymorphBuilder methodsFor: 'creational' stamp: 'lr 11/17/2011 23:38'! newPanelFor: aModel listen: aSelector ^ OBPluggablePanelMorph new model: aModel; listen: aSelector; yourself! ! !OBPolymorphBuilder methodsFor: 'private' stamp: 'lr 12/18/2011 11:48'! requiredColumnsFor: aMetaNode seen: aSet | result | (aSet includes: aMetaNode) ifTrue: [ ^ 1000 ]. aSet add: aMetaNode. result := aMetaNode children inject: 0 into: [ :max :each | max max: 1 + (self requiredColumnsFor: each seen: aSet) ]. aSet remove: aMetaNode. ^ result! ! !OBPolymorphBuilder methodsFor: 'theming' stamp: 'lr 12/3/2011 17:00'! separatorSize ^ 4! ! !OBPolymorphBuilder methodsFor: 'theming' stamp: 'lr 11/19/2011 18:36'! theme ^ UITheme current! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/3/2011 17:53'! visitAnnotationPanel: aPanel | morph | morph := PluggableTextFieldMorph new on: aPanel text: #text accept: #accept:notifying: readSelection: #selection menu: #menu:shifted:; alwaysAccept: true; acceptOnCR: true; font: self theme textFont; cornerStyle: (self theme textEntryCornerStyleIn: currentMorph); borderStyle: (BorderStyle inset width: 1); color: Color white; selectionColor: self theme selectionColor; hideScrollBarsIndefinitely; enabled: false. morph textMorph autoFit: true; wrapFlag: false; margins: (2@1 corner: 2@1). self append: morph! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/31/2011 10:33'! visitBrowser: aBrowser | morph variable fraction offset | morph := StandardWindow new model: aBrowser; title: aBrowser labelString; yourself. variable := aBrowser panels count: [ :each | each isVerticallyElastic ]. fraction := offset := 0. self inMorph: morph do: [ aBrowser panels do: [ :each | | frame | frame := LayoutFrame new. frame leftFraction: 0 offset: 0. frame rightFraction: 1 offset: 0. frame topFraction: fraction offset: offset. each isVerticallyElastic ifFalse: [ offset := offset + self buttonHeight + self separatorSize ] ifTrue: [ fraction := fraction + (1 / variable). offset := 0 ]. frame bottomFraction: fraction offset: offset. self inFrame: frame do: [ self visit: each ] ] ]. ^ morph! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/31/2011 10:16'! visitButton: aButton self append: ((PluggableButtonMorph on: aButton getState: #isPressed action: #execute label: #label) getEnabledSelector: #isEnabled; getColorSelector: #color; yourself)! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/3/2011 19:35'! visitButtonBar: aButtonBar | morph | morph := self newPanelFor: aButtonBar listen: #widgets. morph changeTableLayout; layoutInset: 0 @ 1; rubberBandCells: false; listDirection: #leftToRight; children: [ aButtonBar buttons do: [ :each | self inMorph: morph inFrame: nil do: [ self visit: each ] ] ]. self append: morph! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/3/2011 12:27'! visitColumn: aColumn | morph | morph := self newPanelFor: aColumn listen: #widgets. morph layoutPolicy: ProportionalLayout new. morph children: [ self inMorph: morph inFrame: self fullFrame do: [ self visit: aColumn list. self visit: aColumn switch ] ]. self append: morph! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/18/2011 13:05'! visitColumnPanel: aPanel | fraction fractionStep offset offsetStep depth | depth := self requiredColumnsFor: aPanel root metaNode seen: IdentitySet new. (depth = aPanel minPanes and: [ depth = aPanel maxPanes ]) ifFalse: [ ^ self append: (OBPaneScroller on: aPanel) ]. fraction := currentFrame leftFraction. offset := currentFrame leftOffset. fractionStep := (currentFrame rightFraction - fraction) / aPanel maxPanes. offsetStep := (currentFrame rightOffset - offset) / aPanel maxPanes. (aPanel columns last: aPanel maxPanes) do: [ :each | | frame | frame := LayoutFrame new. frame topFraction: currentFrame topFraction offset: currentFrame topOffset; bottomFraction: currentFrame bottomFraction offset: currentFrame bottomOffset; leftFraction: fraction offset: offset. fraction := fraction + fractionStep. offset := offset + offsetStep. frame rightFraction: fraction offset: offset. self inFrame: frame do: [ self visit: each ] ]! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/3/2011 19:47'! visitDefinitionPanel: aPanel | morph | morph := OBPluggableTextMorph new on: aPanel text: #text accept: #accept:notifying: readSelection: #selection menu: #menu:shifted:selection:; color: Color white; font: StandardFonts codeFont; borderStyle: (BorderStyle inset width: 1); cornerStyle: (self theme textEntryCornerStyleIn: currentMorph); selectionColor: self theme selectionColor; yourself. self append: morph! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/3/2011 13:47'! visitFixedButtonPanel: aPanel | morph | morph := self newPanel. self inMorph: morph inFrame: nil do: [ aPanel buttons do: [ :each | self visit: each ] ]. self append: (OverflowRowMorph new baseMorph: morph; yourself) . ! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/31/2011 10:11'! visitList: aList | morph | morph := OBPluggableListMorph on: aList list: #list selected: #selection changeSelected: #selection: menu: #menu: keystroke: #keystroke:. morph getListElementSelector: #listAt:; getListSizeSelector: #listSize; getIconSelector: #iconAt:; doubleClickSelector: #doubleClick; showHScrollBarOnlyWhenNeeded: true; autoDeselect: true; dragItemSelector: #nodeAt:; dropItemSelector: #dropNode:at:; wantsDropSelector: #wantsDroppedNode:; color: Color white; borderWidth: 0. self append: morph! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/3/2011 17:52'! visitMercuryPanel: aPanel | morph | morph := PluggableTextFieldMorph new on: aPanel text: #text accept: #accept:notifying: readSelection: #selection menu: #menu:shifted:; alwaysAccept: true; acceptOnCR: true; font: self theme textFont; cornerStyle: (self theme textEntryCornerStyleIn: currentMorph); borderStyle: (BorderStyle inset width: 1); color: Color white; selectionColor: self theme selectionColor; hideScrollBarsIndefinitely. morph textMorph autoFit: true; wrapFlag: false; margins: (2@1 corner: 2@1). self append: morph! ! !OBPolymorphBuilder methodsFor: 'visiting' stamp: 'lr 12/3/2011 19:38'! visitSwitch: aSwitch | offset | aSwitch isActive ifFalse: [ ^ self ]. "First update the list frame to make room for the switch:" offset := 0 - self buttonHeight - self separatorSize. currentFrame bottomOffset: offset. "Now build the buttons in the resulting empty space:" self inFrame: (self fullFrame topFraction: 1 offset: offset) do: [ self visit: aSwitch bar ]! ! RectangleMorph subclass: #OBPaneScroller instanceVariableNames: 'model sizing panes transform scrollBar' classVariableNames: '' poolDictionaries: '' category: 'OB-Polymorph-Morph'! OBPaneScroller class instanceVariableNames: 'animationDuration'! !OBPaneScroller commentStamp: 'cwp 3/5/2004 12:13' prior: 0! Instances of OBPaneScroller contain the panes which represent columns in a browser. Their primary responsibilities are laying out panes to fit the space available and scrolling them horizontally when there isn't sufficient space. iVars: sizing - The number of panes which should exactly fit the available space. During layout, the width of the panes is determined accordingly. transform - A TransformMorph used for scrolling scrollBar - An OBHorizontalScrollBar used for scrolling! OBPaneScroller class instanceVariableNames: 'animationDuration'! !OBPaneScroller class methodsFor: 'settings' stamp: 'lr 3/13/2010 19:54'! animationDuration ^ animationDuration! ! !OBPaneScroller class methodsFor: 'settings' stamp: 'lr 3/13/2010 19:56'! animationDuration: anInteger "The duration of the scroll animation in milliseconds." animationDuration := anInteger! ! !OBPaneScroller class methodsFor: 'initialization' stamp: 'lr 3/13/2010 19:58'! initialize animationDuration := 200! ! !OBPaneScroller class methodsFor: 'instance creation' stamp: 'lr 12/18/2011 13:05'! on: aModel ^ self new model: aModel; updatePanes; yourself! ! !OBPaneScroller methodsFor: 'panes' stamp: 'lr 12/4/2011 19:34'! addMorph: aMorph fullFrame: aFrame aMorph adoptPaneColor: self paneColor; hResizing: #rigid; vResizing: #rigid; borderWidth: 0; layoutInset: 0. transform hasSubmorphs ifTrue: [ transform addMorphBack: self separator ]. transform addMorphBack: aMorph. panes addLast: aMorph ! ! !OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/8/2004 11:10'! adjustPaneHeight "This gets called after the scrollbar has been shown or hidden, to move the bottom of the panes to the right place." transform bounds: self innerBounds. transform submorphsDo: [:m | m bounds: (m bounds withHeight: self paneHeight)] ! ! !OBPaneScroller methodsFor: 'accessing' stamp: 'lr 6/5/2009 22:07'! adoptPaneColor: aColor super adoptPaneColor: aColor. scrollBar adoptPaneColor: aColor! ! !OBPaneScroller methodsFor: 'private' stamp: 'lr 12/16/2011 08:53'! basicUpdatePanes | builder | self clearPanes. builder := OBBuilderRequest signal. builder inMorph: self inFrame: builder fullFrame do: [ model columns do: [ :each | builder visit: each ] ]! ! !OBPaneScroller methodsFor: 'private' stamp: 'lr 3/21/2009 20:04'! basicUpdateSizing sizing := model isNil ifTrue: [ 1 ] ifFalse: [ model sizing ]! ! !OBPaneScroller methodsFor: 'layout' stamp: 'lr 4/29/2011 23:41'! bounds: aRectangle super bounds: aRectangle. self layoutWidgets. self layoutPanes. self hideOrShowScrollBar. self setScrollDeltas. ! ! !OBPaneScroller methodsFor: 'panes' stamp: 'lr 12/3/2011 17:19'! clearPanes transform removeAllMorphs. panes := OrderedCollection new! ! !OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/26/2004 23:14'! computeMorphWidths | paneWidths widths | paneWidths := self paneWidthsToFit: self totalPaneWidth. widths := OrderedCollection new. paneWidths do: [:w | widths add: w] separatedBy: [widths add: self separatorWidth]. ^ widths asArray ! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 10:44'! hideOrShowScrollBar self isScrollable ifTrue: [self showScrollBar] ifFalse: [self hideScrollBar]! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 11:10'! hideScrollBar self removeMorph: scrollBar. self adjustPaneHeight.! ! !OBPaneScroller methodsFor: 'initialization' stamp: 'lr 12/3/2011 18:14'! initialize super initialize. self borderWidth: 0; color: Color transparent; vResizing: #spaceFill; hResizing: #spaceFill. self initializeTransform; initializeScrollbar.! ! !OBPaneScroller methodsFor: 'initialization' stamp: 'lr 4/29/2011 23:23'! initializeScrollbar scrollBar := ScrollBar new model: self slotName: 'scrollBar'. scrollBar borderWidth: 1; borderColor: Color black; height: self scrollBarHeight. self resizeScrollBar. ! ! !OBPaneScroller methodsFor: 'initialization' stamp: 'cwp 2/8/2004 10:52'! initializeTransform transform := TransformMorph new. transform color: Color transparent; borderWidth: 0; vResizing: #spaceFill; hResizing: #spaceFill; disableTableLayout; bounds: super innerBounds. self addMorphBack: transform. ! ! !OBPaneScroller methodsFor: 'layout' stamp: 'lr 4/29/2011 23:25'! innerBounds | rect | rect := super innerBounds. ^ self scrollBarIsVisible ifTrue: [ rect withHeight: rect height - self scrollBarHeight + 1 ] ifFalse: [ rect ]! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'lr 4/29/2011 23:34'! isScrollable ^ self leftoverScrollRange > 0! ! !OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/8/2004 01:22'! layoutPanes | widths rect | widths := self computeMorphWidths. rect := 0@0 extent: (0 @ self paneHeight). transform submorphs with: widths do: [:m :w | rect := rect withWidth: w. m bounds: rect. rect := rect translateBy: (w@0)] ! ! !OBPaneScroller methodsFor: 'layout' stamp: 'lr 4/29/2011 23:24'! layoutWidgets | inner outer | outer := super innerBounds. inner := self innerBounds. transform bounds: inner. scrollBar bounds: (inner bottomLeft corner: outer bottomRight)! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'lr 4/29/2011 23:36'! leftoverScrollRange ^ (self totalScrollRange - self innerBounds width) truncated max: 0! ! !OBPaneScroller methodsFor: 'accessing' stamp: 'cwp 11/17/2004 22:03'! model ^model! ! !OBPaneScroller methodsFor: 'accessing' stamp: 'lr 3/4/2009 08:17'! model: anObject model isNil ifFalse: [ model removeDependent: self ]. anObject isNil ifFalse: [ anObject addDependent: self ]. model := anObject! ! !OBPaneScroller methodsFor: 'layout' stamp: 'cwp 11/17/2004 23:09'! paneCount ^ self panes size! ! !OBPaneScroller methodsFor: 'layout' stamp: 'cwp 12/6/2003 17:08'! paneHeight ^ transform bounds height! ! !OBPaneScroller methodsFor: 'layout' stamp: 'lr 3/21/2009 20:05'! paneWidthsToFit: limit | padded | padded := Array new: self paneCount. padded atAllPut: (limit / self sizing) floor. 1 to: limit - padded sum do: [:i | padded at: i put: (padded at: i) + 1]. ^ padded ! ! !OBPaneScroller methodsFor: 'accessing' stamp: 'cwp 11/17/2004 23:09'! panes ^ panes ifNil: [self updatePanes. panes]! ! !OBPaneScroller methodsFor: 'layout' stamp: 'lr 4/29/2011 23:26'! resizeScrollBar | inner outer | outer := super innerBounds. inner := outer withHeight: outer height - self scrollBarHeight + 1. scrollBar bounds: (inner bottomLeft corner: outer bottomRight)! ! !OBPaneScroller methodsFor: 'layout' stamp: 'lr 4/29/2011 23:11'! scrollBarHeight ^ UITheme current settings scrollBarThickness! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 10:56'! scrollBarIsVisible ^ submorphs includes: scrollBar! ! !OBPaneScroller methodsFor: 'input events' stamp: 'cwp 8/20/2009 08:29'! scrollBarMenuButtonPressed: anObject "Ignore the menu button..."! ! !OBPaneScroller methodsFor: 'input events' stamp: 'lr 5/29/2010 08:11'! scrollBarValue: value transform hasSubmorphs ifFalse: [^ self]. transform offset: (self leftoverScrollRange * value) rounded @ 0. ! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 8/23/2003 16:21'! scrollDeltaWidth ^ 1! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'lr 3/13/2010 19:59'! scrollToRight scrollBar animateValue: 1.0 duration: self class animationDuration! ! !OBPaneScroller methodsFor: 'panes' stamp: 'lr 12/4/2011 19:33'! separator ^ BorderedSubpaneDividerMorph vertical adoptPaneColor: self paneColor; yourself! ! !OBPaneScroller methodsFor: 'defaults' stamp: 'lr 11/15/2011 07:17'! separatorWidth ^ 3! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 8/25/2003 21:14'! setScrollDeltas | range interval value | transform hasSubmorphs ifFalse: [scrollBar interval: 1.0. ^ self]. range := self leftoverScrollRange. range = 0 ifTrue: [^ scrollBar interval: 1.0; setValue: 0]. interval := ((self innerBounds width) / self totalScrollRange) asFloat. value := (transform offset x / range min: 1.0) asFloat. scrollBar interval: interval. scrollBar setValue: value.! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 11:11'! showScrollBar self scrollBarIsVisible ifTrue: [^ self]. self resizeScrollBar. self addMorphFront: scrollBar. self adjustPaneHeight. ! ! !OBPaneScroller methodsFor: 'accessing' stamp: 'cwp 11/22/2004 23:19'! sizing ^ sizing ifNil: [self updateSizing]! ! !OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/25/2004 20:23'! totalPaneWidth ^ self innerBounds width - ((self sizing - 1) * self separatorWidth)! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 8/25/2003 19:27'! totalScrollRange | submorphBounds | submorphBounds := transform localSubmorphBounds ifNil: [^ 0]. ^ submorphBounds width ! ! !OBPaneScroller methodsFor: 'updating' stamp: 'lr 11/19/2011 18:18'! update: aSymbol aSymbol = #sizing ifTrue: [^ self updateSizing]. aSymbol = #widgets ifTrue: [^ self updatePanes].! ! !OBPaneScroller methodsFor: 'updating' stamp: 'lr 3/4/2009 08:18'! updatePanes | count | model ifNil: [ panes := Array new. ^ self ]. count := panes isNil ifFalse: [ panes size ] ifTrue: [ 0 ]. self basicUpdatePanes. self basicUpdateSizing. self layoutPanes. panes size = count ifFalse: [ self hideOrShowScrollBar. self setScrollDeltas ]. panes size > count ifTrue: [ self scrollToRight ]. ^ panes! ! !OBPaneScroller methodsFor: 'updating' stamp: 'cwp 11/23/2004 01:14'! updateSizing | old | old := sizing. self basicUpdateSizing. sizing = old ifFalse: [self layoutPanes]. ^sizing! ! !OBNode methodsFor: '*ob-polymorph' stamp: 'avi 2/20/2004 14:00'! asDraggableMorph ^(StringMorph contents: self name) color: Color white; yourself! ! OBInterface subclass: #OBPolymorphInterface instanceVariableNames: 'icons' classVariableNames: '' poolDictionaries: '' category: 'OB-Polymorph-Core'! !OBPolymorphInterface class methodsFor: 'utilities' stamp: 'lr 12/29/2011 16:29'! compileIcon: aString as: aSymbol | bytes form source | form := Form fromFileNamed: aString. bytes := ByteArray streamContents: [ :out | 0 to: form width - 1 do: [ :x | 0 to: form height - 1 do: [ :y | | color | color := form colorAt: x @ y. out nextPut: (color alpha * 255) rounded. out nextPut: (color red * 255) rounded. out nextPut: (color green * 255) rounded. out nextPut: (color blue * 255) rounded ] ] ]. source := String streamContents: [ :out | out nextPutAll: aSymbol; cr; tab; nextPutAll: 'width := '; print: form width; nextPut: $.; cr; tab; nextPutAll: 'height := '; print: form height; nextPut: $.; cr; tab; nextPutAll: 'bytes := '; print: bytes ]. OBIcon compile: source! ! !OBPolymorphInterface class methodsFor: 'initialization' stamp: 'lr 12/31/2011 10:30'! initialize OBInterface default: self new! ! !OBPolymorphInterface methodsFor: 'building' stamp: 'lr 11/23/2011 21:41'! builder ^ OBPolymorphBuilder new! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 11/17/2011 21:51'! handleBrowseRequest: aRequest (self builder visit: aRequest browser) openInWorld. ^ aRequest browser! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 11/16/2011 20:34'! handleChoiceRequest: aRequest ^ UIManager default chooseFrom: aRequest labels values: aRequest values lines: aRequest lines title: (aRequest prompt ifNil: [ String new ])! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 11/16/2011 20:42'! handleCloseRequest: aRequest aRequest browser changed: #close! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 12/18/2011 12:14'! handleCompletionRequest: aRequest ^ (OBCompletionDialog openOn: aRequest) answer! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 11/16/2011 20:34'! handleConfirmationRequest: aRequest | choice | choice := UIManager default confirm: aRequest prompt trueChoice: aRequest okChoice falseChoice: aRequest cancelChoice. ^ choice ifNil: [ false ] ifNotNil: [ choice ]! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 11/16/2011 20:35'! handleInformRequest: aRequest ^ UIManager default inform: aRequest message! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 12/14/2011 21:07'! handleMethodNameRequest: aMethodNameRequest ^ (OBMethodNameEditor openOn: aMethodNameRequest methodName) methodName! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 11/16/2011 20:35'! handleMultiLineTextRequest: aRequest ^ UIManager default multiLineRequest: aRequest prompt centerAt: Sensor cursorPoint initialAnswer: aRequest template answerHeight: 200! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 10/11/2009 12:18'! handleMultipleChoiceRequest: aRequest | menu | aRequest values isEmpty ifTrue: [ ^ aRequest values ]. menu := MenuMorph new. menu stayUp: true. aRequest prompt isEmptyOrNil ifFalse: [ menu addTitle: aRequest prompt ]. aRequest values do: [ :value | menu addUpdating: #label: target: aRequest selector: #toggleMorphic: argumentList: (Array with: value) ]. menu addLine. menu add: 'ok' target: menu selector: #delete. menu invokeModal. ^ aRequest selection asArray! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 11/16/2011 20:35'! handleTextRequest: aRequest | text | text := UIManager default request: aRequest prompt initialAnswer: aRequest template. ^ (text isNil or: [ text isEmpty ]) ifFalse: [ text ]! ! !OBPolymorphInterface methodsFor: 'interaction' stamp: 'lr 5/14/2008 15:42'! handleWaitRequest: request ^ Cursor wait showWhile: request block! ! !OBPolymorphInterface methodsFor: 'accessing' stamp: 'lr 12/31/2011 10:30'! iconNamed: aSymbol | icon | aSymbol isNil ifTrue: [ ^ nil ]. icons at: aSymbol ifPresent: [ :form | ^ form ]. icon := OBIcon named: aSymbol. icon isNil ifFalse: [ ^ icons at: aSymbol put: icon asPolymorphForm ]. icon := UITheme current iconNamed: ('small' , aSymbol capitalized) asSymbol ifNone: [ UITheme current iconNamed: aSymbol ]. ^ icons at: aSymbol put: icon! ! !OBPolymorphInterface methodsFor: 'initialization' stamp: 'lr 12/31/2011 10:31'! initialize icons := IdentityDictionary new! ! TextMorphForEditView subclass: #OBTextMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Polymorph-Morph'! !OBTextMorph methodsFor: 'callbacks' stamp: 'lr 12/4/2011 13:27'! keyStroke: anEvent (anEvent anyModifierKeyPressed and: [ self editView model keystroke: anEvent asKeystroke selection: self editView selectionInterval in: self editView ]) ifFalse: [ super keyStroke: anEvent ]! ! !OBBrowser class methodsFor: '*ob-polymorph' stamp: 'lr 9/23/2010 08:09'! taskbarIcon ^ UITheme current smallSystemBrowserIcon! ! !OBSwitch methodsFor: '*ob-polymorph-dragging' stamp: 'lr 5/28/2010 18:08'! acceptDroppingMorph: aTransferMorph event: anEvent inMorph: aButtonMorph ^ column drop: aTransferMorph passenger on: (self nodeForMorph: aButtonMorph)! ! !OBSwitch methodsFor: '*ob-polymorph-dragging' stamp: 'lr 5/28/2010 19:31'! nodeForMorph: aButtonMorph | edge nodes | edge := filter metaNode edges at: (aButtonMorph owner submorphs indexOf: aButtonMorph ifAbsent: [ ^ nil ]) ifAbsent: [ ^ nil ]. nodes := column metaNode filters inject: (edge nodesForParent: column parent) into: [ :result :each | each nodesFrom: result forNode: column parent ]. ^ nodes at: column selection ifAbsent: [ ^ nil ]! ! !OBSwitch methodsFor: '*ob-polymorph-dragging' stamp: 'lr 11/19/2011 18:44'! wantsDroppedMorph: aTransferMorph event: anEvent inMorph: aButtonMorph (aTransferMorph isKindOf: TransferMorph) ifFalse: [ ^ false ]. aTransferMorph dragTransferType = column dragTransferType ifFalse: [ ^ false ]. ^ column canDrop: aTransferMorph passenger on: (self nodeForMorph: aButtonMorph)! ! !ScrollBar methodsFor: '*ob-polymorph' stamp: 'lr 7/29/2011 09:16'! animateValue: aNumber duration: anInteger anInteger <= 0 ifTrue: [ self setValue: aNumber ] ifFalse: [ | start startTime | start := value roundTo: scrollDelta. startTime := Time millisecondClockValue. [ | delta | [ (delta := Time millisecondsSince: startTime) < anInteger ] whileTrue: [ self setValue: (aNumber - start) * (delta / anInteger) + start. Processor yield ]. self setValue: aNumber ] fork ]! ! LazyListMorph subclass: #OBLazyListMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Polymorph-Morph'! !OBLazyListMorph commentStamp: 'dr 7/18/2007 14:28' prior: 0! I am an adapted version of LazyListMorph. I can display icons and colors for my elements.! !OBLazyListMorph methodsFor: 'drawing' stamp: 'lr 12/9/2011 08:42'! display: item atRow: row on: canvas | drawBounds top | drawBounds := self drawBoundsForRow: row. (listSource iconAt: row) ifNotNil: [ :form | top := drawBounds top + ((drawBounds height - form height) // 2). canvas translucentImage: form at: drawBounds left @ top. drawBounds := drawBounds left: drawBounds left + form width + 2 ]. item isText ifTrue: [ canvas drawString: item string in: drawBounds font: (font emphasized: (item emphasisAt: 1)) color: (item colorAt: 1) ] ifFalse: [ canvas drawString: item in: drawBounds font: font color: (self colorForRow: row) ]! ! !Text methodsFor: '*ob-polymorph' stamp: 'lr 12/23/2009 15:18'! colorAt: characterIndex | textColor | textColor := (self attributesAt: characterIndex) detect: [ :attribute | attribute isMemberOf: TextColor ] ifNone: [ TextColor black ]. ^ textColor color! ! PanelMorph subclass: #OBPluggablePanelMorph instanceVariableNames: 'model listen children' classVariableNames: '' poolDictionaries: '' category: 'OB-Polymorph-Morph'! !OBPluggablePanelMorph methodsFor: 'accessing' stamp: 'lr 11/17/2011 23:49'! children: aValuable children := aValuable. self refresh! ! !OBPluggablePanelMorph methodsFor: 'accessing' stamp: 'lr 11/17/2011 19:56'! listen: aSelector "If set, listen to change events of aSelector. Otherwise conservatively rebuild the panel whenever an change event is triggered." listen := aSelector! ! !OBPluggablePanelMorph methodsFor: 'accessing' stamp: 'lr 11/17/2011 19:35'! model: aModel model isNil ifFalse: [ model removeDependent: self ]. model := aModel. model isNil ifFalse: [ model addDependent: self ]! ! !OBPluggablePanelMorph methodsFor: 'updating' stamp: 'lr 12/3/2011 12:21'! refresh self removeAllMorphs. children cull: self! ! !OBPluggablePanelMorph methodsFor: 'updating' stamp: 'lr 11/17/2011 23:49'! update: aSymbol (aSymbol notNil and: [ listen isNil or: [ listen = aSymbol ] ]) ifTrue: [ self refresh ]! ! PluggableTextMorph subclass: #OBPluggableTextMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Polymorph-Morph'! !OBPluggableTextMorph methodsFor: 'menu' stamp: 'lr 12/9/2011 08:46'! getMenu: shiftKeyState ^ model perform: getMenuSelector with: (UIManager default newMenuIn: self for: model) with: shiftKeyState with: selectionInterval! ! !OBPluggableTextMorph methodsFor: 'private' stamp: 'lr 12/3/2011 19:56'! textMorphClass ^ OBTextMorph! ! !MenuMorph methodsFor: '*ob-polymorph' stamp: 'lr 12/31/2011 09:54'! add: label target: anObject selector: aSelector enabled: aBoolean icon: aSymbol keystroke: aKeystroke self add: label target: anObject selector: aSelector. self lastItem isEnabled: aBoolean. OBPlatform current menuWithIcons ifTrue: [ self lastItem icon: (OBInterface current iconNamed: aSymbol) ]. aKeystroke isNil ifFalse: [ self lastItem keyText: aKeystroke asKeystroke printString ]. anObject longDescription isNil ifFalse: [ self lastItem assureExtension balloonText: anObject longDescription ] ! ! !MenuMorph methodsFor: '*ob-polymorph' stamp: 'lr 11/14/2011 23:01'! addSubmenu: aString enabled: aBoolean "Append the given submenu with the given label." | item submenu | item := MenuItemMorph new. submenu := MenuMorph new. item contents: aString; isEnabled: aBoolean; subMenu: submenu. self addMorphBack: item. ^ submenu! ! !OBList methodsFor: '*ob-polymorph-dragging' stamp: 'lr 12/31/2011 10:01'! dropNode: aNode at: anInteger | target | target := self children at: anInteger ifAbsent: [ ^ self ]. (target wantsDroppedNode: aNode) ifFalse: [ ^ self ]. [ target acceptDroppedNode: aNode ] on: OBAnnouncerRequest do: [ :request | request resume: self announcer ]! ! !OBList methodsFor: '*ob-polymorph-dragging' stamp: 'lr 12/31/2011 10:02'! wantsDroppedNode: aNode ^ aNode notNil and: [ self children anySatisfy: [ :each | each wantsDroppedNode: aNode ] ]! ! OBPaneScroller initialize! OBPolymorphInterface initialize!