--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HierarchicalFileList.st Sun May 23 14:56:33 1999 +0200
@@ -0,0 +1,505 @@
+HierarchicalList subclass:#HierarchicalFileList
+ instanceVariableNames:'icons matchBlock'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'AAA-Model'
+!
+
+HierarchicalItem subclass:#File
+ instanceVariableNames:'fileName baseName icon'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:HierarchicalFileList
+!
+
+HierarchicalFileList::File subclass:#Directory
+ instanceVariableNames:'modificationTime'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:HierarchicalFileList::File
+!
+
+
+!HierarchicalFileList class methodsFor:'examples'!
+
+test
+ |top sel list item|
+
+ list := HierarchicalFileList new.
+ list directory:(Filename homeDirectory).
+ list showRoot:false.
+ list matchBlock:[:fn :isDir| |suf rslt|
+ (rslt := isDir) ifFalse:[
+ suf := fn suffix.
+
+ suf size ~~ 0 ifTrue:[
+ rslt := ( suf = 'c'
+ or:[suf = 'h'
+ or:[suf = 'hi']]
+ )
+ ]
+ ].
+ rslt
+ ].
+
+ top := StandardSystemView new; extent:300@300.
+ sel := ScrollableView for:HierarchicalListView miniScroller:true
+ origin:0.0@0.0 corner:1.0@1.0 in:top.
+
+ sel list:list.
+ list root expand.
+
+ sel doubleClickAction:[:i| (list at:i) toggleExpand ].
+ sel indicatorAction:[:i| (list at:i) toggleExpand ].
+
+ top open.
+
+
+! !
+
+!HierarchicalFileList class methodsFor:'resources'!
+
+icons
+ "returns set of icons
+ "
+ |icons resources fileKey resource baseName pathName|
+
+ resources := FileBrowser classResources.
+ icons := Dictionary new.
+
+ #(
+ (#directory 'ICON_DIRECTORY' 'tiny_yellow_dir.xpm' )
+ (#directoryLocked 'ICON_DIRECTORY_LOCKED' 'tiny_yellow_dir_locked.xpm')
+ (#directoryLink 'ICON_DIRECTORY_LINK' 'tiny_yellow_dir_link.xpm' )
+ (#file 'ICON_FILE' 'tiny_file_plain.xpm' )
+ (#fileLink 'ICON_FILE_LINK' 'tiny_file_link.xpm' )
+ (#fileLocked 'ICON_FILE_LOCKED' 'tiny_file_lock.xpm' )
+ (#imageFile 'ICON_IMAGE_FILE' 'tiny_file_pix.xpm' )
+ (#textFile 'ICON_TEXT_FILE' 'tiny_file_text.xpm' )
+ (#executableFile 'ICON_EXECUTABLEFILE' 'tiny_file_exec.xpm' )
+
+ ) do:[:entry|
+ fileKey := entry at:1.
+ resource := entry at:2.
+ baseName := entry at:3.
+
+ (pathName := resources at:(entry at:2) default:nil) isNil ifTrue:[
+ pathName := 'bitmaps/xpmBitmaps/document_images/' , baseName
+ ].
+ icons at:fileKey put:(Image fromFile:pathName).
+ ].
+ ^ icons
+
+
+
+
+! !
+
+!HierarchicalFileList methodsFor:'accessing'!
+
+directory
+ "returns the root directory or nil
+ "
+ ^ root notNil ifTrue:[root fileName] ifFalse:[nil]
+
+!
+
+directory:aDirectory
+ "set the root directory or nil
+ "
+ |directory|
+
+ monitoringTaskDelay := 1.
+
+ (aDirectory notNil and:[(directory := aDirectory asFilename) exists]) ifTrue:[
+ directory isDirectory ifFalse:[
+ directory := directory directory
+ ]
+ ] ifFalse:[
+ directory := nil
+ ].
+
+ directory = self directory ifFalse:[
+ directory notNil ifTrue:[
+ directory := File fileName:directory isDirectory:true
+ ].
+ self root:directory
+ ].
+! !
+
+!HierarchicalFileList methodsFor:'actions'!
+
+matchBlock
+ "set the matchBlock - if non-nil, it controls which files are visible.
+ "
+ ^ matchBlock
+
+!
+
+matchBlock:aBlock
+ "set the matchBlock - if non-nil, it controls which files are visible.
+ "
+ matchBlock := aBlock.
+
+! !
+
+!HierarchicalFileList methodsFor:'protocol'!
+
+childrenFor:anItem
+ "returns all visible children derived from the physical
+ directory contents.
+ "
+ |contents list block|
+
+ list := #().
+
+ anItem isDirectory ifFalse:[
+ ^ list
+ ].
+
+ Cursor read showWhile:[
+ contents := DirectoryContents directoryNamed:(anItem fileName).
+
+ contents notNil ifTrue:[
+ list := OrderedCollection new.
+ block := self matchBlockFor:anItem.
+
+ block isNil ifTrue:[
+ contents contentsDo:[:fn :isDir|
+ list add:(File fileName:fn isDirectory:isDir)
+ ]
+ ] ifFalse:[
+ contents contentsDo:[:fn :isDir|
+ (block value:fn value:isDir) ifTrue:[
+ list add:(File fileName:fn isDirectory:isDir)
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ list
+
+
+
+
+!
+
+hasChildrenFor:anItem
+ "returns true if the physical directory contains at least
+ one visible item otherwise false.
+ "
+ |block|
+
+ anItem isDirectory ifFalse:[
+ ^ false
+ ].
+
+ (block := self matchBlockFor:anItem) isNil ifTrue:[
+ block := [:aFilename :isDirectory| true ]
+ ].
+ ^ DirectoryContents directoryNamed:(anItem fileName) detect:block
+!
+
+iconFor:anItem
+ "returns the icon for an item
+ "
+ |fn key|
+
+ fn := anItem fileName.
+
+ fn isDirectory ifTrue:[
+ (fn isReadable and:[fn isExecutable]) ifTrue:[
+ key := fn isSymbolicLink ifTrue:[#directoryLink]
+ ifFalse:[#directory]
+ ] ifFalse:[
+ key := #directoryLocked
+ ]
+ ] ifFalse:[
+ fn isReadable ifTrue:[
+ fn isSymbolicLink ifTrue:[
+ key := #fileLink
+ ] ifFalse:[
+ (Image isImageFileSuffix:(fn suffix)) ifTrue:[
+ key := #imageFile
+ ] ifFalse:[
+ key := #file
+ ]
+ ]
+ ] ifFalse:[
+ key := #fileLocked
+ ]
+ ].
+ icons isNil ifTrue:[
+ icons := self class icons
+ ].
+
+ ^ icons at:key ifAbsent:nil
+!
+
+matchBlockFor:anItem
+ "get the matchBlock - if non-nil, it controls which files are
+ visible within the physical directory
+ "
+ ^ matchBlock
+! !
+
+!HierarchicalFileList::File class methodsFor:'instance creation'!
+
+fileName:aFileName isDirectory:isDirectory
+ "instance creation
+ "
+ |item|
+
+ item := isDirectory ifTrue:[Directory new] ifFalse:[HierarchicalFileList::File new].
+ item fileName:aFileName.
+ ^ item
+
+! !
+
+!HierarchicalFileList::File methodsFor:'accessing'!
+
+baseName
+ "returns the baseName
+ "
+ ^ baseName
+
+
+!
+
+children
+ "always returns an empty list
+ "
+ ^ #()
+!
+
+fileName
+ "returns the fileName
+ "
+ ^ fileName
+
+
+!
+
+fileName:fname
+ "instance creation
+ "
+ fileName := fname.
+ baseName := fname baseName.
+!
+
+icon
+ "returns the icon key
+ "
+ |model|
+
+ icon isNil ifTrue:[
+ (model := self model) notNil ifTrue:[
+ icon := model iconFor:self
+ ]
+ ].
+ ^ icon
+
+
+!
+
+label
+ "returns the printable name, the baseName
+ "
+ ^ baseName
+
+
+!
+
+pathName
+ "returns the pathName
+ "
+ ^ fileName pathName
+! !
+
+!HierarchicalFileList::File methodsFor:'accessing hierarchy'!
+
+recursiveExpand
+ "redefined to expand
+ "
+ self expand
+
+
+! !
+
+!HierarchicalFileList::File methodsFor:'invalidate'!
+
+invalidate
+ "invalidate the contents
+ "
+ self invalidateRepairNow:false
+
+!
+
+invalidateRepairNow
+ "invalidate the contents; repair now
+ "
+ self invalidateRepairNow:true
+
+!
+
+invalidateRepairNow:doRepair
+ "invalidate the contents; dependent on the boolean
+ do repair immediately
+ "
+
+
+! !
+
+!HierarchicalFileList::File methodsFor:'queries'!
+
+hasChildren
+ "always returns false
+ "
+ ^ false
+!
+
+isDirectory
+ "always returns false
+ "
+ ^ false
+
+!
+
+string
+ "returns the string from the label or nil
+ "
+ ^ baseName
+! !
+
+!HierarchicalFileList::File::Directory methodsFor:'accessing'!
+
+children
+ "returns the list of children
+ "
+ |model list|
+
+ children isNil ifTrue:[
+ children := #(). "/ disable reread
+ modificationTime := fileName modificationTime.
+
+ (model := self model) notNil ifTrue:[
+ list := model childrenFor:self.
+
+ list size ~~ 0 ifTrue:[
+ list do:[:aChild| aChild parent:self].
+ children := list.
+ ]
+ ].
+ ].
+ ^ children
+!
+
+icon
+ "returns the icon
+ "
+ (isExpanded and:[children size ~~ 0]) ifTrue:[
+ ^ nil
+ ].
+ ^ super icon
+! !
+
+!HierarchicalFileList::File::Directory methodsFor:'queries'!
+
+hasChildren
+ "returns true if children exists
+ "
+ ^ children isNil or:[children notEmpty]
+!
+
+isDirectory
+ "always returns true
+ "
+ ^ true
+
+
+! !
+
+!HierarchicalFileList::File::Directory methodsFor:'validation'!
+
+invalidateRepairNow:doRepair
+ "invalidate contents
+ "
+ modificationTime := nil.
+
+ doRepair ifTrue:[
+ self monitoringCycle
+ ] ifFalse:[
+ (isExpanded or:[children size == 0]) ifFalse:[
+ children := nil
+ ]
+ ].
+
+!
+
+monitoringCycle
+ "run monitoring cycle
+ "
+ |list size name modifyTime isNotEmpty wasNotEmpty model|
+
+ modifyTime := fileName modificationTime.
+
+ (modificationTime notNil and:[modifyTime <= modificationTime]) ifTrue:[
+ ^ self
+ ].
+ model := self model.
+ modificationTime := modifyTime.
+
+ isExpanded ifFalse:[
+
+ "/ CHECK WHETHER CHILDREN EXIST( INDICATOR )
+ "/ =========================================
+
+ isNotEmpty := model hasChildrenFor:self.
+
+ "/ check whether has changed durring evaluation
+ (isExpanded or:[modificationTime ~= modifyTime]) ifFalse:[
+ wasNotEmpty := children isNil.
+ children := isNotEmpty ifTrue:[nil] ifFalse:[#()].
+
+ wasNotEmpty ~~ isNotEmpty ifTrue:[
+ self changed
+ ]
+ ].
+ ^ self
+
+ ].
+
+ "/ START MERGING( CONTENTS IS VISIBLE )
+ "/ ====================================
+
+ list := model childrenFor:self.
+
+ list size == 0 ifTrue:[ "/ contents becomes empty
+ ^ self removeAll "/ clear contents
+ ].
+ (size := children size) == 0 ifTrue:[ "/ old contents was empty
+ ^ self addAll:list. "/ take over new contents
+ ].
+
+ size to:1 by:-1 do:[:anIndex| "/ remove invisible items
+ name := (children at:anIndex) baseName.
+
+ (list findFirst:[:i|i baseName = name]) == 0 ifTrue:[
+ self removeIndex:anIndex
+ ]
+ ].
+
+ list keysAndValuesDo:[:anIndex :anItem| "/ add new visible items
+ name := anItem baseName.
+
+ (children findFirst:[:i|i baseName = name]) == 0 ifTrue:[
+ self add:anItem beforeIndex:anIndex
+ ]
+ ].
+! !
+
+!HierarchicalFileList class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libwidg2/HierarchicalFileList.st,v 1.1 1999-05-23 12:56:11 cg Exp $'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HierarchicalItem.st Sun May 23 14:56:33 1999 +0200
@@ -0,0 +1,1037 @@
+Object subclass:#HierarchicalItem
+ instanceVariableNames:'parent children isExpanded'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'AAA-Model'
+!
+
+HierarchicalItem subclass:#Example
+ instanceVariableNames:'label icon'
+ classVariableNames:'PenguinIcon'
+ poolDictionaries:''
+ privateIn:HierarchicalItem
+!
+
+!HierarchicalItem class methodsFor:'documentation'!
+
+documentation
+"
+ Hierarchical Items are mostly like Models, but the list of
+ dependencies are kept by its HierarchicalList.
+ The class is used to build up hierarchical trees.
+
+ [Instance variables:]
+ parent <Item, List or nil> parent or my HierarchicalList.
+ children <Collection or nil> list of children
+ isExpanded <Boolean> indicates whether the item is
+ expanded or collapsed
+
+ [author:]
+ Claus Atzkern
+
+ [see also:]
+ HierarchicalList
+ HierarchicalListView
+"
+
+
+! !
+
+!HierarchicalItem class methodsFor:'instance creation'!
+
+new
+ ^ (self basicNew) initialize
+! !
+
+!HierarchicalItem methodsFor:'accessing'!
+
+level
+ "returns the level starting with 1
+ "
+ |parent
+ level "{ Class:SmallInteger }"
+ |
+ level := 0.
+ parent := self.
+
+ [(parent := parent parentOrModel) notNil] whileTrue:[
+ level := level + 1
+ ].
+ ^ level
+
+!
+
+parent
+ "returns the parent or nil
+ "
+ ^ (parent notNil and:[parent isHierarchicalItem]) ifTrue:[parent]
+ ifFalse:[nil]
+!
+
+parent:aParent
+ "set the parent (or the model if the item is the root item)
+ "
+ parent := aParent
+
+! !
+
+!HierarchicalItem methodsFor:'accessing children'!
+
+at:anIndex
+ "returns the child under an index or nil
+ "
+ ^ self children notNil ifTrue:[children at:anIndex ifAbsent:nil]
+ ifFalse:[nil]
+!
+
+at:anIndex put:anItem
+ "replace a child by a new item
+ "
+ |oldItem itemExpanded size|
+
+ size := self children size.
+
+ (anIndex between:1 and:size) ifFalse:[
+ ^ self subscriptBoundsError
+ ].
+
+ anItem isNil ifTrue:[
+ ^ self removeFromIndex:anIndex toIndex:anIndex.
+ ].
+
+ oldItem := children at:anIndex.
+ oldItem collapse.
+ itemExpanded := anItem isExpanded.
+ anItem setExpanded:false.
+ children at:anIndex put:anItem.
+ self changed.
+
+ itemExpanded ifTrue:[
+ anItem expand
+ ].
+!
+
+children:aListOfChildren
+ "set a new list of children
+ "
+ self removeAll.
+ ^ self addAll:aListOfChildren beforeIndex:1
+!
+
+first
+ "returns the first child
+ "
+ ^ self at:1
+!
+
+last
+ "returns the last child
+ "
+ ^ self at:(self children size)
+! !
+
+!HierarchicalItem methodsFor:'accessing hierarchy'!
+
+collapse
+ "hide children
+ "
+ |visChd model index|
+
+ self canCollapse ifTrue:[
+ isExpanded := false.
+
+ (index := self listIndex) notNil ifTrue:[
+ (visChd := children size) ~~ 0 ifTrue:[
+ children do:[:aChild|
+ visChd := visChd + aChild numberOfVisibleChildren
+ ].
+ self model itemRemoveFromIndex:(index + 1)
+ toIndex:(index + visChd).
+
+ index ~~ 0 ifTrue:[
+ self hierarchyChanged
+ ]
+ ]
+ ]
+ ]
+!
+
+expand
+ "expand children
+ "
+ |index list|
+
+ self canExpand ifTrue:[
+ isExpanded := true.
+
+ (index := self listIndex) notNil ifTrue:[
+ (children notNil or:[self children notNil]) ifTrue:[
+ children notEmpty ifTrue:[
+ list := OrderedCollection new:64.
+ self addVisibleChildrenTo:list.
+ self model itemAddAll:list beforeIndex:(index + 1).
+ ].
+ index ~~ 0 ifTrue:[
+ self hierarchyChanged
+ ]
+ ]
+ ]
+ ]
+
+!
+
+recursiveCollapse
+ "collapse children and sub-children
+ **** must be expanded
+ "
+ |visChd index|
+
+ self canCollapse ifTrue:[
+ (index := self listIndex) notNil ifTrue:[
+ (visChd := children size) ~~ 0 ifTrue:[
+ children do:[:aChild|
+ visChd := visChd + aChild numberOfVisibleChildren
+ ]
+ ].
+ self recursiveSetCollapsed.
+
+ visChd ~~ 0 ifTrue:[
+ self model itemRemoveFromIndex:(index + 1)
+ toIndex:(index + visChd)
+ ].
+ index ~~ 0 ifTrue:[
+ self hierarchyChanged
+ ]
+ ] ifFalse:[
+ self recursiveSetCollapsed
+ ]
+ ]
+
+!
+
+recursiveExpand
+ "expand children and sub-children
+ **** must be collapsed
+ "
+ |model index list|
+
+ self canExpand ifTrue:[
+ isExpanded := true.
+
+ self children size ~~ 0 ifTrue:[
+ (index := self listIndex) isNil ifTrue:[
+ children do:[:aChild| aChild setExpanded:true ]
+ ] ifFalse:[
+ list := OrderedCollection new:512.
+ self recursiveSetExpandedAndAddToList:list.
+ self model itemAddAll:list beforeIndex:(index + 1).
+
+ index ~~ 0 ifTrue:[
+ self hierarchyChanged
+ ]
+ ]
+ ]
+ ]
+!
+
+recursiveToggleExpand
+ "if the item is collapsed, the children and all sub-children
+ are expanded otherwise collapsed
+ "
+ isExpanded ifTrue:[self recursiveCollapse] ifFalse:[self recursiveExpand]
+
+!
+
+toggleExpand
+ "if the item is collapsed, the children are expanded
+ otherwise collapsed
+ "
+ isExpanded ifTrue:[self collapse] ifFalse:[self expand]
+
+! !
+
+!HierarchicalItem methodsFor:'accessing mvc'!
+
+application
+ "returns the responsible application or nil
+ "
+ |model|
+
+ (model := self model) notNil ifTrue:[
+ ^ model application
+ ].
+ ^ nil
+!
+
+applicationsDo:aOneArgBlock
+ "evaluate the block on each dependent application
+ "
+ |model|
+
+ (model := self model) notNil ifTrue:[
+ model applicationsDo:aOneArgBlock
+ ]
+
+!
+
+model
+ "returns the hierachicalList model or nil
+ "
+ |p model|
+
+ model := self.
+ [(p := model parentOrModel) notNil] whileTrue:[model := p].
+ ^ model isHierarchicalItem ifFalse:[model] ifTrue:[nil]
+! !
+
+!HierarchicalItem methodsFor:'adding & removing'!
+
+add:aChildItem
+ "add a child at end
+ "
+ ^ self add:aChildItem beforeIndex:(self children size + 1).
+
+!
+
+add:aChildItem after:aChild
+ "add an item after an existing item
+ "
+ |index|
+
+ (index := self listIndex) isNil ifTrue:[
+ self subscriptBoundsError
+ ] ifFalse:[
+ self add:aChildItem beforeIndex:(index + 1)
+ ].
+ ^ aChildItem
+!
+
+add:aChildItem afterIndex:anIndex
+ "add an item after an index
+ "
+ ^ self add:aChildItem beforeIndex:(anIndex + 1).
+!
+
+add:aChildItem before:aChild
+ "add an item before an existing item
+ "
+ |index|
+
+ (index := self identityIndexOf:aChild) ~~ 0 ifTrue:[
+ ^ self add:aChildItem beforeIndex:index
+ ].
+ self subscriptBoundsError
+!
+
+add:aChildItem beforeIndex:anIndex
+ "add an item before an index
+ "
+ aChildItem notNil ifTrue:[
+ self addAll:(Array with:aChildItem) beforeIndex:anIndex
+ ].
+ ^ aChildItem
+!
+
+addAll:aList
+ "add children at the end
+ "
+ ^ self addAll:aList beforeIndex:(self children size + 1)
+!
+
+addAll:aList beforeIndex:anIndex
+ "add children before an index
+ "
+ |coll model notify
+ index "{ Class:SmallInteger }"
+ size "{ Class:SmallInteger }"
+ |
+
+ (aList isNil or:[aList isEmpty]) ifTrue:[
+ ^ aList
+ ].
+ size := self children size.
+
+ anIndex == 1 ifTrue:[
+ notify := self
+ ] ifFalse:[
+ anIndex > size ifTrue:[
+ anIndex > (1 + size) ifTrue:[
+ ^ self subscriptBoundsError
+ ].
+ notify := self at:size
+ ] ifFalse:[
+ notify := nil
+ ]
+ ].
+
+ size == 0 ifTrue:[
+ children := OrderedCollection new
+ ].
+ aList do:[:anItem| anItem parent:self ].
+ children addAll:aList beforeIndex:anIndex.
+
+ (model := self model) isNil ifTrue:[
+ ^ aList
+ ].
+
+ isExpanded ifFalse:[
+ notify notNil ifTrue:[
+ notify changed
+ ].
+ ^ aList
+ ].
+ (index := self listIndex) isNil ifTrue:[
+ ^ aList
+ ].
+
+ children from:1 to:(anIndex - 1) do:[:anItem|
+ index := 1 + index + anItem numberOfVisibleChildren
+ ].
+ coll := OrderedCollection new.
+
+ aList do:[:anItem|
+ coll add:anItem.
+ anItem addVisibleChildrenTo:coll.
+ ].
+ model itemAddAll:coll beforeIndex:(index + 1).
+
+ notify notNil ifTrue:[
+ notify changed
+ ].
+ ^ aList
+!
+
+addAllFirst:aCollectionOfItems
+ "add children at the beginning
+ "
+ ^ self addAll:aCollectionOfItems beforeIndex:1
+!
+
+addAllLast:aCollectionOfItems
+ "add children at the end
+ "
+ ^ self addAll:aCollectionOfItems
+!
+
+addFirst:aChildItem
+ "add a child at begin
+ "
+ ^ self add:aChildItem beforeIndex:1.
+
+!
+
+addLast:anItem
+ "add a child at end
+ "
+ ^ self add:anItem
+!
+
+remove:aChild
+ "remove a child
+ "
+ self removeIndex:(self identityIndexOf:aChild)
+
+!
+
+removeAll
+ "remove all children
+ "
+ |size|
+
+ (size := self children size) ~~ 0 ifTrue:[
+ self removeFromIndex:1 toIndex:size
+ ]
+!
+
+removeFromIndex:startIndex toIndex:stopIndex
+ "remove the children from startIndex up to and including
+ the child under stopIndex.
+ "
+ |model notify
+ index "{ Class:SmallInteger }"
+ start "{ Class:SmallInteger }"
+ stop "{ Class:SmallInteger }"
+ size "{ Class:SmallInteger }"
+ |
+ size := self children size.
+ stop := stopIndex.
+ start := startIndex.
+
+ (stop <= size and:[start between:1 and:stop]) ifFalse:[
+ ^ self subscriptBoundsError
+ ].
+ start == 1 ifTrue:[
+ notify := self
+ ] ifFalse:[
+ stop == size ifTrue:[
+ notify := self at:(start - 1)
+ ] ifFalse:[
+ notify := nil
+ ]
+ ].
+
+ (model := self model) notNil ifTrue:[
+ index := model identityIndexOf:(children at:start).
+ size := stop - start + 1.
+ ] ifFalse:[
+ index := 0
+ ].
+ children from:start to:stop do:[:aChild|
+ index ~~ 0 ifTrue:[
+ size := size + aChild numberOfVisibleChildren
+ ].
+ aChild parent:nil
+ ].
+ children removeFromIndex:start toIndex:stop.
+
+ index ~~ 0 ifTrue:[
+ model itemRemoveFromIndex:index toIndex:(index + size - 1)
+ ].
+ notify notNil ifTrue:[
+ notify changed
+ ].
+!
+
+removeIndex:anIndex
+ "remove the child at an index
+ "
+ anIndex > 0 ifTrue:[
+ self removeFromIndex:anIndex toIndex:anIndex
+ ]
+! !
+
+!HierarchicalItem methodsFor:'change & update'!
+
+changed
+ "the item changed; raise change notification
+ "
+ self changed:nil with:nil
+!
+
+changed:aParameter
+ "the item changed; raise change notification
+ "
+ self changed:aParameter with:nil
+
+!
+
+changed:aParameter with:anArgument
+ "the item changed; raise change notification
+ "
+ |model|
+
+ model := self model.
+
+ model notNil ifTrue:[
+ model itemChanged:aParameter with:anArgument from:self
+ ].
+ super changed:aParameter with:anArgument
+!
+
+hierarchyChanged
+ "hierarchy changed; optimize redrawing
+ "
+ self changed:#hierarchy with:nil
+!
+
+iconChanged
+ "icon changed; optimize redrawing
+ "
+ self changed:#icon with:nil
+! !
+
+!HierarchicalItem methodsFor:'enumerating'!
+
+do:aOneArgBlock
+ "evaluate a block on each child
+ "
+ self children notNil ifTrue:[ children do:aOneArgBlock ]
+
+!
+
+from:startIndex do:aOneArgBlock
+ "evaluate a block on each child starting with the
+ child at startIndex to the end.
+ "
+ self from:startIndex to:self size do:aOneArgBlock
+!
+
+from:startIndex to:endIndex do:aOneArgBlock
+ "evaluate a block on each child starting with the
+ child at startIndex to the endIndex.
+ "
+ self children notNil ifTrue:[
+ children from:startIndex to:endIndex do:aOneArgBlock
+ ]
+
+!
+
+from:startIndex to:endIndex reverseDo:aOneArgBlock
+ "evaluate a block on each child starting with the
+ child at endIndex to the startIndex.
+ "
+ self children notNil ifTrue:[
+ children from:startIndex to:endIndex reverseDo:aOneArgBlock
+ ]
+
+!
+
+recursiveDo:aOneArgBlock
+ "evaluate a block on each item and all the sub-items
+ "
+ self do:[:aChild|
+ aOneArgBlock value:aChild.
+ aChild recursiveDo:aOneArgBlock
+ ].
+
+!
+
+reverseDo:aOneArgBlock
+ "evaluate a block on each child
+ procesing children in reverse direction
+ "
+ self children notNil ifTrue:[ children reverseDo:aOneArgBlock ]
+
+! !
+
+!HierarchicalItem methodsFor:'initialization'!
+
+initialize
+ isExpanded := false
+! !
+
+!HierarchicalItem methodsFor:'private'!
+
+addVisibleChildrenTo:aList
+ "add all visible children and sub-children to the list
+ "
+ isExpanded ifTrue:[
+ (children notNil or:[self children notNil]) ifTrue:[
+ children do:[:aChild|
+ aList add:aChild.
+ aChild addVisibleChildrenTo:aList
+ ]
+ ]
+ ]
+
+
+
+
+
+!
+
+listIndex
+ "returns the visible index or nil; for a none visible root
+ 0 is returned
+ "
+ |index model|
+
+ (model := self model) notNil ifTrue:[
+ index := model identityIndexOf:self.
+
+ (index ~~ 0 or:[parent == model]) ifTrue:[
+ ^ index
+ ]
+ ].
+ ^ nil
+!
+
+numberOfVisibleChildren
+ "returns number of all visible children including subchildren
+ "
+ |size "{ Class: SmallInteger }"
+ |
+ isExpanded ifTrue:[
+ (children notNil or:[self children notNil]) ifTrue:[
+ (size := children size) ~~ 0 ifTrue:[
+ children do:[:el| size := size + el numberOfVisibleChildren ].
+ ^ size
+ ]
+ ]
+ ].
+ ^ 0
+
+
+
+
+!
+
+parentOrModel
+ "returns the parent without checking for item or model
+ "
+ ^ parent
+!
+
+setExpanded:aBoolean
+ "set expanded flag without any computation or notification
+ "
+ isExpanded := aBoolean
+! !
+
+!HierarchicalItem methodsFor:'private hierarchy'!
+
+recursiveSetCollapsed
+ "collapse all children and sub-children without notifications
+ "
+ isExpanded := false.
+
+ children notNil ifTrue:[
+ children do:[:aChild| aChild recursiveSetCollapsed ]
+ ]
+!
+
+recursiveSetExpandedAndAddToList:aList
+ "expand all children and sub-children without notifications;
+ add children to list
+ "
+ isExpanded := true.
+
+ (children notNil or:[self children notNil]) ifTrue:[
+ children do:[:aChild|
+ aList add:aChild.
+ aChild recursiveSetExpandedAndAddToList:aList.
+ ]
+ ]
+
+! !
+
+!HierarchicalItem methodsFor:'protocol accessing'!
+
+children
+ "returns list of children
+ *** to optimize:redefine by subClass
+ "
+ |model|
+
+ children isNil ifTrue:[
+ (model := self model) notNil ifTrue:[
+ model childrenFor:self
+ ].
+ ].
+ ^ children
+!
+
+icon
+ "returns the icon or nil;
+ *** to optimize:redefine by subClass
+ "
+ |model|
+
+ (model := self model) notNil ifTrue:[
+ ^ model iconFor:self
+ ].
+ ^ nil
+!
+
+label
+ "returns the label displayed on aGC;
+ *** to optimize:redefine by subClass
+ "
+ |model|
+
+ (model := self model) notNil ifTrue:[
+ ^ model labelFor:self
+ ].
+ ^ nil
+
+!
+
+middleButtonMenu
+ "returns the middleButtonMenu or nil if no menu is defined
+ "
+ |model|
+
+ (model := self model) notNil ifTrue:[
+ ^ model middleButtonMenuFor:self
+ ].
+ ^ nil
+! !
+
+!HierarchicalItem methodsFor:'protocol displaying'!
+
+displayOn:aGC x:x y:y
+ "draw the receiver in the graphicsContext, aGC.
+ "
+ |label
+ y0 "{ Class:SmallInteger }"
+ |
+ label := self label.
+
+ label notNil ifTrue:[
+ ( label isImageOrForm not
+ and:[(label isString or:[label isKindOf:LabelAndIcon])]
+ ) ifTrue:[
+ y0 := y + aGC font ascent
+ ] ifFalse:[
+ y0 := y
+ ].
+ label displayOn:aGC x:x y:y0.
+ ]
+
+!
+
+heightOn:aGC
+ "return the width of the receiver, if it is to be displayed on aGC
+ "
+ |label|
+
+ label := self label.
+ ^ label notNil ifTrue:[label heightOn:aGC] ifFalse:[0]
+
+
+!
+
+widthOn:aGC
+ "return the width of the receiver, if it is to be displayed on aGC
+ "
+ |label|
+
+ label := self label.
+ ^ label notNil ifTrue:[label widthOn:aGC] ifFalse:[0]
+
+
+! !
+
+!HierarchicalItem methodsFor:'protocol monitoring'!
+
+monitoringCycle
+ "called all 'n' seconds by the model, if the monitoring
+ cycle is enabled. The item can perform some checks, ..
+ **** can be redefined by subclass to perform some actions
+ "
+! !
+
+!HierarchicalItem methodsFor:'protocol queries'!
+
+hasChildren
+ "checks whether the item has a list of children; the list must not
+ be loaded yet( ex. FileDirectory ).
+ *** to optimize:redefine by subClass
+ "
+ ^ children notNil ifTrue:[children notEmpty]
+ ifFalse:[self children size ~~ 0]
+!
+
+string
+ "access the printable string used for steping through a list
+ searching for an entry starting with a character.
+ *** to optimize:redefine by subClass
+ "
+ ^ self label perform:#string ifNotUnderstood:nil
+
+! !
+
+!HierarchicalItem methodsFor:'queries'!
+
+canCollapse
+ "called before collapsing the item
+ "
+ ^ isExpanded
+!
+
+canExpand
+ "called before expanding the item
+ "
+ ^ isExpanded not and:[self hasChildren]
+!
+
+isExpanded
+ "return true if item is expanded
+ "
+ ^ isExpanded
+!
+
+isHierarchicalItem
+ "used to decide if the parent is a hierarchical item
+ or the model
+ "
+ ^ true
+!
+
+size
+ "return the number of children
+ "
+ ^ children notNil ifTrue:[children size]
+ ifFalse:[self children size]
+! !
+
+!HierarchicalItem methodsFor:'searching'!
+
+detect:aOneArgBlock
+ "find the first child, for which evaluation of the block returns
+ true; if none does so, report an error
+ "
+ ^ self detect:aOneArgBlock ifNone:[self errorNotFound]
+
+!
+
+detect:aOneArgBlock ifNone:anExceptionBlock
+ "find the first child, for which evaluation of the block returns
+ true; if none does so, return the evaluation of anExceptionBlock
+ "
+ self children notNil ifTrue:[
+ ^ children detect:aOneArgBlock ifNone:anExceptionBlock
+ ].
+ ^ anExceptionBlock value
+
+
+!
+
+identityIndexOf:aChild
+ "return the index of aChild or 0 if not found. Compare using ==
+ "
+ self children notNil ifTrue:[
+ ^ children identityIndexOf:aChild
+ ].
+ ^ 0
+!
+
+identityIndexOf:aChild startingAt:startIndex
+ "return the index of aChild, starting search at startIndex.
+ Compare using ==; return 0 if not found
+ "
+ self children notNil ifTrue:[
+ ^ children identityIndexOf:aChild startingAt:startIndex
+ ].
+ ^ 0
+! !
+
+!HierarchicalItem::Example class methodsFor:'instance creation'!
+
+labeled:aLabel
+ ^ self new setLabel:aLabel
+
+
+!
+
+labeled:aLabel icon:anIcon
+ ^ self new setLabel:aLabel icon:anIcon
+
+
+! !
+
+!HierarchicalItem::Example class methodsFor:'resources'!
+
+iconForLevel:aLevel
+ "returns an icon
+ "
+ aLevel == 2 ifTrue:[ ^ ResourceSelectionBrowser iconPrivateClass ].
+ aLevel == 3 ifTrue:[ ^ ResourceSelectionBrowser iconClass ].
+ aLevel == 4 ifTrue:[ ^ ResourceSelectionBrowser iconCategory ].
+
+ ^ nil
+
+!
+
+penguinIcon
+ PenguinIcon isNil ifTrue:[
+ PenguinIcon := Image fromFile:'bitmaps/xpmBitmaps/misc_logos/linux_penguin.xpm'.
+ ].
+ ^ PenguinIcon
+! !
+
+!HierarchicalItem::Example methodsFor:'accessing'!
+
+children
+ |lvl lbl txt image img icon|
+
+ children notNil ifTrue:[
+ ^ children
+ ].
+
+ (lvl := self level) == 5 ifTrue:[
+ children := #().
+ ^ children
+ ].
+ icon := self class iconForLevel:(lvl + 1).
+ children := OrderedCollection new.
+
+ lvl < 4 ifTrue:[
+ txt := (lvl + 1) printString, ' ['.
+ img := NewLauncher saveImageIcon.
+
+ 1 to:5 do:[:i|
+ (i == 2 or:[i == 3]) ifTrue:[
+ lbl := img
+ ] ifFalse:[
+ i == 4 ifTrue:[
+ lbl := self class penguinIcon
+ ] ifFalse:[
+ lbl := txt, (i printString), ']'
+ ]
+ ].
+ children add:(self class labeled:lbl icon:icon)
+ ].
+ ] ifFalse:[
+ image := ResourceSelectionBrowser iconPrivateClass.
+ txt := LabelAndIcon icon:image string:'Text'.
+ img := Icon copyIcon.
+
+ 1 to:5 do:[:i|
+ lbl := i odd ifTrue:[txt] ifFalse:[img].
+ children add:(self class labeled:lbl icon:icon).
+ ]
+ ].
+
+ children do:[:aChild| aChild parent:self ].
+ ^ children
+!
+
+icon
+ "returns the icon
+ "
+ ^ icon
+!
+
+icon:anIcon
+ "set the icon; if icon changed, a notification
+ is raised.
+ "
+ icon ~= anIcon ifTrue:[
+ icon := anIcon.
+ self iconChanged
+ ]
+!
+
+label
+ "returns the label
+ "
+ ^ label
+
+!
+
+label:aLabel
+ "set the label; if label changed, a notification
+ is raised.
+ "
+ label ~= aLabel ifTrue:[
+ label := aLabel.
+ self changed.
+ ]
+
+!
+
+setIcon:anIcon
+ "set the icon without any change notification
+ "
+ icon := anIcon
+!
+
+setLabel:aLabel
+ "set the label without any change notification
+ "
+ label := aLabel
+!
+
+setLabel:aLabel icon:anIcon
+ "set the label and icon without any change notification
+ "
+ label := aLabel.
+ icon := anIcon.
+! !
+
+!HierarchicalItem class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libwidg2/HierarchicalItem.st,v 1.1 1999-05-23 12:56:18 cg Exp $'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HierarchicalList.st Sun May 23 14:56:33 1999 +0200
@@ -0,0 +1,307 @@
+List subclass:#HierarchicalList
+ instanceVariableNames:'root showRoot application monitoringTask monitoringTaskDelay'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'AAA-Model'
+!
+
+!HierarchicalList class methodsFor:'documentation'!
+
+documentation
+"
+ Hierarchical Lists are mostly like List, but adding and removing
+ elements are handled by the items itself.
+ Special change notifications are emitted, whenever the list
+ changed.
+
+ [Instance variables:]
+ root <HierarchicalItem> first item into list
+ showRoot <Boolean> show or hide root item
+ application <Application> the user is able to set an application
+ which can be accessed by an item.
+ [author:]
+ Claus Atzkern
+
+ [see also:]
+ HierarchicalItem
+ HierarchicalListView
+"
+
+
+! !
+
+!HierarchicalList methodsFor:'accessing look'!
+
+showRoot
+ "show or hide root item
+ "
+ ^ showRoot ? true
+
+
+!
+
+showRoot:aBoolean
+ "show or hide root item
+ "
+ aBoolean ~~ self showRoot ifTrue:[
+ showRoot := aBoolean.
+
+ root notNil ifTrue:[
+ showRoot ifTrue:[super addFirst:root]
+ ifFalse:[super removeFirst]
+ ]
+ ]
+
+! !
+
+!HierarchicalList methodsFor:'accessing monitoring task'!
+
+monitoringTaskDelay
+ "get the delay time of the monitoring task measured in seconds
+ or nil( monitoring disabled ). The task runs through all items
+ of the list performing #monitoringCycle and than at end of the
+ list the task is suspended for monitoringTaskDelay seconds.
+ "
+ ^ monitoringTaskDelay
+!
+
+monitoringTaskDelay:inSecondsOrNil
+ "set the delay time of the monitoring task measured in seconds
+ or nil( monitoring disabled ). The task runs through all items
+ of the list performing #monitoringCycle and than at end of the
+ list the task is suspended for monitoringTaskDelay seconds.
+ "
+ monitoringTaskDelay := inSecondsOrNil.
+
+ inSecondsOrNil isNil ifTrue:[
+ self stopMonitoringTask
+ ] ifFalse:[
+ self startMonitoringTask
+ ].
+! !
+
+!HierarchicalList methodsFor:'accessing mvc'!
+
+application
+ "returns the responsible application; if no application is defined,
+ nil is returned
+ "
+ ^ application
+!
+
+application:anApplication
+ "set the responsible application
+ "
+ application := anApplication
+!
+
+applicationsDo:aOneArgBlock
+ "evaluate the block on each dependent application
+ "
+ |appl|
+
+ dependents notNil ifTrue:[
+ dependents do:[:aDep|
+ appl := aDep perform:#application ifNotUnderstood:nil.
+
+ appl notNil ifTrue:[
+ aOneArgBlock value:appl
+ ]
+ ]
+ ]
+! !
+
+!HierarchicalList methodsFor:'accessing root'!
+
+root
+ "get the root item
+ "
+ ^ root
+
+!
+
+root:aRoot
+ "set the root item
+ "
+ |children monitoring|
+
+ self stopMonitoringTask.
+
+ root notNil ifTrue:[
+ root parent:nil.
+ root := nil.
+ super removeAll.
+ ].
+
+ (root := aRoot) notNil ifTrue:[
+ root parent:self.
+ children := OrderedCollection new.
+ self showRoot ifTrue:[children add:root].
+ root addVisibleChildrenTo:children.
+ super addAll:children beforeIndex:1
+ ].
+ self startMonitoringTask.
+! !
+
+!HierarchicalList methodsFor:'private'!
+
+isHierarchicalItem
+ "used to decide if the parent is a hierarchical item
+ or the model
+ "
+ ^ false
+!
+
+itemAddAll:aListOfItems beforeIndex:anIndex
+ "insert all items before an index
+ "
+ super addAll:aListOfItems beforeIndex:anIndex
+!
+
+itemChanged:what with:aPara from:anItem
+ "catch notification from item; throw changeNotifications
+ to dependencies;
+ **** don't know what to do with a parameter and argument what
+ **** list protocol ****
+ "
+ |index arrIdx "{ Class: SmallInteger }"|
+
+ (index := super identityIndexOf:anItem) ~~ 0 ifTrue:[
+ arrIdx := index + firstIndex - 1.
+ contentsArray basicAt:arrIdx put:anItem.
+
+ dependents size ~~ 0 ifTrue:[
+ what isNil ifTrue:[self changed:#at: with:index]
+ ifFalse:[self changed:#at: with:(Array with:index with:what)]
+ ]
+ ]
+!
+
+itemRemoveFromIndex:start toIndex:stop
+ "remove the items stored under startIndex up to and including
+ the items under stopIndex.
+ "
+ ^ super removeFromIndex:start toIndex:stop
+!
+
+parentOrModel
+ "always returns nil
+ "
+ ^ nil
+! !
+
+!HierarchicalList methodsFor:'private monitoring task'!
+
+addDependent:anObject
+ "restart the monitoringTask if neccessary
+ "
+ super addDependent:anObject.
+ self startMonitoringTask.
+
+!
+
+removeDependent:anObject
+ "stop the monitoringTask if no more dependencies exists
+ "
+ super removeDependent:anObject.
+
+ dependents size == 0 ifTrue:[
+ self stopMonitoringTask
+ ].
+
+!
+
+startMonitoringTask
+ "start the monitoring task; success only if dependencies exists
+ "
+ |task|
+
+ ( monitoringTask isNil
+ and:[monitoringTaskDelay notNil
+ and:[dependents size ~~ 0]]
+ ) ifTrue:[
+ task := monitoringTask := [|index item delay|
+ index := showRoot ifTrue:[1] ifFalse:[0].
+
+ [true] whileTrue:[
+ item := index == 0 ifTrue:[root]
+ ifFalse:[self at:index ifAbsent:nil].
+
+ item isNil ifTrue:[
+ delay := self monitoringTaskDelay.
+
+ delay isNil ifTrue:[ "/ process might terminate
+ task ~~ monitoringTask ifTrue:[
+ self terminate
+ ].
+ Processor yield
+ ] ifFalse:[
+ Delay waitForSeconds:delay.
+
+ task ~~ monitoringTask ifTrue:[ "/ task has changed
+ self terminate
+ ]
+ ].
+ index := showRoot ifTrue:[1] ifFalse:[0].
+ ] ifFalse:[
+ item monitoringCycle.
+ Processor yield.
+ index := index + 1.
+ ]
+ ]
+ ] forkAt:4.
+ ].
+ ^ true.
+
+
+
+!
+
+stopMonitoringTask
+ "stop the monitoring task
+ "
+ |task|
+
+ (task := monitoringTask) notNil ifTrue:[
+ monitoringTask := nil.
+ task terminate
+ ]
+
+
+! !
+
+!HierarchicalList methodsFor:'protocol'!
+
+childrenFor:anItem
+ "returns the children for an item or an empty list
+ "
+ ^ #()
+!
+
+iconFor:anItem
+ "returns the icon for an item or nil
+ "
+ ^ nil
+!
+
+labelFor:anItem
+ "returns the label for an item or nil
+ "
+ ^ nil
+
+
+!
+
+middleButtonMenuFor:anItem
+ "returns the middleButton menu for an item or nil
+ "
+ ^ nil
+
+
+! !
+
+!HierarchicalList class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libwidg2/HierarchicalList.st,v 1.1 1999-05-23 12:56:14 cg Exp $'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HierarchicalListView.st Sun May 23 14:56:33 1999 +0200
@@ -0,0 +1,889 @@
+SelectionInListModelView subclass:#HierarchicalListView
+ instanceVariableNames:'imageInset imageWidth lineMask lineColor showRoot showLines
+ showLeftIndicators indicatorAction useDefaultIcons icons
+ openIndicator closeIndicator'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'AAA'
+!
+
+!HierarchicalListView class methodsFor:'documentation'!
+
+documentation
+"
+ This class implements a hierarchical list view based on a
+ hierachical list
+
+ [Instance variables:]
+ textStartLeft <Integer> inset between icon and text
+ imageInset <Integer> inset between left side and icon
+ imageWidth <Integer> width of widest icon
+ lineMask <Form> line mask
+ lineColor <Color> line color
+ showRoot <Boolean> root element is shown or hidden
+ derives from the hierachical list.
+ showLines <Boolean> show or hide lines
+ useDefaultIcons <Boolean> use the default icons if no icon
+ for an item is specified
+ icons <IdentityDictionary> list of registered icons;
+ identifier := <key> value := <icon>
+ showLeftIndicators <Boolean> show or hide indicator for most left items
+ indicatorAction <Block> action evaluated if indicator is pressed
+ openIndicator <Icon, Image or Form> expanded indicator
+ closeIndicator <Icon, Image or Form> collapsed indicator
+
+ [author:]
+ Claus Atzkern
+
+ [see also:]
+ ListModelView
+ SelectionInListModelView
+ HierarchicalList
+ HierarchicalItem
+"
+
+
+!
+
+examples
+"
+ [exBegin]
+ |top sel list item|
+
+ list := HierarchicalList new.
+ item := HierarchicalItem::Example labeled:'Root Item'.
+
+ item expand.
+ list showRoot:false.
+ list root:item.
+
+ top := StandardSystemView new; extent:300@300.
+ sel := ScrollableView for:HierarchicalListView miniScroller:true
+ origin:0.0@0.0 corner:1.0@1.0 in:top.
+
+ sel list:list.
+ sel multipleSelectOk:true.
+
+ sel doubleClickAction:[:i| (list at:i) toggleExpand ].
+ sel indicatorAction:[:i| (list at:i) toggleExpand ].
+
+ top open.
+ [exEnd]
+
+
+"
+! !
+
+!HierarchicalListView class methodsFor:'resources'!
+
+closeIndicator
+ "returns a little [+] bitmap"
+
+ <resource: #fileImage>
+
+ ^ Icon constantNamed:#plus
+ ifAbsentPut:[Image fromFile:('xpmBitmaps/plus.xpm')]
+
+
+!
+
+collapsedIcon
+ "returns icon to indicate a collapsed entry
+ "
+ <resource: #fileImage>
+
+ ^ Icon constantNamed:#directory
+ ifAbsentPut:[Image fromFile:('xpmBitmaps/document_images/tiny_yellow_dir.xpm')]
+
+!
+
+emptyIcon
+ "returns icon to indicate an not extendable entry
+ "
+ <resource: #fileImage>
+
+ ^ Icon constantNamed:#plainFile
+ ifAbsentPut:[Image fromFile:('xpmBitmaps/document_images/tiny_file_plain.xpm')]
+
+!
+
+expandedIcon
+ "returns icon to indicate an extended entry
+ "
+ <resource: #fileImage>
+
+ ^ Icon constantNamed:#directoryOpened
+ ifAbsentPut:[Image fromFile:('xpmBitmaps/document_images/tiny_yellow_dir_open.xpm')]
+
+!
+
+openIndicator
+ "returns a little [-] bitmap"
+
+ <resource: #fileImage>
+
+ ^ Icon constantNamed:#minus
+ ifAbsentPut:[Image fromFile:('xpmBitmaps/minus.xpm')]
+
+! !
+
+!HierarchicalListView methodsFor:'accessing'!
+
+list:aList
+ "get the status of <showRoot> from the list
+ "
+ aList notNil ifTrue:[
+ showRoot := aList showRoot
+ ].
+ super list:aList
+! !
+
+!HierarchicalListView methodsFor:'accessing colors'!
+
+lineColor
+ "get the line color
+ "
+ ^ lineColor
+
+
+!
+
+lineColor:aColor
+ "set the line color
+ "
+ (aColor notNil and:[aColor ~= lineColor]) ifTrue:[
+ lineColor := aColor.
+
+ shown ifTrue:[
+ lineColor := lineColor on:device.
+
+ showLines ifTrue:[
+ self invalidate
+ ]
+ ]
+ ]
+
+! !
+
+!HierarchicalListView methodsFor:'accessing look'!
+
+registerKeysAndIcons:aDictionary
+ "register icons by key and value derived from a directory
+ "
+ |image|
+
+ (aDictionary isNil or:[aDictionary isEmpty]) ifTrue:[
+ ^ self
+ ].
+
+ aDictionary keysAndValuesDo:[:aKey :anImage|
+ (image := self imageOnDevice:anImage) notNil ifTrue:[
+ icons at:aKey put:image
+ ]
+ ]
+
+!
+
+showLeftIndicators
+ "show or hide the indicators for the most left items
+ "
+ ^ showLeftIndicators
+
+!
+
+showLeftIndicators:aState
+ "show or hide the indicators for the most left items
+ "
+ aState ~~ showLeftIndicators ifTrue:[
+ showLeftIndicators := aState.
+ self invalidate
+ ].
+
+!
+
+showLines
+ "returns true if lines are shown
+ "
+ ^ showLines
+
+!
+
+showLines:aState
+ "show or hide lines
+ "
+ aState ~~ showLines ifTrue:[
+ showLines := aState.
+ self invalidate
+ ].
+
+!
+
+useDefaultIcons
+ "use the default icons if no icon for an item is specified;
+ ** default: true
+ "
+ ^ useDefaultIcons
+!
+
+useDefaultIcons:aBool
+ "use the default icons if no icon for an item is specified;
+ ** default: true
+ "
+ useDefaultIcons ~~ aBool ifTrue:[
+ useDefaultIcons := aBool.
+
+ shown ifTrue:[
+ self invalidate
+ ]
+ ]
+! !
+
+!HierarchicalListView methodsFor:'actions'!
+
+indicatorAction
+ "if the action is not nil, indicators are shown and a click on the indicator
+ will evaluate the action with none or one argument, the index into the list
+ "
+ ^ indicatorAction
+!
+
+indicatorAction:anAction
+ "if the action is not nil, indicators are shown and a click on the indicator
+ will evaluate the action with none or one argument, the index into the list
+ "
+ |wasNilBefore|
+
+ wasNilBefore := indicatorAction isNil.
+ indicatorAction := anAction.
+
+ wasNilBefore == (anAction isNil) ifTrue:[
+ self invalidate
+ ].
+! !
+
+!HierarchicalListView methodsFor:'change & update'!
+
+lineChangedAt:aLnNr with:arg
+ "line changed at position; check whether line height changed
+ "
+ |item
+ lv "{ Class:SmallInteger }"
+ x0 "{ Class:SmallInteger }"
+ x1 "{ Class:SmallInteger }"
+ h "{ Class:SmallInteger }"
+ y0 "{ Class:SmallInteger }"
+ y1 "{ Class:SmallInteger }"
+ |
+
+ (arg == #icon or:[arg == #hierarchy]) ifFalse:[
+ ^ super lineChangedAt:aLnNr with:arg
+ ].
+ y0 := (self yVisibleOfLine:aLnNr) max:margin.
+ y1 := (self yVisibleOfLine:(aLnNr + 1)) min:(height - margin).
+
+ (h := y1 - y0) > 0 ifTrue:[
+ x0 := margin.
+ x1 := width - margin.
+
+ (item := list at:aLnNr ifAbsent:nil) isNil ifFalse:[
+ lv := item level.
+ x0 := self xOfFigureLevel:lv.
+ x1 := x0 + imageWidth.
+
+ arg == #hierarchy ifTrue:[
+ x0 := self xOfFigureLevel:(lv -1).
+ ].
+ x0 := x0 max:margin.
+ x1 := x1 min:(width - margin).
+
+ x1 > x0 ifFalse:[
+ ^ self
+ ]
+ ].
+ self redrawX:x0 y:y0 width:x1 - x0 height:h.
+ ]
+
+
+
+
+!
+
+update:what with:aPara from:chgObj
+ "get the status of <showRoot> from the list
+ "
+ chgObj == list ifTrue:[
+ showRoot ~~ list showRoot ifTrue:[
+ showRoot := list showRoot.
+ self invalidate.
+ ]
+ ].
+ super update:what with:aPara from:chgObj
+! !
+
+!HierarchicalListView methodsFor:'drawing basics'!
+
+drawElementsFrom:start to:stop x:x0 y:y0 width:aWidth
+ "draw the items between start to stop without clearing the background
+ "
+ |item prevItem parent icon showIndc showIcon showText nxtPrnt
+
+ x1 "{ Class:SmallInteger }"
+ yTop "{ Class:SmallInteger }"
+ yCtr "{ Class:SmallInteger }"
+ yBot "{ Class:SmallInteger }"
+
+ xIndc "{ Class:SmallInteger }"
+ xIcon "{ Class:SmallInteger }"
+ xText "{ Class:SmallInteger }"
+
+ widthLvl "{ Class:SmallInteger }"
+ insetTxt "{ Class:SmallInteger }"
+
+ offIndcX "{ Class:SmallInteger }"
+ offIndcY "{ Class:SmallInteger }"
+ offIconX "{ Class:SmallInteger }"
+ |
+ x1 := x0 + aWidth.
+ widthLvl := imageInset + imageWidth.
+ insetTxt := textStartLeft + imageWidth.
+ offIconX := self xOfFigureLevel:0.
+ showIndc := false.
+
+ indicatorAction notNil ifTrue:[
+ icon := openIndicator extent // 2.
+ offIndcX := imageWidth // 2 - widthLvl.
+ offIndcX := offIndcX - icon x.
+ offIndcY := icon y.
+ ].
+
+ showLines ifTrue:[
+ self drawLinesFrom:start to:stop x:x0 y:y0 width:aWidth
+ ].
+
+ parent := 4711. "/ to force a recompute
+ prevItem := 4711. "/ to force a recomputation of the level
+ yBot := y0.
+
+ start to:stop do:[:anIndex|
+ (item := list at:anIndex ifAbsent:nil) isNil ifTrue:[
+ ^ self "/ list changed
+ ].
+ yTop := yBot.
+ yBot := self yVisibleOfLine:(anIndex + 1).
+ yCtr := yTop + (yBot - yTop // 2).
+
+ (nxtPrnt := item parent) ~~ parent ifTrue:[
+ parent := nxtPrnt.
+ xIcon := prevItem == parent ifTrue:[xIcon + widthLvl]
+ ifFalse:[item level * widthLvl + offIconX].
+
+ xText := xIcon + insetTxt.
+ showIcon := xIcon < x1 and:[xText > x0].
+ showText := xText < x1.
+
+ indicatorAction notNil ifTrue:[
+ xIndc := xIcon + offIndcX.
+
+ showIndc := ( (parent notNil or:[showLeftIndicators])
+ and:[(xIcon > x0 and:[xIndc < x1])]
+ )
+ ]
+ ].
+
+ (showIcon and:[(icon := self figureFor:item) notNil]) ifTrue:[
+ icon width > imageWidth ifTrue:[
+ imageWidth := icon width.
+ StopRedrawSignal raise
+ ].
+ self displayForm:icon x:xIcon y:(yCtr - (icon height // 2))
+ ].
+
+ showText ifTrue:[
+ self drawLabelAt:xText y:yTop h:(yBot - yTop) index:anIndex
+ ].
+ (showIndc and:[item hasChildren]) ifTrue:[
+ icon := item isExpanded ifTrue:[openIndicator] ifFalse:[closeIndicator].
+ self displayForm:icon x:xIndc y:(yCtr - offIndcY)
+ ].
+ prevItem := item.
+ ]
+!
+
+drawLinesFrom:start to:stop x:x0 y:y0 width:aWidth
+ "draw the lines between start to stop without clearing the background
+ "
+ |item prevItem parent p1 p2 showVLines showHLine lv nxtPrnt
+ showRootNot isFirst buildInArray
+
+ x "{ Class:SmallInteger }"
+ x1 "{ Class:SmallInteger }"
+ y "{ Class:SmallInteger }"
+
+ yTop "{ Class:SmallInteger }"
+ yBot "{ Class:SmallInteger }"
+ yCtr "{ Class:SmallInteger }"
+
+ begHLnY "{ Class:SmallInteger }"
+ runHLnY "{ Class:SmallInteger }"
+ begHLnX "{ Class:SmallInteger }"
+ endHLnX "{ Class:SmallInteger }"
+
+ widthLvl "{ Class:SmallInteger }"
+ offsHLnX "{ Class:SmallInteger }"
+
+ level "{ Class:SmallInteger }"
+ startLvI "{ Class:SmallInteger }"
+ startLvX "{ Class:SmallInteger }"
+ limitLvI "{ Class:SmallInteger }"
+ limitLvX "{ Class:SmallInteger }"
+ |
+ x1 := x0 + aWidth.
+ widthLvl := imageInset + imageWidth.
+ offsHLnX := imageWidth // 2 + (self xOfFigureLevel:-1).
+
+ parent := 4711. "/ to force a recompute
+ prevItem := 4711. "/ to force a recomputation of the level
+
+ self setMaskOrigin:(self viewOrigin + (0 @ 1) \\ (lineMask extent)).
+ self paint:lineColor on:bgColor.
+ self mask:lineMask.
+ startLvI := self smallestLevelBetween:start and:stop.
+ startLvX := self xOfFigureLevel:startLvI.
+ limitLvI := 2.
+ limitLvX := limitLvI * widthLvl + offsHLnX.
+
+ buildInArray := Array new:20.
+ buildInArray atAllPut:0.
+
+ showRootNot := showRoot not.
+ yBot := y0.
+ begHLnY := runHLnY := y0.
+
+ start to:stop do:[:anIndex|
+ (item := list at:anIndex ifAbsent:nil) isNil ifTrue:[
+ ^ self mask:nil "/ list changed
+ ].
+ yTop := yBot.
+ yBot := self yVisibleOfLine:(anIndex + 1).
+ yCtr := yTop + (yBot - yTop // 2).
+ anIndex == 1 ifTrue:[ begHLnY := runHLnY := yCtr ].
+
+ (nxtPrnt := item parent) ~~ parent ifTrue:[
+ parent := nxtPrnt.
+
+ prevItem == parent ifTrue:[
+ level := level + 1.
+ begHLnX := endHLnX.
+ ] ifFalse:[
+ level := item level.
+ begHLnX := item level * widthLvl + offsHLnX.
+ ].
+
+ isFirst := parent isNil or:[(showRootNot and:[level == 2])].
+ endHLnX := begHLnX + widthLvl.
+ showVLines := begHLnX >= x0 and:[level > 1].
+ showHLine := x0 < endHLnX and:[x1 > begHLnX].
+
+ (showHLine and:[isFirst]) ifTrue:[
+ showHLine := showLeftIndicators and:[indicatorAction notNil]
+ ]
+ ].
+
+ showHLine ifTrue:[
+ self displayLineFromX:begHLnX y:yCtr toX:endHLnX y:yCtr
+ ].
+
+ showVLines ifTrue:[
+ y := (parent last == item) ifTrue:[yCtr] ifFalse:[yBot].
+ x := begHLnX.
+ p2 := parent.
+ lv := level - 1.
+ self displayLineFromX:x y:runHLnY toX:x y:y.
+
+ [((p1 := p2 parent) notNil and:[(x := x - widthLvl) >= limitLvX])] whileTrue:[
+ (p1 last ~~ p2 and:[x <= x1]) ifTrue:[
+ x >= startLvX ifTrue:[
+ self displayLineFromX:x y:(yTop - 1) toX:x y:yBot
+ ] ifFalse:[
+ buildInArray at:lv put:yBot
+ ].
+ ].
+ lv := lv - 1.
+ p2 := p1
+ ]
+ ].
+ prevItem := item.
+ runHLnY := yCtr.
+ ].
+
+ "/
+ "/ draw outstanding verical lines to left
+ "/
+ x := limitLvX.
+ y := begHLnY.
+
+ limitLvI to:startLvI do:[:i|
+ (yBot := buildInArray at:i) ~~ 0 ifTrue:[
+ self displayLineFromX:x y:y toX:x y:yBot
+ ].
+ x := x + widthLvl.
+ ].
+ ( start == stop
+ and:[(item := list at:start ifAbsent:nil) notNil
+ and:[item isExpanded
+ and:[item hasChildren]]]
+ ) ifTrue:[
+ x := begHLnX + widthLvl.
+
+ (x >= x0 and:[x <= x1]) ifTrue:[
+ yBot := self yVisibleOfLine:(start + 1).
+ yCtr := y0 + (yBot - y0 // 2).
+ self displayLineFromX:x y:yCtr toX:x y:yBot.
+ ]
+ ].
+ self mask:nil.
+
+
+!
+
+redrawLabelFromItem:anItem atY:y h:h
+ "called to redraw a label caused by a selection change
+ "
+ |w "{ Class:SmallInteger }"
+ x "{ Class:SmallInteger }"
+ |
+ x := (self xOfStringLevel:(anItem level)) - (textStartLeft // 2).
+ x := x max:margin.
+
+ (w := width - x) > 0 ifTrue:[
+ self redrawX:x y:y width:w height:h
+ ]
+
+
+! !
+
+!HierarchicalListView methodsFor:'event handling'!
+
+buttonMultiPress:button x:x y:y
+ "handle a button multiPress event
+ "
+ |lnNr|
+
+ enabled ifTrue:[
+ ( (button == 1 or:[button == #select])
+ and:[(lnNr := self indicatorLineAtX:x y:y) notNil]
+ ) ifFalse:[
+ super buttonMultiPress:button x:x y:y
+ ]
+ ]
+!
+
+buttonPress:button x:x y:y
+ "handle a button press event
+ "
+ |lnNr menu item appl|
+
+ enabled ifTrue:[
+ ((button == 2) or:[button == #menu]) ifTrue:[
+ ( (item := self selectedElement) notNil
+ and:[(menu := item middleButtonMenu) notNil]
+ ) ifTrue:[
+ menu isCollection ifTrue:[
+ menu := Menu new fromLiteralArrayEncoding:menu.
+ appl := self application.
+
+ appl notNil ifTrue:[
+ menu findGuiResourcesIn:appl.
+ menu receiver:appl
+ ] ifFalse:[
+ menu receiver:item
+ ]
+ ].
+ ^ menu startUp
+ ].
+ ] ifFalse:[
+ (lnNr := self indicatorLineAtX:x y:y) notNil ifTrue:[
+ (indicatorAction numArgs == 1) ifTrue:[
+ indicatorAction value:lnNr
+ ] ifFalse:[
+ indicatorAction value
+ ].
+ ^ self
+ ]
+ ].
+ super buttonPress:button x:x y:y
+ ]
+!
+
+keyPress:aKey x:x y:y
+ "a key was pressed - handle page-keys here
+ "
+ <resource: #keyboard( #CursorLeft #CursorRight )>
+
+ |item parent index size stop step|
+
+ (aKey == #CursorLeft or:[aKey == #CursorRight]) ifFalse:[
+ ^ super keyPress:aKey x:x y:y
+ ].
+
+ ( enabled
+ and:[(size := list size) > 1
+ and:[(index := self selectedIndex) ~~ 0
+ and:[(item := list at:index ifAbsent:nil) notNil]]]
+ ) ifTrue:[
+ parent := item parent.
+
+ aKey == #CursorLeft ifTrue:[step := -1. stop := 1]
+ ifFalse:[step := 1. stop := size].
+
+ (index + step) to:stop by:step do:[:i|
+ item := list at:i ifAbsent:[^ nil ].
+ item parent ~~ parent ifTrue:[^ self selection:i]
+ ].
+
+ index := aKey == #CursorLeft ifTrue:[size] ifFalse:[1].
+ self selection:index
+ ].
+! !
+
+!HierarchicalListView methodsFor:'fetch resources'!
+
+fetchResources
+ "fetch device colors and ..., to avoid reallocation at redraw time;
+ *** called after a create or snapin to fetch all device resources
+ "
+ |image|
+
+ super fetchResources.
+
+ lineMask := lineMask onDevice:device.
+ lineColor := lineColor onDevice:device.
+ openIndicator := self imageOnDevice:openIndicator.
+ closeIndicator := self imageOnDevice:closeIndicator.
+ imageWidth := 4.
+
+ icons keysAndValuesDo:[:aKey :anImage|
+ image := self imageOnDevice:anImage.
+ icons at:aKey put:image.
+ imageWidth := image width max:imageWidth.
+ ].
+ imageWidth := imageWidth // 2.
+ imageWidth odd ifTrue:[imageWidth := imageWidth + 1].
+ imageWidth := imageWidth * 2.
+
+
+
+! !
+
+!HierarchicalListView methodsFor:'initialize / release'!
+
+initStyle
+ "setup viewStyle specifics
+ "
+ |cls|
+
+ super initStyle.
+
+ cls := self class.
+
+ lineMask := Form width:2 height:2 fromArray:#[16rAA 16r55].
+ icons := IdentityDictionary new.
+
+ icons at:#expanded ifAbsentPut:[cls expandedIcon].
+ icons at:#collapsed ifAbsentPut:[cls collapsedIcon].
+ icons at:#empty ifAbsentPut:[cls emptyIcon].
+
+ openIndicator := self class openIndicator.
+ closeIndicator := self class closeIndicator.
+ lineColor := fgColor.
+ highlightMode := #label.
+ showRoot := true.
+ showLeftIndicators := true.
+ useDefaultIcons := true.
+ showLines := true.
+ imageInset := 4.
+ imageWidth := 8. "/ default
+! !
+
+!HierarchicalListView methodsFor:'private'!
+
+figureFor:anItem
+ "return a (bitmap) figure for an item
+ "
+ |key image w h|
+
+ "/ the item may provide an icon
+ "/ (it knows for itself if its open or closed)
+
+ (key := anItem icon) notNil ifTrue:[
+ (key isImageOrForm and:[key device == device]) ifTrue:[
+ ^ key
+ ].
+
+ (image := icons at:key ifAbsent:nil) notNil ifTrue:[
+ ^ image
+ ].
+
+ key isImageOrForm ifTrue:[
+ image := self imageOnDevice:key.
+ icons at:key put:image.
+ ^ image
+ ]
+ ].
+
+ useDefaultIcons ifFalse:[^ nil].
+
+ "/ ok, item did not return an icon - use default.
+
+ anItem hasChildren ifTrue:[
+ key := anItem isExpanded ifTrue:[#expanded] ifFalse:[#collapsed]
+ ] ifFalse:[
+ key := #empty
+ ].
+ ^ icons at:key
+!
+
+heightOfLineAt:aLineNr
+ "returns the total height for a line at an index, including
+ lineSpacing, the figure and the label
+ "
+ |item icon height|
+
+ item := list at:aLineNr ifAbsent:[^ 4].
+ height := item heightOn:self.
+
+ (icon := self figureFor:item) notNil ifTrue:[
+ height := (item heightOn:self) max:height.
+ ].
+ ^ lineSpacing + height
+
+
+!
+
+indicatorLineAtX:x y:y
+ "returns the lineNumber assigned to an indicator at x/y or nil
+ "
+ |lnNr item x0|
+
+ ( indicatorAction isNil
+ or:[(lnNr := self yVisibleToLineNr:y) isNil
+ or:[(item := list at:lnNr ifAbsent:nil) isNil
+ or:[item hasChildren not]]]
+ ) ifFalse:[
+ x0 := self xOfFigureLevel:(item level - 1).
+
+ (x > x0 and:[(x0 + imageWidth) > x]) ifTrue:[
+ ^ lnNr
+ ]
+ ].
+ ^ nil
+!
+
+smallestLevelBetween:start and:stop
+ "returns the smallest level between a range
+ "
+ |prevItem currParent nextParent item
+
+ lvl "{ Class:SmallInteger }"
+ min "{ Class:SmallInteger }"
+ beg "{ Class:SmallInteger }"
+ |
+
+ prevItem := list at:start ifAbsent:[ ^ 1 ].
+
+ (currParent := prevItem parent) isNil ifTrue:[
+ ^ 1
+ ].
+
+ (min := prevItem level) == 2 ifTrue:[
+ ^ min
+ ].
+ beg := start + 1.
+
+ beg to:stop do:[:i|
+ item := list at:i ifAbsent:[^ min].
+
+ (nextParent := item parent) == currParent ifFalse:[
+ (currParent := nextParent) == prevItem ifFalse:[
+ (lvl := item level) == 2 ifTrue:[
+ ^ 2
+ ].
+ min := min min:lvl
+ ]
+ ].
+ prevItem := item
+ ].
+ ^ min
+
+
+
+
+
+!
+
+widthOfWidestLineBetween:firstLine and:lastLine
+ "return the width of the longest line in pixels
+ "
+ |nprnt pprnt pitem item
+ textX "{ Class: SmallInteger }"
+ level "{ Class: SmallInteger }"
+ width "{ Class: SmallInteger }"
+ deltaX "{ Class: SmallInteger }"
+ startX "{ Class: SmallInteger }"
+ |
+
+ pprnt := 4711. "/ force a computation
+ pitem := 4712. "/ force a computation
+ width := 20.
+ deltaX := imageInset + imageWidth.
+ startX := self xOfStringLevel:1.
+
+ firstLine to:lastLine do:[:idx|
+ item := list at:idx ifAbsent:[^ width + startX].
+
+ (nprnt := item parent) ~~ pprnt ifTrue:[
+ (pprnt := nprnt) == pitem ifTrue:[
+ level := level + 1.
+ textX := textX + deltaX.
+ ] ifFalse:[
+ level := item level.
+ textX := level - 1 * deltaX.
+ ]
+ ].
+ pitem := item.
+ width := (item widthOn:self) max:width
+ ].
+ ^ width + startX
+
+
+!
+
+xOfFigureLevel:aLevel
+ "origin x where to draw the icon
+ "
+ |l "{ Class:SmallInteger }"|
+
+ l := showRoot ifTrue:[aLevel] ifFalse:[aLevel - 1].
+
+ indicatorAction isNil ifTrue:[
+ l := l - 1
+ ] ifFalse:[
+ showLeftIndicators ifFalse:[
+ l := l - 1
+ ]
+ ].
+ ^ (l * (imageInset + imageWidth)) + imageInset - (viewOrigin x)
+!
+
+xOfStringLevel:aLevel
+ "origin x where to draw the text( label )
+ "
+ ^ (self xOfFigureLevel:aLevel) + imageWidth + textStartLeft
+
+! !
+
+!HierarchicalListView class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libwidg2/HierarchicalListView.st,v 1.1 1999-05-23 12:56:26 cg Exp $'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ListModelView.st Sun May 23 14:56:33 1999 +0200
@@ -0,0 +1,1195 @@
+View subclass:#ListModelView
+ instanceVariableNames:'list listHolder textStartLeft viewOrigin enabled fgColor bgColor
+ lineSpacing widthOfContents computeWidthInRange startOfLinesY'
+ classVariableNames:'DefaultForegroundColor DefaultBackgroundColor DefaultShadowColor
+ DefaultLightColor StopRedrawSignal'
+ poolDictionaries:''
+ category:'AAA'
+!
+
+!ListModelView class methodsFor:'documentation'!
+
+documentation
+"
+ This class can only passively display collections of elements.
+ The class doesn't keep its own list, it works directly on
+ the model( List or HierarchicalList ).
+
+ Each list item is obligated to provide 3 services:
+ - heightOn:aGC
+ - widthOn:aGC
+ - displayOn:aGC x:x y:y
+
+ [Instance variables:]
+ list <List-Model> List or HierarchicalList ...
+ listHolder <Model> Model, which keeps a List
+ textStartLeft <Number> left inset of text
+ viewOrigin <Point> the current origin
+ enabled <Boolean> widget is enabled/disabeled
+ fgColor <Color> color to draw characters
+ bgColor <Color> the background
+ lineSpacing <Number> pixels between lines
+ widthOfContents <Number> cached width of widest line
+ computeWidthInRange <Point> used for recompute width of contents
+ startOfLinesY <Collection> keeps all the absolute Y-start positions
+ for each line in the list. The first
+ entry into the list is the top Y inset.
+
+ [author:]
+ Claus Atzkern
+
+ [see also:]
+
+ SelectionInListModelView
+ HierarchicalListView
+ List
+ HierarchicalList
+"
+
+
+
+!
+
+examples
+"
+ [exBegin]
+ |top list view up index|
+
+ list := List new.
+
+ top := StandardSystemView new; extent:300@300.
+ view := ScrollableView for:ListModelView miniScroller:true
+ origin:0.0@0.0 corner:1.0@1.0 in:top.
+ view list:list.
+ top openAndWait.
+ up := true.
+
+ [top shown] whileTrue:[
+ Delay waitForSeconds:0.5.
+
+ up ifTrue:[
+ index := 1 + (list size).
+ list add:('element: ', index printString).
+ up := index < 10
+ ] ifFalse:[
+ list removeIndex:1.
+ up := list isEmpty.
+ ]
+ ].
+ [exEnd]
+
+"
+
+! !
+
+!ListModelView class methodsFor:'initialization'!
+
+initialize
+ "setup the signals"
+
+ StopRedrawSignal := ErrorSignal newSignalMayProceed:false.
+
+
+! !
+
+!ListModelView class methodsFor:'Signal constants'!
+
+stopRedrawSignal
+ ^ StopRedrawSignal
+! !
+
+!ListModelView class methodsFor:'defaults'!
+
+updateStyleCache
+ "extract values from the styleSheet and cache them in class variables"
+
+ <resource: #style (
+ #'text.backgroundColor' #'text.foregroundColor'
+ #'selection.shadowColor' #'selection.lightColor'
+ #'text.font'
+ )>
+
+ DefaultForegroundColor := StyleSheet colorAt:'text.foregroundColor' default:Black.
+ DefaultBackgroundColor := StyleSheet colorAt:'text.backgroundColor'.
+ DefaultShadowColor := StyleSheet colorAt:'selection.shadowColor'.
+ DefaultLightColor := StyleSheet colorAt:'selection.lightColor'.
+ DefaultFont := StyleSheet fontAt:'text.font'.
+
+ "
+ self updateStyleCache
+ "
+
+
+! !
+
+!ListModelView methodsFor:'accessing'!
+
+list
+ "get the list of items
+ "
+ ^ list
+
+
+!
+
+list:aList
+ "set the list of items
+ "
+ |size changed negatedOrg|
+
+ changed := false.
+
+ list notNil ifTrue:[
+ changed := list notEmpty.
+ list removeDependent:self.
+ ].
+ list := aList.
+ self recomputeHeightOfContents.
+
+ list notNil ifTrue:[
+ changed := list notEmpty.
+ list addDependent:self.
+ ].
+ preferredExtent := nil.
+ widthOfContents := nil.
+
+ viewOrigin = (0@0) ifFalse:[
+ self originWillChange.
+ negatedOrg := viewOrigin negated.
+ viewOrigin := (0@0).
+ self originChanged:negatedOrg.
+ ]
+
+ changed ifTrue:[
+ self invalidate.
+ self contentsChanged
+ ]
+
+!
+
+size
+ "returns number of raws
+ "
+ ^ list size
+
+
+! !
+
+!ListModelView methodsFor:'accessing behavior'!
+
+enabled
+ "returns the enabled state
+ "
+ ^ enabled
+
+
+!
+
+enabled:aBoolean
+ "set the enabled state
+ "
+ enabled := aBoolean
+
+
+! !
+
+!ListModelView methodsFor:'accessing items'!
+
+at:anIndex
+ "return the list element at an index
+ "
+ ^ list at:anIndex
+!
+
+at:anIndex ifAbsent:exceptionBlock
+ "return the list element at an index if valid.
+ If the index is invalid, return the result of evaluating
+ the exceptionblock.
+ "
+ list notNil ifTrue:[
+ ^ list at:anIndex ifAbsent:exceptionBlock
+ ].
+ ^ nil.
+!
+
+identityIndexOf:anElement
+ "returns the index of an element or nil
+ "
+ ^ list notNil ifTrue:[list identityIndexOf:anElement]
+ ifFalse:[0]
+
+
+! !
+
+!ListModelView methodsFor:'accessing look'!
+
+backgroundColor
+ "get the background color
+ "
+ ^ bgColor
+
+
+!
+
+backgroundColor:aColor
+ "set the background color
+ "
+ (aColor notNil and:[bgColor ~~ aColor]) ifTrue:[
+ super viewBackground:bgColor.
+
+ self realized ifTrue:[
+ bgColor := aColor on:device.
+ self invalidate
+ ] ifFalse:[
+ bgColor := aColor
+ ]
+ ]
+
+!
+
+font:aFont
+ "set a new font
+ "
+ |oldWidth oldHeight|
+
+ (aFont isNil or:[aFont = font]) ifFalse:[
+ oldWidth := font width.
+ oldHeight := font height.
+
+ super font:aFont.
+
+ (font width) ~~ oldWidth ifTrue:[ "/ force a recomputation
+ preferredExtent := nil.
+ widthOfContents := nil.
+ ].
+ oldHeight ~~ font height ifTrue:[
+ self recomputeHeightOfContents.
+ ].
+ shown ifTrue:[ self invalidate ]
+ ].
+!
+
+foregroundColor
+ "get the foreground color
+ "
+ ^ fgColor
+
+!
+
+foregroundColor:aColor
+ "set the foreground color
+ "
+ (aColor notNil and:[fgColor ~~ aColor]) ifTrue:[
+ self realized ifTrue:[
+ fgColor := aColor on:device.
+ self invalidate
+ ] ifFalse:[
+ fgColor := aColor
+ ]
+ ]
+
+! !
+
+!ListModelView methodsFor:'accessing mvc'!
+
+listHolder
+ "returns the listHolder or nil
+ "
+ ^ listHolder
+!
+
+listHolder:aListHolder
+ "set a new listHolder
+ "
+ |newList|
+
+ listHolder removeDependent:self.
+
+ (listHolder := aListHolder) notNil ifTrue:[
+ listHolder addDependent:self.
+ ].
+ self list:(listHolder value).
+! !
+
+!ListModelView methodsFor:'change & update'!
+
+lineChangedAt:aLnNr with:arg
+ "line changed at position; check whether line height changed
+ "
+ |
+ oldHeight "{ Class:SmallInteger }"
+ dltHeight "{ Class:SmallInteger }"
+ |
+
+
+ (arg notNil and:[(arg == #icon or:[arg == #hierarchy])]) ifTrue:[
+ ^ self
+ ].
+ oldHeight := (self yVisibleOfLine:(aLnNr + 1)) - (self yVisibleOfLine:aLnNr).
+ dltHeight := (self heightOfLineAt:aLnNr) - oldHeight.
+
+ dltHeight == 0 ifTrue:[
+ ^ self redrawLineAt:aLnNr
+ ].
+
+ aLnNr + 1 to:startOfLinesY size do:[:i|
+ startOfLinesY at:i put:((startOfLinesY at:i) + dltHeight)
+ ].
+ self invalidate.
+
+
+!
+
+listChangedInsert:start nItems:nLines
+ "list changed; items are added
+ "
+ |
+ run "{ Class: SmallInteger }"
+ cpyHg "{ Class: SmallInteger }"
+ absY0 "{ Class: SmallInteger }"
+ absY1 "{ Class: SmallInteger }"
+ visY0 "{ Class: SmallInteger }"
+ visY1 "{ Class: SmallInteger }"
+ orgY "{ Class: SmallInteger }"
+ dltY "{ Class: SmallInteger }"
+ maxHg "{ Class: SmallInteger }"
+ |
+
+ nLines == 0 ifTrue:[^ self ].
+ self listSizeChanged:start nLines:nLines.
+ shown not ifTrue:[^ self].
+
+ startOfLinesY addAll:(Array new:nLines) beforeIndex:start + 1.
+ absY0 := startOfLinesY at:start.
+ absY1 := absY0.
+ run := start.
+
+ nLines timesRepeat:[
+ absY1 := absY1 + (self heightOfLineAt:run).
+ run := run + 1.
+ startOfLinesY at:run put:absY1.
+ ].
+
+ dltY := absY1 - absY0.
+ run + 1 to:(startOfLinesY size) do:[:i|
+ startOfLinesY at:i put:((startOfLinesY at:i) + dltY)
+ ].
+
+ orgY := viewOrigin y.
+ absY1 := absY0 + dltY.
+ visY0 := absY0 - orgY.
+ visY1 := absY1 - orgY.
+ maxHg := height - margin.
+
+ absY0 < orgY ifTrue:[
+ self originWillChange.
+ viewOrigin y:(dltY + orgY).
+ self originChanged:(0 @ dltY).
+ ].
+
+ (self sensor hasDamageFor:self) ifTrue:[
+ ^ self contentsChanged.
+ ].
+
+ (visY0 >= maxHg or:[visY1 <= margin]) ifTrue:[
+ ^ self contentsChanged
+ ].
+ visY0 := visY0 max:margin.
+ visY1 := visY1 min:maxHg.
+
+ (start == list size or:[(cpyHg := maxHg - visY1) < 20]) ifTrue:[
+ visY1 := maxHg
+ ] ifFalse:[
+ self catchExpose.
+
+ self copyFrom:self x:0 y:visY0
+ toX:0 y:visY1
+ width:width height:cpyHg async:true.
+
+ self waitForExpose
+ ].
+
+ self redrawX:margin y:visY0
+ width:width - margin - margin
+ height:(visY1 - visY0).
+ self contentsChanged.
+
+
+!
+
+listChangedRemove:start toIndex:stop
+ "list changed; items are removed
+ "
+ |noRedraw
+ size "{ Class: SmallInteger }"
+ absY0 "{ Class: SmallInteger }"
+ absY1 "{ Class: SmallInteger }"
+ visY0 "{ Class: SmallInteger }"
+ visY1 "{ Class: SmallInteger }"
+ orgY "{ Class: SmallInteger }"
+ orgX "{ Class: SmallInteger }"
+ dltY "{ Class: SmallInteger }"
+ cpyHg "{ Class: SmallInteger }"
+ maxHg "{ Class: SmallInteger }"
+ |
+
+ (size := stop - start + 1) == 0 ifTrue:[
+ ^ self
+ ].
+ self listSizeChanged:start nLines:(size negated).
+ shown not ifTrue:[^ self].
+ absY0 := self yAbsoluteOfLine:start.
+ absY1 := self yAbsoluteOfLine:(stop + 1).
+ dltY := absY1 - absY0.
+
+ startOfLinesY removeFromIndex:start toIndex:stop.
+
+ start to:(startOfLinesY size) do:[:i|
+ absY0 := startOfLinesY at:i.
+ startOfLinesY at:i put:(absY0 - dltY).
+ ].
+
+ orgY := viewOrigin y.
+ orgX := viewOrigin x.
+
+ absY0 := self yAbsoluteOfLine:start.
+ absY1 := absY0 + dltY.
+ visY0 := absY0 - orgY.
+ visY1 := absY1 - orgY.
+ maxHg := height - margin.
+
+ (list size == 0 or:[(orgY ~~ 0 and:[self maxViewOriginY == 0])]) ifTrue:[
+ (orgX ~~ 0 or:[orgY ~~ 0]) ifTrue:[
+ self originWillChange.
+ viewOrigin := 0@0.
+ self originChanged:((orgX @ orgY) negated).
+ ].
+ self invalidate.
+ ^ self contentsChanged
+ ].
+
+ visY0 < margin ifTrue:[
+ noRedraw := visY1 <= margin.
+ noRedraw ifTrue:[dltY := dltY negated] ifFalse:[dltY := visY0].
+
+ self originWillChange.
+ viewOrigin y:(dltY + orgY).
+ self originChanged:(0 @ dltY).
+ ] ifFalse:[
+ noRedraw := visY0 >= maxHg
+ ].
+
+ (noRedraw or:[self sensor hasDamageFor:self]) ifFalse:[
+ visY0 := visY0 max:margin.
+ cpyHg := maxHg - visY1.
+
+ cpyHg > 20 ifTrue:[
+ self catchExpose.
+ self copyFrom:self x:0 y:visY1 toX:0 y:visY0
+ width:width height:cpyHg async:true.
+ self waitForExpose.
+ visY0 := visY0 + cpyHg.
+ ].
+
+ self redrawX:margin y:visY0
+ width:width - margin - margin
+ height:(maxHg - visY0).
+ ].
+ self contentsChanged.
+
+
+
+
+
+
+!
+
+update:what with:aPara from:chgObj
+ "catch and handle any notification raised from the list model
+ or list holder
+ "
+ |arg1 arg2|
+
+ chgObj ~~ list ifTrue:[
+ chgObj == listHolder ifTrue:[self list:(listHolder value)]
+ ifFalse:[super update:what with:aPara from:chgObj].
+ ^ self
+ ].
+
+ aPara isCollection ifFalse:[
+ what == #at: ifTrue:[ ^ self lineChangedAt:aPara with:nil].
+ what == #insert: ifTrue:[ ^ self listChangedInsert:aPara nItems:1 ].
+ what == #remove: ifTrue:[ ^ self listChangedRemove:aPara toIndex:aPara ].
+
+ ^ self
+ ].
+
+ arg1 := aPara at:1.
+ arg2 := aPara at:2.
+
+ what == #at: ifTrue:[ ^ self lineChangedAt:arg1 with:arg2 ].
+ what == #insertCollection: ifTrue:[ ^ self listChangedInsert:arg1 nItems:arg2 ].
+ what == #removeFrom: ifTrue:[ ^ self listChangedRemove:arg1 toIndex:arg2 ].
+
+ what == #replace: ifTrue:[
+ arg1 to:arg2 do:[:i| self lineChangedAt:i with:nil ]
+ ]
+
+
+
+
+
+! !
+
+!ListModelView methodsFor:'drawing'!
+
+displayElement:anItem atX:x y:y h:h
+ "draw a label at x/y; fg/bg colors are already set
+ "
+ |yC "{ Class: SmallInteger }"
+ y0 "{ Class: SmallInteger }"
+ |
+ anItem notNil ifTrue:[
+ yC := (anItem heightOn:self) + 1 - h // 2.
+ y0 := y - yC.
+
+ anItem isImageOrForm ifFalse:[
+ (anItem isString or:[anItem isKindOf:LabelAndIcon]) ifTrue:[
+ y0 := y0 + font ascent
+ ]
+ ].
+ anItem displayOn:self x:x y:y0
+ ]
+
+
+!
+
+redraw
+ "redraw complete view
+ "
+ self redrawX:0 y:0 width:width height:height.
+
+
+!
+
+redrawLineAt:aLineNr
+ "redraw a specific line
+ "
+ |y0 "{ Class:SmallInteger }"
+ y1 "{ Class:SmallInteger }"
+ yB "{ Class:SmallInteger }"
+ |
+
+ (shown and:[aLineNr notNil]) ifTrue:[
+ yB := height - margin.
+ y0 := (self yVisibleOfLine:aLineNr) max:margin.
+
+ y0 < yB ifTrue:[
+ y1 := (self yVisibleOfLine:(aLineNr + 1)) min:yB.
+ y1 > margin ifTrue:[
+ self redrawX:0 y:y0 width:width height:(y1 - y0)
+ ]
+ ]
+ ]
+
+!
+
+redrawX:x y:y width:w height:h
+ "redraw part of myself immediately, given logical coordinates
+ "
+ |savClip start stop yAbs|
+
+ shown ifFalse:[^ self].
+
+ self paint:bgColor.
+ self fillRectangleX:x y:y width:w height:h.
+
+ (start := self yVisibleToLineNr:y) isNil ifTrue:[
+ ^ self
+ ].
+ yAbs := y + h.
+
+ (stop := self yVisibleToLineNr:yAbs) isNil ifTrue:[
+ stop := list size.
+ ] ifFalse:[
+ yAbs == (startOfLinesY at:stop) ifTrue:[
+ stop := stop - 1
+ ].
+ ].
+
+ savClip := clipRect.
+ self clippingRectangle:(Rectangle left:x top:y width:w height:h).
+
+ StopRedrawSignal handle:[:ex| self invalidate.
+ ex return
+ ] do:[ self drawFrom:start
+ to:stop
+ x:x
+ y:(self yVisibleOfLine:start)
+ width:w
+ ].
+
+ self clippingRectangle:savClip.
+
+
+
+
+! !
+
+!ListModelView methodsFor:'event handling'!
+
+keyPress:aKey x:x y:y
+ "a key was pressed - handle page-keys here
+ "
+ <resource: #keyboard( #PreviousPage #NextPage #HalfPageUp #HalfPageDown
+ #BeginOfText #EndOfText #ScrollUp #ScrollDown
+ )>
+
+ |n sensor|
+
+ list size ~~ 0 ifTrue:[
+ (aKey == #PreviousPage) ifTrue:[^ self pageUp].
+ (aKey == #NextPage) ifTrue:[^ self pageDown].
+ (aKey == #HalfPageUp) ifTrue:[^ self halfPageUp].
+ (aKey == #HalfPageDown) ifTrue:[^ self halfPageDown].
+ (aKey == #BeginOfText) ifTrue:[^ self scrollToTop].
+ (aKey == #EndOfText) ifTrue:[^ self scrollToBottom].
+
+ (aKey == #ScrollUp or:[aKey == #ScrollDown]) ifTrue:[
+ sensor := self sensor.
+
+ n := sensor notNil ifTrue:[1 + (sensor compressKeyPressEventsWithKey:aKey)]
+ ifFalse:[1].
+
+ n := n * self verticalScrollStep.
+
+ aKey == #ScrollUp ifTrue:[self scrollUp:n]
+ ifFalse:[self scrollDown:n].
+ ^ self
+ ].
+ ].
+ super keyPress:aKey x:x y:y
+!
+
+wantsFocusWithButtonPress
+ "catch the keyboard focus on button click
+ "
+ ^ true
+
+
+! !
+
+!ListModelView methodsFor:'fetch resources'!
+
+colorOnDevice:aColor
+ "fetch a device colors
+ "
+ ^ aColor notNil ifTrue:[aColor on:device] ifFalse:[nil]
+
+!
+
+imageOnDevice:anImage
+ "associate image to device and clear pixel mask
+ returns the new image.
+ "
+ |image|
+
+ (image := anImage) notNil ifTrue:[
+ image device ~~ device ifTrue:[
+ image := image copy.
+ ].
+ image := image on:device.
+ image := image clearMaskedPixels.
+ ].
+ ^ image
+
+! !
+
+!ListModelView methodsFor:'initialize / release'!
+
+create
+ "fetch device dependent resources
+ "
+ super create.
+ self fetchResources.
+ self recomputeHeightOfContents.
+!
+
+destroy
+ "remove dependencies
+ "
+ listHolder removeDependent:self.
+ list removeDependent:self.
+ super destroy
+
+!
+
+initStyle
+ "setup viewStyle specifics
+ "
+ super initStyle.
+
+ DefaultBackgroundColor notNil ifTrue:[
+ viewBackground := DefaultBackgroundColor
+ ].
+ lineSpacing := 0.
+ textStartLeft := 2.
+ fgColor := DefaultForegroundColor.
+ bgColor := viewBackground.
+ startOfLinesY := OrderedCollection new.
+
+ startOfLinesY add:(2 + margin). "/ top inset of first line
+
+ DefaultShadowColor notNil ifTrue:[
+ shadowColor := DefaultShadowColor
+ ].
+
+ DefaultLightColor notNil ifTrue:[
+ lightColor := DefaultLightColor
+ ].
+!
+
+initialize
+ "setup default attributes
+ "
+ super initialize.
+
+ viewOrigin := 0@0.
+ bitGravity := #NorthWest.
+ enabled := true.
+!
+
+recreate
+ "fetch device dependent resources
+ "
+ super recreate.
+ self fetchResources.
+
+! !
+
+!ListModelView methodsFor:'private'!
+
+yAbsoluteOfLine:aLineNr
+ "given a lineNr, return y-coordinate absolute
+ "
+ ^ startOfLinesY at:aLineNr ifAbsent:[startOfLinesY last].
+!
+
+yVisibleOfLine:aLineNr
+ "given a lineNr, return y-coordinate in view
+ "
+ |y|
+
+ y := startOfLinesY at:aLineNr ifAbsent:[startOfLinesY last].
+ ^ y - viewOrigin y
+
+
+!
+
+yVisibleToLineNr:yVisible
+ "returns the line number assigned to a physical y or nil
+ "
+ |
+ yAbs "{ Class: SmallInteger}"
+ yMid "{ Class: SmallInteger}"
+ size "{ Class: SmallInteger}"
+ next "{ Class: SmallInteger}"
+ low "{ Class: SmallInteger}"
+ high "{ Class: SmallInteger}"
+ middle "{ Class: SmallInteger}"
+ |
+
+ (size := startOfLinesY size) == 1 ifTrue:[^ nil]. "/ EMPTY LIST
+ yAbs := yVisible + viewOrigin y.
+ yAbs > (startOfLinesY at:size) ifTrue:[^ nil]. "/ END OF LIST
+
+ middle := size.
+ size := size - 1.
+ high := size.
+ low := 1.
+
+ [(next := low + high // 2) ~~ middle] whileTrue:[
+ yMid := startOfLinesY at:(middle := next).
+
+ yMid < yAbs ifTrue:[low := middle]
+ ifFalse:[high := middle]
+ ].
+
+ yAbs < yMid ifTrue:[
+ ^ (middle - 1) max:1.
+ ].
+ middle < size ifTrue:[
+ next := middle + 1.
+ ^ (startOfLinesY at:next) > yAbs ifTrue:[middle] ifFalse:[next]
+ ].
+ ^ size
+! !
+
+!ListModelView methodsFor:'protocol'!
+
+drawFrom:start to:stop x:x y:y width:width
+ "draw lines from start to stop.
+ clipping and clearing the background is already done
+ "
+ |y0 "{ Class:SmallInteger }"
+ y1 "{ Class:SmallInteger }"
+ x0 "{ Class:SmallInteger }"
+ hg "{ Class:SmallInteger }"
+ |
+ self paint:fgColor on:bgColor.
+
+ x0 := textStartLeft - viewOrigin x.
+ y1 := y.
+
+ start to:stop do:[:i|
+ y0 := y1.
+ y1 := self yVisibleOfLine:(i + 1).
+ self displayElement:(list at:i ifAbsent:nil) atX:x0 y:y0 h:(y1 - y0).
+ ].
+
+!
+
+fetchResources
+ "fetch device colors and ..., to avoid reallocation at redraw time;
+ *** called after a create or snapin to fetch all device resources
+ "
+ fgColor := self colorOnDevice:fgColor.
+ bgColor := self colorOnDevice:bgColor.
+ font := font on:device.
+
+!
+
+heightOfLineAt:aLineNr
+ "returns the total height for a line at an index( including lineSpacing ... )
+ "
+ |item|
+
+ item := list at:aLineNr ifAbsent:[^ 4].
+ ^ lineSpacing + (item heightOn:self)
+!
+
+listSizeChanged:anIndex nLines:noLines
+ "list size changed; information is stored to recompute the
+ width if required( preferredExtent, horizontal scroller ... ).
+ see: widthOfContents
+ *** if nLines is negative, lines are removed otherwise added.
+ "
+ |start "{ Class:SmallInteger }"
+ stop "{ Class:SmallInteger }"
+ size "{ Class:SmallInteger }"
+ |
+ preferredExtent := nil.
+
+ widthOfContents isNil ifTrue:[ "/ recompute whole list
+ ^ self
+ ].
+
+ (noLines < 0 or:[(size := list size) <= noLines]) ifTrue:[
+ widthOfContents := nil. "/ force recompute whole list
+ ^ self
+ ].
+
+ stop := anIndex + noLines - 1. "/ recompute a range
+ start := anIndex.
+
+ computeWidthInRange notNil ifTrue:[
+ start := computeWidthInRange y.
+ stop < start ifTrue:[stop := start min:size].
+ start := (computeWidthInRange x) min:anIndex.
+ ].
+ computeWidthInRange := start@stop
+!
+
+widthOfWidestLineBetween:firstLine and:lastLine
+ "return the width in pixels of the widest line in a range
+ "
+ |lbl item
+ width "{ Class: SmallInteger }"
+ |
+ width := textStartLeft.
+
+ firstLine to:lastLine do:[:anIndex|
+ item := list at:anIndex ifAbsent:[^ width + textStartLeft ].
+ width := (item widthOn:self) max:width
+ ].
+ ^ width + textStartLeft
+
+
+
+
+! !
+
+!ListModelView methodsFor:'recomputation'!
+
+preferredExtent
+ "returns the preferred extent
+ "
+ |x y|
+
+ preferredExtent isNil ifTrue:[
+ y := self heightOfContents.
+ x := self widthOfContents.
+ preferredExtent := x@y
+ ].
+ ^ preferredExtent
+
+
+!
+
+recomputeHeightOfContents
+ "recompute all the y positions
+ "
+ |yAbs "{ Class: SmallInteger }"
+ lnHg "{ Class: SmallInteger }"
+ |
+
+ yAbs := startOfLinesY at:1. "/ top inset of first line
+ startOfLinesY removeAll.
+ startOfLinesY add:yAbs.
+
+ 1 to:(list size) do:[:anIndex|
+ lnHg := self heightOfLineAt:anIndex.
+ startOfLinesY add:(yAbs := yAbs + lnHg)
+ ].
+! !
+
+!ListModelView methodsFor:'scroller interface'!
+
+heightOfContents
+ "return the height of the contents in pixels
+ "
+ ^ startOfLinesY last
+!
+
+innerHeight
+ "returns the inner height of the contents shown
+ "
+ ^ height - margin - margin
+
+!
+
+innerWidth
+ "returns the inner width of the contents shown
+ "
+ ^ width - margin - margin
+
+!
+
+maxViewOriginY
+ "returns the maximum possible y of the view origin
+ "
+ ^ (self heightOfContents - self innerHeight) max:0
+
+
+!
+
+verticalScrollStep
+ "return the amount to scroll when stepping up/down.
+ "
+ ^ 10
+
+!
+
+viewOrigin
+ "return the viewOrigin; thats the coordinate of the contents
+ which is shown topLeft in the view.
+ "
+ ^ viewOrigin
+
+!
+
+widthOfContents
+ "return the width of the contents in pixels
+ "
+ |range
+ size "{ Class:SmallInteger }"
+ start "{ Class:SmallInteger }"
+ stop "{ Class:SmallInteger }"
+ |
+ (widthOfContents notNil and:[computeWidthInRange isNil]) ifTrue:[
+ ^ widthOfContents + textStartLeft
+ ].
+ range := computeWidthInRange.
+ computeWidthInRange := nil.
+ preferredExtent := nil.
+ size := list size.
+
+ size == 0 ifTrue:[
+ widthOfContents := 20.
+ ] ifFalse:[
+ widthOfContents isNil ifTrue:[
+ widthOfContents := self widthOfWidestLineBetween:1 and:size
+ ] ifFalse:[
+ start := range x.
+ stop := range y min:size.
+
+ start > stop ifFalse:[
+ size := self widthOfWidestLineBetween:start and:stop.
+
+ widthOfContents < size ifTrue:[
+ widthOfContents := size
+ ]
+ ]
+ ]
+ ].
+ ^ widthOfContents + textStartLeft
+!
+
+xOriginOfContents
+ "return the horizontal origin of the contents in pixels
+ "
+ ^ viewOrigin x
+
+!
+
+yOriginOfContents
+ "return the vertical origin of the contents in pixels
+ "
+ ^ viewOrigin y
+
+! !
+
+!ListModelView methodsFor:'scrolling'!
+
+halfPageDown
+ "scroll down half a page
+ "
+ self scrollDown:(width // 2).
+
+!
+
+halfPageUp
+ "scroll up half a page
+ "
+ self scrollUp:(width // 2).
+
+!
+
+scrollTo:anOrigin redraw:doRedraw
+ "change origin to have newOrigin be visible at the top-left.
+ "
+ |newOrg dltOrg sensor winGroup
+ innerWT "{ Class:SmallInteger }"
+ innerHG "{ Class:SmallInteger }"
+ h "{ Class:SmallInteger }"
+ x "{ Class:SmallInteger }"
+ x0 "{ Class:SmallInteger }"
+ x1 "{ Class:SmallInteger }"
+ y "{ Class:SmallInteger }"
+ w "{ Class:SmallInteger }"
+ y0 "{ Class:SmallInteger }"
+ y1 "{ Class:SmallInteger }"
+ dX "{ Class:SmallInteger }"
+ dY "{ Class:SmallInteger }"
+ |
+ (shown and:[(sensor := self sensor) notNil]) ifFalse:[
+ ^ self
+ ].
+
+ winGroup := self windowGroup.
+
+ [sensor hasExposeEventFor:nil] whileTrue:[
+ winGroup processExposeEvents
+ ].
+ innerWT := self innerWidth.
+ innerHG := self innerHeight.
+
+ h := viewOrigin y.
+
+ (y := anOrigin y) > h ifTrue:[ "/ end of contents
+ y > (dY := self maxViewOriginY) ifTrue:[
+ y := dY max:h
+ ]
+ ] ifFalse:[
+ y := y max:0.
+ ].
+
+ (x := anOrigin x) > 0 ifTrue:[
+ x := x min:(self widthOfContents - innerWT).
+ ].
+ x := x max:0.
+ newOrg := (x @ y).
+ dltOrg := newOrg - viewOrigin.
+ dX := dltOrg x.
+ dY := dltOrg y.
+
+ (dX == 0 and:[dY == 0]) ifTrue:[
+ ^ self
+ ].
+ self originWillChange.
+ viewOrigin := newOrg.
+
+ doRedraw ifFalse:[
+ ^ self originChanged:dltOrg
+ ].
+
+ dY ~~ 0 ifTrue:[ "/ SCROLL VERTICAL
+ dY := dY abs.
+
+ (dX ~~ 0 or:[innerHG - dY < 20]) ifTrue:[
+ self redraw.
+ ] ifFalse:[ "/ COPY VERTICAL
+ y0 := y1 := margin + dY.
+ h := innerHG - dY.
+
+ dltOrg y < 0 ifTrue:[y0 := margin. y := y0]
+ ifFalse:[y1 := margin. y := y1 + h].
+
+ self catchExpose.
+ self copyFrom:self x:margin y:y0 toX:margin y:y1 width:innerWT height:h async:true.
+ self waitForExpose.
+ self redrawX:margin y:y width:innerWT height:(innerHG - h).
+ ]
+ ] ifFalse:[ "/ SCROLL HORIZONTAL
+ dX := dX abs.
+
+ innerWT - dX < 20 ifTrue:[
+ self redraw.
+ ] ifFalse:[ "/ COPY HORIZONTAL
+ x0 := x1 := dX + margin.
+ w := width - dX - margin.
+
+ dltOrg x < 0 ifTrue:[x0 := x := margin ]
+ ifFalse:[x1 := margin. x := w].
+
+ self catchExpose.
+ self copyFrom:self x:x0 y:margin toX:x1 y:margin width:w height:innerHG async:true.
+ self waitForExpose.
+ self redrawX:x y:margin width:(width - w) height:innerHG.
+ ]
+ ].
+ self originChanged:dltOrg.
+
+!
+
+scrollToLine:aLineNumber
+ "make line visible
+ "
+ |y "{ Class:SmallInteger }"
+ l "{ Class:SmallInteger }"
+ |
+ (aLineNumber notNil and:[aLineNumber between:1 and:(list size)]) ifFalse:[
+ ^ self
+ ].
+
+ y := self yVisibleOfLine:aLineNumber.
+
+ y < margin ifTrue:[
+ y := margin - y.
+ ] ifFalse:[
+ y := self yVisibleOfLine:(1 + aLineNumber).
+ l := height - margin.
+ y > l ifFalse:[^ self].
+ y := l - y.
+ ].
+ self scrollTo:(viewOrigin - (0 @ y)).
+
+
+! !
+
+!ListModelView class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libwidg2/ListModelView.st,v 1.1 1999-05-23 12:56:33 cg Exp $'
+! !
+ListModelView initialize!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SelectionInListModelView.st Sun May 23 14:56:33 1999 +0200
@@ -0,0 +1,1349 @@
+ListModelView subclass:#SelectionInListModelView
+ instanceVariableNames:'selection multipleSelectOk actionBlock doubleClickActionBlock
+ clickLine highlightMode useIndex hilightFgColor hilightBgColor
+ hilightLevel hilightFrameColor hilightStyle dragAccessPoint
+ dropTarget dropSource'
+ classVariableNames:'DefaultHilightStyle DefaultHilightBackgroundColor
+ DefaultHilightForegroundColor DefaultHilightLevel
+ DefaultHilightFrameColor'
+ poolDictionaries:''
+ category:'AAA'
+!
+
+!SelectionInListModelView class methodsFor:'documentation'!
+
+documentation
+"
+ SelectionInListModelView is mostly like SelectionInListView,
+ but derives from the ListModelView and thus the list is kept
+ by the model.
+
+ [Instance variables:]
+ selection <misc> the current selection. nil, a number or collection of numbers
+ multipleSelectOk <Boolean> allow/disallow multiple selections( default:false )
+ actionBlock <Block> action evaluated on single click
+ doubleClickActionBlock <Block> action evaluated on double click
+ clickPosition <Point> internal use
+ highlightMode <Symbol> how to draw the selection
+ useIndex <Boolean> representation of the model selection
+ hilightFgColor <Color>
+ hilightBgColor <Color> how highlighted items are drawn
+ hilightLevel <Integer> level to draw selections (i.e. for 3D effect)
+ hilightFrameColor <Color> rectangle around highlighted items
+ hilightStyle <Boolean> actions on widget are enabled/disabled
+
+ [author:]
+ Claus Atzkern
+
+ [see also:]
+
+ ListModelView
+ HierarchicalListView
+"
+
+
+!
+
+examples
+"
+ [exBegin]
+ |top list view|
+
+ list := List new.
+
+ 1 to:100 do:[:i| list add:('element: ', i printString) ].
+ top := StandardSystemView new; extent:300@300.
+ view := ScrollableView for:SelectionInListModelView miniScroller:true
+ origin:0.0@0.0 corner:1.0@1.0 in:top.
+ view list:list.
+ top open.
+ [exEnd]
+
+
+ [exBegin]
+ |top list view item|
+
+ list := HierarchicalList new.
+ item := HierarchicalItem::Example labeled:'Test'.
+ item expand.
+ list showRoot:false.
+ list root:item.
+
+ top := StandardSystemView new; extent:300@300.
+ view := ScrollableView for:SelectionInListModelView miniScroller:true
+ origin:0.0@0.0 corner:1.0@1.0 in:top.
+
+ view list:list.
+ view doubleClickAction:[:i| (list at:i) toggleExpand ].
+ top open.
+ [exEnd]
+
+"
+
+! !
+
+!SelectionInListModelView class methodsFor:'defaults'!
+
+updateStyleCache
+ "extract values from the styleSheet and cache them in class variables"
+
+ <resource: #style (
+ #'selection.hilightForegroundColor' #'selection.hilightBackgroundColor'
+ #'selection.hilightFrameColor' #'selection.hilightLevel'
+ #'selection.foregroundColor' #'selection.backgroundColor'
+ #'selection.shadowColor' #'selection.lightColor'
+ #'selection.font' #'selection.hilightStyle'
+ #'text.foregroundColor'
+ )>
+
+ DefaultHilightForegroundColor := StyleSheet colorAt:'selection.hilightForegroundColor'.
+ DefaultHilightBackgroundColor := StyleSheet colorAt:'selection.hilightBackgroundColor'.
+ DefaultHilightFrameColor := StyleSheet colorAt:'selection.hilightFrameColor'.
+ DefaultHilightLevel := StyleSheet at:'selection.hilightLevel' default:0.
+ DefaultHilightStyle := StyleSheet at:'selection.hilightStyle' default:(StyleSheet name).
+ DefaultForegroundColor := StyleSheet colorAt:'selection.foregroundColor'.
+ DefaultBackgroundColor := StyleSheet colorAt:'selection.backgroundColor'.
+ DefaultShadowColor := StyleSheet colorAt:'selection.shadowColor'.
+ DefaultLightColor := StyleSheet colorAt:'selection.lightColor'.
+
+ DefaultForegroundColor isNil ifTrue:[
+ DefaultForegroundColor := StyleSheet colorAt:'text.foregroundColor' default:Black
+ ].
+ "
+ self updateStyleCache
+ "
+
+
+! !
+
+!SelectionInListModelView methodsFor:'accessing'!
+
+list:aList
+ "get the status of <showRoot> from the list
+ "
+ selection notNil ifTrue:[
+ selection := nil.
+ self selectionChanged.
+ ].
+ ^ super list:aList
+! !
+
+!SelectionInListModelView methodsFor:'accessing behavior'!
+
+highlightMode
+ "get the mode how to draw a selected line:
+ #line draw whole line selected
+ #label draw label selected
+ "
+ ^ highlightMode
+
+
+!
+
+highlightMode:aMode
+ "set the mode how to draw a selected line:
+ #line draw whole line selected
+ #label draw label selected
+ "
+ (aMode ~~ highlightMode and:[(aMode == #label or:[aMode == #line])]) ifTrue:[
+ highlightMode := aMode.
+
+ shown ifTrue:[
+ self selectionDo:[:i|self redrawSelectionAt:i]
+ ]
+ ]
+
+!
+
+multipleSelectOk
+ "allow/disallow multiple selections; the default is false
+ "
+ ^ multipleSelectOk
+
+
+!
+
+multipleSelectOk:aState
+ "allow/disallow multiple selections; the default is false
+ "
+ aState == multipleSelectOk ifFalse:[
+ multipleSelectOk := aState.
+ selection notNil ifTrue:[
+ multipleSelectOk ifTrue:[
+ selection := Array with:selection
+ ] ifFalse:[
+ selection size ~~ 1 ifTrue:[
+ selection := nil.
+ self invalidate.
+ self selectionChanged
+ ] ifFalse:[
+ selection := selection at:1
+ ]
+ ]
+ ]
+ ]
+
+!
+
+useIndex
+ "set/clear the useIndex flag.
+ the selection writen to the model are the indices into the list
+ or the elements selected.
+ "
+ ^ useIndex
+
+
+!
+
+useIndex:aBoolean
+ "set/clear the useIndex flag.
+ the selection writen to the model are the indices into the list
+ or the elements selected.
+ "
+ useIndex := aBoolean ? true
+
+
+! !
+
+!SelectionInListModelView methodsFor:'actions'!
+
+action:aOneArgAction
+ "set the action block to be performed on select
+ "
+ actionBlock := aOneArgAction
+
+
+!
+
+doubleClickAction:aOneArgAction
+ "set the action block to be performed on doubleclick
+ "
+ doubleClickActionBlock := aOneArgAction
+
+
+! !
+
+!SelectionInListModelView methodsFor:'change & update'!
+
+argForChangeMessage
+ "return the argument for a selectionChange;
+ depending on the setting of useIndex, this is either the numeric
+ index of the selection or the value (i.e. the string)
+ "
+ useIndex ifFalse:[
+ ^ self selectionValue
+ ].
+ selection isNil ifTrue:[
+ ^ multipleSelectOk ifTrue:[#()] ifFalse:[0]
+ ].
+ ^ multipleSelectOk ifTrue:[selection copy] ifFalse:[selection]
+!
+
+getSelectionFromModel
+ "get selection from model; returns a selection or nil
+ "
+ |value newSel|
+
+ ( model isNil
+ or:[(value := model value) isNil
+ or:[value == 0]]
+ ) ifTrue:[
+ ^ nil
+ ].
+
+ multipleSelectOk ifFalse:[
+ useIndex ifFalse:[
+ (value := self identityIndexOf:value) == 0 ifTrue:[
+ ^ nil
+ ]
+ ].
+ ^ value
+ ].
+
+ "/ MULTI SELECT
+
+ value isEmpty ifTrue:[^ nil].
+ useIndex ifTrue:[^ value].
+
+ newSel := OrderedCollection new.
+
+ value do:[:el||index|
+ (index := self identityIndexOf:el) ~~ 0 ifTrue:[
+ newSel add:index
+ ]
+ ].
+
+ ^ newSel notEmpty ifTrue:[newSel] ifFalse:[nil]
+!
+
+listSizeChanged:aLnNr nLines:aDeltaLines
+ "update selection
+ "
+ |newSel noChg size changed|
+
+ super listSizeChanged:aLnNr nLines:aDeltaLines.
+
+ selection isNil ifTrue:[^ self].
+
+ list size == 0 ifTrue:[
+ ^ self deselectWithoutRedraw
+ ].
+ multipleSelectOk ifFalse:[
+ selection >= aLnNr ifTrue:[
+ selection := selection + aDeltaLines.
+
+ (aDeltaLines < 0 and:[selection < aLnNr]) ifTrue:[
+ self deselectWithoutRedraw
+ ] ifFalse:[
+ (model notNil and:[useIndex]) ifTrue:[
+ model setValue:selection
+ ]
+ ]
+ ].
+ ^ self
+ ].
+
+ size := selection size.
+ changed := false.
+
+ aDeltaLines < 0 ifFalse:[
+ 1 to:size do:[:anIndex|
+ newSel := selection at:anIndex.
+
+ newSel >= aLnNr ifTrue:[
+ changed := true.
+ selection at:anIndex put:(newSel + aDeltaLines)
+ ]
+ ].
+ (changed and:[useIndex and:[model notNil]]) ifTrue:[
+ model setValue:(selection copy)
+ ].
+ ^ self
+ ].
+ noChg := 0.
+
+ 1 to:size do:[:anIndex|
+ newSel := selection at:anIndex.
+
+ newSel >= aLnNr ifTrue:[
+ newSel := newSel + aDeltaLines.
+ changed := true.
+
+ newSel < aLnNr ifTrue:[
+ noChg := noChg + 1.
+ newSel := 0.
+ ].
+ selection at:anIndex put:newSel
+ ]
+ ].
+
+ noChg ~~ 0 ifTrue:[
+ noChg == size ifTrue:[
+ self deselectWithoutRedraw
+ ] ifFalse:[
+ selection := selection select:[:i| i ~~ 0].
+ self selectionChanged
+ ]
+ ] ifFalse:[
+ (changed and:[useIndex and:[model notNil]]) ifTrue:[
+ model setValue:(selection copy)
+ ]
+ ]
+
+!
+
+selectionChanged
+ "selection has changed. Call actionblock and/or send changeMessage if defined
+ "
+ |value arg|
+
+ (model isNil and:[actionBlock isNil]) ifTrue:[
+ ^ self
+ ].
+
+ arg := self argForChangeMessage.
+
+ model notNil ifTrue:[
+ model removeDependent:self.
+ self sendChangeMessage:#value: with:arg.
+ model addDependent:self.
+ ].
+
+ actionBlock notNil ifTrue:[
+ (actionBlock numArgs) == 1 ifTrue:[
+ actionBlock value:arg
+ ] ifFalse:[
+ actionBlock value
+ ]
+ ].
+
+!
+
+update:something with:aParameter from:changedObject
+ "one of my models changed
+ "
+ |newSelection|
+
+ changedObject == model ifTrue:[
+ newSelection := self getSelectionFromModel.
+
+ newSelection ~= selection ifTrue:[
+ self setSelection:newSelection
+ ]
+ ] ifFalse:[
+ super update:something with:aParameter from:changedObject
+ ].
+! !
+
+!SelectionInListModelView methodsFor:'drag & drop'!
+
+canDrag
+ "returns true if dragging is enabled
+ "
+ ^ dropSource notNil
+
+!
+
+dropSource
+ "returns the dropSource or nil
+ "
+ ^ dropSource
+
+!
+
+dropSource:aDropSourceOrNil
+ "set the dropSource or nil
+ "
+ dropSource := aDropSourceOrNil.
+
+!
+
+dropTarget
+ "returns the dropTarget or nil
+ "
+ ^ dropTarget
+
+
+!
+
+dropTarget:aDropTragetOrNil
+ "set the dropTarget or nil
+ "
+ dropTarget := aDropTragetOrNil.
+
+!
+
+startDragAt:aPoint
+ "start drag at a point
+ "
+ dropSource notNil ifTrue:[
+ dropSource startDragSelector notNil ifTrue:[
+ dropSource startDragIn:self at:aPoint
+ ] ifFalse:[
+ DragAndDropManager new startDragFrom:self
+ dropSource:dropSource
+ offset:#center
+ ]
+ ]
+
+! !
+
+!SelectionInListModelView methodsFor:'drawing'!
+
+drawFrom:start to:stop x:x y:y width:w
+ "draw the lines between start to stop without clearing the background
+ "
+ |selY selH
+ y0 "{ Class:SmallInteger }"
+ y1 "{ Class:SmallInteger }"
+ hg "{ Class:SmallInteger }"
+ |
+ (highlightMode == #line and:[selection notNil]) ifTrue:[
+ "/ redraw the background for all selected lines in the invalid range
+
+ self selectionDo:[:lnNr|
+ (lnNr between:start and:stop) ifTrue:[
+ selY isNil ifTrue:[
+ selY := OrderedCollection new.
+ selH := OrderedCollection new.
+ self paint:hilightBgColor.
+ ].
+ y0 := self yVisibleOfLine:lnNr.
+ y1 := self yVisibleOfLine:(lnNr + 1).
+ hg := y1 - y0.
+ selY add:y0.
+ selH add:hg.
+ self fillRectangleX:x y:y0 width:w height:hg.
+ ]
+ ]
+ ].
+ self drawElementsFrom:start to:stop x:x y:y width:w.
+
+ "/ draw selection frames
+ selY notNil ifTrue:[
+ 1 to:selY size do:[:i|
+ self drawSelectionFrameAtX:x y:(selY at:i) width:w h:(selH at:i)
+ ]
+ ].
+
+
+
+!
+
+drawLabelAt:x y:y h:h index:anIndex
+ "draw the label at position x/y without clearing the background
+ "
+ |label item
+ w "{ Class:SmallInteger }"
+ x0 "{ Class:SmallInteger }"
+ |
+ item := list at:anIndex ifAbsent:[^ self].
+
+ (self isInSelection:anIndex) ifTrue:[
+ highlightMode == #label ifTrue:[
+ w := (item widthOn:self) + textStartLeft.
+ x0 := x - (textStartLeft // 2).
+ self paint:hilightBgColor.
+ self fillRectangleX:x0 y:y width:w height:h.
+ self drawSelectionFrameAtX:x0 y:y width:w h:h.
+ ].
+ self paint:hilightFgColor on:hilightBgColor
+ ] ifFalse:[
+ self paint:fgColor on:bgColor.
+ ].
+ self displayElement:item atX:x y:y h:h
+
+
+!
+
+drawSelectionFrameAtX:x0 y:y0 width:w h:h
+ "redraw selection frame for a line
+ "
+ |
+ x1 "{ Class: SmallInteger }"
+ x "{ Class: SmallInteger }"
+ y "{ Class: SmallInteger }"
+ |
+ x1 := x0 + w.
+
+ hilightFrameColor notNil ifTrue:[
+ hilightLevel == 0 ifTrue:[
+ self paint:hilightFrameColor.
+
+ highlightMode == #line ifTrue:[
+ self displayLineFromX:x0 y:y0 toX:x1 y:y0.
+ y := y0 + h - 1.
+ self displayLineFromX:x0 y:y toX:x1 y:y.
+ ] ifFalse:[
+ self displayRectangleX:x0 y:y0 width:w height:h
+ ].
+ ^ self.
+ ]
+ ] ifFalse:[
+ hilightStyle == #motif ifTrue:[
+ self paint:bgColor.
+ y := y0 + 1.
+ highlightMode == #line ifTrue:[
+ self displayLineFromX:x0 y:y toX:x1 y:y.
+ y := y0 + h - 2.
+ self displayLineFromX:x0 y:y toX:x1 y:y.
+ ] ifFalse:[
+ self displayRectangleX:x0 + 1 y:y width:w - 2 height:h - 2
+ ]
+ ]
+ ].
+
+ hilightLevel ~~ 0 ifTrue:[
+ "/ draw edge
+ highlightMode == #line ifTrue:[
+ x := margin.
+ x1 := width - x - x.
+ ] ifFalse:[
+ x := x0.
+ x1 := w.
+ ].
+ self drawEdgesForX:x y:y0 width:x1 height:h level:hilightLevel.
+ ]
+
+!
+
+redrawSelectionAt:anIndex
+ "called to redraw a line caused by a change of the selection
+ "
+ |item
+ h "{ Class:SmallInteger }"
+ y0 "{ Class:SmallInteger }"
+ y1 "{ Class:SmallInteger }"
+ |
+ shown ifFalse:[^ self].
+
+ y0 := (self yVisibleOfLine:anIndex) max:margin.
+ y1 := (self yVisibleOfLine:(anIndex + 1)) min:(height - margin).
+
+ (h := y1 - y0) > 0 ifTrue:[
+ ( highlightMode == #label
+ and:[(item := list at:anIndex ifAbsent:nil) notNil]
+ ) ifTrue:[
+ self redrawLabelFromItem:item atY:y0 h:h
+ ] ifFalse:[
+ self redrawX:margin y:y0 width:(self innerWidth) height:h
+ ]
+ ]
+! !
+
+!SelectionInListModelView methodsFor:'event handling'!
+
+buttonMotion:buttonMask x:x y:y
+ "mouse-move while button was pressed - handle selection changes
+ "
+ |sensor idx p cY oY lnNr h|
+
+ (enabled and:[selection notNil]) ifFalse:[^ self].
+
+ dragAccessPoint notNil ifTrue:[
+ p := x @ y.
+
+ (dragAccessPoint dist:p) > 5.0 ifTrue:[
+ dragAccessPoint := nil.
+ self startDragAt:p
+ ].
+ ^ self
+ ].
+
+ (multipleSelectOk and:[self sensor leftButtonPressed]) ifFalse:[
+ ^ self
+ ].
+
+ clickLine isNil ifTrue:[
+ ^ self
+ ].
+ cY := self yVisibleOfLine:clickLine.
+ oY := cY.
+
+ y < cY ifTrue:[
+ (lnNr := clickLine - 1) == 0 ifTrue:[^ self].
+ cY := self yVisibleOfLine:lnNr.
+ h := oY - cY.
+ ] ifFalse:[
+ ( (lnNr := clickLine + 1) > list size
+ or:[(cY := self yVisibleOfLine:lnNr) > y]
+ ) ifTrue:[
+ ^ self
+ ].
+ h := cY - oY.
+ ].
+ selection := selection asOrderedCollection.
+
+ (selection removeIdentical:lnNr ifAbsent:nil) isNil ifTrue:[
+ selection add:lnNr
+ ].
+ clickLine := lnNr.
+
+ (cY between:margin and:(height - h)) ifTrue:[
+ self redrawSelectionAt:lnNr
+ ] ifFalse:[
+ self scrollToLine:lnNr.
+ ].
+ self selectionChanged
+
+!
+
+buttonMultiPress:button x:x y:y
+ "button was pressed multiple - handle a doubleClick action
+ "
+ clickLine := nil.
+ dragAccessPoint := nil.
+
+ enabled ifFalse:[^ self].
+
+ ((button == 1) or:[button == #select]) ifFalse:[
+ ^ super buttonMultiPress:button x:x y:y
+ ].
+ self doubleClicked
+!
+
+buttonPress:button x:x y:y
+ "a button was pressed - handle selection here
+ "
+ |lnNr sensor start step list changed|
+
+ clickLine := nil.
+ dragAccessPoint := nil.
+
+ enabled ifFalse:[^ self].
+
+ (button == 1 or:[button == #select]) ifFalse:[
+ ^ super buttonPress:button x:x y:y
+ ].
+
+ (lnNr := self yVisibleToLineNr:y) isNil ifTrue:[
+ ^ self
+ ].
+ clickLine := lnNr.
+
+ (multipleSelectOk and:[(sensor := self sensor) notNil]) ifTrue:[
+ sensor ctrlDown ifTrue:[
+ (self isInSelection:lnNr) ifTrue:[self removeFromSelection:lnNr]
+ ifFalse:[self addToSelection:lnNr].
+ ^ self selectionChanged
+
+ ].
+ (selection notNil and:[sensor shiftDown]) ifTrue:[
+ start := selection at:1.
+ step := lnNr < start ifTrue:[-1] ifFalse:[1].
+ list := selection.
+ selection := OrderedCollection new.
+ changed := false.
+
+ start to:lnNr by:step do:[:i|
+ selection add:i.
+ (list identityIndexOf:i) == 0 ifTrue:[
+ changed := true.
+ self redrawSelectionAt:i "/ redraw selected
+ ]
+ ].
+ list do:[:i|
+ (selection identityIndexOf:i) == 0 ifTrue:[
+ changed := true.
+ self redrawSelectionAt:i "/ redraw unselected
+ ].
+ ].
+ changed ifTrue:[
+ self selectionChanged
+ ].
+ ^ self
+ ]
+ ].
+
+ (self canDrag and:[self isInSelection:lnNr]) ifTrue:[
+ dragAccessPoint := x @ y
+ ] ifFalse:[
+ self selectedIndex ~~ lnNr ifTrue:[
+ self selectWithoutScroll:lnNr.
+ self selectionChanged
+ ]
+ ]
+!
+
+buttonRelease:button x:x y:y
+ "a button was released
+ "
+ enabled ifTrue:[
+ (dragAccessPoint notNil and:[clickLine notNil]) ifTrue:[
+ self selectedIndex ~~ clickLine ifTrue:[
+ self selectWithoutScroll:clickLine.
+ self selectionChanged
+ ]
+ ]
+ ].
+ clickLine := nil.
+ dragAccessPoint := nil.
+
+
+!
+
+characterPress:aKey x:x y:y
+ " a character is pressed - lookup and change selection
+ "
+ |lnNr size idx sensor stp to1 fr2|
+
+ (enabled and:[(size := self size) > 1]) ifFalse:[
+ ^ self
+ ].
+ lnNr := self firstInSelection ? 0.
+
+ ((sensor := self sensor) notNil and:[sensor shiftDown]) ifTrue:[
+ stp := -1. "/ search backward
+ to1 := 1.
+ fr2 := size.
+ ] ifFalse:[
+ stp := 1. "/ search forward
+ to1 := size.
+ fr2 := 1.
+ ].
+
+ idx := self findLineFrom:lnNr+stp to:to1 by:stp startingWithCharacter:aKey.
+
+ idx == 0 ifTrue:[
+ idx := self findLineFrom:fr2 to:lnNr-stp by:stp startingWithCharacter:aKey
+ ].
+ idx ~~ 0 ifTrue:[^ self selection:idx]
+!
+
+doubleClicked
+ "handle a double click
+ "
+ (doubleClickActionBlock notNil and:[self numberOfSelections == 1]) ifTrue:[
+ (doubleClickActionBlock numArgs == 1) ifTrue:[
+ doubleClickActionBlock value:(self selectedIndex)
+ ] ifFalse:[
+ doubleClickActionBlock value
+ ]
+ ]
+
+!
+
+findLineFrom:aStart to:aStop by:aStep startingWithCharacter:aCharacter
+ "find a line starting with a character
+ "
+ |item char lbl cmp
+ size "{ Class:SmallInteger }"
+ start "{ Class:SmallInteger }"
+ stop "{ Class:SmallInteger }"
+ |
+ (size := list size) ~~ 0 ifTrue:[
+ aStep > 0 ifTrue:[
+ aStart > aStop ifTrue:[^ 0].
+ ] ifFalse:[
+ (aStep == 0 or:[aStop > aStart]) ifTrue:[^ 0]
+ ].
+
+ start := aStart < 0 ifTrue:[1] ifFalse:[aStart min:size].
+ stop := aStop < 0 ifTrue:[1] ifFalse:[aStop min:size].
+ char := aCharacter asUppercase.
+
+ start to:stop by:aStep do:[:anIndex|
+ item := list at:anIndex ifAbsent:[^ 0]. "/ list changed
+ lbl := item perform:#string ifNotUnderstood:nil.
+
+ lbl notNil ifTrue:[
+ cmp := lbl string at:1 ifAbsent:nil.
+
+ cmp notNil ifTrue:[
+ (char == cmp or:[char == cmp asUppercase]) ifTrue:[
+ ^ anIndex
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ 0
+
+
+!
+
+keyPress:aKey x:x y:y
+ "a key was pressed - handle page-keys here
+ "
+ <resource: #keyboard( #Return #CursorUp #CursorDown )>
+
+ |sensor n size lineNr|
+
+ enabled ifFalse:[
+ ^ super keyPress:aKey x:x y:y
+ ].
+ aKey == #Return ifTrue:[
+ self numberOfSelections == 1 ifTrue:[self doubleClicked].
+ ^ self
+ ].
+
+ aKey isCharacter ifTrue:[
+ ^ self characterPress:aKey x:x y:y
+ ].
+
+ (aKey == #CursorUp or:[aKey == #CursorDown]) ifFalse:[
+ ^ super keyPress:aKey x:x y:y
+ ].
+
+ (size := self size) == 0 ifTrue:[
+ ^ self
+ ].
+
+ lineNr := self selectedIndex.
+ sensor := self sensor.
+
+ sensor notNil ifTrue:[
+ n := (1 + (sensor compressKeyPressEventsWithKey:aKey)) \\ size.
+ n == 0 ifTrue:[^ self].
+ ] ifFalse:[
+ n := 1
+ ].
+
+ aKey == #CursorUp ifTrue:[
+ lineNr == 0 ifTrue:[lineNr := size + 1].
+ (n := lineNr - n) <= 0 ifTrue:[n := size + n]
+ ] ifFalse:[
+ (n := lineNr + n) > size ifTrue:[n := n - size]
+ ].
+ self selection:n
+! !
+
+!SelectionInListModelView methodsFor:'initialize / release'!
+
+fetchResources
+ "fetch device colors and ..., to avoid reallocation at redraw time;
+ *** called after a create or snapin to fetch all device resources
+ "
+
+ super fetchResources.
+
+ hilightFgColor := self colorOnDevice:hilightFgColor.
+ hilightBgColor := self colorOnDevice:hilightBgColor.
+ hilightFrameColor := self colorOnDevice:hilightFrameColor.
+!
+
+initStyle
+ "setup viewStyle specifics
+ "
+ |h|
+
+ super initStyle.
+
+ hilightFrameColor := nil.
+ hilightLevel := 0.
+ hilightStyle := DefaultHilightStyle.
+ highlightMode := #line.
+ textStartLeft := 4.
+
+ device hasGrayscales ifTrue:[
+ "
+ must get rid of these hard codings
+ "
+ (hilightStyle == #next) ifTrue:[
+ hilightFgColor := fgColor.
+ hilightBgColor := White.
+ hilightFrameColor := fgColor
+ ] ifFalse:[
+ (hilightStyle == #motif) ifTrue:[
+ fgColor := White.
+ bgColor := Grey.
+ viewBackground := bgColor.
+ hilightFgColor := bgColor.
+ hilightBgColor := fgColor.
+ ] ifFalse:[
+ (hilightStyle == #openwin) ifTrue:[
+ hilightFgColor := fgColor.
+ hilightBgColor := Color grey.
+ ]
+ ]
+ ]
+ ].
+
+ hilightFgColor isNil ifTrue:[
+ hilightFgColor := bgColor.
+ ].
+ hilightBgColor isNil ifTrue:[
+ hilightBgColor := fgColor.
+ ].
+ DefaultForegroundColor notNil ifTrue:[
+ fgColor := DefaultForegroundColor
+ ].
+ DefaultBackgroundColor notNil ifTrue:[
+ bgColor := viewBackground := DefaultBackgroundColor
+ ].
+
+ DefaultHilightForegroundColor notNil ifTrue:[
+ hilightFgColor := DefaultHilightForegroundColor
+ ].
+ DefaultHilightBackgroundColor notNil ifTrue:[
+ hilightBgColor := DefaultHilightBackgroundColor
+ ].
+ DefaultHilightFrameColor notNil ifTrue:[
+ hilightFrameColor := DefaultHilightFrameColor
+ ].
+ DefaultHilightLevel notNil ifTrue:[
+ hilightLevel := DefaultHilightLevel
+ ].
+ lineSpacing := 2 * (hilightLevel abs).
+
+ (hilightStyle == #motif) ifTrue:[
+ lineSpacing := lineSpacing max:6.
+ ] ifFalse:[
+ lineSpacing := lineSpacing max:4.
+ ].
+ hilightFgColor isNil ifTrue:[
+ hilightFgColor := bgColor.
+ hilightBgColor := fgColor
+ ].
+!
+
+initialize
+ "setup default attributes/behavior
+ "
+ super initialize.
+
+ multipleSelectOk := false.
+ useIndex := true.
+
+!
+
+realize
+ "get selection from model; scroll to selection
+ "
+ selection := self getSelectionFromModel.
+
+ super realize.
+
+ selection notNil ifTrue:[
+ useIndex ifTrue:[selection := selection copy].
+ self makeSelectionVisible.
+ ]
+! !
+
+!SelectionInListModelView methodsFor:'protocol'!
+
+drawElementsFrom:start to:stop x:x y:y width:width
+ "draw the items between start to stop without clearing the background
+ "
+ |y0 "{ Class:SmallInteger }"
+ y1 "{ Class:SmallInteger }"
+ x0 "{ Class:SmallInteger }"
+ |
+ x0 := textStartLeft - viewOrigin x.
+ y1 := y.
+
+ start to:stop do:[:i|
+ y0 := y1.
+ y1 := self yVisibleOfLine:(i + 1).
+ self drawLabelAt:x0 y:y0 h:(y1 - y0) index:i.
+ ].
+
+
+!
+
+redrawLabelFromItem:anItem atY:y h:h
+ "called to redraw a label caused by a selection changed
+ "
+ |
+ x0 "{ Class:SmallInteger }"
+ x1 "{ Class:SmallInteger }"
+ |
+ x0 := textStartLeft // 2 - viewOrigin x.
+ x1 := x0 + textStartLeft + (anItem widthOn:self).
+ x0 := x0 max:margin.
+ x1 := x1 min:(self innerWidth).
+
+ x1 > x0 ifTrue:[
+ self redrawX:x0 y:y width:(x1 - x0) height:h.
+ ]
+! !
+
+!SelectionInListModelView methodsFor:'selection'!
+
+deselect
+ "clear selection
+ "
+ self selection:nil
+
+!
+
+firstInSelection
+ "returns line number of first element selected or nil
+ "
+ |lineNr|
+
+ selection notNil ifTrue:[
+ ^ multipleSelectOk ifTrue:[selection at:1] ifFalse:[selection]
+ ].
+ ^ nil
+
+
+!
+
+hasSelection
+ "returns true if a selection exists
+ "
+ ^ selection notNil
+
+!
+
+isInSelection:aNumber
+ "return true, if line, aNumber is in the selection
+ "
+ selection isNil ifTrue:[^ false].
+
+ ^ multipleSelectOk ifFalse:[aNumber == selection]
+ ifTrue:[selection includes:aNumber]
+!
+
+lastInSelection
+ "returns line number of last element selected or nil
+ "
+ |lineNr|
+
+ selection notNil ifTrue:[
+ ^ multipleSelectOk ifTrue:[selection last] ifFalse:[selection]
+ ].
+ ^ nil
+
+
+!
+
+numberOfSelections
+ "return the number of selected items
+ "
+ selection isNil ifTrue:[^ 0].
+ ^ multipleSelectOk ifFalse:[1] ifTrue:[selection size]
+
+
+!
+
+selectElement:anElement
+ "select the element. Scroll to make the new selection visible.
+ Model and/or actionBlock notification IS done.
+ "
+ |index|
+
+ (index := self identityIndexOf:anElement) ~~ 0 ifTrue:[
+ self selection:index
+ ]
+
+!
+
+selectedElement
+ "return the single selected item or nil
+ "
+ |index|
+
+ index := self selectedIndex.
+ ^ index ~~ 0 ifTrue:[self at:index ifAbsent:nil] ifFalse:[nil]
+
+!
+
+selectedIndex
+ "returns the index of the selected line or 0. If more
+ lines are selected, 0 is returned
+ "
+ selection notNil ifTrue:[
+ multipleSelectOk ifFalse:[^ selection].
+ selection size == 1 ifTrue:[^ selection at:1]
+ ].
+ ^ 0
+!
+
+selection
+ "return the selection index or collection of indices
+ in case of multiple selection enabled
+ "
+ ^ selection
+
+!
+
+selection:aNumberOrNil
+ "select line, aNumber or deselect if argument is nil;
+ scroll to make the selected line visible.
+ The model and/or actionBlock IS notified.
+ "
+ |oldSelection|
+
+ oldSelection := selection.
+ self setSelection:aNumberOrNil.
+
+ selection ~= oldSelection ifTrue:[
+ self selectionChanged
+ ]
+
+
+!
+
+selectionDo:aBlock
+ "perform aBlock for each nr in the selection.
+ For single selection, it is called once for the items nr.
+ For multiple selections, it is called for each.
+ "
+ selection notNil ifTrue:[
+ multipleSelectOk ifTrue:[
+ selection do:aBlock
+ ] ifFalse:[
+ aBlock value:selection
+ ].
+ ].
+
+
+!
+
+selectionValue
+ "return the selection value. For multiple selections a collection
+ containing the elements is returned. Otherwise the selected element
+ "
+ selection isNil ifTrue:[
+ ^ multipleSelectOk ifTrue:[#()] ifFalse:[nil]
+ ].
+ multipleSelectOk ifTrue:[
+ ^ selection collect:[:nr | list at:nr ifAbsent:nil ]
+ ].
+ ^ list at:selection ifAbsent:nil
+!
+
+setSelection:aNumberOrNilOrCollection
+ "select line, aNumber or deselect if argument is nil;
+ scroll to make the selected line visible.
+ *** No model and/or actionBlock notification is done here.
+ "
+ self selectWithoutScroll:aNumberOrNilOrCollection.
+
+ selection notNil ifTrue:[
+ self makeSelectionVisible
+ ]
+
+!
+
+toggleSelection:aNumber
+ "toggle selection-state of entry, aNumber.
+ *** No model and/or actionBlock notification is done here.
+ "
+ aNumber notNil ifTrue:[
+ (self isInSelection:aNumber) ifTrue:[
+ self removeFromSelection:aNumber
+ ] ifFalse:[
+ self addToSelection:aNumber
+ ]
+ ]
+! !
+
+!SelectionInListModelView methodsFor:'selection private'!
+
+addToSelection:aNumber
+ "add a number to the selection. No scrolling is done.
+ *** No model and/or actionBlock notification is done here.
+ "
+ |newSelect oldSelect|
+
+ (aNumber notNil and:[aNumber between:1 and:(self size)]) ifFalse:[
+ ^ self
+ ].
+ multipleSelectOk ifFalse:[
+ oldSelect == selection ifTrue:[^ self].
+ oldSelect := selection.
+ selection := aNumber.
+ oldSelect notNil ifTrue:[self redrawSelectionAt:oldSelect].
+ ] ifTrue:[
+ selection isNil ifTrue:[
+ selection := Array with:aNumber.
+ ] ifFalse:[
+ (selection includes:aNumber) ifTrue:[^ self].
+ selection := selection copyWith:aNumber.
+ ].
+ ].
+ self redrawSelectionAt:aNumber.
+!
+
+deselectWithoutRedraw
+ "set selection without redraw, scrolling.
+ The model and/or actionBlock IS notified.
+ "
+ selection notNil ifTrue:[
+ selection := nil.
+ self selectionChanged
+ ]
+!
+
+makeSelectionVisible
+ "scroll to make the selection line visible
+ "
+ |lineNr|
+
+ (lineNr := self firstInSelection) notNil ifTrue:[
+ self scrollToLine:lineNr
+ ]
+
+
+!
+
+removeFromSelection:aNumber
+ "remove aNumber from the selection and redraw line;
+ *** No model and/or actionBlock notification is done here.
+ "
+ selection notNil ifTrue:[
+ multipleSelectOk ifTrue:[
+ (selection includes:aNumber) ifTrue:[
+ selection size == 1 ifTrue:[
+ selection := nil
+ ] ifFalse:[
+ selection := selection copyWithout:aNumber
+ ].
+ self redrawSelectionAt:aNumber
+ ]
+ ] ifFalse:[
+ aNumber == selection ifFalse:[
+ selection := nil.
+ self redrawSelectionAt:aNumber
+ ]
+ ]
+ ]
+
+!
+
+selectWithoutScroll:aNumberOrNilOrCollection
+ "select line, aNumber or deselect if argument is nil;
+ scroll to make the selected line visible.
+ *** No model and/or actionBlock notification is done here.
+ "
+ |oldSelect|
+
+ oldSelect := selection.
+ selection := self validateSelection:aNumberOrNilOrCollection.
+
+ (shown and:[selection ~= oldSelect]) ifFalse:[
+ ^ self
+ ].
+
+ multipleSelectOk ifFalse:[
+ oldSelect notNil ifTrue:[self redrawSelectionAt:oldSelect].
+ selection notNil ifTrue:[self redrawSelectionAt:selection].
+ ] ifTrue:[
+ selection isNil ifTrue:[
+ oldSelect do:[:i|self redrawSelectionAt:i].
+ ] ifFalse:[
+ oldSelect isNil ifTrue:[
+ selection do:[:i|self redrawSelectionAt:i].
+ ] ifFalse:[
+ selection do:[:i|
+ (oldSelect includes:i) ifFalse:[self redrawSelectionAt:i]
+ ].
+ oldSelect do:[:i|
+ (selection includes:i) ifFalse:[self redrawSelectionAt:i]
+ ].
+ ]
+ ]
+ ].
+
+
+
+!
+
+selectionWithoutRedraw:aSelection
+ "set selection without redraw, scrolling.
+ The model and/or actionBlock IS notified.
+ "
+ selection ~= aSelection ifTrue:[
+ selection := aSelection.
+ self selectionChanged
+ ]
+!
+
+validateSelection:aNumberOrCollection
+ "validate the selection; returns a valid selection or nil
+ "
+ |sz newSelection|
+
+ (aNumberOrCollection notNil and:[aNumberOrCollection ~~ 0]) ifTrue:[
+ sz := self size.
+
+ aNumberOrCollection isCollection ifFalse:[
+ (aNumberOrCollection between:1 and:sz) ifTrue:[
+ ^ multipleSelectOk ifFalse:[aNumberOrCollection ]
+ ifTrue:[Array with:aNumberOrCollection]
+ ]
+ ] ifTrue:[
+ (aNumberOrCollection notNil and:[multipleSelectOk]) ifTrue:[
+ newSelection := OrderedCollection new.
+
+ aNumberOrCollection do:[:anIndex|
+ (anIndex between:1 and:sz) ifFalse:[^ nil].
+ newSelection add:anIndex.
+ ].
+ ^ newSelection
+ ]
+ ]
+ ].
+ ^ nil
+
+
+! !
+
+!SelectionInListModelView class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libwidg2/SelectionInListModelView.st,v 1.1 1999-05-23 12:56:29 cg Exp $'
+! !