SystemOrganization addCategory: #'OB-Morphic-Core'! SystemOrganization addCategory: #'OB-Morphic-Morphs'! !OBColumn methodsFor: '*ob-morphic' stamp: 'cwp 7/13/2007 20:59'! acceptDroppingMorph: transferMorph event: evt inMorph: listMorph | target | target := self nodeForDropEvent: evt inMorph: listMorph. ^self drop: transferMorph passenger on: target! ! !OBColumn methodsFor: '*ob-morphic' stamp: 'avi 2/20/2004 13:45'! dragEnabled ^ true! ! !OBColumn methodsFor: '*ob-morphic' stamp: 'cwp 7/13/2007 22:39'! dragPassengerFor: item inMorph: listMorph ^ self nodeForItem: item contents asString! ! !OBColumn methodsFor: '*ob-morphic' stamp: 'avi 2/20/2004 14:37'! dragTransferType ^ #OmniBrowser! ! !OBColumn methodsFor: '*ob-morphic' stamp: 'avi 2/20/2004 14:36'! dragTransferTypeForMorph: listMorph ^ self dragTransferType! ! !OBColumn methodsFor: '*ob-morphic' stamp: 'avi 2/20/2004 14:30'! dropEnabled ^ true! ! !OBColumn methodsFor: '*ob-morphic' stamp: 'dr 3/3/2008 16:32'! nodeForDropEvent: evt inMorph: pluggableListMorph | index item label | index := pluggableListMorph rowAtLocation: evt position. index = 0 ifTrue: [^nil]. item := pluggableListMorph listMorph item: index. label := item contents asString withBlanksTrimmed. ^self children detect: [:child | child displayString asString withBlanksTrimmed = label] ifNone: [nil]! ! !OBColumn methodsFor: '*ob-morphic' stamp: 'dr 11/18/2008 20:20'! wantsDroppedMorph: transferMorph event: evt inMorph: listMorph | node passenger | (transferMorph isKindOf: TransferMorph) ifFalse: [^false]. node := self nodeForDropEvent: evt inMorph: listMorph. transferMorph dragTransferType == self dragTransferType ifFalse: [^false]. passenger := transferMorph passenger. ^self canDrop: passenger on: node! ! TextMorphEditor subclass: #OBTextMorphEditor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBTextMorphEditor commentStamp: 'cwp 1/7/2005 23:27' prior: 0! OBTextMorphEditor overrides the TextMorphEditors handling of command keys, passing them along to its model for processing, rather than hard-coding their implementations.! !OBTextMorphEditor methodsFor: 'actions' stamp: 'alain.plantec 6/18/2008 09:10'! browseIt | symbol | self lineSelectAndEmptyCheck: [^ self]. (symbol := self selectedSymbol) isNil ifTrue: [^ self flash]. self send: #browseIt: toModelWith: {symbol} orDo: [super browseIt]! ! !OBTextMorphEditor methodsFor: 'actions' stamp: 'lr 2/12/2009 10:35'! implementorsOfIt "Open a senders browser on the selected selector" | selector | self lineSelectAndEmptyCheck: [ ^ self ]. (selector := self selectedSelector) isNil ifTrue: [ ^ self flash ]. self send: #implementorsOfIt: toModelWith: { selector } orDo: [ super sendersOfIt ]! ! !OBTextMorphEditor methodsFor: 'actions' stamp: 'lr 2/12/2009 10:35'! referencesToIt | selector | self lineSelectAndEmptyCheck: [ ^ self ]. (selector := self selectedSelector) isNil ifTrue: [ ^ self flash ]. self send: #referencesToIt: toModelWith: { selector } orDo: [ super referencesToIt ]! ! !OBTextMorphEditor methodsFor: 'model access' stamp: 'alain.plantec 6/18/2008 09:10'! send: aSelector toModelWith: args orDo: aBlock self terminateAndInitializeAround: [(model respondsTo: aSelector) ifTrue: [(model perform: aSelector withArguments: args) ifFalse: [self flash]] ifFalse: aBlock]! ! !OBTextMorphEditor methodsFor: 'actions' stamp: 'lr 2/12/2009 10:35'! sendersOfIt "Open a senders browser on the selected selector" | selector | self lineSelectAndEmptyCheck: [ ^ self ]. (selector := self selectedSelector) isNil ifTrue: [ ^ self flash ]. self send: #sendersOfIt: toModelWith: { selector } orDo: [ super sendersOfIt ]! ! OBTextMorphEditor subclass: #OBTextMorphEditorWithShout instanceVariableNames: 'inBackTo' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBTextMorphEditorWithShout methodsFor: 'backspace handling' stamp: 'tween 3/15/2007 14:16'! backTo: startIndex "When backspacing, 2 notifications of the userHasEdited are received. This then causes a background process to not terminate correctly. The reason for all this is uncertain, but discarding the superfluous userHasEdited message received while running backTo: seems to cure the problem" | answer | [inBackTo := true. answer := super backTo: startIndex ] ensure:[ inBackTo:=false. ^answer] ! ! !OBTextMorphEditorWithShout methodsFor: 'parenblinking' stamp: 'lr 3/4/2009 08:17'! blinkParen lastParentLocation isNil ifFalse: [ self text string size >= lastParentLocation ifTrue: [ self text addAttribute: TextEmphasis bold from: lastParentLocation to: lastParentLocation ] ]! ! !OBTextMorphEditorWithShout methodsFor: 'new selection' stamp: 'tween 3/15/2007 14:18'! changeEmphasis: characterStream morph editView styler evaluateWithoutStyling: [^super changeEmphasis: characterStream]! ! !OBTextMorphEditorWithShout methodsFor: 'parenblinking' stamp: 'tween 3/15/2007 14:18'! clearParens super clearParens. lastParentLocation := nil ! ! !OBTextMorphEditorWithShout methodsFor: 'backspace handling' stamp: 'tween 3/15/2007 14:16'! userHasEdited "ignore this if generated during backTo: See comment in backTo: " (inBackTo isNil or: [inBackTo not]) ifTrue:[^super userHasEdited] ! ! RectangleMorph subclass: #OBButtonBar instanceVariableNames: 'model' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBButtonBar class methodsFor: 'as yet unclassified' stamp: 'cwp 3/11/2007 16:39'! on: aModel ^ self new model: aModel; initGeometry; update: #commands.! ! !OBButtonBar methodsFor: 'updating' stamp: 'dc 9/8/2007 15:02'! addButtonFor: aCommand self addMorphBack: ((self buttonFor: aCommand) position: self position; yourself)! ! !OBButtonBar methodsFor: 'visual' stamp: 'cwp 3/11/2007 20:55'! adoptPaneColor: aColor self submorphs do: [:ea | ea onColor: aColor offColor: aColor whiter]! ! !OBButtonBar methodsFor: 'updating' stamp: 'dc 9/27/2007 14:46'! buttonFor: aCommand | buttonColor | buttonColor := model color duller. ^ (PluggableButtonMorph on: aCommand getState: #isActive action: (aCommand isActive ifTrue: [#execute] ifFalse: [#yourself]) label: #buttonLabel) onColor: buttonColor offColor: buttonColor whiter; hResizing: #spaceFill; vResizing: #spaceFill; styleWith: OBMorphBuilder new; setBalloonText: aCommand longDescription; yourself ! ! !OBButtonBar methodsFor: 'initialize-release' stamp: 'lr 2/17/2009 17:24'! initGeometry self layoutPolicy: TableLayout new; listDirection: #leftToRight; hResizing: #spaceFill; vResizing: #spaceFill; rubberBandCells: true; styleWith: OBMorphBuilder new! ! !OBButtonBar methodsFor: 'accessing' stamp: 'cwp 3/11/2007 15:56'! model ^ model! ! !OBButtonBar methodsFor: 'accessing' stamp: 'lr 3/4/2009 08:17'! model: aModel model isNil ifFalse: [ model removeDependent: self ]. model := aModel. model addDependent: self! ! !OBButtonBar methodsFor: 'visual' stamp: 'lr 3/4/2009 08:17'! noteNewOwner: aMorph | window | window := aMorph containingWindow. window isNil ifFalse: [ self adoptPaneColor: window paneColor ]! ! !OBButtonBar methodsFor: 'building' stamp: 'cwp 7/21/2007 21:35'! styleWith: aBuilder aBuilder styleButtonBar: self! ! !OBButtonBar methodsFor: 'updating' stamp: 'cwp 3/11/2007 15:58'! update: aSymbol aSymbol == #commands ifTrue: [self updateCommands]! ! !OBButtonBar methodsFor: 'updating' stamp: 'cwp 3/11/2007 19:27'! updateCommands self removeAllMorphs. model commands do: [:ea | self addButtonFor: ea]. ! ! RectangleMorph subclass: #OBGroupingMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBGroupingMorph methodsFor: 'as yet unclassified' stamp: 'cwp 12/9/2007 12:03'! addBorders self borderWidth: 0. self submorphs do: [:morph | morph class = self class ifTrue: [morph addBorders] ifFalse: [morph adoptPaneColor: color. morph borderWidth: 2; borderColor: #inset; color: Color transparent]]! ! !OBGroupingMorph methodsFor: 'as yet unclassified' stamp: 'cwp 12/9/2007 10:50'! addMorph: aMorph frame: relFrame "Stole this from SystemWindow" | frame | frame := LayoutFrame new. frame leftFraction: relFrame left; rightFraction: relFrame right; topFraction: relFrame top; bottomFraction: relFrame bottom. self addMorph: aMorph fullFrame: frame. ! ! !OBGroupingMorph methodsFor: 'as yet unclassified' stamp: 'lr 1/22/2008 20:08'! initialize super initialize. self borderWidth: 0. self color: Color transparent! ! RectangleMorph subclass: #OBPane instanceVariableNames: 'model list button' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBPane commentStamp: 'cwp 1/7/2005 23:24' prior: 0! An OBPane is the visual representation of a column in a browser. It contains a morph to display nodes (typically a PluggableListMorph) and (optionally) a morph for communicating with the column's filter. It's main responsibility is to lay out its submorphs as the filter controls are added and removed. iVars: model - the OBColumn that controls the node list displayed in this pane list - the morph which displays the node list, usually a PluggableListMorph button - the morph which controls the column's filter, usually an OBRadioButtonBar.! !OBPane methodsFor: 'updating' stamp: 'cwp 11/2/2004 00:53'! addButton: aButton self hasButton ifTrue: [self removeMorph: button]. button := aButton. button height: self defaultButtonHeight. self addMorph: button; adjustList; adjustButton! ! !OBPane methodsFor: 'updating' stamp: 'cwp 3/14/2007 23:33'! addList: aListMorph list := aListMorph. self addMorph: list. list bounds: self innerBounds. ! ! !OBPane methodsFor: 'updating' stamp: 'lr 2/12/2009 10:36'! adjustButton | inner | self hasButton ifFalse: [ ^ self ]. inner := self innerBounds. button bounds: (inner withTop: inner bottom - button height)! ! !OBPane methodsFor: 'updating' stamp: 'cwp 3/14/2007 23:26'! adjustList self hasButton ifFalse: [self list bounds: self innerBounds] ifTrue: [self list bounds: (self innerBounds withHeight: (self height - self buttonHeight))]! ! !OBPane methodsFor: 'geometry' stamp: 'cwp 2/12/2004 18:32'! bounds: aRectangle super bounds: aRectangle. self adjustList. self adjustButton.! ! !OBPane methodsFor: 'accessing' stamp: 'cwp 3/14/2007 23:28'! button ^ button! ! !OBPane methodsFor: 'constructing' stamp: 'cwp 5/18/2007 00:02'! buttonFor: aSwitch ^ aSwitch buildOn: OBMorphBuilder new ! ! !OBPane methodsFor: 'constructing' stamp: 'cwp 11/2/2004 00:57'! buttonHeight ^ self hasButton ifTrue: [button height] ifFalse: [self defaultButtonHeight] ! ! !OBPane methodsFor: 'constructing' stamp: 'lr 2/17/2009 17:34'! defaultButtonHeight ^ Preferences standardButtonFont height * 2.5! ! !OBPane methodsFor: 'testing' stamp: 'cwp 2/12/2004 18:35'! hasButton ^ button notNil! ! !OBPane methodsFor: 'initialization' stamp: 'cwp 3/14/2007 23:42'! initGeometry self hResizing: #spaceFill; vResizing: #spaceFill; clipSubmorphs: true; color: Color transparent; cellInset: 0; borderWidth: 0; layoutPolicy: ProportionalLayout new. ! ! !OBPane methodsFor: 'accessing' stamp: 'cwp 3/14/2007 23:42'! list ^ list! ! !OBPane methodsFor: 'initialization' stamp: 'lr 3/4/2009 08:17'! model: anObject "Set my model and make me me a dependent of the given object." model isNil ifFalse: [ model removeDependent: self ]. anObject isNil ifFalse: [ anObject addDependent: self ]. model := anObject! ! !OBPane methodsFor: 'constructing' stamp: 'lr 3/4/2009 09:37'! noteNewOwner: aMorph self containingWindow isNil ifFalse: [ self adoptPaneColor: self containingWindow paneColor ]! ! !OBPane methodsFor: 'updating' stamp: 'lr 2/12/2009 10:36'! removeButton self hasButton ifFalse: [ ^ self ]. self removeMorph: button. button := nil. self adjustList! ! !OBPane methodsFor: 'updating' stamp: 'cwp 5/18/2007 23:09'! update: aSelector aSelector = #switch ifFalse: [^ self]. self hasButton = model wantsButton ifTrue: [^ self]. model wantsButton ifTrue: [self addButton: (self buttonFor: model switch)] ifFalse: [self removeButton]! ! RectangleMorph subclass: #OBPaneScroller instanceVariableNames: 'model sizing panes transform scrollBar' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !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 methodsFor: 'as yet unclassified' stamp: 'cwp 11/17/2004 22:01'! withModel: aModel ^ self new model: aModel! ! !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: 'private' stamp: 'lr 3/4/2009 08:20'! basicUpdatePanes | builder | builder := OBMorphBuilder new. panes := model isNil ifTrue: [ Array new ] ifFalse: [ model columns collect: [ :ea | ea buildOn: builder ] ]. self clearPanes. panes do: [ :ea | self pushPane: ea ]! ! !OBPaneScroller methodsFor: 'private' stamp: 'lr 3/4/2009 08:20'! basicUpdateSizing model isNil ifTrue: [ sizing := 1 ] ifFalse: [ sizing := model sizing ]! ! !OBPaneScroller methodsFor: 'layout' stamp: 'cwp 11/21/2004 23:45'! bounds: aRectangle super bounds: aRectangle. self layoutWidgets. self layoutPanes. self setScrollDeltas. ! ! !OBPaneScroller methodsFor: 'panes' stamp: 'cwp 12/6/2003 17:06'! clearPanes transform removeAllMorphs! ! !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: 'layout' stamp: 'cwp 2/8/2004 11:06'! doLayout self layoutWidgets. self layoutPanes. self hideOrShowScrollBar. self setScrollDeltas. self scrollToRight.! ! !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: 'cwp 5/28/2007 01:30'! initialize super initialize. self color: Color white; borderWidth: 0; vResizing: #spaceFill; hResizing: #spaceFill. self initializeTransform; initializeScrollbar.! ! !OBPaneScroller methodsFor: 'initialization' stamp: 'cwp 2/8/2004 11:01'! initializeScrollbar scrollBar := OBScrollBar new model: self slotName: 'scrollBar'. scrollBar borderWidth: 0; borderColor: #inset; 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: 'cwp 2/8/2004 10:54'! innerBounds | rect | rect := super innerBounds. ^ self scrollBarIsVisible ifTrue: [rect withHeight: rect height - self scrollBarHeight - 1] ifFalse: [rect]! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 10:42'! 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: 'cwp 8/25/2003 22:13'! layoutWidgets | inner outer | outer := super innerBounds. inner := self innerBounds. transform bounds: inner. scrollBar bounds: ((inner left @ inner bottom + 1) corner: outer bottomRight)! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 8/25/2003 21:04'! leftoverScrollRange ^ (self totalScrollRange - self innerBounds width roundTo: self scrollDeltaWidth) 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: 'cwp 2/26/2004 23:14'! 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: 'panes' stamp: 'cwp 11/23/2004 01:22'! popPanes: count count * 2 timesRepeat: [transform removeMorph: transform lastSubmorph]. panes removeLast: count! ! !OBPaneScroller methodsFor: 'panes' stamp: 'cwp 11/17/2004 22:46'! pushPane: aMorph aMorph borderWidth: 0; hResizing: #rigid; vResizing: #rigid; layoutInset: 0. transform hasSubmorphs ifTrue: [transform addMorphBack: self separator]. transform addMorphBack: aMorph. ! ! !OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/8/2004 11:03'! resizeScrollBar | inner outer | outer := super innerBounds. inner := outer withHeight: outer height - self scrollBarHeight - 1. scrollBar bounds: ((inner left @ inner bottom + 1) corner: outer bottomRight)! ! !OBPaneScroller methodsFor: 'layout' stamp: 'cwp 8/24/2003 14:29'! scrollBarHeight ^ 12! ! !OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 10:56'! scrollBarIsVisible ^ submorphs includes: scrollBar! ! !OBPaneScroller methodsFor: 'updating' stamp: 'cwp 11/21/2004 13:51'! 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: 'cwp 12/8/2003 21:42'! scrollToRight ^ scrollBar setValue: 1.! ! !OBPaneScroller methodsFor: 'panes' stamp: 'cwp 7/21/2007 22:32'! separator ^ BorderedSubpaneDividerMorph vertical color: model defaultBackgroundColor duller; styleWith: OBMorphBuilder new; yourself! ! !OBPaneScroller methodsFor: 'defaults' stamp: 'cwp 7/21/2007 22:45'! separatorWidth ^ OBMorphBuilder new style39 ifTrue: [3] ifFalse: [4]! ! !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: 'cwp 3/25/2007 00:23'! update: aSymbol aSymbol = #sizing ifTrue: [^ self updateSizing]. aSymbol = #columns 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! ! RectangleMorph subclass: #OBRadioButtonBar instanceVariableNames: 'model buttons getListSelector selection getSelectionSelector setSelectionSelector' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBRadioButtonBar commentStamp: 'cwp 1/7/2005 23:27' prior: 0! An OBRadioButtonBar is similar to a PluggableListMorph except that it displays a row of buttons rather than a vertical list. Clicking on a button selects it. model - the model for this button bar buttons - a collection of OBButtonModels, which are derived from the model's list selection - the index of the currently selected button getListSelector - the message for getting the list of labels for the buttons getSelectionSelector - the message for getting the index of the currently selected item setSelectionSelector - the message for informing the model that a button has been clicked! !OBRadioButtonBar class methodsFor: 'as yet unclassified' stamp: 'cwp 2/22/2004 16:44'! on: aModel list: listSelector selected: selectionSelector changeSelected: changedSelector ^ self new on: aModel list: listSelector selected: selectionSelector changeSelected: changedSelector! ! !OBRadioButtonBar methodsFor: 'constructing' stamp: 'cwp 5/18/2007 22:12'! adoptPaneColor: aColor color := aColor. self updateSubmorphColor! ! !OBRadioButtonBar methodsFor: 'accessing' stamp: 'dr 10/21/2008 13:19'! getLabels ^model perform: getListSelector ! ! !OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 2/24/2004 18:53'! getSelectionIndex ^ model perform: getSelectionSelector! ! !OBRadioButtonBar methodsFor: 'initialize-release' stamp: 'cwp 7/21/2007 22:33'! initGeometry self layoutPolicy: TableLayout new; listDirection: #leftToRight; hResizing: #spaceFill; vResizing: #spaceFill; rubberBandCells: true; styleWith: OBMorphBuilder new! ! !OBRadioButtonBar methodsFor: 'callbacks' stamp: 'dr 7/19/2007 15:17'! isEnabled: aButton ^model isEnabled: aButton! ! !OBRadioButtonBar methodsFor: 'callbacks' stamp: 'cwp 2/24/2004 18:54'! isSelected: aButton ^ (buttons at: selection ifAbsent: [^ false]) == aButton! ! !OBRadioButtonBar methodsFor: 'accessing' stamp: 'lr 2/12/2009 10:36'! list buttons ifNil: [ | labels | labels := self getLabels. buttons := Array new: labels size. labels keysAndValuesDo: [ :index :label | buttons at: index put: (OBButtonModel withLabel: label inBar: self) ]. selection := self getSelectionIndex. self ]. ^ buttons collect: [ :b | b label ]! ! !OBRadioButtonBar methodsFor: 'accessing' stamp: 'lr 3/4/2009 08:17'! model: aModel model isNil ifFalse: [ model removeDependent: self ]. model := aModel. model addDependent: self! ! !OBRadioButtonBar methodsFor: 'constructing' stamp: 'lr 3/4/2009 08:17'! noteNewOwner: aMorph | window | window := aMorph containingWindow. window isNil ifFalse: [ self adoptPaneColor: window paneColor ]! ! !OBRadioButtonBar methodsFor: 'initialize-release' stamp: 'cwp 2/25/2004 00:36'! on: aModel list: listSelector selected: selectionGetter changeSelected: selectionSetter self model: aModel. selection := 0. getListSelector := listSelector. getSelectionSelector := selectionGetter. setSelectionSelector := selectionSetter. self initGeometry. self updateList.! ! !OBRadioButtonBar methodsFor: 'callbacks' stamp: 'cwp 2/24/2004 18:47'! push: aButton | index | index := buttons indexOf: aButton. model perform: setSelectionSelector with: index.! ! !OBRadioButtonBar methodsFor: 'constructing' stamp: 'cwp 7/21/2007 21:54'! styleWith: aBuilder aBuilder styleButtonBar: self! ! !OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 2/25/2004 00:35'! update: aSymbol aSymbol = getListSelector ifTrue: [self updateList. ^ self]. aSymbol = getSelectionSelector ifTrue: [self updateSelection]! ! !OBRadioButtonBar methodsFor: 'updating' stamp: 'lr 2/12/2009 10:36'! updateButtons | labels | labels := self getLabels. buttons := Array new: labels size. labels keysAndValuesDo: [ :index :label | buttons at: index put: (OBButtonModel withLabel: label inBar: self) ]. selection := self getSelectionIndex! ! !OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 11/27/2004 17:58'! updateList self updateButtons; updateMorphs! ! !OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 5/18/2007 22:16'! updateMorphs self removeAllMorphs. buttons do: [:button | self addMorphBack: (OBMorphBuilder build: button)]. self updateSubmorphColor ! ! !OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 2/24/2004 19:39'! updateSelection | oldSelection | oldSelection := selection. selection := self getSelectionIndex. self withButtonAt: oldSelection do: [:button | button selectionChanged]. self withSelectedButtonDo: [:button | button selectionChanged]! ! !OBRadioButtonBar methodsFor: 'constructing' stamp: 'cwp 5/18/2007 22:17'! updateSubmorphColor self submorphs do: [:ea | ea onColor: color darker offColor: color lighter]! ! !OBRadioButtonBar methodsFor: 'constructing' stamp: 'cwp 5/18/2007 22:12'! updateSubmorphs self submorphs do: [:ea | ea onColor: color darker offColor: color lighter]! ! !OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 7/9/2007 23:39'! withButtonAt: index do: aBlock ^ aBlock value: (buttons at: index ifAbsent: [^ self]) ! ! !OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 2/24/2004 19:38'! withSelectedButtonDo: aBlock ^ self withButtonAt: selection do: aBlock! ! PluggableTextMorph subclass: #OBPluggableTextMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBPluggableTextMorph commentStamp: 'cwp 12/7/2004 00:04' prior: 0! This is a trivial subclass of PluggableTextMorph. It overrides initialization methods to use an OBTextMorph rather than a regular TextMorph! !OBPluggableTextMorph methodsFor: 'model access' stamp: 'dkh 1/9/2009 10:58'! getColor "Use a fixed selector until we find the need to make the selector pluggable" ^model color! ! !OBPluggableTextMorph methodsFor: 'menu' stamp: 'lr 3/4/2009 08:17'! getMenu: shiftKeyState "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu aMenu aTitle | getMenuSelector isNil ifTrue: [ ^ nil ]. menu := MenuMorph new defaultTarget: model. aTitle := getMenuTitleSelector isNil ifFalse: [ model perform: getMenuTitleSelector ]. aMenu := model menu: menu shifted: shiftKeyState selection: self selectionNode. aTitle isNil ifFalse: [ aMenu addTitle: aTitle ]. ^ aMenu! ! !OBPluggableTextMorph methodsFor: 'event handling' stamp: 'cwp 10/30/2004 23:07'! keyStroke: evt ^ textMorph keyStroke: evt! ! !OBPluggableTextMorph methodsFor: 'access' stamp: 'dr 12/15/2008 19:09'! selectionNode ^ OBTextSelection on: self selectionInterval inText: self text! ! !OBPluggableTextMorph methodsFor: 'model access' stamp: 'lr 3/4/2009 08:20'! setText: aText scrollBar setValue: 0.0. textMorph isNil ifTrue: [ textMorph := OBTextMorph new contents: aText wrappedTo: self innerBounds width - 6. textMorph setEditView: self. scroller addMorph: textMorph ] ifFalse: [ textMorph newContents: aText ]. self hasUnacceptedEdits: false. self setScrollDeltas! ! !OBPluggableTextMorph methodsFor: 'updating' stamp: 'dkh 1/9/2009 11:01'! update: aSymbol super update: aSymbol. aSymbol == #color ifTrue: [ ^self color: self getColor ]. aSymbol == #displayWorld ifTrue: [ ^self currentWorld displayWorld ]! ! OBPluggableTextMorph subclass: #OBPluggableTextMorphWithShout instanceVariableNames: 'styler unstyledAcceptText' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBPluggableTextMorphWithShout class methodsFor: 'instance creation' stamp: 'lr 3/4/2009 08:17'! on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel | styler answer stylerClass | answer := self new. stylerClass := Smalltalk classNamed: #SHTextStylerST80. styler := stylerClass isNil ifFalse: [ stylerClass new view: answer; yourself ]. ^ answer styler: styler; on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel! ! !OBPluggableTextMorphWithShout methodsFor: 'accepting' stamp: 'tween 3/15/2007 14:00'! acceptTextInModel self okToStyle ifFalse:[^super acceptTextInModel]. "#correctFrom:to:with: is sent when the method source is manipulated during compilation (removing unused temps, changing selectors etc). But #correctFrom:to:with: operates on the textMorph's text, and we may be saving an unstyled copy of the text. This means that these corrections will be lost unless we also apply the corrections to the unstyled copy that we are saving. So remember the unstyled copy in unstyledAcceptText, so that when #correctFrom:to:with: is received we can also apply the correction to it" unstyledAcceptText := styler unstyledTextFrom: textMorph asText. [^setTextSelector isNil or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: unstyledAcceptText with: self] ifFalse: [model perform: setTextSelector with: unstyledAcceptText]] ] ensure:[unstyledAcceptText := nil]! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'tween 3/15/2007 14:00'! classOrMetaClass: aBehavior "set the classOrMetaClass in the receiver's styler to aBehavior" styler classOrMetaClass: aBehavior ! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'lr 3/4/2009 08:17'! correctFrom: start to: stop with: aString "see the comment in #acceptTextInModel " unstyledAcceptText isNil ifFalse: [ unstyledAcceptText replaceFrom: start to: stop with: aString ]. ^ super correctFrom: start to: stop with: aString! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'tween 3/15/2007 14:00'! environment: anObject "set the environment in the receiver's styler to anObject" styler environment: anObject ! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'lr 3/4/2009 08:17'! font: aFont super font: aFont. styler isNil ifFalse: [ styler font: aFont ]! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'tween 3/15/2007 14:01'! hasUnacceptedEdits: aBoolean "re-implemented to re-style the text iff aBoolean is true" super hasUnacceptedEdits: aBoolean. (aBoolean and: [self okToStyle]) ifTrue: [ styler styleInBackgroundProcess: textMorph contents]! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'tween 3/15/2007 14:01'! okToStyle styler ifNil:[^false]. Preferences syntaxHighlightingAsYouType ifFalse: [^false]. (model respondsTo: #shoutAboutToStyle: ) ifFalse:[^true]. ^model shoutAboutToStyle: self ! ! !OBPluggableTextMorphWithShout methodsFor: 'private' stamp: 'lr 3/4/2009 08:20'! privateSetText: aText scrollBar setValue: 0.0. textMorph isNil ifTrue: [ textMorph := self textMorphClass new contents: aText wrappedTo: self innerBounds width - 6. textMorph setEditView: self. scroller addMorph: textMorph ] ifFalse: [ textMorph newContents: aText ]. self hasUnacceptedEdits: false. self setScrollDeltas! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'tween 3/15/2007 14:14'! setText: aText self okToStyle ifFalse:[^self privateSetText: aText]. self privateSetText: (styler format: aText asText). aText size < 4096 ifTrue:[ styler style: textMorph contents] ifFalse:[styler styleInBackgroundProcess: textMorph contents] ! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'tween 3/15/2007 14:01'! sourceMap: aSortedCollection "set the sourceMap in the receiver's styler to aSortedCollection" styler sourceMap: aSortedCollection ! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'tween 3/15/2007 14:01'! styler ^styler ! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'tween 3/15/2007 14:02'! styler: anObject styler := anObject ! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'lr 3/4/2009 08:17'! stylerStyled: styledCopyOfText textMorph contents runs: styledCopyOfText runs. "textMorph paragraph recomposeFrom: 1 to: textMorph contents size delta: 0." "caused chars to appear in wrong order esp. in demo mode. remove this line when sure it is fixed" textMorph updateFromParagraph. selectionInterval isNil ifFalse: [ textMorph editor selectInvisiblyFrom: selectionInterval first to: selectionInterval last; storeSelectionInParagraph; setEmphasisHere ]. textMorph editor blinkParen. self scrollSelectionIntoView! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'tween 3/15/2007 14:02'! stylerStyledInBackground: styledCopyOfText "It is possible that the text string has changed since the styling began. Disregard the styles if styledCopyOfText's string differs with the current textMorph contents string" textMorph contents string = styledCopyOfText string ifTrue: [self stylerStyled: styledCopyOfText] ! ! !OBPluggableTextMorphWithShout methodsFor: 'private' stamp: 'tween 3/15/2007 14:15'! textMorphClass "Answer the class used to create the receiver's textMorph" ^OBTextMorphWithShout! ! !OBPluggableTextMorphWithShout methodsFor: 'styler' stamp: 'tween 3/15/2007 14:02'! workspace: anObject "set the workspace in the receiver's styler to anObject" styler workspace: anObject ! ! OBPlatform subclass: #OBMorphicPlatform instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Core'! !OBMorphicPlatform class methodsFor: 'as yet unclassified' stamp: 'cwp 6/1/2007 16:10'! default ^ self new! ! !OBMorphicPlatform methodsFor: 'preferences' stamp: 'cwp 7/1/2007 17:07'! enableGently: aSymbol ^ Preferences enableGently: aSymbol! ! !OBMorphicPlatform methodsFor: 'interaction' stamp: 'cwp 6/1/2007 16:50'! handleBrowseRequest: request ^ OBMorphBuilder open: request browser! ! !OBMorphicPlatform methodsFor: 'interaction' stamp: 'dc 9/18/2007 10:48'! handleChoiceRequest: request ^ UIManager default chooseFrom: request labels values: request values lines: request lines title: (request prompt ifNil: [''])! ! !OBMorphicPlatform methodsFor: 'interaction' stamp: 'lr 3/4/2009 09:38'! handleCloseRequest: request (SystemWindow allInstances detect: [ :ea | ea model = request browser ] ifNone: [ ^ nil ]) delete! ! !OBMorphicPlatform methodsFor: 'interaction' stamp: 'dc 9/18/2007 15:57'! handleConfirmationRequest: request ^ UIManager default chooseFrom: {request okChoice. request cancelChoice} values: {true. false} title: request prompt.! ! !OBMorphicPlatform methodsFor: 'interaction' stamp: 'lr 2/12/2009 10:35'! handleDirectoryRequest: request | fileDirectory | fileDirectory := UIManager default chooseDirectory. fileDirectory isNil ifTrue: [ ^ nil ]. ^ fileDirectory pathName! ! !OBMorphicPlatform methodsFor: 'interaction' stamp: 'dc 7/22/2007 20:32'! handleInformRequest: anOBInformRequest self inform: anOBInformRequest message! ! !OBMorphicPlatform methodsFor: 'interaction' stamp: 'dkh 12/22/2008 12:25'! handleMultiLineTextRequest: request ^UIManager default multiLineRequest: request prompt centerAt: Sensor cursorPoint initialAnswer: request template answerHeight: 200! ! !OBMorphicPlatform methodsFor: 'interaction' stamp: 'lr 4/5/2008 13:02'! 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: #toggle: argumentList: (Array with: value) ]. menu addLine. menu add: 'ok' target: menu selector: #delete. menu invokeModal. ^ aRequest selection asArray! ! !OBMorphicPlatform methodsFor: 'interaction' stamp: 'dc 9/18/2007 16:01'! handleTextRequest: request | text | text := UIManager default request:request prompt initialAnswer: request template. ^ text ifEmpty: [nil] ifNotEmpty: [text]! ! !OBMorphicPlatform methodsFor: 'interaction' stamp: 'lr 5/14/2008 15:42'! handleWaitRequest: request ^ Cursor wait showWhile: request block! ! !OBMorphicPlatform methodsFor: 'preferences' stamp: 'cwp 7/1/2007 16:46'! menuWithIcons ^ Preferences menuWithIcons! ! !OBMorphicPlatform methodsFor: 'preferences' stamp: 'cwp 7/1/2007 16:41'! optionalButtons ^ Preferences optionalButtons ! ! !OBMorphicPlatform methodsFor: 'preferences' stamp: 'cwp 7/1/2007 17:09'! setPreference: aSymbol toValue: anObject ^ Preferences setPreference: aSymbol toValue: anObject! ! TextMorphForEditView subclass: #OBTextMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBTextMorph commentStamp: 'cwp 12/7/2004 00:07' prior: 0! This is a trivial subclass of TextMorph. It overrides editor creation to use OBTextMorphEditor rather than a regular TextMorphEditor.! !OBTextMorph methodsFor: 'private' stamp: 'lr 3/4/2009 08:17'! installEditorToReplace: priorEditor "Install an editor for my paragraph. This constitutes 'hasFocus'. If priorEditor is not nil, then initialize the new editor from its state. We may want to rework this so it actually uses the prior editor." | stateArray | priorEditor isNil ifFalse: [ stateArray := priorEditor stateArray ]. editor := OBTextMorphEditor new morph: self. editor changeParagraph: self paragraph. priorEditor isNil ifFalse: [ editor stateArrayPut: stateArray ]. self selectionChanged. ^ editor! ! OBTextMorph subclass: #OBTextMorphWithShout instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBTextMorphWithShout methodsFor: 'private' stamp: 'tween 3/15/2007 14:08'! editorClass "Answer the class used to create the receiver's editor" ^OBTextMorphEditorWithShout! ! !OBTextMorphWithShout methodsFor: 'private' stamp: 'lr 3/4/2009 08:17'! installEditorToReplace: priorEditor "Install an editor for my paragraph. This constitutes 'hasFocus'. If priorEditor is not nil, then initialize the new editor from its state. We may want to rework this so it actually uses the prior editor." | stateArray | priorEditor isNil ifFalse: [ stateArray := priorEditor stateArray ]. editor := self editorClass new morph: self. editor changeParagraph: self paragraph. priorEditor isNil ifFalse: [ editor stateArrayPut: stateArray ]. self selectionChanged. ^ editor! ! Slider subclass: #OBScrollBar instanceVariableNames: 'upButton downButton pagingArea scrollDelta pageDelta interval menuSelector timeOfMouseDown timeOfLastScroll nextPageDirection currentScrollDelay' classVariableNames: 'CachedImages UpArrow8Bit UpArrow' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBScrollBar commentStamp: 'cwp 3/5/2004 12:01' prior: 0! This class is a relic. It was originally created to work around bugs in ScrollBar which prevented it from working correctly in horizontal orientation. At some point the bugs should be fixed, and ScrollBar should be used instead.! !OBScrollBar class methodsFor: 'as yet unclassified' stamp: 'cwp 11/23/2003 18:07'! alwaysShowFlatScrollbarForAlternativeLook "Set this value to true, if you want to see the flat scrollbar look in flop-out mode as well as inboard. Otherwise the flop-out scrollbar will be rounded and inboard will be flat." ^ false! ! !OBScrollBar class methodsFor: 'class initialization' stamp: 'cwp 11/23/2003 18:07'! initialize "ScrollBar initialize" UpArrow := Form extent: 6@3 fromArray: #(2r11e28 2r1111e27 2r111111e26) offset: 0@0.! ! !OBScrollBar methodsFor: 'accessing' stamp: 'md 2/24/2006 16:12'! adoptPaneColor: aColor "Adopt the given pane color" aColor ifNil:[^self]. self sliderColor: aColor.! ! !OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:06'! buttonExtent ^ bounds isWide ifTrue: [11 @ self innerBounds height] ifFalse: [self innerBounds width @ 11]! ! !OBScrollBar methodsFor: 'accessing' stamp: 'cwp 11/23/2003 18:06'! cachedImageAt: aKey ifAbsentPut: aBlock CachedImages ifNil: [CachedImages := Dictionary new]. ^CachedImages at: aKey ifAbsentPut: aBlock! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! doScrollByPage "Scroll automatically while mouse is down" (self waitForDelay1: 300 delay2: 100) ifFalse: [^ self]. nextPageDirection ifTrue: [self setValue: (value + pageDelta min: 1.0)] ifFalse: [self setValue: (value - pageDelta max: 0.0)] ! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! doScrollDown "Scroll automatically while mouse is down" (self waitForDelay1: 200 delay2: 40) ifFalse: [^ self]. self setValue: (value + scrollDelta + 0.000001 min: 1.0)! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! doScrollUp "Scroll automatically while mouse is down" (self waitForDelay1: 200 delay2: 40) ifFalse: [^ self]. self setValue: (value - scrollDelta - 0.000001 max: 0.0)! ! !OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:06'! expandSlider "Compute the new size of the slider (use the old sliderThickness as a minimum)." | r | r := self totalSliderArea. slider extent: (bounds isWide ifTrue: [((r width * interval) asInteger max: self sliderThickness) @ slider height] ifFalse: [slider width @ ((r height * interval) asInteger max: self sliderThickness)])! ! !OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:06'! extent: p p x > p y ifTrue: [super extent: (p max: 42@8)] ifFalse: [super extent: (p max: 8@42)]! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! finishedScrolling self stopStepping. self scrollBarAction: nil. self roundedScrollbarLook ifTrue:[ upButton borderStyle: (BorderStyle complexRaised width: upButton borderWidth). downButton borderStyle: (BorderStyle complexRaised width: downButton borderWidth). ] ifFalse:[ downButton borderRaised. upButton borderRaised. ]. ! ! !OBScrollBar methodsFor: 'initialization' stamp: 'cwp 11/23/2003 18:07'! initialize super initialize. scrollDelta := 0.02. pageDelta := 0.2. self roundedScrollbarLook ifTrue:[ self borderStyle: ((BorderStyle complexFramed width: 2) "baseColor: Color gray")].! ! !OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'! initializeDownButton downButton := RectangleMorph newBounds: (self innerBounds bottomRight - self buttonExtent extent: self buttonExtent) color: self thumbColor. downButton on: #mouseDown send: #scrollDownInit to: self. downButton on: #mouseUp send: #finishedScrolling to: self. downButton addMorphCentered: (ImageMorph new image: (self cachedImageAt: (bounds isWide ifTrue: ['right'] ifFalse: ['down']) ifAbsentPut: [ self upArrow8Bit rotateBy: (bounds isWide ifTrue: [#right] ifFalse: [#pi]) centerAt: 0@0 ] ) ). self roundedScrollbarLook ifTrue:[ downButton color: Color veryLightGray. downButton borderStyle: (BorderStyle complexRaised width: 3). ] ifFalse:[ downButton setBorderWidth: 1 borderColor: #raised. ]. self addMorph: downButton. ! ! !OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'! initializeEmbedded: aBool "aBool == true => inboard scrollbar aBool == false => flop-out scrollbar" self roundedScrollbarLook ifFalse:[^self]. aBool ifTrue:[ self borderStyle: (BorderStyle inset width: 2). self cornerStyle: #square. ] ifFalse:[ self borderStyle: (BorderStyle width: 1 color: Color black). self cornerStyle: #rounded. ]. self removeAllMorphs. self initializeSlider.! ! !OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'! initializePagingArea pagingArea := RectangleMorph newBounds: self totalSliderArea color: (Color r: 0.6 g: 0.6 b: 0.8). pagingArea borderWidth: 0. pagingArea on: #mouseDown send: #scrollPageInit: to: self. pagingArea on: #mouseUp send: #finishedScrolling to: self. self addMorph: pagingArea. self roundedScrollbarLook ifTrue:[pagingArea color: (Color gray: 0.9)].! ! !OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'! initializeSlider self roundedScrollbarLook ifTrue:[ self initializeUpButton; initializeDownButton; initializePagingArea. ] ifFalse:[ self initializeUpButton; initializeDownButton; initializePagingArea. ]. super initializeSlider. self roundedScrollbarLook ifTrue:[ slider cornerStyle: #rounded. slider borderStyle: (BorderStyle complexRaised width: 3). sliderShadow cornerStyle: #rounded. ]. self sliderColor: self sliderColor.! ! !OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'! initializeUpButton upButton := self roundedScrollbarLook ifTrue: [RectangleMorph newBounds: (self innerBounds topLeft extent: self buttonExtent)] ifFalse: [RectangleMorph newBounds: ((self innerBounds topLeft) extent: self buttonExtent)]. upButton color: self thumbColor. upButton on: #mouseDown send: #scrollUpInit to: self. upButton on: #mouseUp send: #finishedScrolling to: self. upButton addMorphCentered: (ImageMorph new image: (self cachedImageAt: (bounds isWide ifTrue: ['left'] ifFalse: ['up']) ifAbsentPut: [bounds isWide ifTrue: [self upArrow8Bit rotateBy: #left centerAt: 0 @ 0] ifFalse: [self upArrow8Bit]])). self roundedScrollbarLook ifTrue: [upButton color: Color veryLightGray. upButton borderStyle: (BorderStyle complexRaised width: 3)] ifFalse: [upButton setBorderWidth: 1 borderColor: #raised]. self addMorph: upButton! ! !OBScrollBar methodsFor: 'access' stamp: 'cwp 11/23/2003 18:06'! interval: d "Supply an optional floating fraction so slider can expand to indicate range" interval := d min: 1.0. self expandSlider. self computeSlider.! ! !OBScrollBar methodsFor: 'other events' stamp: 'cwp 11/23/2003 18:06'! menuButtonMouseDown: event event hand showTemporaryCursor: nil. self use: menuSelector orMakeModelSelectorFor: 'MenuButtonPressed:' in: [:sel | menuSelector := sel. model perform: sel with: event]! ! !OBScrollBar methodsFor: 'other events' stamp: 'cwp 11/23/2003 18:06'! mouseDownInSlider: event interval = 1.0 ifTrue: ["make the entire scrollable area visible if a full scrollbar is clicked on" self setValue: 0. self model hideOrShowScrollBar]. super mouseDownInSlider: event! ! !OBScrollBar methodsFor: 'access' stamp: 'cwp 11/23/2003 18:06'! pagingArea ^pagingArea! ! !OBScrollBar methodsFor: 'scroll timing' stamp: 'cwp 11/23/2003 18:07'! resetTimer timeOfMouseDown := Time millisecondClockValue. timeOfLastScroll := timeOfMouseDown - 1000 max: 0. nextPageDirection := nil. currentScrollDelay := nil! ! !OBScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 21:25'! roundedScrollbarLook "Rounded look currently only shows up in flop-out mode" ^false and: [self class alwaysShowFlatScrollbarForAlternativeLook not] ! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! scrollBarAction ^self valueOfProperty: #scrollBarAction! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! scrollBarAction: aSymbol self setProperty: #scrollBarAction toValue: aSymbol! ! !OBScrollBar methodsFor: 'access' stamp: 'cwp 11/23/2003 18:06'! scrollDelta ^ scrollDelta! ! !OBScrollBar methodsFor: 'access' stamp: 'cwp 11/23/2003 18:06'! scrollDelta: d1 pageDelta: d2 "Supply optional increments for better scrolling of, eg, text" scrollDelta := d1. pageDelta := d2.! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! scrollDown: count self setValue: (value + (scrollDelta * count) + 0.000001 min: 1.0)! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! scrollDownInit downButton borderInset. self resetTimer. self scrollBarAction: #doScrollDown. self startStepping.! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! scrollPageInit: evt self resetTimer. self setNextDirectionFromEvent: evt. self scrollBarAction: #doScrollByPage. self startStepping.! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! scrollUp: count self setValue: (value - (scrollDelta * count) - 0.000001 max: 0.0)! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! scrollUpInit upButton borderInset. self resetTimer. self scrollBarAction: #doScrollUp. self startStepping.! ! !OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'! setNextDirectionFromEvent: event nextPageDirection := bounds isWide ifTrue: [ event cursorPoint x >= slider center x ] ifFalse: [ event cursorPoint y >= slider center y ] ! ! !OBScrollBar methodsFor: 'model access' stamp: 'cwp 11/23/2003 18:06'! setValue: newValue "Using roundTo: instead of truncateTo: ensures that scrollUp will scroll the same distance as scrollDown." ^ super setValue: (newValue roundTo: scrollDelta)! ! !OBScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 16:26'! sliderColor: aColor "Change the color of the scrollbar to go with aColor." | buttonColor | super sliderColor: aColor. buttonColor := self thumbColor. upButton color: buttonColor. downButton color: buttonColor. slider color: buttonColor. self roundedScrollbarLook ifTrue: [self color: Color transparent. pagingArea color: aColor muchLighter. self borderStyle style == #simple ifTrue:[self borderColor: aColor darker darker] ifFalse:[self borderStyle baseColor: aColor]] ifFalse: [pagingArea color: (aColor alphaMixed: 0.3 with: Color white). self borderWidth: 0] ! ! !OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:06'! sliderExtent "The sliderExtent is now stored in the slider itself, not hardcoded as it is in the superclass." ^slider extent! ! !OBScrollBar methodsFor: 'access' stamp: 'cwp 11/23/2003 18:06'! sliderShadowColor ^ self roundedScrollbarLook ifTrue: [self sliderColor darker] ifFalse: [super sliderShadowColor] ! ! !OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:07'! sliderThickness ^ self roundedScrollbarLook ifTrue:[15] ifFalse:[super sliderThickness]! ! !OBScrollBar methodsFor: 'stepping and presenter' stamp: 'lr 3/4/2009 08:17'! step | action | action := self scrollBarAction. action isNil ifFalse: [ self perform: action ]! ! !OBScrollBar methodsFor: 'testing' stamp: 'cwp 11/23/2003 18:06'! stepTime ^ currentScrollDelay ifNil: [300]! ! !OBScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 16:27'! thumbColor "Problem: Part of the ScrollBar/Slider code uses 'slider' to mean the entire scrollbar/slider widget, and part of it uses 'slider' to mean only the draggable 'thumb'. This should be cleaned up so that 'thumb' is used instead of 'slider' where appropriate. For now, the meaning of thumbColor is clear, at least." ^self sliderColor alphaMixed: 0.7 with: (Color gray: 0.95).! ! !OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:07'! totalSliderArea | upperBoundsButton | upperBoundsButton := upButton. upButton bottom > upperBoundsButton bottom ifTrue: [upperBoundsButton := upButton]. ^ bounds isWide ifTrue: [upperBoundsButton bounds topRight corner: downButton bounds bottomLeft] ifFalse: [upperBoundsButton bounds bottomLeft corner: downButton bounds topRight]. ! ! !OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'! upArrow8Bit "convert to 8-bit and convert white to transparent to avoid gratuitous conversion every time we put one in an ImageMorph" ^UpArrow8Bit ifNil: [ UpArrow8Bit := (ColorForm mappingWhiteToTransparentFrom: UpArrow) asFormOfDepth: 8 ]! ! !OBScrollBar methodsFor: 'scroll timing' stamp: 'cwp 11/23/2003 18:07'! waitForDelay1: delay1 delay2: delay2 "Return true if an appropriate delay has passed since the last scroll operation. The delay decreases exponentially from delay1 to delay2." | now scrollDelay | timeOfLastScroll isNil ifTrue: [self resetTimer]. "Only needed for old instances" now := Time millisecondClockValue. (scrollDelay := currentScrollDelay) isNil ifTrue: [scrollDelay := delay1 "initial delay"]. currentScrollDelay := scrollDelay * 9 // 10 max: delay2. "decrease the delay" timeOfLastScroll := now. ^true! ! !OBScrollBar methodsFor: 'testing' stamp: 'cwp 11/23/2003 18:06'! wantsSteps ^self scrollBarAction notNil! ! Object subclass: #OBButtonModel instanceVariableNames: 'bar label' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !OBButtonModel commentStamp: 'cwp 3/5/2004 12:15' prior: 0! An OBButtonModel serves as a model for PluggableButtonMorphs used OBRadioButtonBar. OBRadioButtonBar cannot be a direct model for its PBMs, since it can contain a variable number of buttons. iVars: bar - the OBRadioButton bar to which this button belongs label - the label of the button! !OBButtonModel class methodsFor: 'as yet unclassified' stamp: 'cwp 8/29/2004 13:31'! offColor ^ Color lightGray twiceLighter! ! !OBButtonModel class methodsFor: 'as yet unclassified' stamp: 'cwp 8/29/2004 13:30'! onColor ^ Color lightGray lighter! ! !OBButtonModel class methodsFor: 'as yet unclassified' stamp: 'cwp 2/24/2004 18:35'! withLabel: aString inBar: aRadioButtonBar ^ self new label: aString; bar: aRadioButtonBar! ! !OBButtonModel methodsFor: 'accessing' stamp: 'cwp 2/24/2004 18:29'! bar: aRadioButtonBar bar := aRadioButtonBar! ! !OBButtonModel methodsFor: 'building' stamp: 'cwp 7/25/2007 23:55'! buildOn: aBuilder ^aBuilder button: self with: []! ! !OBButtonModel methodsFor: 'testing' stamp: 'cwp 11/27/2004 19:09'! isEnabled ^ bar isEnabled: self! ! !OBButtonModel methodsFor: 'callbacks' stamp: 'cwp 2/24/2004 18:42'! isSelected ^ bar isSelected: self! ! !OBButtonModel methodsFor: 'accessing' stamp: 'cwp 3/2/2004 21:46'! label ^ label! ! !OBButtonModel methodsFor: 'accessing' stamp: 'cwp 2/24/2004 18:29'! label: aString label := aString! ! !OBButtonModel methodsFor: 'callbacks' stamp: 'lr 2/17/2009 17:29'! labelMorph ^ StringMorph contents: label font: TextStyle defaultFont! ! !OBButtonModel methodsFor: 'callbacks' stamp: 'cwp 2/24/2004 19:30'! push bar push: self.! ! !OBButtonModel methodsFor: 'accessing' stamp: 'cwp 11/27/2004 00:50'! selectionChanged self changed: #isSelected. self changed: #labelMorph! ! Object subclass: #OBMorphicIcons instanceVariableNames: '' classVariableNames: 'IconLabels Icons Instance' poolDictionaries: '' category: 'OB-Morphic-Core'! !OBMorphicIcons class methodsFor: 'as yet unclassified' stamp: 'dr 9/4/2008 16:34'! default Instance ifNil: [Instance := self new]. ^Instance! ! !OBMorphicIcons class methodsFor: 'as yet unclassified' stamp: 'dr 9/4/2008 16:35'! iconActionNamed: aSymbol | selector | selector := (aSymbol, 'Action') asSymbol. ^(self default respondsTo: selector) ifTrue: [self default perform: selector] ifFalse: [nil]! ! !OBMorphicIcons class methodsFor: 'configuration' stamp: 'dr 9/4/2008 16:16'! iconHeight ^12! ! !OBMorphicIcons class methodsFor: 'as yet unclassified' stamp: 'dr 9/4/2008 16:35'! iconLabelNamed: aSymbol ^ IconLabels at: aSymbol ifAbsentPut: [self default perform: (aSymbol, 'Label') asSymbol]! ! !OBMorphicIcons class methodsFor: 'as yet unclassified' stamp: 'dr 9/4/2008 16:35'! iconNamed: aSymbol ^ Icons at: aSymbol ifAbsentPut: [self default perform: aSymbol]! ! !OBMorphicIcons class methodsFor: 'configuration' stamp: 'dr 9/4/2008 16:16'! iconWidth ^12! ! !OBMorphicIcons class methodsFor: 'as yet unclassified' stamp: 'lr 2/11/2009 10:08'! initialize Instance := nil. Icons := IdentityDictionary new. IconLabels := IdentityDictionary new.! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 8/2/2007 10:27'! arrowDown ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 185273099 185273099 185273099 185273099 185273099 185273099 185273098 168430090 168495883 185273098 151587081 168495883 185273098 151191561 168495883 185207306 151388169 168430091 185207049 151257353 151587339 185272841 328199 151653131 185273098 150997001 168495883 185273099 168364298 185273099 185273099 185207307 185273099 185273099 185273099 185273099) offset: 0@0) colorsFromArray: #(#(0.573 0.804 0.369) #(0.565 0.768 0.412) #(0.577 0.804 0.372) #(0.561 0.804 0.326) #(0.588 0.831 0.345) #(0.6 0.844 0.353) #(0.565 0.804 0.329) #(0.545 0.772 0.349) #(0.486 0.682 0.353) #(0.388 0.561 0.271) #(1.0 1.0 1.0) #( )))! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 2/11/2009 10:17'! arrowDownLabel ^ 'Method is overridden in subclasses'! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 8/2/2007 10:24'! arrowUp ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 185273099 185273099 185273099 185273099 185273099 185273099 185273099 185207307 185273099 185273099 168364298 185273099 185273098 150997001 168495883 185272841 328199 151653131 185207049 151257353 151587339 185207306 151388169 168430091 185273098 151191561 168495883 185273098 151587081 168495883 185273098 168430090 168495883 185273099 185273099 185273099) offset: 0@0) colorsFromArray: #(#(0.573 0.804 0.369) #(0.565 0.768 0.412) #(0.577 0.804 0.372) #(0.561 0.804 0.326) #(0.588 0.831 0.345) #(0.6 0.844 0.353) #(0.565 0.804 0.329) #(0.545 0.772 0.349) #(0.486 0.682 0.353) #(0.388 0.561 0.271) #(1.0 1.0 1.0) #( )))! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 8/2/2007 10:34'! arrowUpAndDown ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 185273099 185207307 185273099 185273099 167772170 185273099 185273098 262400 168495883 185272832 67699971 658187 185204736 524800 2571 185207306 459776 168430091 185207306 394240 168430091 185204736 524800 2571 185272832 67699971 658187 185273098 262400 168495883 185273099 167772170 185273099 185273099 185207307 185273099) offset: 0@0) colorsFromArray: #(#(0.388 0.561 0.271) #(0.486 0.682 0.353) #(0.565 0.768 0.412) #(0.545 0.772 0.349) #(0.573 0.804 0.369) #(0.577 0.804 0.372) #(0.561 0.804 0.326) #(0.565 0.804 0.329) #(0.588 0.831 0.345) #(0.6 0.844 0.353) #(1.0 1.0 1.0) #( )))! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 2/11/2009 10:17'! arrowUpAndDownLabel ^ 'Method overrides superclass method and is overridden in subclasses'! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 2/11/2009 10:17'! arrowUpLabel ^ 'Method overrides superclass method'! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 8/2/2007 10:34'! blank ^ Form extent: 12@12 depth: 8! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 2/11/2009 10:17'! blankLabel ^ ''! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 8/2/2007 19:32'! breakpoint ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 437918234 437918234 437918234 437654804 319885069 26 437590295 404100630 100859930 437524241 269290764 100860442 437327375 235736076 67305498 437261581 218893324 67305754 437130258 303174162 84082970 436931081 134678279 196890 437918234 437918234 196890 454761243 454761242 196890 454761243 454761242 196634 454761243 454761242 26) offset: 0@0) colorsFromArray: #(#(0.349 0.212 0.098) #(0.329 0.2 0.094) #(0.376 0.232 0.109) #(0.694 0.462 0.271) #(0.608 0.271 0.204) #(0.545 0.185 0.113) #(0.784 0.322 0.294) #(0.721 0.023 0.023) #(0.788 0.055 0.055) #(0.848 0.106 0.106) #(0.875 0.137 0.137) #(0.914 0.208 0.208) #(0.953 0.298 0.298) #(0.953 0.318 0.318) #(0.953 0.333 0.333) #(0.953 0.349 0.349) #(0.953 0.365 0.365) #(0.953 0.388 0.388) #(0.922 0.427 0.427) #(0.953 0.482 0.482) #(0.949 0.542 0.538) #(0.957 0.592 0.592) #(0.953 0.624 0.62) #(0.984 0.879 0.879) #(0.988 0.898 0.898) #(0.992 0.918 0.918) #(1.0 1.0 1.0) #( )))! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 2/11/2009 10:17'! breakpointLabel ^ 'Halt or breakpoint in method'! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 8/2/2007 19:32'! flag ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 437918234 437918234 437918234 436470535 101584139 387389210 436404481 17105924 303634202 436666638 218827016 35198490 437126412 185075720 1644314 437060363 168298504 1644570 436930320 269422351 370743322 437326099 320082453 387520538 437918234 437918234 387520538 454761243 454761242 387520538 454761243 454761242 387520282 454761243 454761242 387389210) offset: 0@0) colorsFromArray: #(#(0.22 0.396 0.585) #(0.898 0.945 0.996) #(0.228 0.498 0.761) #(0.608 0.796 0.98) #(0.635 0.804 0.98) #(0.655 0.819 0.98) #(0.47 0.729 0.973) #(0.542 0.768 0.977) #(0.251 0.631 0.961) #(0.267 0.639 0.961) #(0.275 0.643 0.961) #(0.286 0.647 0.961) #(0.302 0.659 0.965) #(0.326 0.667 0.965) #(0.353 0.678 0.965) #(0.396 0.714 0.965) #(0.419 0.729 0.969) #(0.239 0.686 0.93) #(0.243 0.624 0.772) #(0.236 0.682 0.851) #(0.228 0.667 0.788) #(0.224 0.616 0.671) #(0.384 0.228 0.082) #(0.349 0.212 0.098) #(0.329 0.2 0.094) #(0.694 0.462 0.271) #(1.0 1.0 1.0) #( )))! ! !OBMorphicIcons methodsFor: 'icons' stamp: 'lr 2/11/2009 10:18'! flagLabel ^ 'Method is flagged'! ! !OBClassNode methodsFor: '*ob-morphic' stamp: 'dr 8/21/2008 15:13'! shouldBeStyledBy: aShoutMorph super shouldBeStyledBy: aShoutMorph. ^true! ! !BorderedSubpaneDividerMorph methodsFor: '*ob-morphic' stamp: 'cwp 7/23/2007 02:09'! styleWith: aBuilder self vResizing = #spaceFill ifTrue: [aBuilder styleVerticalDivider: self] ifFalse: [aBuilder styleHorizontalDivider: self]! ! !OBMethodNode methodsFor: '*ob-morphic' stamp: 'dr 8/21/2008 15:13'! shouldBeStyledBy: aShoutMorph super shouldBeStyledBy: aShoutMorph. (self theClass isBehavior or: [self theClass isTrait]) ifTrue: [aShoutMorph classOrMetaClass: self theClass]. ^true! ! OBBuilder subclass: #OBMorphBuilder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Core'! !OBMorphBuilder class methodsFor: 'instance-creation' stamp: 'lr 6/20/2007 09:36'! open: aModel ^ (self build: aModel) openInWorld! ! !OBMorphBuilder methodsFor: 'building' stamp: 'cwp 7/25/2007 23:55'! button: aButtonModel with: aBlock | morph | morph := PluggableButtonMorph on: aButtonModel getState: #isSelected action: #push label: #labelMorph. morph hResizing: #spaceFill; vResizing: #spaceFill; styleWith: OBMorphBuilder new. ^self current: morph do: aBlock! ! !OBMorphBuilder methodsFor: 'building' stamp: 'lr 2/17/2009 17:26'! fixedButtonBar: aPanel with: aBlock | morph | morph := OBButtonBar on: aPanel. morph height: Preferences standardButtonFont height * 2.5; layoutPolicy: TableLayout new; vResizing: #rigid; hResizing: #spaceFill; listDirection: #leftToRight; rubberBandCells: true; borderWidth: 0. current addMorphBack: morph. self current: morph do: aBlock! ! !OBMorphBuilder methodsFor: 'building' stamp: 'cwp 12/9/2007 11:58'! horizontalGroupWith: aBlock | morph | morph := OBGroupingMorph new. morph layoutPolicy: TableLayout new. morph listDirection: #leftToRight. current addMorph: morph frame: (0 @ 0 extent: 1 @ 1). self current: morph do: aBlock. morph addBorders! ! !OBMorphBuilder methodsFor: 'private' stamp: 'lr 2/12/2009 10:36'! layoutPanels | panes | panes := current submorphs select: [ :ea | ea class == OBGroupingMorph ]. (self shouldUseSpecialLayoutFor: panes) ifTrue: [ panes first layoutFrame bottomFraction: 0.4. panes second layoutFrame topFraction: 0.4 ] ifFalse: [ panes keysAndValuesDo: [ :index :morph | morph layoutFrame topFraction: (index - 1) / panes size; bottomFraction: index / panes size ] ]. panes do: [ :ea | ea on: #mouseEnter send: #paneTransition: to: current. ea on: #mouseLeave send: #paneTransition: to: current ]. self style39 ifTrue: [ current addPaneSplitters ]! ! !OBMorphBuilder methodsFor: 'private' stamp: 'cwp 7/5/2007 23:31'! listMorphForColumn: aColumn ^ (OBPluggableListMorph on: aColumn list: #list selected: #selection changeSelected: #selection: menu: #menu: keystroke: #keystroke:from:) getListElementSelector: #listAt:; getListSizeSelector: #listSize; dragEnabled: aColumn dragEnabled; dropEnabled: aColumn dropEnabled; borderWidth: 0; autoDeselect: false; yourself! ! !OBMorphBuilder methodsFor: 'private' stamp: 'dr 10/30/2008 16:22'! mercuryMorphFor: aMercuryPanel ^ (OBPluggableTextMorph on: aMercuryPanel text: #text accept: #accept:notifying: readSelection: #selection menu: #menu:shifted:) font: Preferences standardCodeFont; hideScrollBarsIndefinitely; acceptOnCR: true; height: Preferences standardCodeFont height * 1.2; borderWidth: 0; vResizing: #rigid; hResizing: #spaceFill; yourself.! ! !OBMorphBuilder methodsFor: 'building' stamp: 'lr 3/4/2009 08:17'! pane: aColumn with: aBlock | pane | pane := OBPane new. pane model: aColumn; hResizing: #spaceFill; vResizing: #spaceFill; clipSubmorphs: true; color: Color transparent; cellInset: 0; borderWidth: 0; layoutPolicy: ProportionalLayout new; addList: (self listMorphForColumn: aColumn). current isNil ifFalse: [ current pushPane: pane ]. ^ self current: pane do: aBlock! ! !OBMorphBuilder methodsFor: 'building' stamp: 'lr 3/4/2009 08:17'! radioButtonBar: aSwitch with: aBlock | morph | ^ aSwitch isActive ifTrue: [ morph := OBRadioButtonBar on: aSwitch list: #list selected: #selection changeSelected: #selection:. current isNil ifFalse: [ current addButton: morph ]. morph ]! ! !OBMorphBuilder methodsFor: 'building' stamp: 'lr 3/4/2009 08:17'! scroller: aColumnPanel with: aBlock | morph | morph := (OBPaneScroller withModel: aColumnPanel) name: 'scroller'; vResizing: #spaceFill; hResizing: #spaceFill; yourself. current isNil ifFalse: [ current addMorphBack: morph ]. ^ self current: morph do: aBlock! ! !OBMorphBuilder methodsFor: 'private' stamp: 'lr 2/12/2009 10:35'! shouldUseSpecialLayoutFor: panes ^ panes size = 2 and: [ panes first listDirection = #topToBottom and: [ panes second listDirection = #topToBottom and: [ panes first lastSubmorph class = OBPaneScroller and: [ panes last lastSubmorph class = OBPluggableTextMorph ] ] ] ]! ! !OBMorphBuilder methodsFor: 'style' stamp: 'cwp 7/23/2007 02:04'! style39 ^ Smalltalk hasClassNamed: #AbstractResizerMorph! ! !OBMorphBuilder methodsFor: 'style' stamp: 'cwp 7/21/2007 22:26'! styleButton: aButton self style39 ifFalse: [aButton borderWidth: 2; borderRaised]! ! !OBMorphBuilder methodsFor: 'style' stamp: 'cwp 7/21/2007 22:26'! styleButtonBar: aBar self style39 ifFalse: [aBar borderWidth: 0] ifTrue: [aBar color: Color transparent; borderWidth: 0; layoutInset: 2; cellInset: 2] ! ! !OBMorphBuilder methodsFor: 'style' stamp: 'cwp 7/23/2007 02:08'! styleHorizontalDivider: divider self style39 ifTrue: [divider height: 3] ifFalse: [divider borderWidth: 2; borderInset]! ! !OBMorphBuilder methodsFor: 'style' stamp: 'cwp 7/23/2007 02:08'! styleVerticalDivider: divider self style39 ifTrue: [divider height: 3] ifFalse: [divider borderWidth: 2; borderRaised]! ! !OBMorphBuilder methodsFor: 'building' stamp: 'lr 3/4/2009 08:17'! textarea: aDefinitionPanel with: aBlock "see CodeHolder>>buildMorphicCodePaneWith:" | morph shoutInstalled morphClass | shoutInstalled := (Smalltalk classNamed: #SHTextStylerST80) notNil. morphClass := shoutInstalled ifTrue: [ OBPluggableTextMorphWithShout ] ifFalse: [ OBPluggableTextMorph ]. morph := morphClass on: aDefinitionPanel text: #text accept: #accept:notifying: readSelection: #selection menu: #menu:shifted:. morph font: Preferences standardCodeFont; borderWidth: 0; vResizing: #spaceFill; hResizing: #spaceFill. current isNil ifFalse: [ current addMorphBack: morph ]. ^ self current: morph do: aBlock! ! !OBMorphBuilder methodsFor: 'building' stamp: 'lr 3/4/2009 08:17'! textfield: aMercuryPanel with: aBlock | morph divider | morph := self mercuryMorphFor: aMercuryPanel. morph color: Color white. current isNil ifFalse: [ current addMorphBack: morph. self current: morph do: aBlock. divider := BorderedSubpaneDividerMorph horizontal color: aMercuryPanel browser defaultBackgroundColor duller; styleWith: OBMorphBuilder new. current addMorphBack: divider ]. ^ morph! ! !OBMorphBuilder methodsFor: 'building' stamp: 'cwp 12/9/2007 10:57'! verticalGroupWith: aBlock | morph | morph := OBGroupingMorph new. morph layoutPolicy: TableLayout new. current addMorph: morph frame: (0 @ 0 extent: 1 @ 1). self current: morph do: aBlock! ! !OBMorphBuilder methodsFor: 'building' stamp: 'lr 2/17/2009 17:30'! window: aBrowser with: aBlock | window | window := SystemWindow labelled: aBrowser labelString. window model: aBrowser. ^self current: window do: [aBlock value. self layoutPanels]! ! PluggableListMorph subclass: #OBPluggableListMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !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: 'model access' stamp: 'dr 10/31/2008 16:08'! backgroundColorAt: anInteger ^model backgroundColorAt: anInteger! ! !OBPluggableListMorph methodsFor: 'model access' stamp: 'cwp 7/24/2007 00:12'! iconAt: index ^ model iconAt: index! ! !OBPluggableListMorph methodsFor: 'list management' stamp: 'dr 12/2/2008 15:40'! listMorph listMorph ifNil: [ "crate this lazily, in case the morph is legacy" listMorph := self listMorphClass new. listMorph listSource: self. listMorph adjustHeight. listMorph width: self scroller width. listMorph color: self textColor ]. listMorph owner ~~ self scroller ifTrue: [ "list morph needs to be installed. Again, it's done this way to accomodate legacy PluggableListMorphs" self scroller removeAllMorphs. self scroller addMorph: listMorph ]. ^listMorph! ! !OBPluggableListMorph methodsFor: 'list management' stamp: 'dr 4/24/2007 16:39'! listMorphClass ^OBLazyListMorph! ! !OBPluggableListMorph methodsFor: 'as yet unclassified' stamp: 'lr 2/12/2009 10:35'! mouseUp: event "Override a change in PLM that breaks OmniBrowser. This version of the method is from Squeak 3.7 and was originally stamped: 'ls 6/22/2001 22:49'" | row | row := self rowAtLocation: event position. "aMorph ifNotNil: [aMorph highlightForMouseDown: false]." model okToChange ifFalse: [ ^ self ]. (autoDeselect == false and: [ row == 0 ]) ifTrue: [ ^ self ]. "work-around the no-mans-land bug" "No change if model is locked" ((autoDeselect isNil or: [ autoDeselect ]) and: [ row == self selectionIndex ]) ifTrue: [ self changeModelSelection: 0 ] ifFalse: [ self changeModelSelection: row ]. Cursor normal show! ! !OBClassCategoryNode methodsFor: '*ob-morphic' stamp: 'dr 8/21/2008 15:14'! shouldBeStyledBy: aShoutMorph super shouldBeStyledBy: aShoutMorph. ^true! ! !OBNode methodsFor: '*ob-morphic' stamp: 'cwp 3/2/2004 21:28'! acceptDroppedNode: aNode ^ aNode perform: self dropSelector with: self ! ! !OBNode methodsFor: '*ob-morphic' stamp: 'avi 2/20/2004 14:00'! asDraggableMorph ^(StringMorph contents: self name) color: Color white; yourself! ! !OBNode methodsFor: '*ob-morphic' stamp: 'cwp 3/2/2004 21:29'! dropSelector "Override in subclasses" ^ #dropOnNode: ! ! !OBNode methodsFor: '*ob-morphic' stamp: 'dc 9/4/2008 17:40'! shouldBeStyledBy: aShoutMorph aShoutMorph classOrMetaClass: nil. ^false! ! !OBNode methodsFor: '*ob-morphic' stamp: 'cwp 3/2/2004 21:28'! wantsDroppedNode: aNode ^ aNode respondsTo: self dropSelector! ! !OBMethodVersionNode methodsFor: '*ob-morphic' stamp: 'dr 12/16/2008 11:20'! shouldBeStyledBy: aShoutMorph aShoutMorph classOrMetaClass: nil. ^false! ! LazyListMorph subclass: #OBLazyListMorph instanceVariableNames: 'handPoint balloonShown' classVariableNames: '' poolDictionaries: '' category: 'OB-Morphic-Morphs'! !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: 'dr 2/2/2009 15:05'! adjustHeight self height: self listItemHeight * (listItems size max: 1) . ! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'dr 9/1/2008 17:16'! balloonText ^'activate'! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'lr 3/4/2009 08:18'! boundsForBalloon ^ handPoint isNil ifFalse: [ Rectangle origin: (handPoint x + 3) @ (handPoint y - 3) extent: 1 @ 1 ] ifTrue: [ Rectangle origin: 1 @ 1 extent: 1 @ 1 ]! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'lr 3/4/2009 09:38'! colorForRow: row | item clr | ^ (selectedRow notNil and: [ row = selectedRow ]) ifTrue: [ (clr := listSource backgroundColorAt: row) isNil ifFalse: [ clr alphaMixed: 0.1 with: Color blue ] ifTrue: [ Color red ] ] ifFalse: [ item := self getListItem: row. item isText ifTrue: [ item colorAt: 1 ] ifFalse: [ self color ] ]! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'lr 3/4/2009 09:40'! display: item atRow: row on: canvas "display the given item at row row" | drawBounds top icon aColor name | drawBounds := self drawBoundsForRow: row. drawBounds := drawBounds intersect: self bounds. (aColor := listSource backgroundColorAt: row) isNil ifFalse: [ canvas fillRectangle: drawBounds color: aColor ]. (name := listSource iconAt: row) isNil ifFalse: [ icon := OBMorphicIcons iconNamed: name. top := drawBounds top + ((drawBounds height - icon height) // 2). canvas translucentImage: icon at: drawBounds left @ top. drawBounds := drawBounds left: drawBounds left + icon width + 2 ]. item isText ifTrue: [ canvas drawString: item in: drawBounds font: (font emphasized: (item emphasisAt: 1)) color: (self colorForRow: row) ] ifFalse: [ canvas drawString: item in: drawBounds font: font color: (self colorForRow: row) ]! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'dr 12/2/2008 11:02'! drawBoundsForRow: row "calculate the bounds that row should be drawn at. This might be outside our bounds!!" | topLeft drawBounds | topLeft := self topLeft x @ (self topLeft y + ((row - 1) * (listSource listItemHeight))). drawBounds := topLeft extent: self width @ listSource listItemHeight . ^drawBounds! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'lr 3/4/2009 09:40'! handleMouseDown: anEvent | eventPosition row name action | anEvent wasHandled ifTrue: [ ^ self ]. eventPosition := anEvent position. row := self rowAtLocation: eventPosition x @ eventPosition y. (row >= 1 and: [ eventPosition x < OBMorphicIcons iconWidth ]) ifTrue: [ eventPosition x < OBMorphicIcons iconWidth ifTrue: [ (name := listSource iconAt: row) isNil ifFalse: [ anEvent wasHandled: true. (action := OBMorphicIcons iconActionNamed: name) ifFalse: [ listSource model okToChange ifTrue: [ action value: (listSource nodeAt: row) value: listSource model ] ] ] ] ]! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'lr 2/12/2009 10:36'! handleMouseMove: anEvent | iconArea newOrigin eventPosition | super handleMouseMove: anEvent. eventPosition := anEvent position. anEvent wasHandled ifTrue: [ ^ self ]. handPoint ifNil: [ ^ self ]. (balloonShown notNil and: [ balloonShown == false ]) ifTrue: [ ^ self ]. iconArea := self boundsForBalloon. newOrigin := (iconArea origin x - self positionInWorld x - 6) @ (iconArea origin y + self positionInWorld y abs). iconArea setOrigin: newOrigin corner: (newOrigin x + 12) @ (newOrigin y + 12). (iconArea containsPoint: eventPosition) ifTrue: [ ^ self ]. anEvent hand removePendingBalloonFor: self. anEvent hand triggerBalloonFor: self after: 2 * self balloonHelpDelayTime. balloonShown := false! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'dr 9/4/2008 16:10'! handlesMouseDown: anEvent ^true! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'dr 9/1/2008 11:59'! handlesMouseOver: anEvent ^true! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'lr 3/4/2009 08:18'! listItemHeight ^ font height max: (listSource isNil ifFalse: [ listSource listItemHeight ] ifTrue: [ 0 ])! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'alain.plantec 1/29/2009 21:31'! rectForRow: index "return a rectangle containing the row at index" | top | top := self top + (index - 1 * self listItemHeight). ^ (self left @ top) extent: self width @ self listItemHeight ! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'alain.plantec 1/29/2009 21:31'! rowAtLocation: aPoint "return the number of the row at aPoint" | y | y := aPoint y. y < self top ifTrue: [ ^ 1 ]. ^((y - self top // (self listItemHeight)) + 1) min: listItems size max: 0! ! !OBLazyListMorph methodsFor: 'drawing' stamp: 'lr 3/4/2009 09:39'! showBalloon: msgString hand: aHand "find element at hand to determine icon and finally tooltip" | row position name | handPoint := aHand cursorPoint. position := self positionInWorld. row := self rowAtLocation: aHand cursorPoint x @ (handPoint y - position y). handPoint x - self positionInWorld x < 20 ifTrue: [ (name := listSource iconAt: row) isNil ifFalse: [ | label | label := OBMorphicIcons iconLabelNamed: name. label ifNotEmpty: [ balloonShown := true. super showBalloon: label hand: aHand. aHand triggerBalloonFor: self after: self balloonHelpDelayTime ] ] ]! ! !MenuMorph methodsFor: '*ob-morphic' stamp: 'cwp 6/8/2007 20:45'! add: label target: anObject selector: aSelector enabled: aBoolean icon: aSymbol self add: label target: anObject selector: aSelector. self lastItem isEnabled: aBoolean. Preferences menuWithIcons ifTrue: [self lastItem icon: (self iconNamed: aSymbol)]! ! !MenuMorph methodsFor: '*ob-morphic' stamp: 'cwp 9/30/2007 18:34'! 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! ! !MenuMorph methodsFor: '*ob-morphic' stamp: 'cwp 6/8/2007 20:41'! iconNamed: aSymbol | sel | aSymbol ifNil: [^ MenuIcons blankIcon]. sel := (MenuIcons respondsTo: aSymbol) ifTrue: [aSymbol] ifFalse: [('small', aSymbol capitalized) asSymbol]. ^ MenuIcons perform: sel! ! !OBMethodCategoryNode methodsFor: '*ob-morphic' stamp: 'dr 8/21/2008 15:13'! shouldBeStyledBy: aShoutMorph super shouldBeStyledBy: aShoutMorph. (self theClass isBehavior or: [self theClass isTrait]) ifTrue: [aShoutMorph classOrMetaClass: self theClass]. ^true! ! !PluggableButtonMorph methodsFor: '*ob-morphic' stamp: 'cwp 7/21/2007 21:18'! styleWith: aBuilder aBuilder styleButton: self! ! !OBDefinitionPanel methodsFor: '*ob-morphic' stamp: 'dc 8/24/2007 12:34'! addItem: classAndMethod "Used by the system when the user clicks on a link in a class comment. For example see class comment of SystemProgressMorph and click on displayProgressAt:from:to:during:." |tokens class methodNode| tokens := classAndMethod findTokens: Character space. tokens size ~= 2 ifTrue: [^ self]. class := Smalltalk classNamed: tokens first. class ifNil: [^ self]. methodNode := OBMethodNode on: tokens second inClass: class. methodNode browse! ! !OBDefinitionPanel methodsFor: '*ob-morphic' stamp: 'lr 3/4/2009 11:23'! shoutAboutToStyle: aPluggableShoutMorph | node | ^ (node := browser currentNode) isNil ifFalse: [ node shouldBeStyledBy: aPluggableShoutMorph ] ifTrue: [ false ]! ! OBScrollBar initialize! OBMorphicIcons initialize!