'From Squeak 3.2 of 11 July 2002 [latest update: #4917] on 20 July 2002 at 11:22:06 pm'!
"Change Set:		PDA-Scrollbar
Date:			16 May 2002
Author:			Russell Allen

File this in to get PalmOS style small scollbars"!


!ScrollPane methodsFor: 'initialization' stamp: 'rca 4/29/2002 11:46'!
initialize
	retractableScrollBar _ (Preferences valueOfFlag: #inboardScrollbars) not.
	scrollBarOnLeft _ (Preferences valueOfFlag: #scrollBarsOnRight) not.
	super initialize.
	hasFocus _ false.
	borderWidth _ 2.
	borderColor _ Color black.

	scrollBar := ScrollBar new model: self slotName: 'scrollBar'.
	scrollBar borderWidth: 0; borderColor: Color black.

	scroller := TransformMorph new color: Color transparent.
	scroller offset: -3@0.
	self addMorph: scroller.

	retractableScrollBar ifFalse: [self addMorph: scrollBar].

	self on: #mouseEnter send: #mouseEnter: to: self.
	self on: #mouseLeave send: #mouseLeave: to: self.
	self extent: 150@120! !

!ScrollPane methodsFor: 'access' stamp: 'rca 5/16/2002 19:34'!
colorForInsets
	"My submorphs use the surrounding color"

^ Color white! !

!ScrollPane methodsFor: 'geometry' stamp: 'rca 4/29/2002 12:30'!
scrollbarWidth  "Includes border"
	(Preferences valueOfFlag: #scrollBarsNarrow)
		ifTrue: [^ 8]
		ifFalse: [^ 16]! !


!Slider methodsFor: 'initialize' stamp: 'rca 5/16/2002 19:36'!
initialize
	super initialize.
	bounds := 0@0 corner: 16@100.
	color := Color white.
	borderWidth := 0.
	value _ 0.0.
	descending _ false.
	self initializeSlider! !

!Slider methodsFor: 'initialize' stamp: 'rca 5/16/2002 19:28'!
initializeSlider
	slider := RectangleMorph newBounds: self totalSliderArea color: self sliderColor.
	sliderShadow := RectangleMorph newBounds: self totalSliderArea
						color: Color gray.
	slider on: #mouseMove send: #scrollAbsolute: to: self.
	slider on: #mouseDown send: #mouseDownInSlider: to: self.
	slider on: #mouseUp send: #mouseUpInSlider: to: self.
	slider setBorderWidth: 2 borderColor: Color transparent.
	slider width: 8.
	sliderShadow setBorderWidth: 2 borderColor: Color white.
	"(the shadow must have the pagingArea as its owner to highlight properly)"
	self pagingArea addMorph: sliderShadow.
	sliderShadow hide.
	self addMorph: slider.
	self computeSlider.
! !

!Slider methodsFor: 'access' stamp: 'rca 5/16/2002 19:44'!
color: aColor
	"Ignored to be compatible for later scrollbar stuff"! !

!Slider methodsFor: 'access' stamp: 'rca 5/16/2002 19:29'!
sliderColor

	^ Color black! !

!Slider methodsFor: 'geometry' stamp: 'rca 5/13/2002 00:04'!
computeSlider
	| r |
	r _ self roomToMove.
	self descending
		ifFalse:
			[slider position: (bounds isWide
				ifTrue: [r topLeft +  ((r width * value) asInteger @ 0)]
				ifFalse: [r topLeft +  (0 @ (r height * value)  asInteger)])]
		ifTrue:
			[slider position: (bounds isWide
				ifTrue:	[r bottomRight - ((r width * value) asInteger @ 0)]
				ifFalse:	[r bottomRight -  ((0 @ (r height * value) asInteger))])].
	slider extent: self sliderExtent! !

!Slider methodsFor: 'geometry' stamp: 'rca 5/12/2002 23:57'!
sliderThickness
	^ 8
! !


!ScrollBar methodsFor: 'initialize' stamp: 'rca 4/29/2002 11:56'!
initializeDownButton
	downButton := RectangleMorph
		newBounds: (self innerBounds bottomRight - self buttonExtent extent: self buttonExtent)
		color: Color white.
	"Because of space left by removing border"
	downButton bottomRight: (downButton bottomRight x@(downButton bottomRight y - 1)).
	downButton on: #mouseDown send: #scrollDownInit to: self.
	downButton on: #mouseUp send: #finishedScrolling to: self.
	downButton addMorphCentered: (ImageMorph new image: 
		(self 
			cachedImageAt: (bounds isWide ifTrue: ['right'] ifFalse: ['down']) 
			ifAbsentPut: [
				self upArrow8Bit
					rotateBy: (bounds isWide ifTrue: [#right] ifFalse: [#pi])
					centerAt: 0@0
			]
		)
	).
	downButton setBorderWidth: 0 borderColor: #raised.
	self addMorph: downButton! !

!ScrollBar methodsFor: 'initialize' stamp: 'rca 4/29/2002 12:25'!
initializeMenuButton
	"Preferences disable: #scrollBarsWithoutMenuButton"
	"Preferences enable: #scrollBarsWithoutMenuButton"

	(Preferences valueOfFlag: #scrollBarsWithoutMenuButton) ifTrue: [^self].
	menuButton := RectangleMorph
			newBounds: (self innerBounds topLeft extent: self buttonExtent)
			color: Color white.
	"Because of space left by removing border"
	menuButton topLeft: (menuButton topLeft x@(menuButton topLeft y + 1)).
	menuButton on: #mouseEnter send: #menuButtonMouseEnter: to: self.
	menuButton on: #mouseDown send: #menuButtonMouseDown: to: self.
	menuButton on: #mouseLeave send: #menuButtonMouseLeave: to: self.
	menuButton addMorphCentered:
		(RectangleMorph newBounds: (0@0 extent: 4@2) color: Color black).
	menuButton setBorderWidth: 0 borderColor: #raised.
	self addMorph: menuButton! !

!ScrollBar methodsFor: 'initialize' stamp: 'rca 4/29/2002 12:32'!
initializePagingArea
	pagingArea := RectangleMorph newBounds: self totalSliderArea
								color: Color veryLightGray.
	pagingArea setBorderWidth: 2 borderColor: Color white.
	pagingArea on: #mouseDown send: #scrollPageInit: to: self.
	pagingArea on: #mouseUp send: #finishedScrolling to: self.
	self addMorph: pagingArea! !

!ScrollBar methodsFor: 'initialize' stamp: 'rca 4/29/2002 11:16'!
initializeUpButton
	upButton := RectangleMorph
		newBounds: ((menuButton ifNil: [self innerBounds topLeft]
				ifNotNil: [bounds isWide ifTrue: [menuButton bounds topRight]
									ifFalse: [menuButton bounds bottomLeft]])
					extent: self buttonExtent)
		color: Color white.
	upButton on: #mouseDown send: #scrollUpInit to: self.
	upButton on: #mouseUp send: #finishedScrolling to: self.
	upButton addMorphCentered: (ImageMorph new image:
		(self 
			cachedImageAt: (bounds isWide ifTrue: ['left'] ifFalse: ['up'])
			ifAbsentPut: [
				bounds isWide ifTrue: [
					self upArrow8Bit rotateBy: #left centerAt: 0@0
				] ifFalse: [
					self upArrow8Bit
				]
			]
		)
	).
	upButton setBorderWidth: 0 borderColor: #raised.
	self addMorph: upButton! !

!ScrollBar methodsFor: 'access' stamp: 'rca 6/22/2002 01:03'!
sliderColor: aColor
	"Change the color of the scrollbar to go with aColor."
	| buttonColor |
	super sliderColor: aColor.
	buttonColor _ self thumbColor.
	slider color: buttonColor.
	self alternativeScrollbarLook ifTrue:
		[self roundedScrollbarLook
			ifTrue:
				[self color: Color transparent.
				pagingArea color: aColor muchLighter.
				self borderStyle style == #simple 
					ifTrue:[self borderColor: aColor darker darker]
					ifFalse:[self borderStyle baseColor: aColor]]
			ifFalse:
				[pagingArea color: (aColor alphaMixed: 0.3 with: Color white).
				self borderWidth: 0]]
! !

!ScrollBar methodsFor: 'access' stamp: 'rca 6/22/2002 01:00'!
thumbColor
	"Overriden to cope with changing Squeak scollbar code"
	^ Color black! !

!ScrollBar methodsFor: 'geometry' stamp: 'rca 4/29/2002 11:56'!
buttonExtent
	^ bounds isWide
		ifTrue: [10 @ self innerBounds height]
		ifFalse: [self innerBounds width @ 10]! !

"Postscript:
Sets some preferences to work out alright"

Preferences setPreference:   #inboardScrollbars toValue: true.
Preferences setPreference:   #scrollBarsNarrow toValue: true.
Preferences setPreference:   #scrollBarsOnRight toValue: false.
Preferences setPreference:   #scrollBarsWithoutMenuButton toValue: false.

!