Bloc host: Imitate Morphic host regarding initial RSExtentChanged

src/Roassal-Bloc/RSBlocEventListener.class.st

@@ -13,10 +13,10 @@ Class {
 }
 
 { #category : 'instance creation' }
-RSBlocEventListener class >> newForCanvas: aRSHost [ 
+RSBlocEventListener class >> newWithCanvas: aRSHost [ 
 
 	^ self basicNew
-		initializeForCanvas: aRSHost;
+		initializeWithCanvas: aRSHost;
 		yourself
 ]
 
@@ -27,8 +27,8 @@ RSBlocEventListener >> announceEventOfClass: aRSEventClass actionClass: anAction
 	targetShape := aBlEvent target roassalShape.
 
 	((targetShape handleAnnouncementClass: anActionClass) or: [
-		(targetShape handleAnnouncementClass: aRSEventClass)]) ifFalse:[ 
-		targetShape := roassalCanvas ].
+		(targetShape handleAnnouncementClass: aRSEventClass)])
+			ifFalse:[ targetShape := roassalCanvas ].
 
 	aBlEvent consumed: true.
 	aRSEvent := aRSEventClass newFromBlEvent: aBlEvent canvas: roassalCanvas.
@@ -106,7 +106,7 @@ RSBlocEventListener >> dragStartEvent: aBlEvent [
 ]
 
 { #category : 'initialization' }
-RSBlocEventListener >> initializeForCanvas: aRSCanvas [
+RSBlocEventListener >> initializeWithCanvas: aRSCanvas [
 
 	self initialize.
 	roassalCanvas := aRSCanvas

src/Roassal-Bloc/RSBlocExamples.class.st

@@ -210,7 +210,8 @@ RSBlocExamples >> example08ZoomToFitWhenExtentChangedEvent [
 	| canvas |
 	canvas := self newCanvas.
 
-	canvas add: (RSBox new
+	canvas add:
+		(RSEllipse new
 			 color: Color blue;
 			 position: 100 asPoint;
 			 size: 5000 @ 3000;

src/Roassal-Bloc/RSBlocHost.class.st

@@ -79,8 +79,20 @@ RSBlocHost >> openWithTitle: aTitleAsString [
 	"Open a canvas with a given title"
 
 	self createSpace.
-	space	title: aTitleAsString.
-	space show.
+
+	"Force announcement of an initial BlSpaceShownEvent.
+	Many Roassal examples show this assumption.
+	See: https://github.com/pharo-graphics/Roassal/issues/139"
+	space addEventHandlerOn: BlSpaceShownEvent doOnce: [
+		space extent = canvas extent ifTrue: [
+			canvas notifyExtentChanged: canvas extent ] ].
+
+	"We imitate Morphic host, which ignores the canvas extent"
+	space extent: self defaultWindowExtent.
+
+	space
+		title: aTitleAsString;
+		show.
 
 	^ space
 ]

src/Roassal-Bloc/RSBlocHostTest.class.st

@@ -75,3 +75,60 @@ RSBlocHostTest >> testAsForm [
 	self assert: (form colorAt: 1@1) equals: Color blue.
 	self assert: (form colorAt: form extent // 2) equals: Color red
 ]
+
+{ #category : 'tests' }
+RSBlocHostTest >> testOpenWithDefaultExtent [
+	"Many examples trigger an initial action via RSExtentChangedEvent."
+
+	| events canvas space semaphore |
+	events := OrderedCollection new.
+
+	canvas := RSCanvas new.
+	canvas useBlocHost.
+	semaphore := Semaphore new.
+	canvas
+		when: RSExtentChangedEvent
+		do: [ :evt |
+			events add: evt.
+			semaphore signal ]
+		for: self.
+	space := canvas open.
+	semaphore
+		waitTimeoutMilliseconds: 1000
+		onCompletion: [ space close ]
+		onTimeout: [ self fail ].
+
+	self assert: space extent equals: 500@500. "Default extent"
+	self assert: events size equals: 1.
+	self assert: events first newExtent equals: 500@500
+]
+
+{ #category : 'tests' }
+RSBlocHostTest >> testOpenWithExplicitExtent [
+	"Imitate Morphic host, which overrides initial canvas extent with 500@500."
+
+	| events canvas space semaphore |
+	events := OrderedCollection new.
+
+	canvas := RSCanvas new.
+	canvas useBlocHost.
+	canvas extent: 200@100.
+
+	semaphore := Semaphore new.
+	canvas
+		when: RSExtentChangedEvent
+		do: [ :evt |
+			events add: evt.
+			semaphore signal ]
+		for: self.
+	space := canvas open.
+	semaphore
+		waitTimeoutMilliseconds: 1000
+		onCompletion: [ space close ]
+		onTimeout: [ self fail ].
+
+	self assert: space extent equals: 500@500.
+	self assert: events size equals: 1.
+	self assert: events first oldExtent equals: 200@100.
+	self assert: events first newExtent equals: 500@500
+]

src/Roassal-Bloc/RSCanvasElement.class.st

@@ -3,8 +3,8 @@ Class {
 	#superclass : 'BlElement',
 	#instVars : [
 		'roassalCanvas',
-		'elementListener',
-		'cameraElement'
+		'cameraElement',
+		'blocToRoassalListener'
 	],
 	#category : 'Roassal-Bloc-Elements',
 	#package : 'Roassal-Bloc',
@@ -24,7 +24,7 @@ RSCanvasElement >> addFixedShapeElementFor: aRSShape [
 
 	self addChild:
 		(aRSShape asBlElement
-			addBlocToRoassalEventHandler: elementListener;
+			addBlocToRoassalListener: blocToRoassalListener;
 			yourself)
 ]
 
@@ -41,7 +41,7 @@ RSCanvasElement >> addRegularShapeElementFor: aRSShape [
 
 	cameraElement addChild:
 		(aRSShape asBlElement
-			addBlocToRoassalEventHandler: elementListener;
+			addBlocToRoassalListener: blocToRoassalListener;
 			yourself)
 ]
 
@@ -53,6 +53,16 @@ RSCanvasElement >> addRegularShapeElements [
 		self addRegularShapeElementFor: each ]
 ]
 
+{ #category : 'accessing' }
+RSCanvasElement >> childAtShape: aRSShape ifFound: foundBlock ifNone: noneBlock [
+
+	self childrenDo: [ :each |
+		each roassalShape == aRSShape
+			ifTrue: [ ^ foundBlock value: each ] ].
+
+	noneBlock value
+]
+
 { #category : 'accessing' }
 RSCanvasElement >> elementAtShape: aRSShape ifFound: foundBlock ifNone: noneBlock [
 
@@ -72,11 +82,12 @@ RSCanvasElement >> handleRSShapeAddedEvent: evt [
 { #category : 'private' }
 RSCanvasElement >> handleRSShapeRemovedEvent: evt [
 
-	self flag: #todo. "Remove handler"
-
 	self
-		elementAtShape: evt shape
-		ifFound: [ :element | element removeFromParent ]
+		childAtShape: evt shape
+		ifFound: [ :element |
+			element
+				removeEventHandler: blocToRoassalListener;
+				removeFromParent ]
 		ifNone: [ #couldntRemoveShapeElement traceCr ]
 ]
 
@@ -87,20 +98,21 @@ RSCanvasElement >> initializeWithCanvas: aRSCanvas [
 
 	roassalCanvas := aRSCanvas.
 
-	elementListener := RSBlocEventListener newForCanvas: aRSCanvas.
+	blocToRoassalListener := RSBlocEventListener newWithCanvas: aRSCanvas.
 	cameraElement := RSCameraElement newWithCanvas: aRSCanvas.
 
 	self addFixedShapeElements.
 	self addRegularShapeElements.
 
 	self
-		extent: aRSCanvas extent;
+		constraintsDo: [ :c |
+			c horizontal matchParent.
+			c vertical matchParent ];
 		enqueueTask: (RSBlocAnimationPlayingTask newWithCanvas: aRSCanvas);
 		addChild: cameraElement.
 
-	self
-		subscribeBlocToRoassal;
-		subscribeRoassalToBloc
+	self subscribeToBlEvents.
+	self subscribeToRSShape: roassalCanvas
 ]
 
 { #category : 'accessing' }
@@ -122,7 +134,7 @@ RSCanvasElement >> signalUpdate [
 	As an optimization, multiple signalUpdate requests may be converted as a single redraw."
 
 
-	self updateFromRoassalCanvas.
+	self updateFromRSCanvas.
 
 	"Skip if the request is already done."
 "	signalUpdateRequested ifTrue: [ ^ self ].
@@ -138,32 +150,32 @@ RSCanvasElement >> signalUpdate [
 ]
 
 { #category : 'initialization' }
-RSCanvasElement >> subscribeBlocToRoassal [
+RSCanvasElement >> subscribeToBlEvents [
 
 	self
-		addEventHandler: elementListener;
+		addEventHandler: blocToRoassalListener;
 		addEventHandlerOn: BlElementExtentChangedEvent
 			do: [ :evt | self updateRSCanvasExtent ];
 		addEventHandlerOn: BlElementAddedToSceneGraphEvent 
 			do: [ :evt | self updateRSCanvasExtent ]
 ]
 
 { #category : 'initialization' }
-RSCanvasElement >> subscribeRoassalToBloc [
+RSCanvasElement >> subscribeToRSShape: aShape [
 
-	roassalCanvas
+	aShape
 		when: RSShapeAddedEvent
-		do: [ :evt | self handleRSShapeAddedEvent: evt ]
-		for: self.
+		send: #handleRSShapeAddedEvent:
+		to: self.
 
-	roassalCanvas
+	aShape
 		when: RSShapeRemovedEvent
-		do: [ :evt | self handleRSShapeRemovedEvent: evt ]
-		for: self
+		send: #handleRSShapeRemovedEvent:
+		to: self
 ]
 
 { #category : 'refreshing' }
-RSCanvasElement >> updateFromRoassalCanvas [
+RSCanvasElement >> updateFromRSCanvas [
 
 	self background: roassalCanvas color.
 
@@ -172,9 +184,8 @@ RSCanvasElement >> updateFromRoassalCanvas [
 
 { #category : 'refreshing' }
 RSCanvasElement >> updateRSCanvasExtent [
-	"Note: RSCanvas extent change does not trigger signalUpdate"
 
-	self extent isZero ifFalse: [
-			roassalCanvas extent: self extent.
-			self updateFromRoassalCanvas ]
+	self extent isZero ifTrue: [ ^ self ].
+	roassalCanvas extent: self extent.
+	self updateFromRSCanvas
 ]

src/Roassal-Bloc/RSCompositeElement.class.st

@@ -10,12 +10,12 @@ Class {
 }
 
 { #category : 'adding' }
-RSCompositeElement >> addBlocToRoassalEventHandler: aHandler [
+RSCompositeElement >> addBlocToRoassalListener: aHandler [
 
-	super addBlocToRoassalEventHandler: aHandler.
+	super addBlocToRoassalListener: aHandler.
 
-	self allChildrenDepthFirstDo: [ :each |
-		each addEventHandler: aHandler ]
+	self childrenDo: [ :each |
+		each addBlocToRoassalListener: aHandler ]
 ]
 
 { #category : 'refreshing' }

src/Roassal-Bloc/RSLabelElement.class.st

@@ -18,7 +18,7 @@ RSLabelElement class >> newWith: aRSLabel [
 ]
 
 { #category : 'adding' }
-RSLabelElement >> addBlocToRoassalEventHandler: aHandler [
+RSLabelElement >> addBlocToRoassalListener: aHandler [
 
 	self addEventHandler: aHandler
 ]

src/Roassal-Bloc/RSShapeElement.class.st

@@ -21,7 +21,7 @@ RSShapeElement class >> newWith: aRSShape [
 ]
 
 { #category : 'adding' }
-RSShapeElement >> addBlocToRoassalEventHandler: aHandler [
+RSShapeElement >> addBlocToRoassalListener: aHandler [
 
 	self addEventHandler: aHandler
 ]

src/Roassal-Global-Tests/RSRoassalTest.class.st

@@ -54,6 +54,50 @@ RSRoassalTest >> testOpenOnce [
 	v delete
 ]
 
+{ #category : 'tests' }
+RSRoassalTest >> testOpenWithDefaultExtent [
+	"Many examples trigger an initial action via RSExtentChangedEvent."
+
+	| events canvas window |
+	events := OrderedCollection new.
+
+	canvas := RSCanvas new.
+	canvas
+		when: RSExtentChangedEvent
+		send: #add:
+		to: events.
+	window := canvas open.
+	World doOneCycleNow.
+	window delete.
+
+	self assert: window extent equals: 500@500. "Default extent"
+	self assert: events size equals: 1.
+	self assert: events first oldExtent equals: 500@500
+]
+
+{ #category : 'tests' }
+RSRoassalTest >> testOpenWithExplicitExtent [
+	"Many examples trigger an initial action via RSExtentChangedEvent."
+
+	| events canvas window |
+	events := OrderedCollection new.
+
+	canvas := RSCanvas new.
+	canvas extent: 200@100.
+	canvas
+		when: RSExtentChangedEvent
+		send: #add:
+		to: events.
+	window := canvas open.
+	World doOneCycleNow.
+	window delete.
+
+	"Default window extent overrides canvas extent"
+	self assert: window extent equals: 500@500.
+	self assert: events size equals: 1.
+	self assert: events first oldExtent equals: 200@100
+]
+
 { #category : 'tests' }
 RSRoassalTest >> testRemoveInteractionIfPresent [
 	| box |

src/Roassal/RSHost.class.st

@@ -40,6 +40,12 @@ RSHost >> canvas: aRSCanvas [
 	canvas := aRSCanvas
 ]
 
+{ #category : 'accessing' }
+RSHost >> defaultWindowExtent [
+
+	^ 500 @ 500
+]
+
 { #category : 'accessing' }
 RSHost >> defaultWindowTitle [
 

src/Roassal/RSMorphicHost.class.st

@@ -144,7 +144,7 @@ RSMorphicHost >> openWithTitle: aTitleAsString [
 	| window |
 	self createMorph.
 	window := morph openInWindowLabeled: aTitleAsString.
-	window extent: 500 @ 500.
+	window extent: self defaultWindowExtent.
 	morph privateOwner: window.
 	^ window
 ]