# HG changeset patch # User Claus Gittinger # Date 1265191359 -3600 # Node ID 0c6f4a677a0826d1d993f9b9da2006ea79794eca # Parent 5bee95e91ffd8f15bcb7177a52f5b1b56e91b0f2 removed via FileBrowser diff -r 5bee95e91ffd -r 0c6f4a677a08 Tools__ViewTreeModel.st --- a/Tools__ViewTreeModel.st Wed Feb 03 11:02:07 2010 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1338 +0,0 @@ -"{ Package: 'stx:libtool2' }" - -"{ NameSpace: Tools }" - -ValueModel subclass:#ViewTreeModel - instanceVariableNames:'lockSema selectedSuperItems selection hiddenLevel listOfItems - inputEventAction mappedViewAction beforeSelectionChangedAction - icons timedUpdateTask selectOnClickHolder testModeChannel - hasTargetWidgetChannel' - classVariableNames:'' - poolDictionaries:'' - category:'A-Views-Support' -! - -HierarchicalList subclass:#ItemList - instanceVariableNames:'treeModel eventHook eventHookInitialized showWidgetNames' - classVariableNames:'' - poolDictionaries:'' - privateIn:ViewTreeModel -! - -!ViewTreeModel class methodsFor:'documentation'! - -documentation -" - Instances of ViewTreeModel can be used as model on a View and all - it contained subviews for a HierarchicalListView. - The model keeps two values, the hierarchical representation of the views - and subviews (ViewTreeItems) and the selection, a list of selected ViewTreeItems's. - It shows the selected items highlighted. - - - [Instance variables:] - lockSema lock selection notifications and redraws - - testModeChannel true, than running in test mode. - - hasTargetWidgetChannel true, than any target view is grapped - - selection selected items or nil - - hiddenLevel internal use; redrawing the selection - only is done if the counter is 0. - - listOfItems hiearchical list build from existing items. - - selectedSuperItems list of selected super items; items selected - but not contained in another selected item. - - inputEventAction called for each InputEvent - - mappedViewAction called for a new mapped view which - can not be found in the current item list. - - beforeSelectionChangedAction called before the selection changed - - [author:] - Claus Atzkern - - [see also:] - ViewTreeItem -" -! - -examples -" - example 1: pick any window and show views and contained views - [exBegin] - |top sel model panel| - - model := ViewTreeModel new. - top := StandardSystemView new; extent:440@400. - sel := ScrollableView for:HierarchicalListView miniScroller:true origin:0.0@0.0 corner:1.0@1.0 in:top. - sel bottomInset:24. - - panel := HorizontalPanelView origin:0.0@1.0 corner:1.0@1.0 in:top. - panel topInset:-24. - panel horizontalLayout:#fitSpace. - - Button label:'Exit' action:[model rootItem:nil. top destroy] in:panel. - Button label:'Pick Views' action:[ |win| - ( (win := Screen current viewFromUser) notNil - and:[(win := win topView) ~~ Screen current rootView - and:[win ~~ top]] - ) ifTrue:[ - model rootItem:(ViewTreeItem buildViewsFrom:win) - ] ifFalse:[ - model rootItem:nil - ] - ] in:panel. - - sel multipleSelectOk:true. - sel list:model listOfItems. - sel model:model. - sel useIndex:false. - - sel doubleClickAction:[:i| |el| - el := model listOfItems at:i. - el spec notNil ifTrue:[ el spec inspect ] ifFalse:[ el widget inspect ] - ]. - sel indicatorAction:[:i| (model listOfItems at:i) toggleExpand ]. - - model inputEventAction:[:anEvent| |item| - anEvent isButtonEvent ifTrue:[ - anEvent isButtonPressEvent ifTrue:[ - model selectedItem:(model listOfItems detectItemRespondsToView:(anEvent view)). - ] ifFalse:[ - anEvent type == #'buttonMultiPress:x:y:' ifTrue:[ - (item := model selectedItem) notNil ifTrue:[item widget inspect] - ] - ] - ] - ]. - - top openAndWait. - [[top shown] whileTrue:[Delay waitForSeconds:0.5]. model rootItem:nil] forkAt:8 - - [exEnd] -" -! ! - -!ViewTreeModel methodsFor:'accessing'! - -application:anApplication - listOfItems application:anApplication. -! - -rootItem - "get the rootItem the event viewer is established on - " - ^ listOfItems root -! - -rootItem:anItem - "set the rootItem the event viewer is established on - " - |expanded| - - timedUpdateTask := nil. - self deselect. - - lockSema critical:[ - anItem notNil ifTrue:[ expanded := anItem isExpanded ] - ifFalse:[ expanded := false ]. - - self value:nil. - listOfItems root:anItem. - - anItem notNil ifTrue:[ - timedUpdateTask := Process for:[ self timedUpdateTaskCycle ] priority:8. - timedUpdateTask name:'Update'. - timedUpdateTask resume. - ]. - ]. - - (expanded and:[anItem notNil]) ifTrue:[ - anItem expand - ]. - ^ anItem -! - -rootView - "get the top widget the event viewer is established on, a View - " - ^ listOfItems rootView -! ! - -!ViewTreeModel methodsFor:'accessing actions'! - -beforeSelectionChangedAction - "none argument action which is called before - the selection changed - " - ^ beforeSelectionChangedAction -! - -beforeSelectionChangedAction:aNoneArgBlock - "none argument action which is called before - the selection changed - " - beforeSelectionChangedAction := aNoneArgBlock. -! - -inputEventAction - "called for each input event; the argument to the action is the WindowEvent - " - ^ inputEventAction -! - -inputEventAction:aOneArgActionTheEvent - "called for each input event; the argument to the action is the WindowEvent - " - inputEventAction := aOneArgActionTheEvent. -! - -mappedViewAction - "called for a new mapped view which can not be found - in the current item list - " - ^ mappedViewAction -! - -mappedViewAction:aOneArgBlockTheMappedView - "called for a new mapped view which can not be found - in the current item list - " - mappedViewAction := aOneArgBlockTheMappedView -! ! - -!ViewTreeModel methodsFor:'accessing look'! - -iconAt:aKey ifNonePut:aNoneArgBlock - |icon view| - - icon := icons at:aKey ifAbsent:nil. - icon notNil ifTrue:[^ icon]. - - icon := aNoneArgBlock value. - icon isNil ifTrue:[^ nil]. - - view := self rootView. - view isNil ifTrue:[^ icon]. - - icon := icon copy onDevice:(view device). - icon isImage ifTrue:[ - icon clearMaskedPixels. - ]. - icons at:aKey put:icon. - ^ icon -! ! - -!ViewTreeModel methodsFor:'accessing visibility'! - -signalHiddenLevel - "show the selection if signaled; increments hiddenLevel - see: #waitHiddenLevel - " - (hiddenLevel := hiddenLevel - 1) < 1 ifTrue:[ - hiddenLevel := 0. - self invalidateSelection. - ]. -! - -waitHiddenLevel - "hide the selection until signaled; increments hiddenLevel - see: #signalHiddenLevel - " - self redrawUnselected:selection andLock:true -! - -withSelectionHiddenDo:aNoneArgumentBlock - "apply block with selection hidden - " - - [ self waitHiddenLevel. - - aNoneArgumentBlock value - - ] valueNowOrOnUnwindDo:[ - self signalHiddenLevel. - ]. -! ! - -!ViewTreeModel methodsFor:'aspects'! - -hasTargetWidgetChannel - "answer the channel which is set to true if a target widget exists" - - ^ hasTargetWidgetChannel -! - -listOfItems - "hiearchical list build from existing items" - - ^ listOfItems -! - -selectOnClickHolder - "boolean holder, which indicates whether the selection will change on click - " - ^ selectOnClickHolder -! - -testModeChannel - "answer a boolean channel which describes the behaviour how to process - events on the target view. - - false: all input events are eaten and the selection is shown on the target view. - true: no input events are eaten and no selection is shown on the target view." - - ^ testModeChannel -! ! - -!ViewTreeModel methodsFor:'change & update'! - -targetWidgetChanged - hasTargetWidgetChannel value:(self rootItem notNil). -! - -timedUpdateTaskCycle - |view myTaskId| - - myTaskId := timedUpdateTask. - - listOfItems root notNil ifTrue:[ - view := listOfItems root widget. - ]. - - [ view notNil ] whileTrue:[ - Delay waitForSeconds:0.5. - - (myTaskId == timedUpdateTask and:[view id notNil]) ifFalse:[ - view := nil. - ] ifTrue:[ - (view sensor hasUserEvent:#updateChildren for:self) ifFalse:[ - view sensor pushUserEvent:#updateChildren for:self. - ]. - ]. - ]. - timedUpdateTask == myTaskId ifTrue:[ - timedUpdateTask := nil. - listOfItems root:nil. - ]. -! - -update:something with:someArgument from:aModel - - aModel == testModeChannel ifTrue:[ - (hiddenLevel == 0 and:[selection size > 0]) ifTrue:[ - testModeChannel value ifTrue:[ - self redrawUnselected:selection andLock:false checkTestMode:false. - ] ifFalse:[ - self invalidateSelection. - ]. - ]. - ^ self - ]. - super update:something with:someArgument from:aModel. -! - -updateChildren - |rootItem| - - rootItem := listOfItems root. - rootItem isNil ifTrue:[^ self]. - - rootItem exists ifFalse:[ - listOfItems root:nil. - ] ifTrue:[ - rootItem updateChildren. - ]. -! ! - -!ViewTreeModel methodsFor:'event processing'! - -processEvent:anEvent - "catch and process all WindowEvents for the rootComponent and its contained - widgets; redraw selection in case of damage .... - " - |evView item rootView testMode| - - evView := anEvent view. - evView isNil ifTrue:[ - (anEvent isMessageSendEvent and:[anEvent receiver == self]) ifFalse:[ - ^ false - ]. - anEvent value. - ^ true. - ]. - rootView := listOfItems rootView. - rootView isNil ifTrue:[ ^ false ]. - - anEvent isConfigureEvent ifTrue:[ - hiddenLevel == 0 ifTrue:[ - self redrawUnselected:selection andLock:false. - ]. - ^ false - ]. - - "/ check whether view is contained within the rootView - (evView == rootView or:[evView isComponentOf:rootView]) ifFalse:[ - ^ false - ]. - - anEvent isInputEvent ifFalse:[ - anEvent isDamage ifTrue:[ - hiddenLevel == 0 ifTrue:[self invalidateSelection]. - ^ false - ]. - - anEvent isMapEvent ifTrue:[ - mappedViewAction notNil ifTrue:[ - item := listOfItems recursiveDetect:[:el| el widget == evView]. - item isNil ifTrue:[ mappedViewAction value:evView ] - ]. - ^ false - ]. - - anEvent type == #terminate ifTrue:[ - item := listOfItems recursiveDetect:[:el| el widget == evView]. - item notNil ifTrue:[ self processTerminateForItem:item ]. - ^ false - ]. - ^ false - ]. - testMode := testModeChannel value. - - anEvent isFocusEvent ifTrue:[ - evView == rootView ifTrue:[ - self invalidateSelection - ]. - ^ testMode not. - ]. - anEvent isPointerEnterLeaveEvent ifTrue:[ ^ testMode not ]. - - testMode ifFalse:[ - inputEventAction notNil ifTrue:[ inputEventAction value:anEvent ]. - ] ifTrue:[ - anEvent isButtonPressEvent ifTrue:[ - selectOnClickHolder value ifTrue:[ - self selectItem:(listOfItems detectItemRespondsToView:evView). - ]. - ] - ]. - - (hiddenLevel ~~ 0 and:[anEvent isButtonReleaseEvent]) ifTrue:[ - hiddenLevel := 1. - self signalHiddenLevel. - ]. - - ^ testMode not -! - -processTerminateForItem:anItem - "received terminate for an item - " - anItem remove. -! ! - -!ViewTreeModel methodsFor:'initialization'! - -initialize - "setup the default attributes - " - super initialize. - - hiddenLevel := 0. - lockSema := RecursionLock new. - listOfItems := ItemList new on:self. - selectedSuperItems := #(). - icons := IdentityDictionary new. - - hasTargetWidgetChannel := false asValue. - selectOnClickHolder := true asValue. - - testModeChannel := false asValue. - testModeChannel addDependent:self. -! ! - -!ViewTreeModel methodsFor:'private selection'! - -invalidateSelection - "invalidate the current selection - " - |topView| - - testModeChannel value ifTrue:[ ^ self ]. "/ test whether running testMode - - ( hiddenLevel == 0 - and:[selection notNil - and:[(topView := listOfItems rootView) notNil - and:[topView shown]]] - ) ifTrue:[ - topView sensor pushUserEvent:#redrawSelection for:self withArguments:#() - ] -! - -recursiveRepair:theDamages startIn:aView relativeTo:aRootView - "repair all views and contained views, which intersects the damage. - !!!! all damages repaired are removed from the list of damages !!!! - " - |color relOrg damage subViews repaired - bwWidth "{ Class:SmallInteger }" - x "{ Class:SmallInteger }" - y "{ Class:SmallInteger }" - w "{ Class:SmallInteger }" - h "{ Class:SmallInteger }" - relOrgX "{ Class:SmallInteger }" - relOrgY "{ Class:SmallInteger }" - width "{ Class:SmallInteger }" - height "{ Class:SmallInteger }" - size "{ Class:SmallInteger }" - | - (aView shown and:[theDamages notEmpty]) ifFalse:[ ^ self ]. - - subViews := aView subViews. - - subViews size ~~ 0 ifTrue:[ - subViews reverseDo:[:v| self recursiveRepair:theDamages startIn:v relativeTo:aRootView ]. - theDamages isEmpty ifTrue:[ ^ self ]. - ]. - - relOrg := aView originRelativeTo:aRootView. - bwWidth := aView borderWidth. - size := theDamages size. - - "/ compute relative origin starting from border left@top - relOrgX := relOrg x - bwWidth. - relOrgY := relOrg y - bwWidth. - width := aView width + bwWidth + bwWidth. - height := aView height + bwWidth + bwWidth. - - size to:1 by:-1 do:[:anIndex| - repaired := damage := theDamages at:anIndex. - - "/ compute the rectangle into the view - y := damage top - relOrgY. - x := damage left - relOrgX. - w := damage width. - h := damage height. - - x < 0 ifTrue:[ w := w + x. x := 0. repaired := nil ]. - y < 0 ifTrue:[ h := h + y. y := 0. repaired := nil ]. - x + w > width ifTrue:[ w := width - x. repaired := nil ]. - y + h > height ifTrue:[ h := height - y. repaired := nil ]. - - (w > 0 and:[h > 0]) ifTrue:[ - bwWidth ~~ 0 ifTrue:[ - color isNil ifTrue:[ - "/ must force redraw of border - color := aView borderColor. - aView borderColor:(Color colorId:1). - aView borderColor:color. - ]. - w := w - bwWidth. - h := h - bwWidth. - - (x := x - bwWidth) < 0 ifTrue:[w := w + x. x := 0]. - (y := y - bwWidth) < 0 ifTrue:[h := h + y. y := 0]. - - h > 0 ifFalse:[w := 0]. "/ later testing on width only - ]. - - w > 0 ifTrue:[ - aView clearRectangleX:x y:y width:w height:h. - aView exposeX:x y:y width:w height:h - ]. - repaired notNil ifTrue:[ theDamages removeFromIndex:anIndex toIndex:anIndex ]. - ] - ]. -! - -redrawSelection - "redraw all items selected - " - |topView size| - - testModeChannel value ifTrue:[ ^ self ]. "/ test whether running testMode - - ( hiddenLevel == 0 - and:[(size := selection size) > 0 - and:[(topView := listOfItems rootView) notNil - and:[topView shown - and:[(topView sensor hasEvent:#redrawSelection for:self) not]]]] - ) ifFalse:[ - ^ self - ]. - - lockSema critical:[ - |list| - - list := selection. - - list size > 0 ifTrue:[ - topView paint:(Color black). - topView clippedByChildren:false. - - list keysAndValuesReverseDo:[:anIndex :anItem| - (anIndex == 1 and:[size > 1]) ifTrue:[ topView paint:(Color red) ]. - - anItem handlesDo:[:aRect :what| - what isNil ifTrue:[topView displayRectangle:aRect] - ifFalse:[topView fillRectangle:aRect] - ] - ]. - topView clippedByChildren:true. - ]. - ]. -! - -redrawUnselected:aList andLock:doLock - "redraw all items unselected; if doLock is true, the hiddenLevel - is incremented and thus the select mechanism is locked. - " - self redrawUnselected:aList andLock:doLock checkTestMode:true. -! - -redrawUnselected:aList andLock:doLock checkTestMode:checkTestMode - "redraw all items unselected; if doLock is true, the hiddenLevel - is incremented and thus the select mechanism is locked. - " - |rootView damages subViews x y w h| - - doLock ifTrue:[ - hiddenLevel := hiddenLevel + 1. - hiddenLevel ~~ 1 ifTrue:[^ self]. - ] ifFalse:[ - hiddenLevel ~~ 0 ifTrue:[^ self]. - ]. - checkTestMode ifTrue:[ - testModeChannel value ifTrue:[ ^ self ]. "/ test whether running testMode - ]. - - ( aList size ~~ 0 - and:[(rootView := listOfItems rootView) notNil - and:[rootView shown]] - ) ifFalse:[ - ^ self - ]. - - lockSema critical:[ - damages := OrderedCollection new:(8 * aList size). - - aList do:[:item| - item handlesDo:[:handle :what| - damages reverseDo:[:el| - (el intersects:handle) ifTrue:[ - damages removeIdentical:el. - - handle left:(handle left min:el left) - right:(handle right max:el right) - top:(handle top min:el top) - bottom:(handle bottom max:el bottom) - ] - ]. - damages add:handle - ] - ]. - - damages do:[:el| - x := el left. - y := el top. - w := el width. - h := el height. - - rootView clearRectangleX:x y:y width:w height:h. - rootView exposeX:x y:y width:w height:h. - ]. - - (subViews := rootView subViews) notNil ifTrue:[ - subViews reverseDo:[:v| self recursiveRepair:damages startIn:v relativeTo:rootView ]. - ]. - ]. -! ! - -!ViewTreeModel methodsFor:'queries'! - -isInTestMode - "answer false, all input events are eaten and the selection is shown on the target view. - answer true, no input events are eaten and no selection is shown on the target view." - - ^ testModeChannel value -! ! - -!ViewTreeModel methodsFor:'selection accessing'! - -at:anIndex - "returns the selected item at an index or nil - " - selection notNil ifTrue:[ - ^ selection at:anIndex ifAbsent:nil - ]. - ^ nil -! - -at:anIndex ifAbsent:aBlock - "returns the selected item at an index or the result of the block - " - selection notNil ifTrue:[ - ^ selection at:anIndex ifAbsent:aBlock - ]. - ^ aBlock value -! - -first - "returns the first selected item or nil - " - ^ self at:1 -! - -last - "returns the last selected item or nil - " - ^ selection notNil ifTrue:[selection last] ifFalse:[nil] -! - -selectedItem - "returns the single selected item or nil (size ~~ 1 nil is returned) - " - ^ selection size == 1 ifTrue:[selection at:1] ifFalse:[nil] -! - -selectedSuperItems - "returs the list of selected superItems; items selected - but not contained in another selected item. - " - ^ selectedSuperItems -! - -size - "returns the number of items selected - " - ^ selection size -! ! - -!ViewTreeModel methodsFor:'selection adding & removing'! - -add:item - "add an item to the current selection - " - |newSelect| - - item isNil ifTrue:[^ item]. - - lockSema critical:[ - selection isNil ifTrue:[ - newSelect := Array with:item. - ] ifFalse:[ - (self includes:item) ifFalse:[ - newSelect := selection copyWith:item - ] - ]. - - newSelect size ~~ selection size ifTrue:[ - item makeVisible. - self value:newSelect - ] - ]. - ^ item -! - -addAll:aCollectionOfItems - "add a collection of items to the current selection - " - |newSelect| - - aCollectionOfItems size == 0 ifTrue:[ ^ aCollectionOfItems ]. - - lockSema critical:[ - selection isNil ifTrue:[ - newSelect := Array withAll:aCollectionOfItems. - ] ifFalse:[ - newSelect := OrderedCollection withAll:selection. - - aCollectionOfItems do:[:el| - (selection includesIdentical:el) ifFalse:[newSelect add:el] - ]. - ]. - self value:newSelect. - ]. - ^ aCollectionOfItems -! - -deselect - "clear the selection - " - self value:nil. -! - -remove:item - "remove the item from the current selection - " - |newSelect| - - item isNil ifTrue:[^ nil]. - - lockSema critical:[ - (selection notNil and:[selection includesIdentical:item]) ifTrue:[ - selection size == 1 ifTrue:[ newSelect := nil ] - ifFalse:[ newSelect := selection copyWithout:item ]. - - self value:newSelect - ]. - ]. - ^ item -! - -removeAll - "clear the selection - " - self deselect. -! - -removeAll:loItems - "remove all items of the collection from the current selection - " - |newSelect| - - selection isNil ifTrue:[ ^ loItems ]. - loItems size == 0 ifTrue:[ ^ loItems ]. - - lockSema critical:[ - selection notNil ifTrue:[ - newSelect := selection select:[:el| (loItems includesIdentical:el) not ]. - self value:newSelect. - ] - ]. - ^ loItems -! - -selectAll - "select all items - " - |root newSelection| - - root := listOfItems root. - - root isNil ifTrue:[ - newSelection := nil - ] ifFalse:[ - newSelection := OrderedCollection new. - root recursiveDo:[:el| newSelection add:el ]. - ]. - self value:newSelection. -! - -selectItem:anItem - "set the current selection to the item - " - self value:anItem -! - -selectRootItem - "set the current selection to the root item - " - self value:(self rootItem). -! - -selectedItem:anItem - "set the current selection to the item - " - self selectItem:anItem. -! - -toggleSelectItem:anItem - "toggle selection-state of the item; add or remove the item from the - current selection. - " - anItem notNil ifTrue:[ - (self includes:anItem) ifTrue:[self remove:anItem] - ifFalse:[self add:anItem] - ]. - ^ anItem -! ! - -!ViewTreeModel methodsFor:'selection enumerating'! - -collect:aBlock - "for each element in the selection, evaluate the argument, aBlock - and return a new collection with the results - " - |res| - - res := OrderedCollection new. - self do:[:el| res add:(aBlock value:el)]. - ^ res -! - -do:aOneArgBlock - "evaluate the argument, aBlock for each item in the selection - " - |cashedSelection| - - cashedSelection := selection. - cashedSelection isNil ifTrue:[^ nil]. - ^ cashedSelection do:aOneArgBlock -! - -from:start do:aOneArgBlock - "evaluate the argument, aBlock for the items starting at index start - " - |cashedSelection| - - cashedSelection := selection. - cashedSelection isNil ifTrue:[^ nil]. - ^ cashedSelection from:start do:aOneArgBlock -! - -from:start to:stop do:aOneArgBlock - "evaluate the argument, aBlock for the items with index start to - stop in the selection. - " - |cashedSelection| - - cashedSelection := selection. - cashedSelection isNil ifTrue:[^ nil]. - ^ cashedSelection from:start to:stop do:aOneArgBlock -! - -reverseDo:aOneArgBlock - "evaluate the argument, aBlock for each item in the selection - " - |cashedSelection| - - cashedSelection := selection. - cashedSelection isNil ifTrue:[^ nil]. - ^ cashedSelection reverseDo:aOneArgBlock -! - -select:aBlock - "return a new collection with all elements from the selection, for which - the argument aBlock evaluates to true. - " - |res| - - res := OrderedCollection new. - self do:[:el| (aBlock value:el) ifTrue:[res add:el] ]. - ^ res -! ! - -!ViewTreeModel methodsFor:'selection protocol'! - -changed:aParameter with:oldSelection - "update the visibility staus of the current selection - " - |unselected rootView rootItem selSize| - - selSize := selection size. - - selSize == 0 ifTrue:[ - selectedSuperItems := #(). - ] ifFalse:[ - selSize == 1 ifTrue:[ - selectedSuperItems := Array with:(selection at:1). - ] ifFalse:[ - rootItem := listOfItems root. - - (selection includesIdentical:rootItem) ifTrue:[ - selectedSuperItems := Array with:rootItem. - ] ifFalse:[ - selectedSuperItems := OrderedCollection new:selSize. - - selection do:[:anItem| - anItem parentsDetect:[:el| selection includesIdentical:el ] - ifNone:[ selectedSuperItems add:anItem ]. - ]. - ] - ] - ]. - - ( hiddenLevel == 0 - and:[(rootView := listOfItems rootView) notNil - and:[rootView shown]] - ) ifTrue:[ - selSize == 0 ifTrue:[ - "/ must redraw the old selection unselected - self redrawUnselected:oldSelection andLock:false - ] ifFalse:[ - self invalidateSelection. - - oldSelection size ~~ 0 ifTrue:[ - "/ must redraw all elements no longer in the selection - unselected := oldSelection select:[:el| (selection includesIdentical:el) not ]. - self redrawUnselected:unselected andLock:false. - ] - ] - ]. - super changed:aParameter with:oldSelection. -! - -setValue:aNewSelection - "set the selection without notifying - " - |newSelect idx| - - newSelect := nil. - - aNewSelection notNil ifTrue:[ - lockSema critical:[ - aNewSelection isCollection ifFalse:[ - (selection size == 1 and:[selection first == aNewSelection]) ifTrue:[ - newSelect := selection - ] ifFalse:[ - newSelect := Array with:aNewSelection. - ] - ] ifTrue:[ - aNewSelection notEmpty ifTrue:[ - aNewSelection size ~~ selection size ifTrue:[ - newSelect := aNewSelection copy. - ] ifFalse:[ - idx := selection findFirst:[:el| (aNewSelection includesIdentical:el) not ]. - - idx ~~ 0 ifTrue:[newSelect := aNewSelection copy] - ifFalse:[newSelect := selection ]. - ] - ] - ] - ]. - ]. - newSelect ~~ selection ifTrue:[ - beforeSelectionChangedAction value. - selection := newSelect. - selection notNil ifTrue:[selection do:[:el| el makeVisible]] - ]. -! - -triggerValue:aValue - "set my value & send change notifications to my dependents. - Send the change message even if the value didn't change. - " - |oldSelection| - - lockSema critical:[ - oldSelection := selection. - self setValue:aValue. - self changed:#value with:oldSelection - ] -! - -value - "returns the current selection - " - ^ selection ? #() -! - -value:aValue - "change the current selection and send change notifications to my - dependents if it changed. - " - |oldSelection| - - lockSema critical:[ - oldSelection := selection. - self setValue:aValue. - - oldSelection == selection ifFalse:[ - self changed:#value with:oldSelection - ] - ]. -! ! - -!ViewTreeModel methodsFor:'selection searching'! - -detect:aBlock - "evaluate the argument, aBlock for each item in the selection until - the block returns true; in this case return the element which caused - the true evaluation. - If none of the evaluations returns true, an error is raised - " - ^ self detect:aBlock ifNone:[self errorNotFound] -! - -detect:aBlock ifNone:exceptionBlock - "evaluate the argument, aBlock for each item in the selection until the - block returns true; in this case return the element which caused the - true evaluation. - If none of the evaluations returns true, the result of the evaluation - of the exceptionBlock is returned - " - |cashedSelection| - - cashedSelection := selection. - cashedSelection isNil ifTrue:[ ^ exceptionBlock value ]. - ^ cashedSelection detect:aBlock ifNone:exceptionBlock -! - -detectLast:aBlock - "evaluate the argument, aBlock for each item in the selection until - the block returns true; in this case return the element which caused - the true evaluation. The items are processed in reverse order. - If none of the evaluations returns true, an error is raised - " - ^ self detectLast:aBlock ifNone:[self errorNotFound] -! - -detectLast:aBlock ifNone:exceptionBlock - "evaluate the argument, aBlock for each item in the selection until - the block returns true; in this case return the element which caused - the true evaluation. The items are processed in reverse order. - If none of the evaluations returns true, the result of the evaluation - of the exceptionBlock is returned - " - |cashedSelection| - - cashedSelection := selection. - cashedSelection isNil ifTrue:[ ^ exceptionBlock value ]. - ^ cashedSelection detectLast:aBlock ifNone:exceptionBlock -! ! - -!ViewTreeModel methodsFor:'selection testing'! - -includes:anItem - "returns true if the item is in the current selection - " - |cashedSelection| - - cashedSelection := selection. - cashedSelection isNil ifTrue:[^ false]. - ^ cashedSelection includesIdentical:anItem -! - -includesAll:aCollection - "return true, if all items of the collection are included in the current selection - " - |cashedSelection| - - aCollection size ~~ 0 ifTrue:[ - cashedSelection := selection. - cashedSelection isNil ifTrue:[ ^ false ]. - - aCollection do:[:el| - (cashedSelection includesIdentical:el) ifFalse:[^ false] - ] - ]. - ^ true -! - -includesAny:aCollection - "return true, if the any item of the collection is in the current selection - " - |cashedSelection| - - aCollection notNil ifTrue:[ - cashedSelection := selection. - - cashedSelection notNil ifTrue:[ - aCollection do:[:el| - (cashedSelection includesIdentical:el) ifTrue:[^ true] - ] - ] - ]. - ^ false -! - -includesIdentical:anItem - "returns true if the item is in the current selection - " - ^ self includes:anItem -! - -isEmpty - "returns true if the current selection is empty - " - ^ selection size == 0 -! - -isSelected:anItem - "returns true if the item is in the current selection - " - ^ self includes:anItem -! - -notEmpty - "returns true if the current selection is not empty - " - ^ selection size ~~ 0 -! ! - -!ViewTreeModel::ItemList class methodsFor:'documentation'! - -documentation -" - Kind of HierarchicalList class which contains all the visible - ViewTreeItem's and the root, the anchor of the hierarchical list. - - [Instance variables:] - treeModel all events are delegated to - eventHook save and resore the pre/post -EventHook - - - [author:] - Claus Atzkern - - [see also:] - HierarchicalList - ViewTreeModel - ViewTreeItem -" -! ! - -!ViewTreeModel::ItemList methodsFor:'accessing'! - -root:theRoot - "set the root item; delegate events to my treeModel - " - |rootView| - - theRoot == root ifTrue:[^ self]. - - rootView := self rootView. - super root:theRoot. - - rootView notNil ifTrue:[ |wgrp| - wgrp := rootView windowGroup. - - wgrp notNil ifTrue:[ - wgrp removePreEventHook:treeModel. - wgrp removePostEventHook:self. - ]. - ]. - - super root:theRoot. - rootView := self rootView. - - rootView notNil ifTrue:[ - "must setup a task because there might not exist a windowGroup at the moment - " - [ |wgrp| - - [rootView == self rootView] whileTrue:[ - wgrp := rootView windowGroup. - wgrp notNil ifTrue:[ - rootView := nil. - wgrp addPreEventHook:treeModel. - wgrp addPostEventHook:self. - ] ifFalse:[ - Delay waitForMilliseconds:100. - ]. - ]. - - ] forkAt:(Processor userSchedulingPriority + 2). - ]. - treeModel notNil ifTrue:[ - treeModel targetWidgetChanged. - ]. - - ^ root. -! - -rootView - "returns the widget assigned to the root or nil - " - ^ root notNil ifTrue:[root widget] ifFalse:[nil] -! - -treeModel - "returne the treeModel, a ViewTreeModel - " - ^ treeModel -! ! - -!ViewTreeModel::ItemList methodsFor:'accessing look'! - -additionalLabelForItem:anItem - "answer the additional lable for an item or nil" - - |applClass| - - showWidgetNames == true ifTrue:[ - ^ '[', anItem widget name, ']' - ]. - - anItem isApplicationClass ifTrue:[ - applClass := anItem applicationClass. - - applClass notNil ifTrue:[ - ^ ('[', applClass name, ']') - ]. - ]. - ^ nil -! - -showWidgetNames - "answer true if the additional text is the widget name - otherwise the name of the application" - - ^ showWidgetNames ? false -! - -showWidgetNames:aBoolean - "set true if the additional text is the widget name - otherwise the name of the application" - - self showWidgetNames == aBoolean ifFalse:[ - showWidgetNames := aBoolean. - - root notNil ifTrue:[ - root recursiveAdditionalNameBehaviourChanged. - self changed. - ]. - ]. -! ! - -!ViewTreeModel::ItemList methodsFor:'event processing'! - -processEvent:anEvent - "post process event - " - ^ treeModel isInTestMode not -! ! - -!ViewTreeModel::ItemList methodsFor:'instance creation'! - -on:aModel - "set the model, a ViewTreeModel - " - treeModel := aModel. - showRoot := true. - showWidgetNames := false. -! ! - -!ViewTreeModel::ItemList methodsFor:'searching'! - -detectItemRespondsToView:aView - "returns the bottom-most item which contains the view - " - |view item topView| - - root notNil ifTrue:[ - view := aView. - topView := root widget. - - [ view notNil ] whileTrue:[ - topView == view ifTrue:[^ root]. - item := root recursiveDetect:[:el| el widget == view ]. - item notNil ifTrue:[^ item]. - view := view superView - ] - ]. - ^ nil -! - -recursiveDetect:aOneOrgBlock - "recursive find the first child, for which evaluation - of the block returns true; if none nil is returned - " - root notNil ifTrue:[ - (aOneOrgBlock value:root) ifTrue:[ ^ root ]. - ^ root recursiveDetect:aOneOrgBlock - ]. - ^ nil -! ! - -!ViewTreeModel class methodsFor:'documentation'! - -version - ^ '$Header$' -! !