Made #drawOn: on RSAthensMorph apply the world renderer canvas scale …

…factor to the Athens surface and canvas.

src/Roassal/RSAthensMorph.class.st

@@ -8,6 +8,7 @@ Class {
 	#instVars : [
 		'renderer',
 		'session',
+		'surfaceScale',
 		'surface',
 		'isDrawing',
 		'roassalCanvas',
@@ -60,7 +61,7 @@ RSAthensMorph >> checkSession [
 
 { #category : #'surface management' }
 RSAthensMorph >> createSurface [
-	surface := AthensCairoSurface extent: self extent asIntegerPoint.
+	surface := AthensCairoSurface extent: self extent asIntegerPoint * surfaceScale.
 	session := Smalltalk session.
 	roassalCanvas ifNotNil: [ roassalCanvas invalidate ]
 ]
@@ -72,7 +73,7 @@ RSAthensMorph >> drawOn: aCanvas [
 	isDrawing := true.
 	[
 		self checkSession.
-		self recreateSurfaceIfNecessary.
+		self recreateSurfaceIfNecessary: OSWorldRenderer canvasScaleFactor.
 		aCanvas
 			fillRectangle: self bounds
 			fillStyle: roassalCanvas color
@@ -83,10 +84,8 @@ RSAthensMorph >> drawOn: aCanvas [
 		surface hasBeenFreed
 			ifTrue: [ self createSurface ].
 		[ aCanvas
-			image: surface asForm
-			at: self bounds origin asIntegerPoint
-			sourceRect: (0 @ 0 extent: surface extent)
-			rule: 34 ]
+			translucentFormSet: (FormSet extent: self extent asIntegerPoint depth: 32 forms: { surface asForm })
+			at: self bounds origin asIntegerPoint ]
 		on: Exception
 		do: [ :ex | ex traceCr ]
 	] ensure: [ isDrawing := false ]
@@ -118,7 +117,8 @@ RSAthensMorph >> drawShapes [
 	surface drawDuring: [ :athensCanvas |
 		renderer
 			surface: surface;
-			canvas: athensCanvas.
+			canvas: athensCanvas;
+			scale: surfaceScale.
 		roassalCanvas accept: renderer.
 	]
 ]
@@ -138,7 +138,7 @@ RSAthensMorph >> fullDrawOnAthensCanvas: aCanvas [
 	isDrawing := true.
 	[
 		self checkSession.
-		self recreateSurfaceIfNecessary.
+		self recreateSurfaceIfNecessary: 1.
 
 		aCanvas setPaint: roassalCanvas color.
 		aCanvas drawShape: (bounds translateBy: bounds origin negated).
@@ -217,6 +217,7 @@ RSAthensMorph >> hasFocus [
 RSAthensMorph >> initialize [
 	super initialize.
 	self eventProcessor: RSEventProcessor new.
+	surfaceScale := 0.
 	self createSurface.
 	session := Smalltalk session.
 	isDrawing := false
@@ -293,10 +294,11 @@ RSAthensMorph >> mouseWheel: evt [
 ]
 
 { #category : #'session management' }
-RSAthensMorph >> recreateSurfaceIfNecessary [
+RSAthensMorph >> recreateSurfaceIfNecessary: scale [
 	surface
-		ifNotNil: [ self extent asIntegerPoint ~= surface extent
-				ifTrue: [ self createSurface.
+		ifNotNil: [ (surfaceScale ~= scale or: [ self extent asIntegerPoint * surfaceScale ~= surface extent ])
+				ifTrue: [ surfaceScale := scale.
+					self createSurface.
 					roassalCanvas extent: self extent ] ]
 ]
 

src/Roassal/RSAthensRenderer.class.st

@@ -23,6 +23,7 @@ Class {
 		'showRectangles',
 		'originMatrix',
 		'surface',
+		'scale',
 		'dirtyRectangle'
 	],
 	#category : 'Roassal-Rendering'
@@ -580,6 +581,32 @@ RSAthensRenderer >> paintFor: shape form: form [
 			paint ]
 ]
 
+{ #category : #'visiting - helpers' }
+RSAthensRenderer >> pathTransformLoadMatrix [
+
+	athensCanvas pathTransform loadAffineTransform:
+		(AthensAffineTransform new
+			x: matrix x * scale;
+			y: matrix y * scale;
+			sx: matrix sx * scale;
+			sy: matrix sy * scale;
+			shx: matrix shx * scale;
+			shy: matrix shy * scale;
+			yourself)
+]
+
+{ #category : #accessing }
+RSAthensRenderer >> scale [
+
+	^ scale
+]
+
+{ #category : #accessing }
+RSAthensRenderer >> scale: anObject [
+
+	scale := anObject
+]
+
 { #category : #'visiting - helpers' }
 RSAthensRenderer >> showEncompassingRectangleForLineIfNecessary: line [
 	showRectangles ifFalse: [ ^ self ].
@@ -630,7 +657,7 @@ RSAthensRenderer >> visitBorderIfNecessary: shape [
 RSAthensRenderer >> visitBoundingShape: shape [
 	self visitShapeIfNecessary: shape block: [
 		| path paint |
-		athensCanvas pathTransform loadAffineTransform: matrix.
+		self pathTransformLoadMatrix.
 		path := self getOrCreatePathOf: shape.
 		paint := shape paintOn: self.
 		paint ifNotNil: [
@@ -666,6 +693,7 @@ RSAthensRenderer >> visitCanvas: aRSCanvas [
 	athensCanvas setAA: aRSCanvas host antialiasing.
 	aRSCanvas camera accept: self.
 	transformeDirtyRectangle := self transform: dirtyRectangle.
+	athensCanvas pathTransform loadIdentity scaleBy: scale.
 	aRSCanvas shouldClearBackground ifTrue: [
 		self clearRectangle: transformeDirtyRectangle ].
 	modifiedDirtyRectangle := self inverseTransform: transformeDirtyRectangle.
@@ -674,14 +702,14 @@ RSAthensRenderer >> visitCanvas: aRSCanvas [
 	dirtyRectangle := transformeDirtyRectangle.
 	matrix loadIdentity.
 	originMatrix loadIdentity.
-	athensCanvas pathTransform loadIdentity.
+	athensCanvas pathTransform loadIdentity scaleBy: scale.
 	athensCanvas clipBy: transformeDirtyRectangle during: [
 		(aRSCanvas fixedShapes entriesAtRectangle: dirtyRectangle) do: [ :each | each accept: self ] ].
 	aRSCanvas resetDirtyRectangle.
 
 	aRSCanvas shouldShowDirtyRectangle ifFalse: [ ^ self ].
 
-	athensCanvas pathTransform loadIdentity.
+	athensCanvas pathTransform loadIdentity scaleBy: scale.
 	matrix loadIdentity.
 	originMatrix loadIdentity.
 	aRSCanvas camera accept: self.
@@ -718,7 +746,7 @@ RSAthensRenderer >> visitLabel: label [
 		| lbtranslation |
 		lbtranslation := label textExtents translationPoint asFloatPoint.
 		matrix translateBy: lbtranslation.
-		athensCanvas pathTransform loadAffineTransform: matrix.
+		self pathTransformLoadMatrix.
 		label hasBorder
 			ifTrue: [ self drawPathLabel: label ]
 			ifFalse: [ self drawSimpleLabel: label ].
@@ -752,7 +780,7 @@ RSAthensRenderer >> visitLabelDecoratorsIfNecessary: label [
 RSAthensRenderer >> visitLine: line [
 	| path paint |
 	(line intersects: dirtyRectangle) ifFalse: [ ^ self ].
-	athensCanvas pathTransform loadAffineTransform: matrix.
+	self pathTransformLoadMatrix.
 	path := self getOrCreatePathOf: line.
 	paint := line paintOn: self.