[Pkg] Squeak3.10bc: Balloon-kph.14.mcz
squeak-dev-noreply at lists.squeakfoundation.org
squeak-dev-noreply at lists.squeakfoundation.org
Sat Dec 13 04:49:16 UTC 2008
A new version of Balloon was added to project Squeak3.10bc:
http://www.squeaksource.com/310bc/Balloon-kph.14.mcz
==================== Summary ====================
Name: Balloon-kph.14
Author: kph
Time: 13 December 2008, 4:49:13 am
UUID: a4d3fece-48a1-4650-988c-a28a6ec6f10c
Ancestors: Balloon-ar.13
Saved from SystemVersion
==================== Snapshot ====================
SystemOrganization addCategory: #'Balloon-Collections'!
SystemOrganization addCategory: #'Balloon-Engine'!
SystemOrganization addCategory: #'Balloon-Fills'!
SystemOrganization addCategory: #'Balloon-Geometry'!
SystemOrganization addCategory: #'Balloon-Simulation'!
IntegerArray variableWordSubclass: #PointArray
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Collections'!
!PointArray commentStamp: '<historical>' prior: 0!
This class stores 32bit Integer points in place. It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.!
----- Method: PointArray class>>new: (in category 'instance creation') -----
new: n
^super new: n*2!
----- Method: PointArray>>asPointArray (in category 'converting') -----
asPointArray
^ self!
----- Method: PointArray>>at: (in category 'accessing') -----
at: index
"Return the element (e.g., point) at the given index"
^(super at: index * 2 - 1) @ (super at: index * 2)!
----- Method: PointArray>>at:put: (in category 'accessing') -----
at: index put: aPoint
"Store the argument aPoint at the given index"
super at: index * 2 - 1 put: aPoint x asInteger.
super at: index * 2 put: aPoint y asInteger.
^aPoint!
----- Method: PointArray>>bounds (in category 'accessing') -----
bounds
| min max |
min := max := self at: 1.
self do:[:pt|
min := min min: pt.
max := max max: pt].
^min corner: max
!
----- Method: PointArray>>defaultElement (in category 'accessing') -----
defaultElement
"Return the default element of the receiver"
^0 at 0!
----- Method: PointArray>>size (in category 'accessing') -----
size
"Return the number of elements in the receiver"
^super size // 2!
Object subclass: #BalloonBezierSimulation
instanceVariableNames: 'start end via lastX lastY fwDx fwDy fwDDx fwDDy maxSteps'
classVariableNames: 'LineConversions OverflowSubdivisions HeightSubdivisions MonotonSubdivisions'
poolDictionaries: ''
category: 'Balloon-Simulation'!
!BalloonBezierSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!
----- Method: BalloonBezierSimulation class>>initialize (in category 'class initialization') -----
initialize
"GraphicsBezierSimulation initialize"
HeightSubdivisions := 0.
LineConversions := 0.
MonotonSubdivisions := 0.
OverflowSubdivisions := 0.!
----- Method: BalloonBezierSimulation>>absoluteSquared8Dot24: (in category 'private') -----
absoluteSquared8Dot24: value
"Compute the squared value of a 8.24 number with 0.0 <= value < 1.0,
e.g., compute (value * value) bitShift: -24"
| halfWord1 halfWord2 result |
(value >= 0 and:[value < 16r1000000]) ifFalse:[^self error:'Value out of range'].
halfWord1 := value bitAnd: 16rFFFF.
halfWord2 := (value bitShift: -16) bitAnd: 255.
result := (halfWord1 * halfWord1) bitShift: -16. "We don't need the lower 16bits at all"
result := result + ((halfWord1 * halfWord2) * 2).
result := result + ((halfWord2 * halfWord2) bitShift: 16).
"word1 := halfWord1 * halfWord1.
word2 := (halfWord2 * halfWord1) + (word1 bitShift: -16).
word1 := word1 bitAnd: 16rFFFF.
word2 := word2 + (halfWord1 * halfWord2).
word2 := word2 + ((halfWord2 * halfWord2) bitShift: 16)."
^result bitShift: -8!
----- Method: BalloonBezierSimulation>>computeInitialStateFrom:with: (in category 'computing') -----
computeInitialStateFrom: source with: transformation
"Compute the initial state in the receiver."
start := (transformation localPointToGlobal: source start) asIntegerPoint.
end := (transformation localPointToGlobal: source end) asIntegerPoint.
via := (transformation localPointToGlobal: source via) asIntegerPoint.!
----- Method: BalloonBezierSimulation>>computeSplitAt: (in category 'computing') -----
computeSplitAt: t
"Split the receiver at the parametric value t"
| left right newVia1 newVia2 newPoint |
left := self clone.
right := self clone.
"Compute new intermediate points"
newVia1 := (via - start) * t + start.
newVia2 := (end - via) * t + via.
"Compute new point on curve"
newPoint := ((newVia1 - newVia2) * t + newVia2) asIntegerPoint.
left via: newVia1 asIntegerPoint.
left end: newPoint.
right start: newPoint.
right via: newVia2 asIntegerPoint.
^Array with: left with: right!
----- Method: BalloonBezierSimulation>>debugDraw (in category 'private') -----
debugDraw
| entry minY maxY lX lY canvas |
entry := BalloonEdgeData new.
canvas := Display getCanvas.
minY := (start y min: end y) min: via y.
maxY := (start y max: end y) max: via y.
entry yValue: minY.
self stepToFirstScanLineAt: minY in: entry.
lX := entry xValue.
lY := entry yValue.
minY+1 to: maxY do:[:y|
self stepToNextScanLineAt: y in: entry.
canvas line: lX at lY to: entry xValue @ y width: 2 color: Color black.
lX := entry xValue.
lY := y.
].
!
----- Method: BalloonBezierSimulation>>debugDraw2 (in category 'private') -----
debugDraw2
| canvas last max t next |
canvas := Display getCanvas.
max := 100.
last := nil.
0 to: max do:[:i|
t := i asFloat / max asFloat.
next := self valueAt: t.
last ifNotNil:[
canvas line: last to: next rounded width: 2 color: Color blue.
].
last := next rounded.
].!
----- Method: BalloonBezierSimulation>>debugDrawWide: (in category 'private') -----
debugDrawWide: n
| entry minY maxY canvas curve p1 p2 entry2 y |
curve := self class new.
curve start: start + (0 at n).
curve via: via + (0 at n).
curve end: end + (0 at n).
entry := BalloonEdgeData new.
entry2 := BalloonEdgeData new.
canvas := Display getCanvas.
minY := (start y min: end y) min: via y.
maxY := (start y max: end y) max: via y.
entry yValue: minY.
entry2 yValue: minY + n.
self stepToFirstScanLineAt: minY in: entry.
curve stepToFirstScanLineAt: minY+n in: entry2.
y := minY.
1 to: n do:[:i|
y := y + 1.
self stepToNextScanLineAt: y in: entry.
p1 := entry xValue @ y.
canvas line: p1 to: p1 + (n at 0) width: 1 color: Color black.
].
[y < maxY] whileTrue:[
y := y + 1.
self stepToNextScanLineAt: y in: entry.
p2 := (entry xValue + n) @ y.
curve stepToNextScanLineAt: y in: entry2.
p1 := entry2 xValue @ y.
canvas line: p1 to: p2 width: 1 color: Color black.
].
!
----- Method: BalloonBezierSimulation>>end (in category 'accessing') -----
end
^end!
----- Method: BalloonBezierSimulation>>end: (in category 'accessing') -----
end: aPoint
end := aPoint!
----- Method: BalloonBezierSimulation>>floatStepToFirstScanLineAt:in: (in category 'computing') -----
floatStepToFirstScanLineAt: yValue in: edgeTableEntry
"Float version of forward differencing"
| startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2
steps scaledStepSize squaredStepSize |
(end y) >= (start y) ifTrue:[
startX := start x. endX := end x.
startY := start y. endY := end y.
] ifFalse:[
startX := end x. endX := start x.
startY := end y. endY := start y.
].
deltaY := endY - startY.
"Quickly check if the line is visible at all"
(yValue >= endY or:[deltaY = 0]) ifTrue:[
^edgeTableEntry lines: 0].
fwX1 := (startX + endX - (2 * via x)) asFloat.
fwX2 := (via x - startX * 2) asFloat.
fwY1 := (startY + endY - (2 * via y)) asFloat.
fwY2 := ((via y - startY) * 2) asFloat.
steps := deltaY asInteger * 2.
scaledStepSize := 1.0 / steps asFloat.
squaredStepSize := scaledStepSize * scaledStepSize.
fwDx := fwX2 * scaledStepSize.
fwDDx := 2.0 * fwX1 * squaredStepSize.
fwDy := fwY2 * scaledStepSize.
fwDDy := 2.0 * fwY1 * squaredStepSize.
fwDx := fwDx + (fwDDx * 0.5).
fwDy := fwDy + (fwDDy * 0.5).
lastX := startX asFloat.
lastY := startY asFloat.
"self xDirection: xDir.
self yDirection: yDir."
edgeTableEntry xValue: startX.
edgeTableEntry yValue: startY.
edgeTableEntry zValue: 0.
edgeTableEntry lines: deltaY.
"If not at first scan line then step down to yValue"
yValue = startY ifFalse:[
self stepToNextScanLineAt: yValue in: edgeTableEntry.
"And adjust remainingLines"
edgeTableEntry lines: deltaY - (yValue - startY).
].!
----- Method: BalloonBezierSimulation>>floatStepToNextScanLineAt:in: (in category 'computing') -----
floatStepToNextScanLineAt: yValue in: edgeTableEntry
"Float version of forward differencing"
[yValue asFloat > lastY] whileTrue:[
(fwDx < -50.0 or:[fwDx > 50.0]) ifTrue:[self halt].
(fwDy < -50.0 or:[fwDy > 50.0]) ifTrue:[self halt].
(fwDDx < -50.0 or:[fwDDx > 50.0]) ifTrue:[self halt].
(fwDDy < -50.0 or:[fwDDy > 50.0]) ifTrue:[self halt].
lastX := lastX + fwDx.
lastY := lastY + fwDy.
fwDx := fwDx + fwDDx.
fwDy := fwDy + fwDDy.
].
edgeTableEntry xValue: lastX asInteger.
edgeTableEntry zValue: 0.!
----- Method: BalloonBezierSimulation>>inTangent (in category 'accessing') -----
inTangent
"Return the tangent at the start point"
^via - start!
----- Method: BalloonBezierSimulation>>initialX (in category 'accessing') -----
initialX
^start y <= end y
ifTrue:[start x]
ifFalse:[end x]!
----- Method: BalloonBezierSimulation>>initialY (in category 'accessing') -----
initialY
^start y <= end y
ifTrue:[start y]
ifFalse:[end y]!
----- Method: BalloonBezierSimulation>>initialZ (in category 'accessing') -----
initialZ
^0 "Assume no depth given"!
----- Method: BalloonBezierSimulation>>intStepToFirstScanLineAt:in: (in category 'computing') -----
intStepToFirstScanLineAt: yValue in: edgeTableEntry
"Scaled integer version of forward differencing"
| startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2
scaledStepSize squaredStepSize |
(end y) >= (start y) ifTrue:[
startX := start x. endX := end x.
startY := start y. endY := end y.
] ifFalse:[
startX := end x. endX := start x.
startY := end y. endY := start y.
].
deltaY := endY - startY.
"Quickly check if the line is visible at all"
(yValue >= endY or:[deltaY = 0]) ifTrue:[
^edgeTableEntry lines: 0].
fwX1 := (startX + endX - (2 * via x)).
fwX2 := (via x - startX * 2).
fwY1 := (startY + endY - (2 * via y)).
fwY2 := ((via y - startY) * 2).
maxSteps := deltaY asInteger * 2.
scaledStepSize := 16r1000000 // maxSteps.
"@@: Okay, we need some fancy 64bit multiplication here"
squaredStepSize := self absoluteSquared8Dot24: scaledStepSize.
squaredStepSize = ((scaledStepSize * scaledStepSize) bitShift: -24)
ifFalse:[self error:'Bad computation'].
fwDx := fwX2 * scaledStepSize.
fwDDx := 2 * fwX1 * squaredStepSize.
fwDy := fwY2 * scaledStepSize.
fwDDy := 2 * fwY1 * squaredStepSize.
fwDx := fwDx + (fwDDx // 2).
fwDy := fwDy + (fwDDy // 2).
self validateIntegerRange.
lastX := startX * 256.
lastY := startY * 256.
edgeTableEntry xValue: startX.
edgeTableEntry yValue: startY.
edgeTableEntry zValue: 0.
edgeTableEntry lines: deltaY.
"If not at first scan line then step down to yValue"
yValue = startY ifFalse:[
self stepToNextScanLineAt: yValue in: edgeTableEntry.
"And adjust remainingLines"
edgeTableEntry lines: deltaY - (yValue - startY).
].!
----- Method: BalloonBezierSimulation>>intStepToNextScanLineAt:in: (in category 'computing') -----
intStepToNextScanLineAt: yValue in: edgeTableEntry
"Scaled integer version of forward differencing"
[maxSteps >= 0 and:[yValue * 256 > lastY]] whileTrue:[
self validateIntegerRange.
lastX := lastX + ((fwDx + 16r8000) // 16r10000).
lastY := lastY + ((fwDy + 16r8000) // 16r10000).
fwDx := fwDx + fwDDx.
fwDy := fwDy + fwDDy.
maxSteps := maxSteps - 1.
].
edgeTableEntry xValue: lastX // 256.
edgeTableEntry zValue: 0.!
----- Method: BalloonBezierSimulation>>isMonoton (in category 'computing') -----
isMonoton
"Return true if the receiver is monoton along the y-axis,
e.g., check if the tangents have the same sign"
^(via y - start y) * (end y - via y) >= 0!
----- Method: BalloonBezierSimulation>>outTangent (in category 'accessing') -----
outTangent
"Return the tangent at the end point"
^end - via!
----- Method: BalloonBezierSimulation>>printOn: (in category 'private') -----
printOn: aStream
aStream
nextPutAll: self class name;
nextPut:$(;
print: start;
nextPutAll:' - ';
print: via;
nextPutAll:' - ';
print: end;
nextPut:$)!
----- Method: BalloonBezierSimulation>>printOnStream: (in category 'private') -----
printOnStream: aStream
aStream
print: self class name;
print:'(';
write: start;
print:' - ';
write: via;
print:' - ';
write: end;
print:')'.!
----- Method: BalloonBezierSimulation>>quickPrint: (in category 'private') -----
quickPrint: curve
Transcript nextPut:$(;
print: curve start;
space;
print: curve via;
space;
print: curve end;
nextPut:$).!
----- Method: BalloonBezierSimulation>>quickPrint:first: (in category 'private') -----
quickPrint: curve first: aBool
aBool ifTrue:[Transcript cr].
Transcript nextPut:$(;
print: curve start;
space;
print: curve via;
space;
print: curve end;
nextPut:$).
Transcript endEntry.!
----- Method: BalloonBezierSimulation>>start (in category 'accessing') -----
start
^start!
----- Method: BalloonBezierSimulation>>start: (in category 'accessing') -----
start: aPoint
start := aPoint!
----- Method: BalloonBezierSimulation>>stepToFirst (in category 'private') -----
stepToFirst
| startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2
steps scaledStepSize squaredStepSize |
(end y) >= (start y) ifTrue:[
startX := start x. endX := end x.
startY := start y. endY := end y.
] ifFalse:[
startX := end x. endX := start x.
startY := end y. endY := start y.
].
deltaY := endY - startY.
"Quickly check if the line is visible at all"
(deltaY = 0) ifTrue:[^self].
fwX1 := (startX + endX - (2 * via x)) asFloat.
fwX2 := (via x - startX * 2) asFloat.
fwY1 := (startY + endY - (2 * via y)) asFloat.
fwY2 := ((via y - startY) * 2) asFloat.
steps := deltaY asInteger * 2.
scaledStepSize := 1.0 / steps asFloat.
squaredStepSize := scaledStepSize * scaledStepSize.
fwDx := fwX2 * scaledStepSize.
fwDDx := 2.0 * fwX1 * squaredStepSize.
fwDy := fwY2 * scaledStepSize.
fwDDy := 2.0 * fwY1 * squaredStepSize.
fwDx := fwDx + (fwDDx * 0.5).
fwDy := fwDy + (fwDDy * 0.5).
lastX := startX asFloat.
lastY := startY asFloat.
!
----- Method: BalloonBezierSimulation>>stepToFirstInt (in category 'private') -----
stepToFirstInt
"Scaled integer version of forward differencing"
| startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2
scaledStepSize squaredStepSize |
self halt.
(end y) >= (start y) ifTrue:[
startX := start x. endX := end x.
startY := start y. endY := end y.
] ifFalse:[
startX := end x. endX := start x.
startY := end y. endY := start y.
].
deltaY := endY - startY.
"Quickly check if the line is visible at all"
(deltaY = 0) ifTrue:[^nil].
fwX1 := (startX + endX - (2 * via x)).
fwX2 := (via x - startX * 2).
fwY1 := (startY + endY - (2 * via y)).
fwY2 := ((via y - startY) * 2).
maxSteps := deltaY asInteger * 2.
scaledStepSize := 16r1000000 // maxSteps.
"@@: Okay, we need some fancy 64bit multiplication here"
squaredStepSize := (scaledStepSize * scaledStepSize) bitShift: -24.
fwDx := fwX2 * scaledStepSize.
fwDDx := 2 * fwX1 * squaredStepSize.
fwDy := fwY2 * scaledStepSize.
fwDDy := 2 * fwY1 * squaredStepSize.
fwDx := fwDx + (fwDDx // 2).
fwDy := fwDy + (fwDDy // 2).
self validateIntegerRange.
lastX := startX * 256.
lastY := startY * 256.
!
----- Method: BalloonBezierSimulation>>stepToFirstScanLineAt:in: (in category 'computing') -----
stepToFirstScanLineAt: yValue in: edgeTableEntry
"Compute the initial x value for the scan line at yValue"
^self intStepToFirstScanLineAt: yValue in: edgeTableEntry!
----- Method: BalloonBezierSimulation>>stepToNext (in category 'private') -----
stepToNext
lastX := lastX + fwDx.
lastY := lastY + fwDy.
fwDx := fwDx + fwDDx.
fwDy := fwDy + fwDDy.!
----- Method: BalloonBezierSimulation>>stepToNextInt (in category 'private') -----
stepToNextInt
"Scaled integer version of forward differencing"
self halt.
(maxSteps >= 0) ifTrue:[
self validateIntegerRange.
lastX := lastX + ((fwDx + 16r8000) // 16r10000).
lastY := lastY + ((fwDy + 16r8000) // 16r10000).
fwDx := fwDx + fwDDx.
fwDy := fwDy + fwDDy.
maxSteps := maxSteps - 1.
].!
----- Method: BalloonBezierSimulation>>stepToNextScanLineAt:in: (in category 'computing') -----
stepToNextScanLineAt: yValue in: edgeTableEntry
"Compute the next x value for the scan line at yValue.
This message is sent during incremental updates.
The yValue parameter is passed in here for edges
that have more complicated computations,"
^self intStepToNextScanLineAt: yValue in: edgeTableEntry!
----- Method: BalloonBezierSimulation>>subdivide (in category 'computing') -----
subdivide
"Subdivide the receiver"
| dy dx |
"Test 1: If the bezier curve is not monoton in Y, we need a subdivision"
self isMonoton ifFalse:[
MonotonSubdivisions := MonotonSubdivisions + 1.
^self subdivideToBeMonoton].
"Test 2: If the receiver is horizontal, don't do anything"
(end y = start y) ifTrue:[^nil].
"Test 3: If the receiver can be represented as a straight line,
make a line from the receiver and declare it invalid"
((end - start) crossProduct: (via - start)) = 0 ifTrue:[
LineConversions := LineConversions + 1.
^self subdivideToBeLine].
"Test 4: If the height of the curve exceeds 256 pixels, subdivide
(forward differencing is numerically not very stable)"
dy := end y - start y.
dy < 0 ifTrue:[dy := dy negated].
(dy > 255) ifTrue:[
HeightSubdivisions := HeightSubdivisions + 1.
^self subdivideAt: 0.5].
"Test 5: Check if the incremental values could possibly overflow the scaled integer range"
dx := end x - start x.
dx < 0 ifTrue:[dx := dx negated].
dy * 32 < dx ifTrue:[
OverflowSubdivisions := OverflowSubdivisions + 1.
^self subdivideAt: 0.5].
^nil!
----- Method: BalloonBezierSimulation>>subdivideAt: (in category 'computing') -----
subdivideAt: parameter
"Subdivide the receiver at the given parameter"
| both |
(parameter <= 0.0 or:[parameter >= 1.0]) ifTrue:[self halt].
both := self computeSplitAt: parameter.
"Transcript cr.
self quickPrint: self.
Transcript space.
self quickPrint: both first.
Transcript space.
self quickPrint: both last.
Transcript endEntry."
self via: both first via.
self end: both first end.
^both last!
----- Method: BalloonBezierSimulation>>subdivideToBeLine (in category 'computing') -----
subdivideToBeLine
"Not a true subdivision.
Just return a line representing the receiver and fake me to be of zero height"
| line |
line := BalloonLineSimulation new.
line start: start.
line end: end.
"Make me invalid"
end := start.
via := start.
^line!
----- Method: BalloonBezierSimulation>>subdivideToBeMonoton (in category 'computing') -----
subdivideToBeMonoton
"Subdivide the receiver at it's extreme point"
| v1 v2 t other |
v1 := (via - start).
v2 := (end - via).
t := (v1 y / (v2 y - v1 y)) negated asFloat.
other := self subdivideAt: t.
self isMonoton ifFalse:[self halt].
other isMonoton ifFalse:[self halt].
^other!
----- Method: BalloonBezierSimulation>>validateIntegerRange (in category 'private') -----
validateIntegerRange
fwDx class == SmallInteger ifFalse:[self halt].
fwDy class == SmallInteger ifFalse:[self halt].
fwDDx class == SmallInteger ifFalse:[self halt].
fwDDy class == SmallInteger ifFalse:[self halt].
!
----- Method: BalloonBezierSimulation>>valueAt: (in category 'private') -----
valueAt: parameter
"Return the point at the value parameter:
p(t) = (1-t)^2 * p1 +
2*t*(1-t) * p2 +
t^2 * p3.
"
| t1 t2 t3 |
t1 := (1.0 - parameter) squared.
t2 := 2 * parameter * (1.0 - parameter).
t3 := parameter squared.
^(start * t1) + (via * t2) + (end * t3)!
----- Method: BalloonBezierSimulation>>via (in category 'accessing') -----
via
^via!
----- Method: BalloonBezierSimulation>>via: (in category 'accessing') -----
via: aPoint
via := aPoint!
Object variableWordSubclass: #BalloonBuffer
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Engine'!
!BalloonBuffer commentStamp: '<historical>' prior: 0!
BalloonBuffer is a repository for primitive data used by the BalloonEngine.!
----- Method: BalloonBuffer class>>new (in category 'instance creation') -----
new
^self new: 256.!
----- Method: BalloonBuffer>>at: (in category 'accessing') -----
at: index
"For simulation only"
| word |
word := self basicAt: index.
word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations"
^word >= 16r80000000 "Negative?!!"
ifTrue:["word - 16r100000000"
(word bitInvert32 + 1) negated]
ifFalse:[word]!
----- Method: BalloonBuffer>>at:put: (in category 'accessing') -----
at: index put: anInteger
"For simulation only"
| word |
anInteger < 0
ifTrue:["word := 16r100000000 + anInteger"
word := (anInteger + 1) negated bitInvert32]
ifFalse:[word := anInteger].
self basicAt: index put: word.
^anInteger!
----- Method: BalloonBuffer>>floatAt: (in category 'accessing') -----
floatAt: index
"For simulation only"
<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
^Float fromIEEE32Bit: (self basicAt: index)!
----- Method: BalloonBuffer>>floatAt:put: (in category 'accessing') -----
floatAt: index put: value
"For simulation only"
<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
value isFloat
ifTrue:[self basicAt: index put: value asIEEE32BitWord]
ifFalse:[self at: index put: value asFloat].
^value!
Object subclass: #BalloonEdgeData
instanceVariableNames: 'index xValue yValue zValue lines source'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Simulation'!
!BalloonEdgeData commentStamp: '<historical>' prior: 0!
BalloonEdgeData defines an entry in the internal edge table of the Balloon engine.
Instance Variables:
index <Integer> The index into the external objects array of the associated graphics engine
xValue <Integer> The computed x-value of the requested operation
yValue <Integer> The y-value for the requested operation
height <Integer> The (remaining) height of the edge
source <Object> The object from the external objects array!
----- Method: BalloonEdgeData>>index (in category 'accessing') -----
index
^index!
----- Method: BalloonEdgeData>>index: (in category 'accessing') -----
index: anInteger
index := anInteger!
----- Method: BalloonEdgeData>>lines (in category 'accessing') -----
lines
^lines!
----- Method: BalloonEdgeData>>lines: (in category 'accessing') -----
lines: anInteger
^lines := anInteger!
----- Method: BalloonEdgeData>>source (in category 'accessing') -----
source
^source!
----- Method: BalloonEdgeData>>source: (in category 'accessing') -----
source: anObject
source := anObject!
----- Method: BalloonEdgeData>>stepToFirstScanLine (in category 'computing') -----
stepToFirstScanLine
source stepToFirstScanLineAt: yValue in: self!
----- Method: BalloonEdgeData>>stepToNextScanLine (in category 'computing') -----
stepToNextScanLine
source stepToNextScanLineAt: yValue in: self!
----- Method: BalloonEdgeData>>xValue (in category 'accessing') -----
xValue
^xValue!
----- Method: BalloonEdgeData>>xValue: (in category 'accessing') -----
xValue: anInteger
xValue := anInteger!
----- Method: BalloonEdgeData>>yValue (in category 'accessing') -----
yValue
^yValue!
----- Method: BalloonEdgeData>>yValue: (in category 'accessing') -----
yValue: anInteger
yValue := anInteger!
----- Method: BalloonEdgeData>>zValue (in category 'accessing') -----
zValue
^zValue!
----- Method: BalloonEdgeData>>zValue: (in category 'accessing') -----
zValue: anInteger
zValue := anInteger!
Object subclass: #BalloonFillData
instanceVariableNames: 'index minX maxX yValue source destForm'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Simulation'!
!BalloonFillData commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!
----- Method: BalloonFillData>>computeFill (in category 'computing') -----
computeFill
(destForm isNil or:[destForm width < self width]) ifTrue:[
destForm := Form extent: (self width + 10) @ 1 depth: 32.
].
source computeFillFrom: minX to: maxX at: yValue in: destForm!
----- Method: BalloonFillData>>destForm (in category 'accessing') -----
destForm
^destForm!
----- Method: BalloonFillData>>destForm: (in category 'accessing') -----
destForm: aForm
destForm := aForm!
----- Method: BalloonFillData>>index (in category 'accessing') -----
index
^index!
----- Method: BalloonFillData>>index: (in category 'accessing') -----
index: anInteger
index := anInteger!
----- Method: BalloonFillData>>maxX (in category 'accessing') -----
maxX
^maxX!
----- Method: BalloonFillData>>maxX: (in category 'accessing') -----
maxX: anInteger
maxX := anInteger!
----- Method: BalloonFillData>>minX (in category 'accessing') -----
minX
^minX!
----- Method: BalloonFillData>>minX: (in category 'accessing') -----
minX: anInteger
minX := anInteger!
----- Method: BalloonFillData>>source (in category 'accessing') -----
source
^source!
----- Method: BalloonFillData>>source: (in category 'accessing') -----
source: anObject
source := anObject!
----- Method: BalloonFillData>>width (in category 'accessing') -----
width
^maxX - minX!
----- Method: BalloonFillData>>yValue (in category 'accessing') -----
yValue
^yValue!
----- Method: BalloonFillData>>yValue: (in category 'accessing') -----
yValue: anInteger
yValue := anInteger!
Object subclass: #BalloonLineSimulation
instanceVariableNames: 'start end xIncrement xDirection error errorAdjUp errorAdjDown'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Simulation'!
!BalloonLineSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!
----- Method: BalloonLineSimulation>>computeInitialStateFrom:with: (in category 'computing') -----
computeInitialStateFrom: source with: aTransformation
"Compute the initial state in the receiver."
start := (aTransformation localPointToGlobal: source start) asIntegerPoint.
end := (aTransformation localPointToGlobal: source end) asIntegerPoint.!
----- Method: BalloonLineSimulation>>end (in category 'accessing') -----
end
^end!
----- Method: BalloonLineSimulation>>end: (in category 'accessing') -----
end: aPoint
end := aPoint!
----- Method: BalloonLineSimulation>>initialX (in category 'accessing') -----
initialX
^start y <= end y
ifTrue:[start x]
ifFalse:[end x]!
----- Method: BalloonLineSimulation>>initialY (in category 'accessing') -----
initialY
^start y <= end y
ifTrue:[start y]
ifFalse:[end y]!
----- Method: BalloonLineSimulation>>initialZ (in category 'accessing') -----
initialZ
^0 "Assume no depth given"!
----- Method: BalloonLineSimulation>>printOn: (in category 'printing') -----
printOn: aStream
aStream
nextPutAll: self class name;
nextPut:$(;
print: start;
nextPutAll:' - ';
print: end;
nextPut:$)!
----- Method: BalloonLineSimulation>>printOnStream: (in category 'printing') -----
printOnStream: aStream
aStream
print: self class name;
print:'(';
write: start;
print:' - ';
write: end;
print:')'.!
----- Method: BalloonLineSimulation>>start (in category 'accessing') -----
start
^start!
----- Method: BalloonLineSimulation>>start: (in category 'accessing') -----
start: aPoint
start := aPoint!
----- Method: BalloonLineSimulation>>stepToFirstScanLineAt:in: (in category 'computing') -----
stepToFirstScanLineAt: yValue in: edgeTableEntry
"Compute the initial x value for the scan line at yValue"
| startX endX startY endY yDir deltaY deltaX widthX |
(start y) <= (end y) ifTrue:[
startX := start x. endX := end x.
startY := start y. endY := end y.
yDir := 1.
] ifFalse:[
startX := end x. endX := start x.
startY := end y. endY := start y.
yDir := -1.
].
deltaY := endY - startY.
deltaX := endX - startX.
"Quickly check if the line is visible at all"
(yValue >= endY or:[deltaY = 0]) ifTrue:[^edgeTableEntry lines: 0].
"Check if edge goes left to right"
deltaX >= 0 ifTrue:[
xDirection := 1.
widthX := deltaX.
error := 0.
] ifFalse:[
xDirection := -1.
widthX := 0 - deltaX.
error := 1 - deltaY.
].
"Check if edge is horizontal"
deltaY = 0
ifTrue:[ xIncrement := 0.
errorAdjUp := 0]
ifFalse:["Check if edge is y-major"
deltaY > widthX
ifTrue:[ xIncrement := 0.
errorAdjUp := widthX]
ifFalse:[ xIncrement := (widthX // deltaY) * xDirection.
errorAdjUp := widthX \\ deltaY]].
errorAdjDown := deltaY.
edgeTableEntry xValue: startX.
edgeTableEntry lines: deltaY.
"If not at first scan line then step down to yValue"
yValue = startY ifFalse:[
startY to: yValue do:[:y| self stepToNextScanLineAt: y in: edgeTableEntry].
"And adjust remainingLines"
edgeTableEntry lines: deltaY - (yValue - startY).
].!
----- Method: BalloonLineSimulation>>stepToNextScanLineAt:in: (in category 'computing') -----
stepToNextScanLineAt: yValue in: edgeTableEntry
"Compute the next x value for the scan line at yValue.
This message is sent during incremental updates.
The yValue parameter is passed in here for edges
that have more complicated computations,"
| x |
x := edgeTableEntry xValue + xIncrement.
error := error + errorAdjUp.
error > 0 ifTrue:[
x := x + xDirection.
error := error - errorAdjDown.
].
edgeTableEntry xValue: x.!
----- Method: BalloonLineSimulation>>subdivide (in category 'computing') -----
subdivide
^nil!
Object subclass: #BalloonSolidFillSimulation
instanceVariableNames: 'color'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Simulation'!
!BalloonSolidFillSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!
----- Method: BalloonSolidFillSimulation>>computeFillFrom:to:at:in: (in category 'computing') -----
computeFillFrom: minX to: maxX at: yValue in: form
| bb |
color isTransparent ifFalse:[
bb := BitBlt toForm: form.
bb fillColor: color.
bb destX: 0 destY: 0 width: (maxX - minX) height: 1.
bb combinationRule: Form over.
bb copyBits].!
----- Method: BalloonSolidFillSimulation>>computeInitialStateFrom:with: (in category 'computing') -----
computeInitialStateFrom: source with: aColorTransform
color := source asColor.!
Object subclass: #BalloonState
instanceVariableNames: 'transform colorTransform aaLevel'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Engine'!
!BalloonState commentStamp: '<historical>' prior: 0!
This class is a repository for data which needs to be preserved during certain operations of BalloonCanvas.!
----- Method: BalloonState>>aaLevel (in category 'accessing') -----
aaLevel
^aaLevel!
----- Method: BalloonState>>aaLevel: (in category 'accessing') -----
aaLevel: aNumber
aaLevel := aNumber!
----- Method: BalloonState>>colorTransform (in category 'accessing') -----
colorTransform
^colorTransform!
----- Method: BalloonState>>colorTransform: (in category 'accessing') -----
colorTransform: aColorTransform
colorTransform := aColorTransform!
----- Method: BalloonState>>transform (in category 'accessing') -----
transform
^transform!
----- Method: BalloonState>>transform: (in category 'accessing') -----
transform: aMatrixTransform
transform := aMatrixTransform!
Object subclass: #CompressedBoundaryShape
instanceVariableNames: 'points leftFills rightFills lineWidths lineFills fillStyles'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Geometry'!
!CompressedBoundaryShape commentStamp: '<historical>' prior: 0!
This class represents a very compact representation of a boundary shape. It consists of a number of compressed arrays that can be handled by the balloon engine directly. Due to this, there are certain restrictions (see below). Boundaries are always represented by three subsequent points that define a quadratic bezier segment. It is recommended that for straight line segments the control point is set either to the previous or the next point.
Instance variables:
points <PointArray | ShortPointArray> Point storage area
leftFills <ShortRunArray> Containing the "left" fill index of each segment
rightFills <ShortRunArray> Containing the "right" fill index of each segment
lineWidths <ShortRunArray> Containing the line width of each segment
lineFills <ShortRunArray> Containing the line fill (e.g., line color) of each segment
fillStyles <Collections> Contains the actual fill styles referenced by the indexes
RESTRICTIONS:
None of the ShortRunArrays may contain a run of length Zero.
Also, due to the use of ShortRunArrays
a) you cannot have more than 32768 different fill styles
b) you cannot have a line width that exceeds 32768
In case you have trouble with a), try to merge some of the fills into one. You might do so by converting colors to 32bit pixel values. In case you have trouble with b) you might change the general resolution of the compressed shape to have less accuracy.
!
----- Method: CompressedBoundaryShape class>>points:leftFills:rightFills:fillStyles:lineWidths:lineFills: (in category 'instance creation') -----
points: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList
^self new setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList!
----- Method: CompressedBoundaryShape>>bounds (in category 'accessing') -----
bounds
| min max width |
points isEmpty ifTrue:[^0 at 0 corner: 1 at 1].
min := max := points first.
points do:[:pt|
min := min min: pt.
max := max max: pt
].
width := 0.
lineWidths valuesDo:[:w| width := width max: w].
^(min corner: max) insetBy: (width negated asPoint)!
----- Method: CompressedBoundaryShape>>collectFills: (in category 'editing') -----
collectFills: aBlock
fillStyles := fillStyles collect: aBlock.!
----- Method: CompressedBoundaryShape>>copyAndCollectFills: (in category 'editing') -----
copyAndCollectFills: aBlock
^self copy collectFills: aBlock!
----- Method: CompressedBoundaryShape>>fillStyles (in category 'accessing') -----
fillStyles
^fillStyles!
----- Method: CompressedBoundaryShape>>leftFills (in category 'accessing') -----
leftFills
^leftFills!
----- Method: CompressedBoundaryShape>>lineFills (in category 'accessing') -----
lineFills
^lineFills!
----- Method: CompressedBoundaryShape>>lineWidths (in category 'accessing') -----
lineWidths
^lineWidths!
----- Method: CompressedBoundaryShape>>morphFrom:to:at: (in category 'morphing') -----
morphFrom: srcShape to: dstShape at: ratio
| scale unscale srcPoints dstPoints pt1 pt2 x y |
scale := (ratio * 1024) asInteger.
scale < 0 ifTrue:[scale := 0].
scale > 1024 ifTrue:[scale := 1024].
unscale := 1024 - scale.
srcPoints := srcShape points.
dstPoints := dstShape points.
1 to: points size do:[:i|
pt1 := srcPoints at: i.
pt2 := dstPoints at: i.
x := ((pt1 x * unscale) + (pt2 x * scale)) bitShift: -10.
y := ((pt1 y * unscale) + (pt2 y * scale)) bitShift: -10.
points at: i put: x at y].!
----- Method: CompressedBoundaryShape>>numSegments (in category 'accessing') -----
numSegments
^points size // 3!
----- Method: CompressedBoundaryShape>>points (in category 'accessing') -----
points
^points!
----- Method: CompressedBoundaryShape>>rightFills (in category 'accessing') -----
rightFills
^rightFills!
----- Method: CompressedBoundaryShape>>segments (in category 'accessing') -----
segments
"Return all the segments in the receiver"
| out |
out := WriteStream on: Array new.
self segmentsDo:[:seg| out nextPut: seg].
^out contents!
----- Method: CompressedBoundaryShape>>segmentsDo: (in category 'enumerating') -----
segmentsDo: aBlock
"Enumerate all segments in the receiver and execute aBlock"
| p1 p2 p3 |
1 to: points size by: 3 do:[:i|
p1 := points at: i.
p2 := points at: i+1.
p3 := points at: i+2.
(p1 = p2 or:[p2 = p3]) ifTrue:[
aBlock value: (LineSegment from: p1 to: p3).
] ifFalse:[
aBlock value: (Bezier2Segment from: p1 via: p2 to: p3).
].
].!
----- Method: CompressedBoundaryShape>>setPoints:leftFills:rightFills:fillStyles:lineWidths:lineFills: (in category 'private') -----
setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList
points := pointList.
leftFills := leftFillList.
rightFills := rightFillList.
lineWidths := lineWidthList.
lineFills := lineFillList.
fillStyles := fillStyleList.!
Object subclass: #FillStyle
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Fills'!
!FillStyle commentStamp: '<historical>' prior: 0!
FillStyle is an abstract base class for fills in the BalloonEngine.!
----- Method: FillStyle>>asColor (in category 'converting') -----
asColor
^self subclassResponsibility!
----- Method: FillStyle>>isBitmapFill (in category 'testing') -----
isBitmapFill
^false!
----- Method: FillStyle>>isGradientFill (in category 'testing') -----
isGradientFill
^false!
----- Method: FillStyle>>isOrientedFill (in category 'testing') -----
isOrientedFill
"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
^false!
----- Method: FillStyle>>isSolidFill (in category 'testing') -----
isSolidFill
^false!
----- Method: FillStyle>>isTranslucent (in category 'testing') -----
isTranslucent
^true "Since we don't know better"!
----- Method: FillStyle>>isTransparent (in category 'testing') -----
isTransparent
^false!
----- Method: FillStyle>>mixed:with: (in category 'converting') -----
mixed: fraction with: aColor
^self asColor mixed: fraction with: aColor!
----- Method: FillStyle>>scaledPixelValue32 (in category 'accessing') -----
scaledPixelValue32
"Return a pixel value of depth 32 for the primary color in the fill style"
^self asColor scaledPixelValue32!
FillStyle subclass: #OrientedFillStyle
instanceVariableNames: 'origin direction normal'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Fills'!
!OrientedFillStyle commentStamp: '<historical>' prior: 0!
OrientedFill is an abstract superclass for fills which can be aligned appropriately.
Instance variables:
origin <Point> The point at which to align the fill.
direction <Point> The direction in which the fill is defined
normal <Point> Typically, just the direction rotated by 90 degrees.!
OrientedFillStyle subclass: #BitmapFillStyle
instanceVariableNames: 'form tileFlag'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Fills'!
!BitmapFillStyle commentStamp: '<historical>' prior: 0!
A BitmapFillStyle fills using any kind of form.
Instance variables:
form <Form> The form to be used as fill.
tileFlag <Boolean> If true, then the form is repeatedly drawn to fill the area.!
----- Method: BitmapFillStyle class>>form: (in category 'instance creation') -----
form: aForm
^self new form: aForm!
----- Method: BitmapFillStyle class>>fromForm: (in category 'instance creation') -----
fromForm: aForm
| fs |
fs := self form: aForm.
fs origin: 0 at 0.
fs direction: aForm width @ 0.
fs normal: 0 @ aForm height.
fs tileFlag: true.
^fs!
----- Method: BitmapFillStyle class>>fromUser (in category 'instance creation') -----
fromUser
| fill |
fill := self form: Form fromUser.
fill origin: 0 at 0.
fill direction: fill form width @ 0.
fill normal: 0 @ fill form height.
fill tileFlag: true. "So that we can fill arbitrary objects"
^fill!
----- Method: BitmapFillStyle>>asColor (in category 'converting') -----
asColor
^form colorAt: 0 at 0!
----- Method: BitmapFillStyle>>direction (in category 'accessing') -----
direction
^direction ifNil:[direction :=( (normal y @ normal x negated) * form width / form height ) rounded]!
----- Method: BitmapFillStyle>>form (in category 'accessing') -----
form
^form!
----- Method: BitmapFillStyle>>form: (in category 'accessing') -----
form: aForm
form := aForm!
----- Method: BitmapFillStyle>>isBitmapFill (in category 'testing') -----
isBitmapFill
^true!
----- Method: BitmapFillStyle>>isTiled (in category 'testing') -----
isTiled
"Return true if the receiver should be repeated if the fill shape is larger than the form"
^tileFlag == true!
----- Method: BitmapFillStyle>>isTranslucent (in category 'testing') -----
isTranslucent
"Return true since the bitmap may be translucent and we don't really want to check"
^true!
----- Method: BitmapFillStyle>>normal (in category 'accessing') -----
normal
^normal ifNil:[normal := ((direction y negated @ direction x) * form height / form width ) rounded]!
----- Method: BitmapFillStyle>>tileFlag (in category 'accessing') -----
tileFlag
^tileFlag!
----- Method: BitmapFillStyle>>tileFlag: (in category 'accessing') -----
tileFlag: aBoolean
tileFlag := aBoolean!
OrientedFillStyle subclass: #GradientFillStyle
instanceVariableNames: 'colorRamp pixelRamp radial isTranslucent'
classVariableNames: 'PixelRampCache'
poolDictionaries: ''
category: 'Balloon-Fills'!
!GradientFillStyle commentStamp: 'efc 8/30/2005 21:44' prior: 0!
A gradient fill style is a fill which interpolates smoothly between any number of colors.
Instance variables:
colorRamp <Array of: Association> Contains the colors and their relative positions along the fill, which is a number between zero and one.
pixelRamp <Bitmap> A cached version of the colorRamp to avoid needless recomputations.
radial <Boolean> If true, this fill describes a radial gradient. If false, it is a linear gradient.
isTranslucent <Boolean> A (cached) flag determining if there are any translucent colors involved.
Class variables:
PixelRampCache <LRUCache> Recently used pixelRamps. They tend to have high temporal locality and this saves space and time.!
----- Method: GradientFillStyle class>>colors: (in category 'instance creation') -----
colors: colorArray
"Create a gradient fill style from an array of equally spaced colors"
^self ramp: (colorArray withIndexCollect:
[:color :index| (index-1 asFloat / (colorArray size - 1 max: 1)) -> color]).!
----- Method: GradientFillStyle class>>initPixelRampCache (in category 'class initialization') -----
initPixelRampCache
"Create an LRUCache to use for accessing pixel ramps."
"Details: when a new pixel ramp is needed, a temporary GradientFillStyle is created so that it can be used to create a new pixel ramp"
^PixelRampCache := LRUCache size: 32 factory:[:key|
(GradientFillStyle new colorRamp: key) computePixelRampOfSize: 512] !
----- Method: GradientFillStyle class>>pixelRampCache (in category 'class initialization') -----
pixelRampCache
"Allow access to my cache of pixel ramps. This is mainly for debugging and profiling purposes."
^PixelRampCache !
----- Method: GradientFillStyle class>>ramp: (in category 'instance creation') -----
ramp: colorRamp
^self new colorRamp: colorRamp!
----- Method: GradientFillStyle class>>sample (in category 'instance creation') -----
sample
"GradientFill sample"
^(self ramp: { 0.0 -> Color red. 0.5 -> Color green. 1.0 -> Color blue})
origin: 300 @ 300;
direction: 400 at 0;
normal: 0 at 400;
radial: true;
yourself!
----- Method: GradientFillStyle>>asColor (in category 'converting') -----
asColor
"Guess..."
^colorRamp first value mixed: 0.5 with: colorRamp last value!
----- Method: GradientFillStyle>>checkTranslucency (in category 'private') -----
checkTranslucency
^colorRamp anySatisfy: [:any| any value isTranslucent]!
----- Method: GradientFillStyle>>colorRamp (in category 'accessing') -----
colorRamp
^colorRamp!
----- Method: GradientFillStyle>>colorRamp: (in category 'accessing') -----
colorRamp: anArray
colorRamp := anArray.
pixelRamp := nil.
isTranslucent := nil.!
----- Method: GradientFillStyle>>computePixelRampOfSize: (in category 'private') -----
computePixelRampOfSize: length
"Compute the pixel ramp in the receiver"
| bits lastColor lastIndex nextIndex nextColor distance theta lastValue ramp lastWord nextWord step |
ramp := colorRamp asSortedCollection:[:a1 :a2| a1 key < a2 key].
bits := Bitmap new: length.
lastColor := ramp first value.
lastWord := lastColor pixelWordForDepth: 32.
lastIndex := 0.
ramp do:[:assoc|
nextIndex := (assoc key * length) rounded.
nextColor := assoc value.
nextWord := nextColor pixelWordForDepth: 32.
distance := (nextIndex - lastIndex).
distance = 0 ifTrue:[distance := 1].
step := 1.0 / distance asFloat.
theta := 0.0.
lastIndex+1 to: nextIndex do:[:i|
theta := theta + step.
"The following is an open-coded version of:
color := nextColor alphaMixed: theta with: lastColor.
bits at: i put: (color scaledPixelValue32).
"
bits at: i put: (self scaledAlphaMix: theta of: lastWord with: nextWord).
].
lastIndex := nextIndex.
lastColor := nextColor.
lastWord := nextWord.
].
lastValue := lastColor scaledPixelValue32.
lastIndex+1 to: length do:[:i| bits at: i put: lastValue].
^bits!
----- Method: GradientFillStyle>>display (in category 'private') -----
display
| f ramp |
ramp := self pixelRamp.
f := Form extent: ramp size @ 1 depth: 32 bits: ramp.
1 to: 100 do:[:i| f displayAt: 1 at i].
[Sensor anyButtonPressed] whileFalse.
[Sensor anyButtonPressed] whileTrue.!
----- Method: GradientFillStyle>>isGradientFill (in category 'testing') -----
isGradientFill
^true!
----- Method: GradientFillStyle>>isRadialFill (in category 'testing') -----
isRadialFill
^radial == true!
----- Method: GradientFillStyle>>isSolidFill (in category 'testing') -----
isSolidFill
^false!
----- Method: GradientFillStyle>>isTranslucent (in category 'testing') -----
isTranslucent
^isTranslucent ifNil:[isTranslucent := self checkTranslucency]!
----- Method: GradientFillStyle>>mixed:with: (in category 'converting') -----
mixed: fraction with: aColor
^self copy colorRamp: (colorRamp collect:[:assoc| assoc key -> (assoc value mixed: fraction with: aColor)])!
----- Method: GradientFillStyle>>pixelRamp (in category 'accessing') -----
pixelRamp
"Compute a pixel ramp, and cache it for future accesses"
^pixelRamp ifNil:[
"Insure the PixelRampCache is in place"
PixelRampCache ifNil:[ self class initPixelRampCache ].
"Ask my cache for an existing instance if one is available"
pixelRamp := PixelRampCache at: colorRamp
].!
----- Method: GradientFillStyle>>pixelRamp: (in category 'accessing') -----
pixelRamp: aBitmap
pixelRamp := aBitmap!
----- Method: GradientFillStyle>>radial (in category 'accessing') -----
radial
^radial ifNil:[false]!
----- Method: GradientFillStyle>>radial: (in category 'accessing') -----
radial: aBoolean
radial := aBoolean!
----- Method: GradientFillStyle>>scaledAlphaMix:of:with: (in category 'private') -----
scaledAlphaMix: theta of: lastWord with: nextWord
"Open-coded version of alpha mixing two 32bit pixel words and returning the scaled pixel value."
| word0 word1 a0 a1 alpha v0 v1 vv value |
word0 := lastWord.
word1 := nextWord.
"note: extract alpha first so we'll be in SmallInteger range afterwards"
a0 := word0 bitShift: -24. a1 := word1 bitShift: -24.
alpha := a0 + (a1 - a0 * theta) truncated.
"Now make word0 and word1 SmallIntegers"
word0 := word0 bitAnd: 16rFFFFFF. word1 := word1 bitAnd: 16rFFFFFF.
"Compute first component value"
v0 := (word0 bitAnd: 255). v1 := (word1 bitAnd: 255).
vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
value := vv.
"Compute second component value"
v0 := ((word0 bitShift: -8) bitAnd: 255). v1 := ((word1 bitShift: -8) bitAnd: 255).
vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
value := value bitOr: (vv bitShift: 8).
"Compute third component value"
v0 := ((word0 bitShift: -16) bitAnd: 255). v1 := ((word1 bitShift: -16) bitAnd: 255).
vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
value := value bitOr: (vv bitShift: 16).
"Return result"
^value bitOr: (alpha bitShift: 24)!
----- Method: OrientedFillStyle>>direction (in category 'accessing') -----
direction
^direction ifNil:[direction := normal y @ normal x negated]!
----- Method: OrientedFillStyle>>direction: (in category 'accessing') -----
direction: aPoint
direction := aPoint!
----- Method: OrientedFillStyle>>isOrientedFill (in category 'testing') -----
isOrientedFill
"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
^true!
----- Method: OrientedFillStyle>>normal (in category 'accessing') -----
normal
^normal ifNil:[normal := direction y negated @ direction x]!
----- Method: OrientedFillStyle>>normal: (in category 'accessing') -----
normal: aPoint
normal := aPoint!
----- Method: OrientedFillStyle>>origin (in category 'accessing') -----
origin
^origin!
----- Method: OrientedFillStyle>>origin: (in category 'accessing') -----
origin: aPoint
origin := aPoint.!
FillStyle subclass: #SolidFillStyle
instanceVariableNames: 'color pixelValue32'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Fills'!
!SolidFillStyle commentStamp: '<historical>' prior: 0!
SolidFillStyle is a fill which represents a color for the BalloonEngine.
Instance variables:
color <Color> The color to use.
pixelValue32 <Integer> The cached pixel value to use.!
----- Method: SolidFillStyle class>>color: (in category 'instance creation') -----
color: aColor
^self new color: aColor!
----- Method: SolidFillStyle>>asColor (in category 'converting') -----
asColor
^color!
----- Method: SolidFillStyle>>color: (in category 'accessing') -----
color: aColor
color := aColor.
pixelValue32 := aColor scaledPixelValue32!
----- Method: SolidFillStyle>>display (in category 'accessing') -----
display
^color display!
----- Method: SolidFillStyle>>isSolidFill (in category 'testing') -----
isSolidFill
^true!
----- Method: SolidFillStyle>>isTranslucent (in category 'testing') -----
isTranslucent
^color isTranslucent!
----- Method: SolidFillStyle>>isTransparent (in category 'testing') -----
isTransparent
^color isTransparent!
----- Method: SolidFillStyle>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPut:$(; print: color; nextPut:$).!
----- Method: SolidFillStyle>>scaledPixelValue32 (in category 'accessing') -----
scaledPixelValue32
"Return the alpha scaled pixel value for depth 32"
^pixelValue32!
Object subclass: #LineSegment
instanceVariableNames: 'start end'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Geometry'!
!LineSegment commentStamp: '<historical>' prior: 0!
This class represents a straight line segment between two points
Instance variables:
start <Point> start point of the line
end <Point> end point of the line
!
LineSegment subclass: #Bezier2Segment
instanceVariableNames: 'via'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Geometry'!
!Bezier2Segment commentStamp: '<historical>' prior: 0!
This class represents a quadratic bezier segment between two points
Instance variables:
via <Point> The additional control point (OFF the curve)!
----- Method: Bezier2Segment class>>from:to:via: (in category 'instance creation') -----
from: startPoint to: endPoint via: viaPoint
^self new from: startPoint to: endPoint via: viaPoint!
----- Method: Bezier2Segment class>>from:to:withMidPoint: (in category 'instance creation') -----
from: startPoint to: endPoint withMidPoint: pointOnCurve
^self new from: startPoint to: endPoint withMidPoint: pointOnCurve!
----- Method: Bezier2Segment class>>from:to:withMidPoint:at: (in category 'instance creation') -----
from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter
^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter!
----- Method: Bezier2Segment class>>from:via:to: (in category 'instance creation') -----
from: startPoint via: viaPoint to: endPoint
^self new from: startPoint to: endPoint via: viaPoint!
----- Method: Bezier2Segment class>>from:withMidPoint:at:to: (in category 'instance creation') -----
from: startPoint withMidPoint: pointOnCurve at: parameter to: endPoint
^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter!
----- Method: Bezier2Segment class>>from:withMidPoint:to: (in category 'instance creation') -----
from: startPoint withMidPoint: pointOnCurve to: endPoint
^self new from: startPoint to: endPoint withMidPoint: pointOnCurve!
----- Method: Bezier2Segment class>>makeEllipseSegments: (in category 'utilities') -----
makeEllipseSegments: aRectangle
"Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle.
This method creates eight bezier segments (two for each quadrant) approximating the oval."
"EXAMPLE:
This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval.
| rect |
rect := 100 at 100 extent: 1200 at 500.
Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red.
(Bezier2Segment makeEllipseSegments: rect) do:[:seg|
seg lineSegmentsDo:[:last :next|
Display getCanvas line: last to: next width: 1 color: Color black]].
"
"EXAMPLE:
| minRadius maxRadius |
maxRadius := 300.
minRadius := 20.
maxRadius to: minRadius by: -10 do:[:rad|
| rect |
rect := 400 at 400 - rad corner: 400 at 400 + rad.
Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red.
(Bezier2Segment makeEllipseSegments: rect) do:[:seg|
seg lineSegmentsDo:[:last :next|
Display getCanvas line: last to: next width: 1 color: Color black]]].
"
| nrm topCenter leftCenter rightCenter bottomCenter dir scale seg1a topRight seg1b seg2a bottomRight seg2b center bottomLeft topLeft seg3a seg3b seg4a seg4b |
dir := aRectangle width * 0.5.
nrm := aRectangle height * 0.5.
"Compute the eight control points on the oval"
scale := 0.7071067811865475. "45 degreesToRadians cos = 45 degreesToRadians sin = 2 sqrt / 2"
center := aRectangle origin + aRectangle corner * 0.5.
topCenter := aRectangle topCenter.
rightCenter := aRectangle rightCenter.
leftCenter := aRectangle leftCenter.
bottomCenter := aRectangle bottomCenter.
topRight := (center x + (dir * scale)) @ (center y - (nrm * scale)).
bottomRight := (center x + (dir * scale)) @ (center y + (nrm * scale)).
bottomLeft := (center x - (dir * scale)) @ (center y + (nrm * scale)).
topLeft := (center x - (dir * scale)) @ (center y - (nrm * scale)).
scale := 0.414213562373095. "2 sqrt - 1"
dir := (dir * scale) @ 0.
nrm := 0 @ (nrm * scale).
seg1a := self from: topCenter via: topCenter + dir to: topRight.
seg1b := self from: topRight via: rightCenter - nrm to: rightCenter.
seg2a := self from: rightCenter via: rightCenter + nrm to: bottomRight.
seg2b := self from: bottomRight via: bottomCenter + dir to: bottomCenter.
seg3a := self from: bottomCenter via: bottomCenter - dir to: bottomLeft.
seg3b := self from: bottomLeft via: leftCenter + nrm to: leftCenter.
seg4a := self from: leftCenter via: leftCenter - nrm to: topLeft.
seg4b := self from: topLeft via: topCenter - dir to: topCenter.
^{seg1a. seg1b. seg2a. seg2b. seg3a. seg3b. seg4a. seg4b}!
----- Method: Bezier2Segment>>asBezier2Points: (in category 'converting') -----
asBezier2Points: error
^Array with: start with: via with: end!
----- Method: Bezier2Segment>>asBezier2Segment (in category 'converting') -----
asBezier2Segment
"Represent the receiver as quadratic bezier segment"
^self!
----- Method: Bezier2Segment>>asBezier3Segment (in category 'converting') -----
asBezier3Segment
"Represent the receiver as cubic bezier segment"
^Bezier3Segment
from: start
via: 2*via+start / 3.0
and: 2*via+end / 3.0
to: end!
----- Method: Bezier2Segment>>asIntegerSegment (in category 'converting') -----
asIntegerSegment
"Convert the receiver into integer representation"
^self species
from: start asIntegerPoint
to: end asIntegerPoint
via: via asIntegerPoint!
----- Method: Bezier2Segment>>asTangentSegment (in category 'converting') -----
asTangentSegment
^LineSegment from: via-start to: end-via!
----- Method: Bezier2Segment>>bezierClipHeight: (in category 'bezier clipping') -----
bezierClipHeight: dir
| dirX dirY uMin uMax dx dy u |
dirX := dir x.
dirY := dir y.
uMin := 0.0.
uMax := (dirX * dirX) + (dirY * dirY).
dx := via x - start x.
dy := via y - start y.
u := (dirX * dx) + (dirY * dy).
u < uMin ifTrue:[uMin := u].
u > uMax ifTrue:[uMax := u].
^uMin at uMax!
----- Method: Bezier2Segment>>bounds (in category 'accessing') -----
bounds
"Return the bounds containing the receiver"
^super bounds encompass: via!
----- Method: Bezier2Segment>>controlPoints (in category 'vector functions') -----
controlPoints
^{start. via. end}!
----- Method: Bezier2Segment>>controlPointsDo: (in category 'vector functions') -----
controlPointsDo: aBlock
aBlock value: start; value: via; value: end!
----- Method: Bezier2Segment>>curveFrom:to: (in category 'vector functions') -----
curveFrom: param1 to: param2
"Return a new curve from param1 to param2"
| newStart newEnd newVia tan1 tan2 d1 d2 |
tan1 := via - start.
tan2 := end - via.
param1 <= 0.0 ifTrue:[
newStart := start.
] ifFalse:[
d1 := tan1 * param1 + start.
d2 := tan2 * param1 + via.
newStart := (d2 - d1) * param1 + d1
].
param2 >= 1.0 ifTrue:[
newEnd := end.
] ifFalse:[
d1 := tan1 * param2 + start.
d2 := tan2 * param2 + via.
newEnd := (d2 - d1) * param2 + d1.
].
tan2 := (tan2 - tan1 * param1 + tan1) * (param2 - param1).
newVia := newStart + tan2.
^self clone from: newStart to: newEnd via: newVia.!
----- Method: Bezier2Segment>>degree (in category 'accessing') -----
degree
^2!
----- Method: Bezier2Segment>>end: (in category 'vector functions') -----
end: aPoint
end := aPoint.!
----- Method: Bezier2Segment>>from:to: (in category 'initialize') -----
from: startPoint to: endPoint
"Initialize the receiver as straight line"
start := startPoint.
end := endPoint.
via := (start + end) // 2.!
----- Method: Bezier2Segment>>from:to:via: (in category 'initialize') -----
from: startPoint to: endPoint via: viaPoint
"Initialize the receiver"
start := startPoint.
end := endPoint.
via := viaPoint.!
----- Method: Bezier2Segment>>from:to:withMidPoint: (in category 'initialize') -----
from: startPoint to: endPoint withMidPoint: pointOnCurve
"Initialize the receiver with the pointOnCurve assumed at the parametric value 0.5"
start := startPoint.
end := endPoint.
"Compute via"
via := (pointOnCurve * 2) - (start + end * 0.5).!
----- Method: Bezier2Segment>>from:to:withMidPoint:at: (in category 'initialize') -----
from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter
"Initialize the receiver with the pointOnCurve at the given parametric value"
| t1 t2 t3 |
start := startPoint.
end := endPoint.
"Compute via"
t1 := (1.0 - parameter) squared.
t2 := 1.0 / (2 * parameter * (1.0 - parameter)).
t3 := parameter squared.
via := (pointOnCurve - (start * t1) - (end * t3)) * t2!
----- Method: Bezier2Segment>>hasZeroLength (in category 'testing') -----
hasZeroLength
"Return true if the receiver has zero length"
^start = end and:[start = via]!
----- Method: Bezier2Segment>>initializeFrom: (in category 'initialize') -----
initializeFrom: controlPoints
controlPoints size = 3 ifFalse:[self error:'Wrong number of control points'].
start := controlPoints at: 1.
via := controlPoints at: 2.
end := controlPoints at: 3.!
----- Method: Bezier2Segment>>isBezier2Segment (in category 'testing') -----
isBezier2Segment
"Return true if the receiver is a quadratic bezier segment"
^true!
----- Method: Bezier2Segment>>isStraight (in category 'testing') -----
isStraight
"Return true if the receiver represents a straight line"
^(self tangentAtStart crossProduct: self tangentAtEnd) = 0!
----- Method: Bezier2Segment>>length (in category 'vector functions') -----
length
"Return the length of the receiver"
"Note: Overestimates the length"
^(start dist: via) + (via dist: end)!
----- Method: Bezier2Segment>>lineSegments:do: (in category 'vector functions') -----
lineSegments: steps do: aBlock
"Evaluate aBlock with the receiver's line segments"
"Note: We could use forward differencing here."
| last deltaStep t next |
last := start.
deltaStep := 1.0 / steps asFloat.
t := deltaStep.
1 to: steps do:[:i|
next := self valueAt: t.
aBlock value: last value: next.
last := next.
t := t + deltaStep].!
----- Method: Bezier2Segment>>lineSegmentsDo: (in category 'vector functions') -----
lineSegmentsDo: aBlock
"Evaluate aBlock with the receiver's line segments"
"Note: We could use forward differencing here."
| steps last deltaStep t next |
steps := 1 max: (self length // 10). "Assume 10 pixels per step"
last := start.
deltaStep := 1.0 / steps asFloat.
t := deltaStep.
1 to: steps do:[:i|
next := self valueAt: t.
aBlock value: last value: next.
last := next.
t := t + deltaStep].!
----- Method: Bezier2Segment>>outlineSegment: (in category 'vector functions') -----
outlineSegment: width
| delta newStart newEnd param newMid |
delta := self tangentAtStart normalized * width.
delta := delta y @ delta x negated.
newStart := start + delta.
delta := self tangentAtEnd normalized * width.
delta := delta y @ delta x negated.
newEnd := end + delta.
param := 0.5. "self tangentAtStart r / (self tangentAtStart r + self tangentAtEnd r)."
delta := (self tangentAt: param) normalized * width.
delta := delta y @ delta x negated.
newMid := (self valueAt: param) + delta.
^self class from: newStart to: newEnd withMidPoint: newMid at: param!
----- Method: Bezier2Segment>>parameterAtExtreme: (in category 'vector functions') -----
parameterAtExtreme: tangentDirection
"Compute the parameter value at which the tangent reaches tangentDirection.
We need to find the parameter value t at which the following holds
((t * dir + in) crossProduct: tangentDirection) = 0.
Since this is pretty ugly we use the normal direction rather than the tangent and compute the equivalent relation using the dot product as
((t * dir + in) dotProduct: nrm) = 0.
Reformulation yields
((t * dir x + in x) * nrm x) + ((t * dir y + in y) * nrm y) = 0.
(t * dir x * nrm x) + (in x * nrm x) + (t * dir y * nrm y) + (in y * nrm y) = 0.
(t * dir x * nrm x) + (t * dir y * nrm y) = 0 - ((in x * nrm x) + (in y * nrm y)).
(in x * nrm x) + (in y * nrm y)
t = 0 - ---------------------------------------
(dir x * nrm x) + (dir y * nrm y)
And that's that. Note that we can get rid of the negation by computing 'dir' the other way around (e.g., in the above it would read '-dir') which is trivial to do. Note also that the above does not generalize easily beyond 2D since its not clear how to express the 'normal direction' of a tangent plane.
"
| inX inY dirX dirY nrmX nrmY |
"Compute in"
inX := via x - start x.
inY := via y - start y.
"Compute -dir"
dirX := inX - (end x - via x).
dirY := inY - (end y - via y).
"Compute nrm"
nrmX := tangentDirection y.
nrmY := 0 - tangentDirection x.
"Compute result"
^((inX * nrmX) + (inY * nrmY)) /
((dirX * nrmX) + (dirY * nrmY))!
----- Method: Bezier2Segment>>parameterAtExtremeX (in category 'vector functions') -----
parameterAtExtremeX
"Note: Only valid for non-monoton receivers"
^self parameterAtExtreme: 0.0 at 1.0.
!
----- Method: Bezier2Segment>>parameterAtExtremeY (in category 'vector functions') -----
parameterAtExtremeY
"Note: Only valid for non-monoton receivers"
^self parameterAtExtreme: 1.0 at 0.0.
!
----- Method: Bezier2Segment>>printOn: (in category 'printing') -----
printOn: aStream
"Print the receiver on aStream"
aStream
nextPutAll: self class name;
nextPutAll:' from: ';
print: start;
nextPutAll: ' via: ';
print: via;
nextPutAll: ' to: ';
print: end;
space.!
----- Method: Bezier2Segment>>printOnStream: (in category 'printing') -----
printOnStream: aStream
aStream
print: self class name;
print:'from: ';
write: start;
print:'via: ';
write: via;
print:'to: ';
write: end;
print:' '.!
----- Method: Bezier2Segment>>roundTo: (in category 'vector functions') -----
roundTo: quantum
super roundTo: quantum.
via := via roundTo: quantum.
!
----- Method: Bezier2Segment>>start: (in category 'vector functions') -----
start: aPoint
start := aPoint.!
----- Method: Bezier2Segment>>tangentAt: (in category 'vector functions') -----
tangentAt: parameter
"Return the tangent at the given parametric value along the receiver"
| in out |
in := self tangentAtStart.
out := self tangentAtEnd.
^in + (out - in * parameter)!
----- Method: Bezier2Segment>>tangentAtEnd (in category 'vector functions') -----
tangentAtEnd
"Return the tangent for the last point"
^end - via!
----- Method: Bezier2Segment>>tangentAtMid (in category 'vector functions') -----
tangentAtMid
"Return the tangent at the given parametric value along the receiver"
| in out |
in := self tangentAtStart.
out := self tangentAtEnd.
^in + out * 0.5!
----- Method: Bezier2Segment>>tangentAtStart (in category 'vector functions') -----
tangentAtStart
"Return the tangent for the first point"
^via - start!
----- Method: Bezier2Segment>>valueAt: (in category 'vector functions') -----
valueAt: parameter
"Evaluate the receiver at the given parametric value"
"Return the point at the parametric value t:
p(t) = (1-t)^2 * p1 +
2*t*(1-t) * p2 +
t^2 * p3.
"
| t1 t2 t3 |
t1 := (1.0 - parameter) squared.
t2 := 2 * parameter * (1.0 - parameter).
t3 := parameter squared.
^(start * t1) + (via * t2) + (end * t3)!
----- Method: Bezier2Segment>>via (in category 'accessing') -----
via
"Return the control point"
^via!
LineSegment subclass: #Bezier3Segment
instanceVariableNames: 'via1 via2'
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Geometry'!
!Bezier3Segment commentStamp: '<historical>' prior: 0!
This class represents a cubic bezier segment between two points
Instance variables:
via1, via2 <Point> The additional control points (OFF the curve)!
----- Method: Bezier3Segment class>>convertBezier3ToBezier2: (in category 'utilities') -----
convertBezier3ToBezier2: vertices
| pa pts index c |
pts := OrderedCollection new.
1 to: vertices size // 4 do:
[:i |
index := i * 4 - 3.
c := Bezier3Segment new
from: (vertices at: index)
via: (vertices at: index + 1)
and: (vertices at: index + 2)
to: (vertices at: index + 3).
pts addAll: c asBezierShape].
pa := PointArray new: pts size.
pts withIndexDo: [:p :i | pa at: i put: p ].
^ pa!
----- Method: Bezier3Segment class>>example1 (in category 'examples') -----
example1
| c |
c := Bezier3Segment new from: 0 at 0 via: 0 at 100 and: 100 at 0 to: 100 at 100.
^ c asBezierShape!
----- Method: Bezier3Segment class>>example2 (in category 'examples') -----
example2
"draws a cubic bezier on the screen"
| c canvas |
c := Bezier3Segment new
from: 0 @ 0
via: 0 @ 100
and: 100 @ 0
to: 100 @ 100.
canvas := BalloonCanvas on: Display.
canvas aaLevel: 4.
canvas
drawBezier3Shape: c asPointArray
color: Color transparent
borderWidth: 1
borderColor: Color black!
----- Method: Bezier3Segment class>>from:to: (in category 'instance creation') -----
from: p1 to: p2
^ self new from: p1 via: (p1 interpolateTo: p2 at: 0.3333) and: (p1
interpolateTo: p2 at: 0.66667) to: p2!
----- Method: Bezier3Segment class>>from:via:and:to: (in category 'instance creation') -----
from: p1 via: p2 and: p3 to: p4
^ self new from: p1 via: p2 and: p3 to: p4!
----- Method: Bezier3Segment class>>makeEllipseSegments: (in category 'utilities') -----
makeEllipseSegments: aRectangle
"Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle.
This method creates four bezier segments (one for each quadrant) approximating the oval."
"EXAMPLE:
This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval.
| rect |
rect := 100 at 100 extent: 500 at 200.
Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red.
(Bezier3Segment makeEllipseSegments: rect) do:[:seg|
seg lineSegmentsDo:[:last :next|
Display getCanvas line: last to: next width: 1 color: Color black]].
"
"EXAMPLE:
| minRadius maxRadius |
maxRadius := 300.
minRadius := 20.
maxRadius to: minRadius by: -10 do:[:rad|
| rect |
rect := 400 at 400 - rad corner: 400 at 400 + rad.
Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red.
(Bezier3Segment makeEllipseSegments: rect) do:[:seg|
seg lineSegmentsDo:[:last :next|
Display getCanvas line: last to: next width: 1 color: Color black]]].
"
^self makeEllipseSegments: aRectangle count: 4!
----- Method: Bezier3Segment class>>makeEllipseSegments:count: (in category 'utilities') -----
makeEllipseSegments: aRectangle count: segmentCount
"Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle.
This method creates segmentCount bezier segments (one for each quadrant) approximating the oval."
| count angle seg center scale |
center := aRectangle origin + aRectangle corner * 0.5.
scale := aRectangle extent * 0.5.
count := segmentCount max: 2. "need at least two segments"
angle := 360.0 / count.
^(1 to: count) collect:[:i|
seg := self makeUnitPieSegmentFrom: i-1*angle to: i*angle.
self controlPoints: (seg controlPoints collect:[:pt| pt * scale + center])
].!
----- Method: Bezier3Segment class>>makePieSegment:from:to: (in category 'utilities') -----
makePieSegment: aRectangle from: angle1 to: angle2
"Create a single pie segment for the oval inscribed in aRectangle between angle1 and angle2. If angle1 is less than angle2 this method creates a CW pie segment, otherwise it creates a CCW pie segment."
| seg center scale |
angle1 > angle2 ifTrue:["ccw"
^(self makePieSegment: aRectangle from: angle2 to: angle1) reversed
].
"create a unit circle pie segment from angle1 to angle2"
seg := self makeUnitPieSegmentFrom: angle1 to: angle2.
"scale the segment to fit aRectangle"
center := aRectangle origin + aRectangle corner * 0.5.
scale := aRectangle extent * 0.5.
^self controlPoints: (seg controlPoints collect:[:pt| pt * scale + center])!
----- Method: Bezier3Segment class>>makePieSegments:from:to: (in category 'utilities') -----
makePieSegments: aRectangle from: angle1 to: angle2
"Create a series of cubic bezier segments for the oval inscribed in aRectangle between angle1 and angle2. The segments are oriented clockwise, to get counter-clockwise segments simply switch angle1 and angle2."
angle2 < angle1 ifTrue:[
"ccw segments"
^(self makePieSegments: aRectangle from: angle2 to: angle1)
reversed collect:[:seg| seg reversed]
].
"Split up segments if larger than 120 degrees"
angle2 - angle1 > 120 ifTrue:["subdivide"
| midAngle |
midAngle := angle1 + angle2 * 0.5.
^(self makePieSegments: aRectangle from: angle1 to: midAngle),
(self makePieSegments: aRectangle from: midAngle to: angle2).
].
"Create actual pie segment"
^self makePieSegment: aRectangle from: angle1 to: angle2
!
----- Method: Bezier3Segment class>>makeUnitPieSegmentFrom:to: (in category 'utilities') -----
makeUnitPieSegmentFrom: angle1 to: angle2
"Create a clockwise unit pie segment from angle1 to angle2, that is a pie segment for a circle centered at zero with radius one. Note: This method can be used to create at most a quarter circle."
| pt1 pt2 rad1 rad2 |
rad1 := angle1 degreesToRadians.
rad2 := angle2 degreesToRadians.
pt1 := rad1 sin @ rad1 cos negated.
pt2 := rad2 sin @ rad2 cos negated.
^self makeUnitPieSegmentWith: pt1 and: pt2!
----- Method: Bezier3Segment class>>makeUnitPieSegmentWith:and: (in category 'utilities') -----
makeUnitPieSegmentWith: point1 and: point2
"Create a clockwise unit pie segment from point1 to point2, that is a pie segment for a circle centered at zero with radius one."
| pt1 pt2 dir1 dir2 mid length scale cp1 cp2 pt3 magic |
"point1 and point2 are the points on the unit circle
for accuracy (or broken input), renormalize them."
pt1 := point1 normalized.
pt2 := point2 normalized.
"compute the normal vectors - those are tangent directions for the bezier"
dir1 := pt1 y negated @ pt1 x.
dir2 := pt2 y negated @ pt2 x.
"Okay, now that we have the points and tangents on the unit circle, let's do the magic. For fitting a cubic bezier onto a circle section we know that we want the end points be on the circle and the tangents to point towards the right direction (both of which we have in the above). What we do NOT know is how to scale the tangents so that midpoint of the bezier is exactly on the circle.
The good news is that there is a linear relation between the length of the tangent vectors and the distance of the midpoint from the circle's origin. The bad news is that I don't know how to derive it analytically. So what I do here is simply sampling the bezier twice (not really - the first sample is free) and then to compute the distance from the sample."
"The first sample is just between the two points on the curve"
mid := pt1 + pt2 * 0.5.
"The second sample will be taken from the curve with coincident control points at the intersection of dir1 and dir2, which simplifies significantly with a little understanding about trigonometry, since the angle formed between mid, pt1 and the intersection is the same as between the center, pt1 and mid."
length := mid r.
"length is not only the distance from the center of the unit circle but also the sine of the angle between the circle's center, pt1 and mid (since center is at zero and pt1 has unit length). Therefore, to scale dir1 to the intersection with dir2 we can use mid's distance from pt1 and simply divide it by the sine value."
scale := (mid dist: pt1).
length > 0.0 ifTrue:[ scale := scale / length].
"now sample the cubic bezier (optimized version for coincident control points)"
cp1 := pt1 + (dir1 * (scale * 0.75)).
cp2 := pt2 - (dir2 * (scale * 0.75)).
pt3 := cp1 + cp2 * 0.5.
"compute the magic constant"
scale := (pt3 - mid) r / scale.
magic := 1.0 - length / scale.
"and finally answer the pie segment"
^self
from: pt1
via: pt1 + (dir1 * magic)
and: pt2 - (dir2 * magic)
to: pt2!
----- Method: Bezier3Segment>>asBezier2Points: (in category 'converting') -----
asBezier2Points: error
"Demote a cubic bezier to a set of approximating quadratic beziers.
Should convert to forward differencing someday"
| curves pts step prev index a b f |
curves := self bezier2SegmentCount: error.
pts := Array new: curves * 3.
step := 1.0 / (curves * 2).
prev := start.
1 to: curves do: [ :c |
index := 3*c.
a := pts at: index-2 put: prev.
b := (self valueAt: (c*2-1)*step).
f := pts at: index put: (self valueAt: (c*2)*step).
pts at: index-1 put: (4 * b - a - f) / 2.
prev := pts at: index.
].
^ pts.
!
----- Method: Bezier3Segment>>asBezier2Segments (in category 'converting') -----
asBezier2Segments
"Demote a cubic bezier to a set of approximating quadratic beziers."
^self asBezier2Segments: 0.5!
----- Method: Bezier3Segment>>asBezierShape (in category 'converting') -----
asBezierShape
"Demote a cubic bezier to a set of approximating quadratic beziers."
^self asBezierShape: 0.5!
----- Method: Bezier3Segment>>asBezierShape: (in category 'converting') -----
asBezierShape: error
"Demote a cubic bezier to a set of approximating quadratic beziers.
Should convert to forward differencing someday"
^(self asBezier2Points: error) asPointArray.!
----- Method: Bezier3Segment>>asPointArray (in category 'converting') -----
asPointArray
| p |
p := PointArray new: 4.
p at: 1 put: start.
p at: 2 put: via1.
p at: 3 put: via2.
p at: 4 put: end.
^ p!
----- Method: Bezier3Segment>>asTangentSegment (in category 'converting') -----
asTangentSegment
^Bezier2Segment
from: via1-start
via: via2-via1
to: end-via2!
----- Method: Bezier3Segment>>bezier2SegmentCount (in category 'private') -----
bezier2SegmentCount
"Compute the number of quadratic bezier segments needed to approximate
this cubic with less than a 1-pixel error"
^ self bezier2SegmentCount: 1.0!
----- Method: Bezier3Segment>>bezier2SegmentCount: (in category 'converting') -----
bezier2SegmentCount: pixelError
"Compute the number of quadratic bezier segments needed to approximate
this cubic with no more than a specified error"
| a |
a := (start x negated @ start y negated) + (3 * via1) - (3 * via2) +
(end).
^ (((a r / (20.0 * pixelError)) raisedTo: 0.333333) ceiling) max: 1.
!
----- Method: Bezier3Segment>>bezierClipHeight: (in category 'bezier clipping') -----
bezierClipHeight: dir
"Check if the argument overlaps the receiver somewhere
along the line from start to end. Optimized for speed."
| u dirX dirY dx dy uMin uMax |
dirX := dir x.
dirY := dir y.
uMin := 0.0.
uMax := (dirX * dirX) + (dirY * dirY).
dx := via1 x - start x.
dy := via1 y - start y.
u := (dirX * dx) + (dirY * dy).
u < uMin ifTrue:[uMin := u].
u > uMax ifTrue:[uMax := u].
dx := via2 x - start x.
dy := via2 y - start y.
u := (dirX * dx) + (dirY * dy).
u < uMin ifTrue:[uMin := u].
u > uMax ifTrue:[uMax := u].
^uMin at uMax!
----- Method: Bezier3Segment>>bounds (in category 'accessing') -----
bounds
^ ((super bounds encompassing: via1) encompassing: via2)!
----- Method: Bezier3Segment>>controlPoints (in category 'vector functions') -----
controlPoints
^{start. via1. via2. end}!
----- Method: Bezier3Segment>>controlPointsDo: (in category 'vector functions') -----
controlPointsDo: aBlock
aBlock value: start; value: via1; value: via2; value: end!
----- Method: Bezier3Segment>>degree (in category 'accessing') -----
degree
^3!
----- Method: Bezier3Segment>>from:via:and:to: (in category 'initialization') -----
from: aPoint1 via: aPoint2 and: aPoint3 to: aPoint4
start := aPoint1.
via1 := aPoint2.
via2 := aPoint3.
end := aPoint4!
----- Method: Bezier3Segment>>initializeFrom: (in category 'initialization') -----
initializeFrom: controlPoints
controlPoints size = 4 ifFalse:[self error:'Wrong number of control points'].
start := controlPoints at: 1.
via1 := controlPoints at: 2.
via2 := controlPoints at: 3.
end := controlPoints at: 4.!
----- Method: Bezier3Segment>>length (in category 'accessing') -----
length
"Answer a gross approximation of the length of the receiver"
^(start dist: via1) + (via1 dist: via2) + (via2 dist: end)!
----- Method: Bezier3Segment>>lineSegments:do: (in category 'vector functions') -----
lineSegments: steps do: aBlock
"Evaluate aBlock with the receiver's line segments"
"Note: We could use forward differencing here."
| last deltaStep t next |
last := start.
deltaStep := 1.0 / steps asFloat.
t := deltaStep.
1 to: steps do:[:i|
next := self valueAt: t.
aBlock value: last value: next.
last := next.
t := t + deltaStep].!
----- Method: Bezier3Segment>>lineSegmentsDo: (in category 'vector functions') -----
lineSegmentsDo: aBlock
"Evaluate aBlock with the receiver's line segments"
"Note: We could use forward differencing here."
| steps last deltaStep t next |
steps := 1 max: (self length // 10). "Assume 10 pixels per step"
last := start.
deltaStep := 1.0 / steps asFloat.
t := deltaStep.
1 to: steps do:[:i|
next := self valueAt: t.
aBlock value: last value: next.
last := next.
t := t + deltaStep].!
----- Method: Bezier3Segment>>outlineSegment: (in category 'vector functions') -----
outlineSegment: width
| tan1 nrm1 tan2 nrm2 newStart newVia1 newEnd newVia2 dist |
tan1 := (via1 - start) normalized.
nrm1 := tan1 * width.
nrm1 := nrm1 y @ nrm1 x negated.
tan2 := (end - via2) normalized.
nrm2 := tan2 * width.
nrm2 := nrm2 y @ nrm2 x negated.
newStart := start + nrm1.
newEnd := end + nrm2.
dist := (newStart dist: newEnd) * 0.3.
newVia1 := newStart + (tan1 * dist).
newVia2 := newEnd - (tan2 * dist).
^self class from: newStart via: newVia1 and: newVia2 to: newEnd.
!
----- Method: Bezier3Segment>>tangentAt: (in category 'vector functions') -----
tangentAt: parameter
| tan1 tan2 tan3 t1 t2 t3 |
tan1 := via1 - start.
tan2 := via2 - via1.
tan3 := end - via2.
t1 := (1.0 - parameter) squared.
t2 := 2 * parameter * (1.0 - parameter).
t3 := parameter squared.
^(tan1 * t1) + (tan2 * t2) + (tan3 * t3)!
----- Method: Bezier3Segment>>tangentAtEnd (in category 'vector functions') -----
tangentAtEnd
^end - via2!
----- Method: Bezier3Segment>>tangentAtMid (in category 'vector functions') -----
tangentAtMid
| tan1 tan2 tan3 |
tan1 := via1 - start.
tan2 := via2 - via1.
tan3 := end - via2.
^(tan1 + (2*tan2) + tan3) * 0.25
!
----- Method: Bezier3Segment>>tangentAtStart (in category 'vector functions') -----
tangentAtStart
^via1 - start!
----- Method: Bezier3Segment>>valueAt: (in category 'accessing') -----
valueAt: t
| a b c d |
"| p1 p2 p3 |
p1 := start interpolateTo: via1 at: t.
p2 := via1 interpolateTo: via2 at: t.
p3 := via2 interpolateTo: end at: t.
p1 := p1 interpolateTo: p2 at: t.
p2 := p2 interpolateTo: p3 at: t.
^ p1 interpolateTo: p2 at: t"
a := (start negated) + (3 * via1) - (3 * via2) + (end).
b := (3 * start) - (6 * via1) + (3 * via2).
c := (3 * start negated) + (3 * via1).
d := start.
^ ((a * t + b) * t + c) * t + d
!
----- Method: Bezier3Segment>>via1 (in category 'accessing') -----
via1
^via1!
----- Method: Bezier3Segment>>via1: (in category 'accessing') -----
via1: aPoint
via1 := aPoint!
----- Method: Bezier3Segment>>via2 (in category 'accessing') -----
via2
^via2!
----- Method: Bezier3Segment>>via2: (in category 'accessing') -----
via2: aPoint
via2 := aPoint!
----- Method: LineSegment class>>controlPoints: (in category 'instance creation') -----
controlPoints: anArray
"Create a new instance of the receiver from the given control points"
anArray size = 2 ifTrue:[^LineSegment new initializeFrom: anArray].
anArray size = 3 ifTrue:[^Bezier2Segment new initializeFrom: anArray].
anArray size = 4 ifTrue:[^Bezier3Segment new initializeFrom: anArray].
self error:'Unsupported'.!
----- Method: LineSegment class>>from:to: (in category 'instance creation') -----
from: startPoint to: endPoint
^self new from: startPoint to: endPoint!
----- Method: LineSegment class>>from:to:via: (in category 'geometry') -----
from: startPoint to: endPoint via: via
(startPoint = via or: [ endPoint = via ]) ifTrue: [ ^self new from: startPoint to: endPoint ].
^Bezier2Segment from: startPoint to: endPoint via: via!
----- Method: LineSegment class>>fromPoints: (in category 'geometry') -----
fromPoints: pts
^self from: pts first to: pts third via: pts second!
----- Method: LineSegment class>>intersectFrom:with:to:with: (in category 'utilities') -----
intersectFrom: startPt with: startDir to: endPt with: endDir
"Compute the intersection of two lines, e.g., compute alpha and beta for
startPt + (alpha * startDir) = endPt + (beta * endDir).
Reformulating this yields
(alpha * startDir) - (beta * endDir) = endPt - startPt.
or
(alpha * startDir) + (-beta * endDir) = endPt - startPt.
or
(alpha * startDir x) + (-beta * endDir x) = endPt x - startPt x.
(alpha * startDir y) + (-beta * endDir y) = endPt y - startPt y.
which is trivial to solve using Cramer's rule. Note that since
we're really only interested in the intersection point we need only
one of alpha or beta since the resulting intersection point can be
computed based on either one."
| det deltaPt alpha |
det := (startDir x * endDir y) - (startDir y * endDir x).
det = 0.0 ifTrue:[^nil]. "There's no solution for it"
deltaPt := endPt - startPt.
alpha := (deltaPt x * endDir y) - (deltaPt y * endDir x).
alpha := alpha / det.
"And compute intersection"
^startPt + (alpha * startDir)!
----- Method: LineSegment>>asBezier2Curves: (in category 'vector functions') -----
asBezier2Curves: err
^Array with: self!
----- Method: LineSegment>>asBezier2Points: (in category 'converting') -----
asBezier2Points: error
^Array with: start with: start with: end!
----- Method: LineSegment>>asBezier2Segment (in category 'converting') -----
asBezier2Segment
"Represent the receiver as quadratic bezier segment"
^Bezier2Segment from: start to: end!
----- Method: LineSegment>>asBezier2Segments: (in category 'converting') -----
asBezier2Segments: error
"Demote a cubic bezier to a set of approximating quadratic beziers."
| pts |
pts := self asBezier2Points: error.
^(1 to: pts size by: 3) collect:[:i|
Bezier2Segment from: (pts at: i) via: (pts at: i+1) to: (pts at: i+2)].
!
----- Method: LineSegment>>asIntegerSegment (in category 'converting') -----
asIntegerSegment
"Convert the receiver into integer representation"
^self species from: start asIntegerPoint to: end asIntegerPoint!
----- Method: LineSegment>>asLineSegment (in category 'converting') -----
asLineSegment
"Represent the receiver as a straight line segment"
^self!
----- Method: LineSegment>>asTangentSegment (in category 'converting') -----
asTangentSegment
^LineSegment from: end-start to: end-start!
----- Method: LineSegment>>bezierClipCurve: (in category 'bezier clipping') -----
bezierClipCurve: aCurve
^self bezierClipCurve: aCurve epsilon: 1!
----- Method: LineSegment>>bezierClipCurve:epsilon: (in category 'bezier clipping') -----
bezierClipCurve: aCurve epsilon: eps
"Compute the intersection of the receiver (a line) with the given curve using bezier clipping."
| tMin tMax clip newCurve |
clip := self bezierClipInterval: aCurve.
clip ifNil:[^#()]. "no overlap"
tMin := clip at: 1.
tMax := clip at: 2.
newCurve := aCurve curveFrom: tMin to: tMax.
newCurve length < eps ifTrue:[^Array with: (aCurve valueAt: tMin + tMax * 0.5)].
(tMin < 0.001 and:[tMax > 0.999]) ifTrue:[
"Need to split aCurve before proceeding"
| curve1 curve2 |
curve1 := aCurve curveFrom: 0.0 to: 0.5.
curve2 := aCurve curveFrom: 0.5 to: 1.0.
^(curve1 bezierClipCurve: self epsilon: eps),
(curve2 bezierClipCurve: self epsilon: eps).
].
^newCurve bezierClipCurve: self epsilon: eps.!
----- Method: LineSegment>>bezierClipInterval: (in category 'bezier clipping') -----
bezierClipInterval: aCurve
"Compute the new bezier clip interval for the argument,
based on the fat line (the direction aligned bounding box) of the receiver.
Note: This could be modified so that multiple clip intervals are returned.
The idea is that for a distance curve like
x x
tMax---- --\-----/---\-------
x x
tMin-------------------------
all the intersections intervals with tMin/tMax are reported, therefore
minimizing the iteration count. As it is, the process will slowly iterate
against tMax and then the curve will be split.
"
| nrm tStep pts eps inside vValue vMin vMax tValue tMin tMax
last lastV lastT lastInside next nextV nextT nextInside |
eps := 0.00001. "distance epsilon"
nrm := (start y - end y) @ (end x - start x). "normal direction for (end-start)"
"Map receiver's control point into fat line; compute vMin and vMax"
vMin := vMax := nil.
self controlPointsDo:[:pt|
vValue := (nrm x * pt x) + (nrm y * pt y). "nrm dotProduct: pt."
vMin == nil ifTrue:[ vMin := vMax := vValue]
ifFalse:[vValue < vMin ifTrue:[vMin := vValue].
vValue > vMax ifTrue:[vMax := vValue]]].
"Map the argument into fat line; compute tMin, tMax for clip"
tStep := 1.0 / aCurve degree.
pts := aCurve controlPoints.
last := pts at: pts size.
lastV := (nrm x * last x) + (nrm y * last y). "nrm dotProduct: last."
lastT := 1.0.
lastInside := lastV+eps < vMin ifTrue:[-1] ifFalse:[lastV-eps > vMax ifTrue:[1] ifFalse:[0]].
"Now compute new minimal and maximal clip boundaries"
inside := false. "assume we're completely outside"
tMin := 2.0. tMax := -1.0. "clip interval"
1 to: pts size do:[:i|
next := pts at: i.
nextV := (nrm x * next x) + (nrm y * next y). "nrm dotProduct: next."
false ifTrue:[
(nextV - vMin / (vMax - vMin)) printString displayAt: 0@ (i-1*20)].
nextT := i-1 * tStep.
nextInside := nextV+eps < vMin ifTrue:[-1] ifFalse:[nextV-eps > vMax ifTrue:[1] ifFalse:[0]].
nextInside = 0 ifTrue:[
inside := true.
tValue := nextT.
tValue < tMin ifTrue:[tMin := tValue].
tValue > tMax ifTrue:[tMax := tValue].
].
lastInside = nextInside ifFalse:["At least one clip boundary"
inside := true.
"See if one is below vMin"
(lastInside + nextInside <= 0) ifTrue:[
tValue := lastT + ((nextT - lastT) * (vMin - lastV) / (nextV - lastV)).
tValue < tMin ifTrue:[tMin := tValue].
tValue > tMax ifTrue:[tMax := tValue].
].
"See if one is above vMax"
(lastInside + nextInside >= 0) ifTrue:[
tValue := lastT + ((nextT - lastT) * (vMax - lastV) / (nextV - lastV)).
tValue < tMin ifTrue:[tMin := tValue].
tValue > tMax ifTrue:[tMax := tValue].
].
].
last := next.
lastT := nextT.
lastV := nextV.
lastInside := nextInside.
].
inside
ifTrue:[^Array with: tMin with: tMax]
ifFalse:[^nil]!
----- Method: LineSegment>>bounds (in category 'accessing') -----
bounds
"Return the bounds containing the receiver"
^(start min: end) corner: (start max: end)!
----- Method: LineSegment>>controlPoints (in category 'vector functions') -----
controlPoints
^{start. end}!
----- Method: LineSegment>>controlPointsDo: (in category 'vector functions') -----
controlPointsDo: aBlock
aBlock value: start; value: end!
----- Method: LineSegment>>curveFrom:to: (in category 'vector functions') -----
curveFrom: parameter1 to: parameter2
"Create a new segment like the receiver but starting/ending at the given parametric values"
| delta |
delta := end - start.
^self clone from: delta * parameter1 + start to: delta * parameter2 + start!
----- Method: LineSegment>>debugDraw (in category 'private') -----
debugDraw
^self debugDrawAt: 0 at 0.!
----- Method: LineSegment>>debugDrawAt: (in category 'private') -----
debugDrawAt: offset
| canvas |
canvas := Display getCanvas.
canvas translateBy: offset during:[:aCanvas|
self lineSegmentsDo:[:p1 :p2|
aCanvas line: p1 rounded to: p2 rounded width: 1 color: Color black.
].
].!
----- Method: LineSegment>>degree (in category 'accessing') -----
degree
^1!
----- Method: LineSegment>>direction (in category 'accessing') -----
direction
^end - start!
----- Method: LineSegment>>end (in category 'accessing') -----
end
"Return the end point"
^end!
----- Method: LineSegment>>end: (in category 'accessing') -----
end: aPoint
end := aPoint!
----- Method: LineSegment>>from:to: (in category 'initialize') -----
from: startPoint to: endPoint
"Initialize the receiver"
start := startPoint.
end := endPoint.!
----- Method: LineSegment>>hasZeroLength (in category 'testing') -----
hasZeroLength
"Return true if the receiver has zero length"
^start = end!
----- Method: LineSegment>>initializeFrom: (in category 'initialize') -----
initializeFrom: controlPoints
controlPoints size = 2 ifFalse:[self error:'Wrong number of control points'].
start := controlPoints at: 1.
end := controlPoints at: 2.!
----- Method: LineSegment>>intersectionWith: (in category 'intersection') -----
intersectionWith: anotherSegment
"Copied from LineIntersections>>intersectFrom:to:with:to:"
| det deltaPt alpha beta pt1Dir pt2Dir |
pt1Dir := end - start.
pt2Dir := anotherSegment end - anotherSegment start.
det := (pt1Dir x * pt2Dir y) - (pt1Dir y * pt2Dir x).
deltaPt := anotherSegment start - start.
alpha := (deltaPt x * pt2Dir y) - (deltaPt y * pt2Dir x).
beta := (deltaPt x * pt1Dir y) - (deltaPt y * pt1Dir x).
det = 0 ifTrue:[^nil]. "no intersection"
alpha * det < 0 ifTrue:[^nil].
beta * det < 0 ifTrue:[^nil].
det > 0
ifTrue:[(alpha > det or:[beta > det]) ifTrue:[^nil]]
ifFalse:[(alpha < det or:[beta < det]) ifTrue:[^nil]].
"And compute intersection"
^start + (alpha * pt1Dir / (det at det))!
----- Method: LineSegment>>isArcSegment (in category 'testing') -----
isArcSegment
"Answer whether I approximate an arc segment reasonably well"
| mid v1 v2 d1 d2 center |
start = end ifTrue:[^false].
mid := self valueAt: 0.5.
v1 := (start + mid) * 0.5.
v2 := (mid + end) * 0.5.
d1 := mid - start. d1 := d1 y @ d1 x negated.
d2 := end - mid. d2 := d2 y @ d2 x negated.
center := LineSegment
intersectFrom: v1 with: d1 to: v2 with: d2.
"Now see if the tangents are 'reasonably close' to the circle"
d1 := (start - center) normalized dotProduct: self tangentAtStart normalized.
d1 abs > 0.02 ifTrue:[^false].
d1 := (end - center) normalized dotProduct: self tangentAtEnd normalized.
d1 abs > 0.02 ifTrue:[^false].
d1 := (mid - center) normalized dotProduct: self tangentAtMid normalized.
d1 abs > 0.02 ifTrue:[^false].
^true!
----- Method: LineSegment>>isBezier2Segment (in category 'testing') -----
isBezier2Segment
"Return true if the receiver is a quadratic bezier segment"
^false!
----- Method: LineSegment>>isLineSegment (in category 'testing') -----
isLineSegment
"Return true if the receiver is a line segment"
^true!
----- Method: LineSegment>>isStraight (in category 'testing') -----
isStraight
"Return true if the receiver represents a straight line"
^true!
----- Method: LineSegment>>length (in category 'vector functions') -----
length
"Return the length of the receiver"
^start dist: end!
----- Method: LineSegment>>lineSegments:do: (in category 'vector functions') -----
lineSegments: steps do: aBlock
"Evaluate aBlock with the receiver's line segments"
aBlock value: start value: end!
----- Method: LineSegment>>lineSegmentsDo: (in category 'vector functions') -----
lineSegmentsDo: aBlock
"Evaluate aBlock with the receiver's line segments"
aBlock value: start value: end!
----- Method: LineSegment>>printOn: (in category 'printing') -----
printOn: aStream
"Print the receiver on aStream"
aStream
nextPutAll: self class name;
nextPutAll:' from: ';
print: start;
nextPutAll: ' to: ';
print: end;
space.!
----- Method: LineSegment>>reversed (in category 'converting') -----
reversed
^self class controlPoints: self controlPoints reversed!
----- Method: LineSegment>>roundTo: (in category 'intersection') -----
roundTo: quantum
start := start roundTo: quantum.
end := end roundTo: quantum.!
----- Method: LineSegment>>sideOfPoint: (in category 'vector functions') -----
sideOfPoint: aPoint
"Return the side of the receiver this point is on. The method returns
-1: if aPoint is left
0: if aPoint is on
+1: if a point is right
of the receiver."
| dx dy px py |
dx := end x - start x.
dy := end y - start y.
px := aPoint x - start x.
py := aPoint y - start y.
^((dx * py) - (px * dy)) sign
"
(LineSegment from: 0 at 0 to: 100 at 0) sideOfPoint: 50 at -50.
(LineSegment from: 0 at 0 to: 100 at 0) sideOfPoint: 50 at 50.
(LineSegment from: 0 at 0 to: 100 at 0) sideOfPoint: 50 at 0.
"
!
----- Method: LineSegment>>start (in category 'accessing') -----
start
"Return the start point"
^start!
----- Method: LineSegment>>start: (in category 'accessing') -----
start: aPoint
start := aPoint!
----- Method: LineSegment>>tangentAt: (in category 'vector functions') -----
tangentAt: parameter
"Return the tangent at the given parametric value along the receiver"
^end - start!
----- Method: LineSegment>>tangentAtEnd (in category 'vector functions') -----
tangentAtEnd
"Return the tangent for the last point"
^(end - start)!
----- Method: LineSegment>>tangentAtMid (in category 'vector functions') -----
tangentAtMid
"Return the tangent for the last point"
^(end - start)!
----- Method: LineSegment>>tangentAtStart (in category 'vector functions') -----
tangentAtStart
"Return the tangent for the last point"
^(end - start)!
----- Method: LineSegment>>valueAt: (in category 'vector functions') -----
valueAt: parameter
"Evaluate the receiver at the given parametric value"
^start + (end - start * parameter)!
----- Method: LineSegment>>valueAtEnd (in category 'vector functions') -----
valueAtEnd
"Evaluate the receiver at it's end point (e.g., self valueAtEnd = (self valueAt: 1.0))"
^end!
----- Method: LineSegment>>valueAtStart (in category 'vector functions') -----
valueAtStart
"Evaluate the receiver at it's start point (e.g., self valueAtEnd = (self valueAt: 0.0))"
^start!
SharedPool subclass: #BalloonEngineConstants
instanceVariableNames: ''
classVariableNames: 'GWCountDisplaySpan GBUpdateDX GEPrimitiveWideBezier GWAETUsed GWHasEdgeTransform GFNormalX GWCountMergeFill BEWorkBufferIndex GEStateScanningAET GEPrimitiveRepeatedBitmapFill GWState GBMBaseSize GFDirectionY GEPrimitiveLinearGradientFill GFRampOffset GEStateUnlocked GLXDirection GWAAScanMask GEObjectType BEFormsIndex GWAAHalfPixel GWCurrentZ GEXValue ETLinesIndex GBWideFill BESpanIndex GFDirectionX GEPrimitiveWide GWTimeInitializing GWTimeChangeAETEntry GErrorBadState GWFillOffsetY GWDestOffsetY GEPrimitiveRadialGradientFill GWCurrentY GGBaseSize GEEdgeClipFlag GWMagicNumber GBEndY GBUpdateData GEYValue GWCountFinishTest GLWideEntry GWTimeNextFillEntry GWFillOffsetX BEPostFlushNeededIndex GLXIncrement GWAAShift GWBufferTop GWDestOffsetX GBFinalX ETXValueIndex GWClearSpanBuffer ETSourceIndex GWGETStart BEDeferredIndex GBEndX GEStateWaitingChange GLYDirection GEFillIndexRight ETYValueIndex GWTimeAddAETEntry GEZValue GErrorNoMoreSpace GWBezierHeightSubdivisions BEColorTransformIndex GEBaseEdgeSize GLWideWidth BEDestOffsetIndex ETZValueIndex GWObjStart GLWideExtent GWSpanSize FTIndexIndex GEPrimitiveLine FTSourceIndex GEPrimitiveFill GEPrimitiveEdgeMask GWTimeNextAETEntry GEObjectLength GBBitmapSize GWEdgeTransform FTYValueIndex GENumLines GLError GLBaseSize GBBitmapRaster GWAAColorMask GBViaY GWObjUsed ETIndexIndex GWNeedsFlush GEPrimitiveWideLine GBBitmapHeight GBColormapSize GWTimeNextGETEntry GWHasColorTransform GWSpanEndAA GBUpdateDDY GBWideSize GEPrimitiveEdge GWSpanEnd GWHasClipShapes GWCountInitializing GEObjectUnused GWCountChangeAETEntry GBBitmapDepth GWBezierOverflowSubdivisions GWFillMinY GBViaX GEPrimitiveTypeMask GBWideWidth GErrorAETEntry GErrorFillEntry BEClipRectIndex GLWideFill GWTimeDisplaySpan GWAAColorShift GFRampLength GBUpdateDDX GWSize GEPrimitiveWideEdge GBBaseSize GWPoint4 GWLastExportedRightX GWFillMinX GWAALevel GEPrimitiveBezier GErrorGETEntry GWHeaderSize GWBezierLineConversions GWCountNextFillEntry GEStateWaitingForEdge GBWideUpdateData BEBalloonEngineSize!
GWClipM
inY GWBezierMonotonSubdivisions GEEdgeFillsInvalid BEBitBltIndex GEStateAddingFromGET GWPoint3 GLErrorAdjUp GWMinimalSize GEStateUpdateEdges GWCountNextAETEntry GWGETUsed GEFillIndexLeft GWCountAddAETEntry GBUpdateY GErrorNeedFlush GBBitmapWidth GWFillMaxY BEEdgeTransformIndex BEExternalsIndex GWClipMinX GLErrorAdjDown GEObjectIndex GWAETStart GLEndY GWLastExportedFill GWPoint2 GWLastExportedLeftX GEPrimitiveUnknown GBWideExtent GBUpdateX GWCountNextGETEntry GBColormapOffset FTDestFormIndex GWMagicIndex GBWideEntry GWStopReason GWFillMaxX GWSpanStart GFOriginY GWTimeFinishTest GLWideExit FTBalloonFillDataSize GWClipMaxY GLEndX GBTileFlag GBUpdateDY BEAaLevelIndex GWPointListFirst GEBaseFillSize GEStateCompleted GFNormalY ETBalloonEdgeDataSize GWColorTransform FTMinXIndex GLWideSize GEStateWaitingForFill GWPoint1 GEStateBlitBuffer GFOriginX FTMaxXIndex GEPrimitiveFillMask GWLastExportedEdge GWTimeMergeFill GEPrimitiveWideMask GBWideExit GEPrimitiveClippedBitmapFill GWClipMaxX'
poolDictionaries: ''
category: 'Balloon-Engine'!
Object subclass: #BalloonEngine
instanceVariableNames: 'workBuffer span bitBlt forms clipRect destOffset externals aaLevel edgeTransform colorTransform deferred postFlushNeeded'
classVariableNames: 'BufferCache Counts Times Debug BezierStats CacheProtect'
poolDictionaries: 'BalloonEngineConstants'
category: 'Balloon-Engine'!
!BalloonEngine commentStamp: '<historical>' prior: 0!
BalloonEngine is the representative for the Balloon engine inside Squeak. For most purposes it should not be used directly but via BalloonCanvas since this ensures proper initialization and is polymorphic with other canvas uses.!
----- Method: BalloonEngine class>>allocateOrRecycleBuffer: (in category 'private') -----
allocateOrRecycleBuffer: initialSize
"Try to recycly a buffer. If this is not possibly, create a new one."
| buffer |
CacheProtect critical:[
buffer := BufferCache at: 1.
BufferCache at: 1 put: nil.
].
^buffer ifNil:[BalloonBuffer new: initialSize]!
----- Method: BalloonEngine class>>debug: (in category 'accessing') -----
debug: aBoolean
"BalloonEngine debug: true"
"BalloonEngine debug: false"
Debug := aBoolean!
----- Method: BalloonEngine class>>doProfileStats: (in category 'accessing') -----
doProfileStats: aBool
"Note: On Macintosh systems turning on profiling can significantly
degrade the performance of Balloon since we're using the high
accuracy timer for measuring."
"BalloonEngine doProfileStats: true"
"BalloonEngine doProfileStats: false"
<primitive: 'primitiveDoProfileStats' module: 'B2DPlugin'>
^false!
----- Method: BalloonEngine class>>initialize (in category 'class initialization') -----
initialize
"BalloonEngine initialize"
BufferCache := WeakArray new: 1.
Smalltalk garbageCollect. "Make the cache old"
CacheProtect := Semaphore forMutualExclusion.
Times := WordArray new: 10.
Counts := WordArray new: 10.
BezierStats := WordArray new: 4.
Debug ifNil:[Debug := false].!
----- Method: BalloonEngine class>>primitiveSetBitBltPlugin: (in category 'private') -----
primitiveSetBitBltPlugin: pluginName
<primitive: 'primitiveSetBitBltPlugin' module: 'B2DPlugin'>
^nil!
----- Method: BalloonEngine class>>printBezierStats (in category 'accessing') -----
printBezierStats
"BalloonEngine printBezierStats"
"BalloonEngine resetBezierStats"
Transcript
cr; nextPutAll:'Bezier statistics:';
crtab; print: (BezierStats at: 1); tab; nextPutAll:' non-monoton curves splitted';
crtab; print: (BezierStats at: 2); tab; nextPutAll:' curves splitted for numerical accuracy';
crtab; print: (BezierStats at: 3); tab; nextPutAll:' curves splitted to avoid integer overflow';
crtab; print: (BezierStats at: 4); tab; nextPutAll:' curves internally converted to lines';
endEntry.!
----- Method: BalloonEngine class>>printStat:count:string: (in category 'accessing') -----
printStat: time count: n string: aString
Transcript
cr;
print: time; tab;
nextPutAll:' mSecs -- ';
print: n; tab;
nextPutAll:' ops -- ';
print: ((time asFloat / (n max: 1) asFloat) roundTo: 0.01); tab;
nextPutAll: ' avg. mSecs/op -- ';
nextPutAll: aString.!
----- Method: BalloonEngine class>>printStats (in category 'accessing') -----
printStats
"BalloonEngine doProfileStats: true"
"BalloonEngine printStats"
"BalloonEngine resetStats"
Transcript cr; nextPutAll:'/************** BalloonEngine statistics ****************/'.
self printStat: (Times at: 1) count: (Counts at: 1) string: 'Initialization'.
self printStat: (Times at: 2) count: (Counts at: 2) string: 'Finish test'.
self printStat: (Times at: 3) count: (Counts at: 3) string: 'Fetching/Adding GET entries'.
self printStat: (Times at: 4) count: (Counts at: 4) string: 'Adding AET entries'.
self printStat: (Times at: 5) count: (Counts at: 5) string: 'Fetching/Computing fills'.
self printStat: (Times at: 6) count: (Counts at: 6) string: 'Merging fills'.
self printStat: (Times at: 7) count: (Counts at: 7) string: 'Displaying span buffer'.
self printStat: (Times at: 8) count: (Counts at: 8) string: 'Fetching/Updating AET entries'.
self printStat: (Times at: 9) count: (Counts at: 9) string: 'Changing AET entries'.
Transcript cr; print: Times sum; nextPutAll:' mSecs for all operations'.
Transcript cr; print: Counts sum; nextPutAll: ' overall operations'.
Transcript endEntry.!
----- Method: BalloonEngine class>>recycleBuffer: (in category 'private') -----
recycleBuffer: balloonBuffer
"Try to keep the buffer for later drawing operations."
| buffer |
CacheProtect critical:[
buffer := BufferCache at: 1.
(buffer isNil or:[buffer size < balloonBuffer size] )
ifTrue:[BufferCache at: 1 put: balloonBuffer].
].!
----- Method: BalloonEngine class>>resetBezierStats (in category 'accessing') -----
resetBezierStats
BezierStats := WordArray new: 4.!
----- Method: BalloonEngine class>>resetStats (in category 'accessing') -----
resetStats
Times := WordArray new: 10.
Counts := WordArray new: 10.!
----- Method: BalloonEngine>>aaLevel (in category 'accessing') -----
aaLevel
^aaLevel ifNil:[1]!
----- Method: BalloonEngine>>aaLevel: (in category 'accessing') -----
aaLevel: anInteger
aaLevel := (anInteger min: 4) max: 1.!
----- Method: BalloonEngine>>aaTransform (in category 'accessing') -----
aaTransform
"Return a transformation for the current anti-aliasing level"
| matrix |
matrix := MatrixTransform2x3 withScale: (self aaLevel) asFloat asPoint.
matrix offset: (self aaLevel // 2) asFloat asPoint.
^matrix composedWith:(MatrixTransform2x3 withOffset: destOffset asFloatPoint)!
----- Method: BalloonEngine>>bitBlt (in category 'accessing') -----
bitBlt
^bitBlt!
----- Method: BalloonEngine>>bitBlt: (in category 'accessing') -----
bitBlt: aBitBlt
bitBlt := aBitBlt.
bitBlt isNil ifTrue:[^self].
self class primitiveSetBitBltPlugin: bitBlt getPluginName.
self clipRect: bitBlt clipRect.
bitBlt
sourceForm: (Form extent: span size @ 1 depth: 32 bits: span);
sourceRect: (0 at 0 extent: 1 at span size);
colorMap: (Color colorMapIfNeededFrom: 32 to: bitBlt destForm depth);
combinationRule: (bitBlt destForm depth >= 8 ifTrue:[34] ifFalse:[Form paint]).!
----- Method: BalloonEngine>>canProceedAfter: (in category 'copying') -----
canProceedAfter: failureReason
"Check if we can proceed after the failureReason indicated."
| newBuffer |
failureReason = GErrorNeedFlush ifTrue:[
"Need to flush engine before proceeding"
self copyBits.
self reset.
^true].
failureReason = GErrorNoMoreSpace ifTrue:[
"Work buffer is too small"
newBuffer := workBuffer species new: workBuffer size * 2.
self primCopyBufferFrom: workBuffer to: newBuffer.
workBuffer := newBuffer.
^true].
"Not handled"
^false!
----- Method: BalloonEngine>>clipRect (in category 'accessing') -----
clipRect
^clipRect!
----- Method: BalloonEngine>>clipRect: (in category 'accessing') -----
clipRect: aRect
clipRect := aRect truncated!
----- Method: BalloonEngine>>colorTransform (in category 'accessing') -----
colorTransform
^colorTransform!
----- Method: BalloonEngine>>colorTransform: (in category 'accessing') -----
colorTransform: aColorTransform
colorTransform := aColorTransform!
----- Method: BalloonEngine>>copyBits (in category 'copying') -----
copyBits
(bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate].
self copyLoopFaster.!
----- Method: BalloonEngine>>copyLoop (in category 'copying') -----
copyLoop
"This is the basic rendering loop using as little primitive support as possible."
| finished edge fill |
edge := BalloonEdgeData new.
fill := BalloonFillData new.
self primInitializeProcessing. "Initialize the GE for processing"
[self primFinishedProcessing] whileFalse:[
"Step 1: Process the edges in the global edge table that will be added in this step"
[finished := self primNextGlobalEdgeEntryInto: edge.
finished] whileFalse:[
edge source: (externals at: edge index).
edge stepToFirstScanLine.
self primAddActiveEdgeTableEntryFrom: edge].
"Step 2: Scan the active edge table"
[finished := self primNextFillEntryInto: fill.
finished] whileFalse:[
fill source: (externals at: fill index).
"Compute the new fill"
fill computeFill.
"And mix it in the out buffer"
self primMergeFill: fill destForm bits from: fill].
"Step 3: Display the current span buffer if necessary"
self primDisplaySpanBuffer.
"Step 4: Advance and resort the active edge table"
[finished := self primNextActiveEdgeEntryInto: edge.
finished] whileFalse:[
"If the index is zero then the edge has been handled by the GE"
edge source: (externals at: edge index).
edge stepToNextScanLine.
self primChangeActiveEdgeTableEntryFrom: edge].
].
self primGetTimes: Times.
self primGetCounts: Counts.
self primGetBezierStats: BezierStats.!
----- Method: BalloonEngine>>copyLoopFaster (in category 'copying') -----
copyLoopFaster
"This is a copy loop drawing one scan line at a time"
| edge fill reason |
edge := BalloonEdgeData new.
fill := BalloonFillData new.
[self primFinishedProcessing] whileFalse:[
reason := self primRenderScanline: edge with: fill.
"reason ~= 0 means there has been a problem"
reason = 0 ifFalse:[
self processStopReason: reason edge: edge fill: fill.
].
].
self primGetTimes: Times.
self primGetCounts: Counts.
self primGetBezierStats: BezierStats.!
----- Method: BalloonEngine>>copyLoopFastest (in category 'copying') -----
copyLoopFastest
"This is a copy loop drawing the entire image"
| edge fill reason |
edge := BalloonEdgeData new.
fill := BalloonFillData new.
[self primFinishedProcessing] whileFalse:[
reason := self primRenderImage: edge with: fill.
"reason ~= 0 means there has been a problem"
reason = 0 ifFalse:[
self processStopReason: reason edge: edge fill: fill.
].
].
self primGetTimes: Times.
self primGetCounts: Counts.
self primGetBezierStats: BezierStats.!
----- Method: BalloonEngine>>deferred (in category 'accessing') -----
deferred
^deferred!
----- Method: BalloonEngine>>deferred: (in category 'accessing') -----
deferred: aBoolean
deferred := aBoolean.!
----- Method: BalloonEngine>>destOffset (in category 'accessing') -----
destOffset
^destOffset!
----- Method: BalloonEngine>>destOffset: (in category 'accessing') -----
destOffset: aPoint
destOffset := aPoint asIntegerPoint.
bitBlt destX: aPoint x; destY: aPoint y.!
----- Method: BalloonEngine>>doAddCompressedShape:segments:leftFills:rightFills:lineWidths:lineFills:fillIndexList:matrix: (in category 'profiling') -----
doAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList matrix: aMatrix
"Note: This method is for profiling the overhead of loading a compressed shape into the engine."
^self primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList matrix: aMatrix!
----- Method: BalloonEngine>>drawBezierShape:fill:borderWidth:borderColor:transform: (in category 'drawing') -----
drawBezierShape: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform
| fills |
self edgeTransform: aTransform.
self resetIfNeeded.
fills := self registerFill: fillStyle and: borderFill.
self primAddBezierShape: points
segments: (points size) // 3
fill: (fills at: 1)
lineWidth: borderWidth
lineFill: (fills at: 2).
self postFlushIfNeeded.!
----- Method: BalloonEngine>>drawCompressedShape:transform: (in category 'drawing') -----
drawCompressedShape: shape transform: aTransform
| fillIndexList |
self edgeTransform: aTransform.
self resetIfNeeded.
fillIndexList := self registerFills: shape fillStyles.
self primAddCompressedShape: shape points
segments: shape numSegments
leftFills: shape leftFills
rightFills: shape rightFills
lineWidths: shape lineWidths
lineFills: shape lineFills
fillIndexList: fillIndexList.
self postFlushIfNeeded.!
----- Method: BalloonEngine>>drawGeneralBezierShape:fill:borderWidth:borderColor:transform: (in category 'drawing') -----
drawGeneralBezierShape: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform
| fills |
self edgeTransform: aTransform.
self resetIfNeeded.
fills := self registerFill: fillStyle and: borderFill.
contours do:[:points|
self primAddBezierShape: points
segments: (points size // 3)
fill: (fills at: 1)
lineWidth: borderWidth
lineFill: (fills at: 2).
"Note: To avoid premature flushing of the pipeline we need to
reset the flush bit within the engine."
self primFlushNeeded: false.
].
"And set the flush bit afterwards"
self primFlushNeeded: true.
self postFlushIfNeeded.!
----- Method: BalloonEngine>>drawGeneralPolygon:fill:borderWidth:borderColor:transform: (in category 'drawing') -----
drawGeneralPolygon: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform
| fills |
self edgeTransform: aTransform.
self resetIfNeeded.
fills := self registerFill: fillStyle and: borderFill.
contours do:[:points|
self primAddPolygon: points
segments: points size
fill: (fills at: 1)
lineWidth: borderWidth
lineFill: (fills at: 2).
"Note: To avoid premature flushing of the pipeline we need to
reset the flush bit within the engine."
self primFlushNeeded: false.
].
"And set the flush bit afterwards"
self primFlushNeeded: true.
self postFlushIfNeeded.!
----- Method: BalloonEngine>>drawOval:fill:borderWidth:borderColor:transform: (in category 'drawing') -----
drawOval: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix
| fills |
self edgeTransform: aMatrix.
self resetIfNeeded.
fills := self registerFill: fillStyle and: borderColor.
self primAddOvalFrom: rect origin
to: rect corner
fillIndex: (fills at: 1)
borderWidth: borderWidth
borderColor: (fills at: 2).
self postFlushIfNeeded.!
----- Method: BalloonEngine>>drawPolygon:fill:borderWidth:borderColor:transform: (in category 'drawing') -----
drawPolygon: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform
| fills |
self edgeTransform: aTransform.
self resetIfNeeded.
fills := self registerFill: fillStyle and: borderFill.
self primAddPolygon: points
segments: points size
fill: (fills at: 1)
lineWidth: borderWidth
lineFill: (fills at: 2).
self postFlushIfNeeded.!
----- Method: BalloonEngine>>drawRectangle:fill:borderWidth:borderColor:transform: (in category 'drawing') -----
drawRectangle: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix
| fills |
self edgeTransform: aMatrix.
self resetIfNeeded.
fills := self registerFill: fillStyle and: borderColor.
self primAddRectFrom: rect origin
to: rect corner
fillIndex: (fills at: 1)
borderWidth: borderWidth
borderColor: (fills at: 2).
self postFlushIfNeeded.!
----- Method: BalloonEngine>>edgeTransform (in category 'accessing') -----
edgeTransform
^edgeTransform!
----- Method: BalloonEngine>>edgeTransform: (in category 'accessing') -----
edgeTransform: aTransform
edgeTransform := aTransform.!
----- Method: BalloonEngine>>flush (in category 'initialize') -----
flush
"Force all pending primitives onscreen"
workBuffer ifNil:[^self].
self copyBits.
self release.!
----- Method: BalloonEngine>>fullTransformFrom: (in category 'accessing') -----
fullTransformFrom: aMatrix
| m |
m := self aaTransform composedWith: aMatrix.
"m offset: m offset + destOffset."
^m!
----- Method: BalloonEngine>>initialize (in category 'initialize') -----
initialize
| w |
w := Display width > 2048 ifTrue: [ 4096 ] ifFalse: [ 2048 ].
externals := OrderedCollection new: 100.
span := Bitmap new: w.
bitBlt := nil.
self bitBlt: ((BitBlt toForm: Display) destRect: Display boundingBox; yourself).
forms := #().
deferred := false.!
----- Method: BalloonEngine>>postFlushIfNeeded (in category 'initialize') -----
postFlushIfNeeded
"Force all pending primitives onscreen"
workBuffer ifNil:[^self].
(deferred not or:[postFlushNeeded]) ifTrue:[
self copyBits.
self release].!
----- Method: BalloonEngine>>preFlushIfNeeded (in category 'initialize') -----
preFlushIfNeeded
"Force all pending primitives onscreen"
workBuffer ifNil:[^self].
self primFlushNeeded ifTrue:[
self copyBits.
self reset].!
----- Method: BalloonEngine>>primAddActiveEdgeTableEntryFrom: (in category 'primitives-incremental') -----
primAddActiveEdgeTableEntryFrom: edgeEntry
"Add edge entry to the AET."
<primitive: 'primitiveAddActiveEdgeEntry' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddActiveEdgeTableEntryFrom: edgeEntry
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddBezierFrom:to:via:leftFillIndex:rightFillIndex: (in category 'primitives-adding') -----
primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
<primitive: 'primitiveAddBezier' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddBezierShape:segments:fill:lineWidth:lineFill: (in category 'primitives-adding') -----
primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
<primitive: 'primitiveAddBezierShape' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddBitmapFill:colormap:tile:from:along:normal:xIndex: (in category 'primitives-adding') -----
primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex
<primitive: 'primitiveAddBitmapFill' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddCompressedShape:segments:leftFills:rightFills:lineWidths:lineFills:fillIndexList: (in category 'primitives-adding') -----
primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList
<primitive: 'primitiveAddCompressedShape' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddExternalEdge:initialX:initialY:initialZ:leftFillIndex:rightFillIndex: (in category 'primitives-adding') -----
primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
<primitive: 'primitiveRegisterExternalEdge' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddExternalFill: (in category 'primitives-adding') -----
primAddExternalFill: index
<primitive: 'primitiveRegisterExternalFill' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddExternalFill: index
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddGradientFill:from:along:normal:radial: (in category 'primitives-adding') -----
primAddGradientFill: colorRamp from: origin along: direction normal: normal radial: isRadial
<primitive: 'primitiveAddGradientFill' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddGradientFill: colorRamp
from: origin
along: direction
normal: normal
radial: isRadial
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddLineFrom:to:leftFillIndex:rightFillIndex: (in category 'primitives-adding') -----
primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
<primitive: 'primitiveAddLine' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddOvalFrom:to:fillIndex:borderWidth:borderColor: (in category 'primitives-adding') -----
primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
<primitive: 'primitiveAddOval' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddPolygon:segments:fill:lineWidth:lineFill: (in category 'primitives-adding') -----
primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
<primitive: 'primitiveAddPolygon' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
].
^self primitiveFailed!
----- Method: BalloonEngine>>primAddRectFrom:to:fillIndex:borderWidth:borderColor: (in category 'primitives-adding') -----
primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
<primitive: 'primitiveAddRect' module: 'B2DPlugin'>
(self canProceedAfter: self primGetFailureReason) ifTrue:[
^self primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
].
^self primitiveFailed!
----- Method: BalloonEngine>>primChangeActiveEdgeTableEntryFrom: (in category 'primitives-incremental') -----
primChangeActiveEdgeTableEntryFrom: edgeEntry
"Change the entry in the active edge table from edgeEntry"
<primitive: 'primitiveChangedActiveEdgeEntry' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primClipRectInto: (in category 'primitives-access') -----
primClipRectInto: rect
<primitive: 'primitiveGetClipRect' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primCopyBufferFrom:to: (in category 'primitives-misc') -----
primCopyBufferFrom: oldBuffer to: newBuffer
"Copy the contents of oldBuffer into the (larger) newBuffer"
<primitive: 'primitiveCopyBuffer' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primDisplaySpanBuffer (in category 'primitives-incremental') -----
primDisplaySpanBuffer
"Display the current scan line if necessary"
<primitive: 'primitiveDisplaySpanBuffer' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primFinishedProcessing (in category 'primitives-incremental') -----
primFinishedProcessing
"Return true if there are no more entries in AET and GET and the last scan line has been displayed"
<primitive: 'primitiveFinishedProcessing' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primFlushNeeded (in category 'primitives-access') -----
primFlushNeeded
<primitive: 'primitiveNeedsFlush' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primFlushNeeded: (in category 'primitives-access') -----
primFlushNeeded: aBoolean
<primitive: 'primitiveNeedsFlushPut' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primGetAALevel (in category 'primitives-access') -----
primGetAALevel
"Set the AA level"
<primitive: 'primitiveGetAALevel' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primGetBezierStats: (in category 'primitives-access') -----
primGetBezierStats: statsArray
<primitive: 'primitiveGetBezierStats' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primGetClipRect: (in category 'primitives-access') -----
primGetClipRect: rect
<primitive: 'primitiveGetClipRect' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primGetCounts: (in category 'primitives-access') -----
primGetCounts: statsArray
<primitive: 'primitiveGetCounts' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primGetDepth (in category 'primitives-access') -----
primGetDepth
<primitive: 'primitiveGetDepth' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primGetFailureReason (in category 'primitives-access') -----
primGetFailureReason
<primitive: 'primitiveGetFailureReason' module: 'B2DPlugin'>
^0!
----- Method: BalloonEngine>>primGetOffset (in category 'primitives-access') -----
primGetOffset
<primitive: 'primitiveGetOffset' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primGetTimes: (in category 'primitives-access') -----
primGetTimes: statsArray
<primitive: 'primitiveGetTimes' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primInitializeBuffer: (in category 'primitives-misc') -----
primInitializeBuffer: buffer
<primitive: 'primitiveInitializeBuffer' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primInitializeProcessing (in category 'primitives-incremental') -----
primInitializeProcessing
"Initialize processing in the GE.
Create the active edge table and sort it."
<primitive: 'primitiveInitializeProcessing' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primMergeFill:from: (in category 'primitives-incremental') -----
primMergeFill: fillBitmap from: fill
"Merge the filled bitmap into the current output buffer."
<primitive: 'primitiveMergeFillFrom' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primNextActiveEdgeEntryInto: (in category 'primitives-incremental') -----
primNextActiveEdgeEntryInto: edgeEntry
"Store the next entry of the AET at the current y-value in edgeEntry.
Return false if there is no entry, true otherwise."
<primitive: 'primitiveNextActiveEdgeEntry' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primNextFillEntryInto: (in category 'primitives-incremental') -----
primNextFillEntryInto: fillEntry
"Store the next fill entry of the active edge table in fillEntry.
Return false if there is no such entry, true otherwise"
<primitive: 'primitiveNextFillEntry' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primNextGlobalEdgeEntryInto: (in category 'primitives-incremental') -----
primNextGlobalEdgeEntryInto: edgeEntry
"Store the next entry of the GET at the current y-value in edgeEntry.
Return false if there is no entry, true otherwise."
<primitive: 'primitiveNextGlobalEdgeEntry' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primRenderImage:with: (in category 'primitives-incremental') -----
primRenderImage: edge with: fill
"Start/Proceed rendering the current scan line"
<primitive: 'primitiveRenderImage' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primRenderScanline:with: (in category 'primitives-incremental') -----
primRenderScanline: edge with: fill
"Start/Proceed rendering the current scan line"
<primitive: 'primitiveRenderScanline' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primSetAALevel: (in category 'primitives-access') -----
primSetAALevel: level
"Set the AA level"
<primitive: 'primitiveSetAALevel' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primSetClipRect: (in category 'primitives-access') -----
primSetClipRect: rect
<primitive: 'primitiveSetClipRect' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primSetColorTransform: (in category 'primitives-access') -----
primSetColorTransform: transform
<primitive: 'primitiveSetColorTransform' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primSetDepth: (in category 'primitives-access') -----
primSetDepth: depth
<primitive: 'primitiveSetDepth' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primSetEdgeTransform: (in category 'primitives-access') -----
primSetEdgeTransform: transform
<primitive: 'primitiveSetEdgeTransform' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>primSetOffset: (in category 'primitives-access') -----
primSetOffset: point
<primitive: 'primitiveSetOffset' module: 'B2DPlugin'>
^self primitiveFailed!
----- Method: BalloonEngine>>processStopReason:edge:fill: (in category 'copying') -----
processStopReason: reason edge: edge fill: fill
"The engine has stopped because of some reason.
Try to figure out how to respond and do the necessary actions."
"Note: The order of operations below can affect the speed"
"Process unknown fills first"
reason = GErrorFillEntry ifTrue:[
fill source: (externals at: fill index).
"Compute the new fill"
fill computeFill.
"And mix it in the out buffer"
^self primMergeFill: fill destForm bits from: fill].
"Process unknown steppings in the AET second"
reason = GErrorAETEntry ifTrue:[
edge source: (externals at: edge index).
edge stepToNextScanLine.
^self primChangeActiveEdgeTableEntryFrom: edge].
"Process unknown entries in the GET third"
reason = GErrorGETEntry ifTrue:[
edge source: (externals at: edge index).
edge stepToFirstScanLine.
^self primAddActiveEdgeTableEntryFrom: edge].
"Process generic problems last"
(self canProceedAfter: reason) ifTrue:[^self]. "Okay."
^self error:'Unkown stop reason in graphics engine'
!
----- Method: BalloonEngine>>registerBezier:transformation: (in category 'experimental') -----
registerBezier: aCurve transformation: aMatrix
self primAddBezierFrom: aCurve start
to: aCurve end
via: aCurve via
leftFillIndex: (self registerFill: aCurve leftFill transform: aMatrix)
rightFillIndex: (self registerFill: aCurve rightFill transform: aMatrix)
matrix: aMatrix!
----- Method: BalloonEngine>>registerBoundary:transformation: (in category 'experimental') -----
registerBoundary: boundaryObject transformation: aMatrix
| external |
external := boundaryObject asEdgeRepresentation: (self fullTransformFrom: aMatrix).
self subdivideExternalEdge: external from: boundaryObject.
!
----- Method: BalloonEngine>>registerExternalEdge:from: (in category 'experimental') -----
registerExternalEdge: externalEdge from: boundaryObject
externals addLast: externalEdge.
self primAddExternalEdge: externals size
initialX: externalEdge initialX
initialY: externalEdge initialY
initialZ: externalEdge initialZ
leftFillIndex: (self registerFill: boundaryObject leftFill transform: nil)
rightFillIndex: (self registerFill: boundaryObject rightFill transform: nil)!
----- Method: BalloonEngine>>registerFill: (in category 'drawing') -----
registerFill: aFillStyle
"Register the given fill style."
| theForm |
aFillStyle ifNil:[^0].
aFillStyle isSolidFill
ifTrue:[^aFillStyle scaledPixelValue32].
aFillStyle isGradientFill ifTrue:[
^self primAddGradientFill: aFillStyle pixelRamp
from: aFillStyle origin
along: aFillStyle direction
normal: aFillStyle normal
radial: aFillStyle isRadialFill
].
aFillStyle isBitmapFill ifTrue:[
theForm := aFillStyle form asSourceForm.
theForm unhibernate.
forms := forms copyWith: theForm.
^self primAddBitmapFill: theForm
colormap: (theForm colormapIfNeededForDepth: 32)
tile: aFillStyle isTiled
from: aFillStyle origin
along: aFillStyle direction
normal: aFillStyle normal
xIndex: forms size].
^0!
----- Method: BalloonEngine>>registerFill:and: (in category 'drawing') -----
registerFill: fill1 and: fill2
^self registerFills: (Array with: fill1 with: fill2)!
----- Method: BalloonEngine>>registerFill:transform: (in category 'drawing') -----
registerFill: aFillStyle transform: aTransform
aFillStyle ifNil:[^0].
aFillStyle isSolidFill
ifTrue:[^aFillStyle scaledPixelValue32].
aFillStyle isGradientFill ifTrue:[
^self primAddGradientFill: aFillStyle pixelRamp
from: aFillStyle origin
along: aFillStyle direction
normal: aFillStyle normal
radial: aFillStyle isRadialFill
matrix: aTransform.
].
^0!
----- Method: BalloonEngine>>registerFills: (in category 'drawing') -----
registerFills: fills
| fillIndexList index fillIndex |
((colorTransform notNil and:[colorTransform isAlphaTransform]) or:[
fills anySatisfy: [:any| any notNil and:[any isTranslucent]]])
ifTrue:[ self flush.
self reset.
postFlushNeeded := true].
fillIndexList := WordArray new: fills size.
index := 1.
[index <= fills size] whileTrue:[
fillIndex := self registerFill: (fills at: index).
fillIndex == nil
ifTrue:[index := 1] "Need to start over"
ifFalse:[fillIndexList at: index put: fillIndex.
index := index+1]
].
^fillIndexList!
----- Method: BalloonEngine>>registerLine:transformation: (in category 'experimental') -----
registerLine: aLine transformation: aMatrix
self primAddLineFrom: aLine start to: aLine end
leftFillIndex: (self registerFill: aLine leftFill transform: aMatrix)
rightFillIndex: (self registerFill: aLine rightFill transform: aMatrix)
matrix: aMatrix!
----- Method: BalloonEngine>>release (in category 'initialize') -----
release
self class recycleBuffer: workBuffer.
workBuffer := nil.!
----- Method: BalloonEngine>>reset (in category 'initialize') -----
reset
workBuffer ifNil:[workBuffer := self class allocateOrRecycleBuffer: 10000].
self primInitializeBuffer: workBuffer.
self primSetAALevel: self aaLevel.
self primSetOffset: destOffset.
self primSetClipRect: clipRect.
self primSetEdgeTransform: edgeTransform.
self primSetColorTransform: colorTransform.
forms := #().!
----- Method: BalloonEngine>>resetIfNeeded (in category 'initialize') -----
resetIfNeeded
workBuffer ifNil:[self reset].
self primSetEdgeTransform: edgeTransform.
self primSetColorTransform: colorTransform.
self primSetDepth: self primGetDepth + 1.
postFlushNeeded := false.!
----- Method: BalloonEngine>>subdivideExternalEdge:from: (in category 'experimental') -----
subdivideExternalEdge: external from: boundaryObject
| external2 |
external2 := external subdivide.
external2 notNil ifTrue:[
self subdivideExternalEdge: external from: boundaryObject.
self subdivideExternalEdge: external2 from: boundaryObject.
] ifFalse:[
self registerExternalEdge: external from: boundaryObject.
].!
----- Method: BalloonEngineConstants class>>initEdgeConstants (in category 'pool definition') -----
initEdgeConstants
"Initialize the edge constants"
"Edge primitive types"
GEPrimitiveEdge := 2. "External edge - not handled by the GE"
GEPrimitiveWideEdge := 3. "Wide external edge"
GEPrimitiveLine := 4. "Straight line"
GEPrimitiveWideLine := 5. "Wide line"
GEPrimitiveBezier := 6. "Quadratic bezier curve"
GEPrimitiveWideBezier := 7. "Wide bezier curve"
"Special flags"
GEPrimitiveWide := 16r01. "Flag determining a wide primitive"
GEPrimitiveWideMask := 16rFE. "Mask for clearing the wide flag"
GEEdgeFillsInvalid := 16r10000. "Flag determining if left/right fills of an edge are invalid"
GEEdgeClipFlag := 16r20000. "Flag determining if this is a clip edge"
"General edge state constants"
GEXValue := 4. "Current raster x"
GEYValue := 5. "Current raster y"
GEZValue := 6. "Current raster z"
GENumLines := 7. "Number of scan lines remaining"
GEFillIndexLeft := 8. "Left fill index"
GEFillIndexRight := 9. "Right fill index"
GEBaseEdgeSize := 10. "Basic size of each edge"
"General fill state constants"
GEBaseFillSize := 4. "Basic size of each fill"
"General Line state constants"
GLXDirection := 10. "Direction of edge (1: left-to-right; -1: right-to-left)"
GLYDirection := 11. "Direction of edge (1: top-to-bottom; -1: bottom-to-top)"
GLXIncrement := 12. "Increment at each scan line"
GLError := 13. "Current error"
GLErrorAdjUp := 14. "Error to add at each scan line"
GLErrorAdjDown := 15. "Error to subtract on roll-over"
"Note: The following entries are only needed before the incremental
state is computed. They are therefore aliased to the error values above"
GLEndX := 14. "End X of line"
GLEndY := 15. "End Y of line"
GLBaseSize := 16. "Basic size of each line"
"Additional stuff for wide lines"
GLWideFill := 16. "Current fill of line"
GLWideWidth := 17. "Current width of line"
GLWideEntry := 18. "Initial steps"
GLWideExit := 19. "Final steps"
GLWideExtent := 20. "Target width"
GLWideSize := 21. "Size of wide lines"
"General Bezier state constants"
GBUpdateData := 10. "Incremental update data for beziers"
GBUpdateX := 0. "Last computed X value (24.8)"
GBUpdateY := 1. "Last computed Y value (24.8)"
GBUpdateDX := 2. "Delta X forward difference step (8.24)"
GBUpdateDY := 3. "Delta Y forward difference step (8.24)"
GBUpdateDDX := 4. "Delta DX forward difference step (8.24)"
GBUpdateDDY := 5. "Delta DY forward difference step (8.24)"
"Note: The following four entries are only needed before the incremental
state is computed. They are therefore aliased to the incremental values above"
GBViaX := 12. "via x"
GBViaY := 13. "via y"
GBEndX := 14. "end x"
GBEndY := 15. "end y"
GBBaseSize := 16. "Basic size of each bezier.
Note: MUST be greater or equal to the size of lines"
"Additional stuff for wide beziers"
GBWideFill := 16. "Current fill of line"
GBWideWidth := 17. "Current width of line"
GBWideEntry := 18. "Initial steps"
GBWideExit := 19. "Final steps"
GBWideExtent := 20. "Target extent"
GBFinalX := 21. "Final X value"
GBWideUpdateData := 22. "Update data for second curve"
GBWideSize := 28. "Size of wide beziers"
!
----- Method: BalloonEngineConstants class>>initFillConstants (in category 'pool definition') -----
initFillConstants
"Initialize the fill constants"
"Fill primitive types"
GEPrimitiveFill := 16r100.
GEPrimitiveLinearGradientFill := 16r200.
GEPrimitiveRadialGradientFill := 16r300.
GEPrimitiveClippedBitmapFill := 16r400.
GEPrimitiveRepeatedBitmapFill := 16r500.
"General fill state constants"
GEBaseFillSize := 4. "Basic size of each fill"
"Oriented fill constants"
GFOriginX := 4. "X origin of fill"
GFOriginY := 5. "Y origin of fill"
GFDirectionX := 6. "X direction of fill"
GFDirectionY := 7. "Y direction of fill"
GFNormalX := 8. "X normal of fill"
GFNormalY := 9. "Y normal of fill"
"Gradient fill constants"
GFRampLength := 10. "Length of following color ramp"
GFRampOffset := 12. "Offset of first ramp entry"
GGBaseSize := 12.
"Bitmap fill constants"
GBBitmapWidth := 10. "Width of bitmap"
GBBitmapHeight := 11. "Height of bitmap"
GBBitmapDepth := 12. "Depth of bitmap"
GBBitmapSize := 13. "Size of bitmap words"
GBBitmapRaster := 14. "Size of raster line"
GBColormapSize := 15. "Size of colormap, if any"
GBTileFlag := 16. "True if the bitmap is tiled"
GBColormapOffset := 18. "Offset of colormap, if any"
GBMBaseSize := 18. "Basic size of bitmap fill"
!
----- Method: BalloonEngineConstants class>>initPrimitiveConstants (in category 'pool definition') -----
initPrimitiveConstants
"Initialize the primitive constants"
"Primitive type constants"
GEPrimitiveUnknown := 0.
GEPrimitiveEdgeMask := 16rFF.
GEPrimitiveFillMask := 16rFF00.
GEPrimitiveTypeMask := 16rFFFF.
"General state constants (Note: could be compressed later)"
GEObjectType := 0. "Type of object"
GEObjectLength := 1. "Length of object"
GEObjectIndex := 2. "Index into external objects"
GEObjectUnused := 3. "Currently unused"
!
----- Method: BalloonEngineConstants class>>initStateConstants (in category 'pool definition') -----
initStateConstants
"Initialize the state Constants"
GEStateUnlocked := 0. "Buffer is unlocked and can be modified as wanted"
GEStateAddingFromGET := 1. "Adding edges from the GET"
GEStateWaitingForEdge := 2. "Waiting for edges added to GET"
GEStateScanningAET := 3. "Scanning the active edge table"
GEStateWaitingForFill := 4. "Waiting for a fill to mix in during AET scan"
GEStateBlitBuffer := 5. "Blt the current scan line"
GEStateUpdateEdges := 6. "Update edges to next scan line"
GEStateWaitingChange := 7. "Waiting for a changed edge"
GEStateCompleted := 8. "Rendering completed"
"Error constants"
GErrorNoMoreSpace := 1. "No more space in collection"
GErrorBadState := 2. "Tried to call a primitive while engine in bad state"
GErrorNeedFlush := 3. "Tried to call a primitive that requires flushing before"
"Incremental error constants"
GErrorGETEntry := 4. "Unknown entry in GET"
GErrorFillEntry := 5. "Unknown FILL encountered"
GErrorAETEntry := 6. "Unknown entry in AET"
!
----- Method: BalloonEngineConstants class>>initWorkBufferConstants (in category 'pool definition') -----
initWorkBufferConstants
"Initialize the work buffer constants"
"General work buffer constants"
GWMagicNumber := 16r416E6469. "Magic number"
GWHeaderSize := 128. "Size of header"
GWMinimalSize := 256. "Minimal size of work buffer"
"Header entries"
GWMagicIndex := 0. "Index of magic number"
GWSize := 1. "Size of full buffer"
GWState := 2. "Current state (e.g., locked or not."
"Buffer entries"
GWObjStart := 8. "objStart"
GWObjUsed := 9. "objUsed"
GWBufferTop := 10. "wbTop"
GWGETStart := 11. "getStart"
GWGETUsed := 12. "getUsed"
GWAETStart := 13. "aetStart"
GWAETUsed := 14. "aetUsed"
"Transform entries"
GWHasEdgeTransform := 16. "True if we have an edge transformation"
GWHasColorTransform := 17. "True if we have a color transformation"
GWEdgeTransform := 18. "2x3 edge transformation"
GWColorTransform := 24. "8 word RGBA color transformation"
"Span entries"
GWSpanStart := 32. "spStart"
GWSpanSize := 33. "spSize"
GWSpanEnd := 34. "spEnd"
GWSpanEndAA := 35. "spEndAA"
"Bounds entries"
GWFillMinX := 36. "fillMinX"
GWFillMaxX := 37. "fillMaxX"
GWFillMinY := 38. "fillMinY"
GWFillMaxY := 39. "fillMaxY"
GWFillOffsetX := 40. "fillOffsetX"
GWFillOffsetY := 41. "fillOffsetY"
GWClipMinX := 42.
GWClipMaxX := 43.
GWClipMinY := 44.
GWClipMaxY := 45.
GWDestOffsetX := 46.
GWDestOffsetY := 47.
"AA entries"
GWAALevel := 48. "aaLevel"
GWAAShift := 49. "aaShift"
GWAAColorShift := 50. "aaColorShift"
GWAAColorMask := 51. "aaColorMask"
GWAAScanMask := 52. "aaScanMask"
GWAAHalfPixel := 53. "aaHalfPixel"
"Misc entries"
GWNeedsFlush := 63. "True if the engine may need a flush"
GWStopReason := 64. "stopReason"
GWLastExportedEdge := 65. "last exported edge"
GWLastExportedFill := 66. "last exported fill"
GWLastExportedLeftX := 67. "last exported leftX"
GWLastExportedRightX := 68. "last exported rightX"
GWClearSpanBuffer := 69. "Do we have to clear the span buffer?"
GWPointListFirst := 70. "First point list in buffer"
GWPoint1 := 80.
GWPoint2 := 82.
GWPoint3 := 84.
GWPoint4 := 86.
GWCurrentY := 88.
"Profile stats"
GWTimeInitializing := 90.
GWCountInitializing := 91.
GWTimeFinishTest := 92.
GWCountFinishTest := 93.
GWTimeNextGETEntry := 94.
GWCountNextGETEntry := 95.
GWTimeAddAETEntry := 96.
GWCountAddAETEntry := 97.
GWTimeNextFillEntry := 98.
GWCountNextFillEntry := 99.
GWTimeMergeFill := 100.
GWCountMergeFill := 101.
GWTimeDisplaySpan := 102.
GWCountDisplaySpan := 103.
GWTimeNextAETEntry := 104.
GWCountNextAETEntry := 105.
GWTimeChangeAETEntry := 106.
GWCountChangeAETEntry := 107.
"Bezier stats"
GWBezierMonotonSubdivisions := 108. "# of subdivision due to non-monoton beziers"
GWBezierHeightSubdivisions := 109. "# of subdivisions due to excessive height"
GWBezierOverflowSubdivisions := 110. "# of subdivisions due to possible int overflow"
GWBezierLineConversions := 111. "# of beziers converted to lines"
GWHasClipShapes := 112. "True if the engine contains clip shapes"
GWCurrentZ := 113. "Current z value of primitives"
!
----- Method: BalloonEngineConstants class>>initialize (in category 'pool definition') -----
initialize
"BalloonEngineConstants initialize"
self initStateConstants.
self initWorkBufferConstants.
self initPrimitiveConstants.
self initEdgeConstants.
self initFillConstants.
self initializeInstVarNames: BalloonEngine prefixedBy: 'BE'.
self initializeInstVarNames: BalloonEdgeData prefixedBy: 'ET'.
self initializeInstVarNames: BalloonFillData prefixedBy: 'FT'.!
----- Method: BalloonEngineConstants class>>initializeInstVarNames:prefixedBy: (in category 'pool definition') -----
initializeInstVarNames: aClass prefixedBy: aString
| token value |
aClass instVarNames doWithIndex:[:instVarName :index|
token := (aString, instVarName first asUppercase asString, (instVarName copyFrom: 2 to: instVarName size),'Index') asSymbol.
value := index - 1.
(self bindingOf: token) ifNil:[self addClassVarName: token].
(self bindingOf: token) value: value.
].
token := (aString, aClass name,'Size') asSymbol.
(self bindingOf: token) ifNil:[self addClassVarName: token].
(self bindingOf: token) value: aClass instSize.!
ArrayedCollection variableWordSubclass: #ShortIntegerArray
instanceVariableNames: ''
classVariableNames: 'LastSaveOrder'
poolDictionaries: ''
category: 'Balloon-Collections'!
!ShortIntegerArray commentStamp: '<historical>' prior: 0!
ShortIntegerArray is an array for efficiently representing integers in the 16bit range.!
----- Method: ShortIntegerArray class>>initialize (in category 'class initialization') -----
initialize
"ShortIntegerArray initialize"
Smalltalk addToStartUpList: self after: Delay.
LastSaveOrder := self new: 2.
LastSaveOrder at: 1 put: 42.
LastSaveOrder at: 2 put: 13.!
----- Method: ShortIntegerArray class>>new: (in category 'instance creation') -----
new: n
^super new: n + 1 // 2!
----- Method: ShortIntegerArray class>>startUp (in category 'class initialization') -----
startUp
"Check if the word order has changed from the last save"
((LastSaveOrder at: 1) = 42 and:[(LastSaveOrder at: 2) = 13])
ifTrue:[^self]. "Okay"
((LastSaveOrder at: 2) = 42 and:[(LastSaveOrder at: 1) = 13])
ifTrue:[^self swapShortObjects]. "Reverse guys"
^self error:'This must never happen'!
----- Method: ShortIntegerArray class>>startUpFrom: (in category 'class initialization') -----
startUpFrom: anImageSegment
"In this case, do we need to swap word halves when reading this segement?"
^ (SmalltalkImage current endianness) ~~ (anImageSegment endianness)
ifTrue: [Message selector: #swapShortObjects] "will be run on each instance"
ifFalse: [nil].
!
----- Method: ShortIntegerArray class>>swapShortObjects (in category 'class initialization') -----
swapShortObjects
self allSubInstancesDo:[:inst| inst swapShortObjects]!
----- Method: ShortIntegerArray>>at: (in category 'accessing') -----
at: index
"Return the 16-bit integer value at the given index of the receiver."
<primitive: 143>
index isInteger ifTrue: [self errorSubscriptBounds: index].
index isNumber ifTrue: [^ self at: index truncated].
self errorNonIntegerIndex.
!
----- Method: ShortIntegerArray>>at:put: (in category 'accessing') -----
at: index put: value
"Store the given 16-bit integer at the given index in the receiver."
<primitive: 144>
index isInteger
ifTrue: [
(index >= 1 and: [index <= self size])
ifTrue: [self errorImproperStore]
ifFalse: [self errorSubscriptBounds: index]].
index isNumber ifTrue: [^ self at: index truncated put: value].
self errorNonIntegerIndex.
!
----- Method: ShortIntegerArray>>bytesPerBasicElement (in category 'objects from disk') -----
bytesPerBasicElement
^4!
----- Method: ShortIntegerArray>>bytesPerElement (in category 'objects from disk') -----
bytesPerElement
^2!
----- Method: ShortIntegerArray>>defaultElement (in category 'accessing') -----
defaultElement
^0!
----- Method: ShortIntegerArray>>pvtAt: (in category 'private') -----
pvtAt: index
"Private -- for swapping only"
<primitive: 143>
index isInteger ifTrue: [self errorSubscriptBounds: index].
index isNumber ifTrue: [^ self at: index truncated].
self errorNonIntegerIndex.
!
----- Method: ShortIntegerArray>>pvtAt:put: (in category 'private') -----
pvtAt: index put: value
"Private -- for swapping only"
<primitive: 144>
index isInteger
ifTrue: [
(index >= 1 and: [index <= self size])
ifTrue: [self errorImproperStore]
ifFalse: [self errorSubscriptBounds: index]].
index isNumber ifTrue: [^ self at: index truncated put: value].
self errorNonIntegerIndex.
!
----- Method: ShortIntegerArray>>restoreEndianness (in category 'objects from disk') -----
restoreEndianness
"This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian.
Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap."
| hack blt |
SmalltalkImage current isLittleEndian ifTrue: [
"The implementation is a hack, but fast for large ranges"
hack := Form new hackBits: self.
blt := (BitBlt toForm: hack) sourceForm: hack.
blt combinationRule: Form reverse. "XOR"
blt sourceY: 0; destY: 0; height: hack height; width: 1.
blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1"
blt sourceX: 1; destX: 0; copyBits.
blt sourceX: 0; destX: 1; copyBits.
blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3"
blt sourceX: 3; destX: 2; copyBits.
blt sourceX: 2; destX: 3; copyBits
].
!
----- Method: ShortIntegerArray>>size (in category 'accessing') -----
size
^super size * 2!
----- Method: ShortIntegerArray>>swapShortObjects (in category 'private') -----
swapShortObjects
"Private -- swap all the short quantities in the receiver"
| tmp |
1 to: self basicSize do:[:i|
tmp := (self pvtAt: i * 2).
self pvtAt: i * 2 put: (self pvtAt: i * 2 - 1).
self pvtAt: i * 2 - 1 put: tmp.
]!
----- Method: ShortIntegerArray>>writeOn: (in category 'objects from disk') -----
writeOn: aStream
aStream nextInt32Put: self basicSize.
1 to: self basicSize do: [ :i | | w |
w := self basicAt: i.
SmalltalkImage current isLittleEndian
ifFalse: [ aStream nextNumber: 4 put: w ]
ifTrue: [ aStream
nextPut: (w digitAt: 2);
nextPut: (w digitAt: 1);
nextPut: (w digitAt: 4);
nextPut: (w digitAt: 3) ]].!
ShortIntegerArray variableWordSubclass: #ShortPointArray
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Balloon-Collections'!
!ShortPointArray commentStamp: '<historical>' prior: 0!
This class stores points that are in short integer range (e.g., -32767 <= value <= 32768). It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.!
----- Method: ShortPointArray class>>new: (in category 'instance creation') -----
new: n
^super new: n * 2!
----- Method: ShortPointArray>>at: (in category 'accessing') -----
at: index
"Return the element (e.g., point) at the given index"
^(super at: index * 2 - 1) @ (super at: index * 2)!
----- Method: ShortPointArray>>at:put: (in category 'accessing') -----
at: index put: aPoint
"Store the argument aPoint at the given index"
super at: index * 2 - 1 put: aPoint x asInteger.
super at: index * 2 put: aPoint y asInteger.
^aPoint!
----- Method: ShortPointArray>>bounds (in category 'accessing') -----
bounds
| min max |
min := max := self at: 1.
self do:[:pt|
min := min min: pt.
max := max max: pt].
^min corner: max
!
----- Method: ShortPointArray>>bytesPerElement (in category 'accessing') -----
bytesPerElement
^ 4.
!
----- Method: ShortPointArray>>defaultElement (in category 'accessing') -----
defaultElement
"Return the default element of the receiver"
^0 at 0!
----- Method: ShortPointArray>>size (in category 'accessing') -----
size
^self basicSize!
ArrayedCollection variableWordSubclass: #ShortRunArray
instanceVariableNames: ''
classVariableNames: 'LastSaveOrder'
poolDictionaries: ''
category: 'Balloon-Collections'!
!ShortRunArray commentStamp: '<historical>' prior: 0!
This class is run-length encoded representation of short integer (e.g., 16bit signed integer values)!
----- Method: ShortRunArray class>>initialize (in category 'class initialization') -----
initialize
"ShortRunArray initialize"
Smalltalk addToStartUpList: self after: Delay.
LastSaveOrder := #(42 42 42) as: self.!
----- Method: ShortRunArray class>>new: (in category 'instance creation') -----
new: n
"ShortRunArrays must be created with either
someCollection as: ShortRunArray
or by using
ShortRunArray runs: runCollection values: valueCollection.
"
^self shouldNotImplement!
----- Method: ShortRunArray class>>newFrom: (in category 'instance creation') -----
newFrom: aCollection
"Compress aCollection into a ShortRunArray"
| lastValue lastRun runs values |
aCollection isEmpty ifTrue:[^self runs:#() values: #()].
runs := WriteStream on: (WordArray new: 100).
values := WriteStream on: (ShortIntegerArray new: 100).
lastValue := aCollection first.
lastRun := 0.
aCollection do:[:item|
(item = lastValue and:[lastRun < 16r8000]) ifTrue:[
lastRun := lastRun + 1.
] ifFalse:[
runs nextPut: lastRun.
values nextPut: lastValue.
lastRun := 1.
lastValue := item.
].
].
runs nextPut: lastRun.
values nextPut: lastValue.
^self runs: runs contents values: values contents!
----- Method: ShortRunArray class>>runs:values: (in category 'instance creation') -----
runs: runCollection values: valueCollection
^(self basicNew: runCollection size) setRuns: runCollection values: valueCollection!
----- Method: ShortRunArray class>>startUp (in category 'class initialization') -----
startUp
"Check if the word order has changed from the last save"
((LastSaveOrder valueAtRun: 1) = 42 and:[(LastSaveOrder lengthAtRun: 1) = 3])
ifTrue:[^self]. "Okay"
((LastSaveOrder lengthAtRun: 1) = 42 and:[(LastSaveOrder valueAtRun: 1) = 3])
ifTrue:[^self swapRuns]. "Reverse guys"
^self error:'This must never happen'!
----- Method: ShortRunArray class>>startUpFrom: (in category 'class initialization') -----
startUpFrom: anImageSegment
"In this case, do we need to swap word halves when reading this segement?"
^SmalltalkImage current endianness ~~ anImageSegment endianness
ifTrue: [Message selector: #swapRuns "will be run on each instance"]
ifFalse: [nil]!
----- Method: ShortRunArray class>>swapRuns (in category 'class initialization') -----
swapRuns
self allSubInstancesDo:[:inst| inst swapRuns]!
----- Method: ShortRunArray>>at: (in category 'accessing') -----
at: index
"Return the short value at the given index"
| rlIndex |
index < 1 ifTrue:[^self errorSubscriptBounds: index].
rlIndex := index.
self lengthsAndValuesDo:[:runLength :runValue|
rlIndex <= runLength ifTrue:[^runValue].
rlIndex := rlIndex - runLength].
"Not found. Must be out of range"
^self errorSubscriptBounds: index!
----- Method: ShortRunArray>>at:put: (in category 'accessing') -----
at: index put: value
"ShortRunArrays are read-only"
^self shouldNotImplement.!
----- Method: ShortRunArray>>bytesPerElement (in category 'accessing') -----
bytesPerElement
^ 4
!
----- Method: ShortRunArray>>compressionRatio (in category 'accessing') -----
compressionRatio
"Return the compression ratio.
The compression ratio is computed based
on how much space would be needed to
store the receiver in a ShortIntegerArray"
^(self size asFloat * 0.5) "Would need only half of the amount in ShortIntegerArray"
/ (self runSize max: 1)!
----- Method: ShortRunArray>>do: (in category 'enumerating') -----
do: aBlock
"Evaluate aBlock with all elements of the receiver"
self lengthsAndValuesDo:[:runLength :runValue|
"Use to:do: instead of timesRepeat: for compiler optimization"
1 to: runLength do:[:i|
aBlock value: runValue.
].
].!
----- Method: ShortRunArray>>lengthAtRun: (in category 'accessing') -----
lengthAtRun: index
"Return the length of the run starting at the given index"
^(self basicAt: index) bitShift: -16!
----- Method: ShortRunArray>>lengthsAndValuesDo: (in category 'enumerating') -----
lengthsAndValuesDo: aBlock
"Evaluate aBlock with the length and value of each run in the receiver"
^self runsAndValuesDo: aBlock!
----- Method: ShortRunArray>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPutAll: self class name; nextPutAll:' ( '.
self lengthsAndValuesDo:[:runLength :runValue |
aStream
nextPutAll:' (';
print: runLength;
space;
print: runValue;
nextPut:$).
].
aStream nextPutAll:' )'.!
----- Method: ShortRunArray>>pvtAt: (in category 'private') -----
pvtAt: index
"Private -- for swapping only"
<primitive: 143>
index isInteger ifTrue: [self errorSubscriptBounds: index].
index isNumber ifTrue: [^ self at: index truncated].
self errorNonIntegerIndex.
!
----- Method: ShortRunArray>>pvtAt:put: (in category 'private') -----
pvtAt: index put: value
"Private -- for swapping only"
<primitive: 144>
index isInteger
ifTrue: [
(index >= 1 and: [index <= self size])
ifTrue: [self errorImproperStore]
ifFalse: [self errorSubscriptBounds: index]].
index isNumber ifTrue: [^ self at: index truncated put: value].
self errorNonIntegerIndex.
!
----- Method: ShortRunArray>>restoreEndianness (in category 'objects from disk') -----
restoreEndianness
"This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian.
Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap."
| w b1 b2 b3 b4 |
SmalltalkImage current isLittleEndian ifTrue: [
1 to: self basicSize do: [:i |
w := self basicAt: i.
b1 := w digitAt: 1.
b2 := w digitAt: 2.
b3 := w digitAt: 3.
b4 := w digitAt: 4.
w := (b1 << 24) + (b2 << 16) + (b3 << 8) + b4.
self basicAt: i put: w.
]
].
!
----- Method: ShortRunArray>>runSize (in category 'accessing') -----
runSize
"Return the number of runs in the receiver"
^self basicSize!
----- Method: ShortRunArray>>runsAndValuesDo: (in category 'enumerating') -----
runsAndValuesDo: aBlock
"Evaluate aBlock with the length and value of each run in the receiver"
| basicValue length value |
1 to: self basicSize do:[:i|
basicValue := self basicAt: i.
length := basicValue bitShift: -16.
value := basicValue bitAnd: 16rFFFF.
value := (value bitAnd: 16r7FFF) - (value bitAnd: 16r8000).
aBlock value: length value: value.
].!
----- Method: ShortRunArray>>setRunAt:toLength:value: (in category 'private') -----
setRunAt: i toLength: runLength value: value
(value < -16r7FFF or:[value > 16r8000]) ifTrue:[^self errorImproperStore].
(runLength < 0 or:[runLength > 16rFFFF]) ifTrue:[^self errorImproperStore].
self basicAt: i put: (runLength bitShift: 16) +
((value bitAnd: 16r7FFF) - (value bitAnd: -16r8000)).!
----- Method: ShortRunArray>>setRuns:values: (in category 'private') -----
setRuns: runArray values: valueArray
| runLength value |
1 to: runArray size do:[:i|
runLength := runArray at: i.
value := valueArray at: i.
self setRunAt: i toLength: runLength value: value.
].!
----- Method: ShortRunArray>>size (in category 'accessing') -----
size
"Return the number of elements stored in the receiver"
| n |
n := 0.
"Note: The following loop is open-coded for speed"
1 to: self basicSize do:[:i|
n := n + ((self basicAt: i) bitShift: -16).
].
^n!
----- Method: ShortRunArray>>species (in category 'accessing') -----
species
"Answer the preferred class for reconstructing the receiver."
^ShortIntegerArray!
----- Method: ShortRunArray>>swapRuns (in category 'private') -----
swapRuns
"Private -- swap length/value pairs in the receiver"
| tmp |
1 to: self basicSize do:[:i|
tmp := (self pvtAt: i * 2).
self pvtAt: i * 2 put: (self pvtAt: i * 2 - 1).
self pvtAt: i * 2 - 1 put: tmp.
]!
----- Method: ShortRunArray>>valueAtRun: (in category 'accessing') -----
valueAtRun: index
"Return the value of the run starting at the given index"
| uShort |
uShort := (self basicAt: index) bitAnd: 16rFFFF.
^(uShort bitAnd: 16r7FFF) - (uShort bitAnd: 16r8000)!
----- Method: ShortRunArray>>valuesCollect: (in category 'enumerating') -----
valuesCollect: aBlock
"Evaluate aBlock with each of the receiver's values as the argument.
Collect the resulting values into a collection like the receiver. Answer
the new collection."
| newArray newValue |
newArray := self class basicNew: self basicSize.
1 to: self runSize do:[:i|
newValue := aBlock value: (self valueAtRun: i).
newArray setRunAt: i toLength: (self lengthAtRun: i) value: newValue.
].
^newArray!
----- Method: ShortRunArray>>valuesDo: (in category 'enumerating') -----
valuesDo: aBlock
self lengthsAndValuesDo:[:runLength :runValue| aBlock value: runValue]!
More information about the Packages
mailing list