reworked coloring

repository/OpenPonk-Core/OPDiagramElement.class.st

@@ -74,6 +74,8 @@ OPDiagramElement >> addEventForwardingFrom: anOriginalRoassalShape to: aTargetRo
 	| forward |
 	forward := [ :event | aTargetRoassalShape announce: event ].
 	anOriginalRoassalShape
+		when: RSMouseEnter do: forward for: self;
+		when: RSMouseLeave do: forward for: self;
 		when: RSMouseClick do: forward for: self;
 		when: RSMouseDragStart do: forward for: self;
 		when: RSMouseDragEnd do: forward for: self;
@@ -390,8 +392,9 @@ OPDiagramElement >> renderIn: aCanvas [
 	self createOwnedElementsWithoutController.
 	self ownedElements do: [ :each | each renderIn: aCanvas ].
 	self updateRenderFromModel.
+	self updateRenderFromStyles.
 	self updateRenderFromSelf.
-	self owningElement ifNotNil: [ :element | 
+	self owningElement ifNotNil: [ :element |
 		element ownedElement: self renderedIn: self canvas ].
 	^ roassalShape
 ]
@@ -566,7 +569,16 @@ OPDiagramElement >> stylePropertyNamed: aName put: aValue [
 { #category : #initialization }
 OPDiagramElement >> supportsColorChange [
 
-	^ (self respondsTo: #color) and: [ self respondsTo: #color: ]
+	^ (self supportsColorChangeOfType: #fillColor) or: [
+		  (self supportsColorChangeOfType: #strokeColor) or: [
+			  self supportsColorChangeOfType: #fontColor ] ]
+]
+
+{ #category : #initialization }
+OPDiagramElement >> supportsColorChangeOfType: aSymbol [
+
+	^ (self respondsTo: aSymbol asSymbol) and: [
+		  self respondsTo: aSymbol asMutator ]
 ]
 
 { #category : #accessing }
@@ -598,8 +610,7 @@ OPDiagramElement >> updateFromRender [
 { #category : #rendering }
 OPDiagramElement >> updateRenderFromModel [
 
-	self ownedElements select: #isRendered thenDo: #updateRenderFromModel.
-	self updateRenderFromStyles
+	self ownedElements select: #isRendered thenDo: #updateRenderFromModel
 ]
 
 { #category : #rendering }

repository/OpenPonk-Core/OPInvisibleOnMouseShape.class.st

@@ -16,33 +16,20 @@ OPInvisibleOnMouseShape class >> renderToPosition: aPoint onCanvas: aCanvas [
 { #category : #rendering }
 OPInvisibleOnMouseShape >> mouseMovedBy: event [
 
-	| position block |
 	roassalShape
 		translateTo: event position;
-		signalUpdate.
-
-	position := event position.
-
-	block := [ :list :pos | 
-	         list reverseDo: [ :s | 
-		         (s shapeWithActionForPosition: pos) ifNotNil: [ :shape | 
-			         ^ shape announcer announce: event ] ] ].
-	block
-		value: event canvas fixedShapes
-		value: (event camera fromSpaceToPixel: position).
-	block
-		value:
-		(event canvas shapes copyWithoutAll: roassalShape connectedLines)
-		value: position
+		signalUpdate
 ]
 
 { #category : #rendering }
 OPInvisibleOnMouseShape >> removeRender [
 
+	| canvas |
 	self isRendered ifFalse: [ ^ self ].
-	roassalShape canvas announcer unsubscribe: self.
-	roassalShape canvas removeKey: #shapesIgnoringMouseMoveBlock.
-	super removeRender
+	canvas := roassalShape canvas.
+	canvas announcer unsubscribe: self.
+	super removeRender.
+	canvas signalUpdate
 ]
 
 { #category : #rendering }
@@ -58,10 +45,9 @@ OPInvisibleOnMouseShape >> renderBasicShape [
 OPInvisibleOnMouseShape >> renderShapeDetails [
 
 	super renderShapeDetails.
+
+	roassalShape translateTo: self bounds position.
 
-	roassalShape canvas
-		propertyAt: #shapesIgnoringMouseMoveBlock
-		put: [ roassalShape connectedLines , { roassalShape } ].
 	roassalShape canvas
 		when: RSMouseMove
 		do: [ :event | self mouseMovedBy: event ]

repository/OpenPonk-Core/OPTDIBorderColoredAsStroke.trait.st

@@ -6,8 +6,6 @@ Trait {
 { #category : #accessing }
 OPTDIBorderColoredAsStroke >> strokeColor [
 
-	(self isRendered and: [ self roassalShape isSelected ]) ifTrue: [
-		^ self roassalShape borderColor ].
 	^ self stylePropertyNamed: #strokeColor ifAbsent: [ Color black ]
 ]
 
@@ -21,6 +19,16 @@ OPTDIBorderColoredAsStroke >> strokeColor: aColor [
 OPTDIBorderColoredAsStroke >> updateRenderFromStyles [
 
 	self isRendered ifFalse: [ ^ self ].
+	self roassalShape
+		propertyAt: OPRSSelectable
+		ifPresent: [ :selectable |
+			| key |
+			key := selectable copyKey , 'color'.
+			self roassalShape properties
+				at: key
+				ifPresent: [ :previousBorder |
+					previousBorder color: self strokeColor.
+					^ self ] ].
 	self roassalShape borderColor: self strokeColor.
 	super updateRenderFromStyles.
 	self roassalShape signalUpdate

repository/OpenPonk-Core/OPTDIColored.trait.st

@@ -0,0 +1,29 @@
+Trait {
+	#name : #OPTDIColored,
+	#category : #'OpenPonk-Core-DiagramInterchange'
+}
+
+{ #category : #accessing }
+OPTDIColored >> color [
+
+	^ self shouldBeImplemented
+]
+
+{ #category : #update }
+OPTDIColored >> updateRenderFromStyles [
+
+	self isRendered ifFalse: [ ^ self ].
+	self roassalShape
+		propertyAt: OPRSSelectable
+		ifPresent: [ :selectable |
+			| key |
+			key := selectable copyKey , 'color'.
+			self roassalShape properties at: key ifPresent: [
+				self roassalShape properties
+					at: key
+					put: (OrderedCollection with: self color).
+				^ self ] ].
+	self roassalShape color: self color.
+	super updateRenderFromStyles.
+	self roassalShape signalUpdate
+]

repository/OpenPonk-Core/OPTDIColoredAsFill.trait.st

@@ -1,5 +1,7 @@
 Trait {
 	#name : #OPTDIColoredAsFill,
+	#traits : 'OPTDIColored',
+	#classTraits : 'OPTDIColored classTrait',
 	#category : #'OpenPonk-Core-DiagramInterchange'
 }
 
@@ -9,12 +11,6 @@ OPTDIColoredAsFill >> color [
 	^ self fillColor
 ]
 
-{ #category : #accessing }
-OPTDIColoredAsFill >> color: aColor [
-
-	^ self fillColor: aColor
-]
-
 { #category : #accessing }
 OPTDIColoredAsFill >> fillColor [
 
@@ -26,12 +22,3 @@ OPTDIColoredAsFill >> fillColor: aColor [
 
 	^ self stylePropertyNamed: #fillColor put: aColor
 ]
-
-{ #category : #accessing }
-OPTDIColoredAsFill >> updateRenderFromStyles [
-
-	self isRendered ifFalse: [ ^ self ].
-	self roassalShape color: self fillColor.
-	super updateRenderFromStyles.
-	self roassalShape signalUpdate
-]

repository/OpenPonk-Core/OPTDIColoredAsFont.trait.st

@@ -0,0 +1,24 @@
+Trait {
+	#name : #OPTDIColoredAsFont,
+	#traits : 'OPTDIColored',
+	#classTraits : 'OPTDIColored classTrait',
+	#category : #'OpenPonk-Core-DiagramInterchange'
+}
+
+{ #category : #accessing }
+OPTDIColoredAsFont >> color [
+
+	^ self fontColor
+]
+
+{ #category : #accessing }
+OPTDIColoredAsFont >> fontColor [
+
+	^ self stylePropertyNamed: #fontColor ifAbsent: [ Color black ]
+]
+
+{ #category : #accessing }
+OPTDIColoredAsFont >> fontColor: aColor [
+
+	^ self stylePropertyNamed: #fontColor put: aColor
+]

repository/OpenPonk-Core/OPTDIColoredAsStroke.trait.st

@@ -1,25 +1,19 @@
 Trait {
 	#name : #OPTDIColoredAsStroke,
+	#traits : 'OPTDIColored',
+	#classTraits : 'OPTDIColored classTrait',
 	#category : #'OpenPonk-Core-DiagramInterchange'
 }
 
-{ #category : #accessing }
+{ #category : #update }
 OPTDIColoredAsStroke >> color [
 
 	^ self strokeColor
 ]
 
-{ #category : #accessing }
-OPTDIColoredAsStroke >> color: aColor [
-
-	^ self strokeColor: aColor
-]
-
 { #category : #accessing }
 OPTDIColoredAsStroke >> strokeColor [
 
-	(self isRendered and: [ self roassalShape isSelected ]) ifTrue: [
-		^ self roassalShape color ].
 	^ self stylePropertyNamed: #strokeColor ifAbsent: [ Color black ]
 ]
 
@@ -28,12 +22,3 @@ OPTDIColoredAsStroke >> strokeColor: aColor [
 
 	^ self stylePropertyNamed: #strokeColor put: aColor
 ]
-
-{ #category : #update }
-OPTDIColoredAsStroke >> updateRenderFromStyles [
-
-	self isRendered ifFalse: [ ^ self ].
-	self roassalShape color: self strokeColor.
-	super updateRenderFromStyles.
-	self roassalShape signalUpdate
-]

repository/OpenPonk-Roassal3/OPRSSelectable.class.st

@@ -60,6 +60,33 @@ OPRSSelectable >> announceUnHightlight: shape source: shapeOrCanvas [
 			source: shapeOrCanvas ]
 ]
 
+{ #category : #hooks }
+OPRSSelectable >> clicked: aShape by: anEvent [
+
+	aShape canvas
+		propertyAt: OPRSSelectableCanvas
+		ifPresent: [ :selectableCanvasInteraction |
+			| currentlySelectedShapes |
+			currentlySelectedShapes := selectableCanvasInteraction
+				                           selectedShapes.
+			selectableCanvasInteraction
+				selectShapes: (anEvent metaKeyPressed
+						 ifTrue: [
+							 (currentlySelectedShapes includes: aShape)
+								 ifTrue: [
+								 RSGroup withAll:
+									 (currentlySelectedShapes copyWithout: aShape) ]
+								 ifFalse: [
+									 (RSGroup withAll: currentlySelectedShapes)
+										 add: aShape;
+										 yourself ] ]
+						 ifFalse: [ RSGroup with: aShape ])
+				byEvent: anEvent ]
+		ifAbsent: [
+			self error:
+				'OPRSSelectable requires OPRSSelectableCanvas on canvas' ]
+]
+
 { #category : #'as yet unclassified' }
 OPRSSelectable >> highlightAdornments: aBlock [
 	"Show adornments (little icons with actions). The block receives an OPRSAdornmentBuilder"
@@ -80,14 +107,8 @@ OPRSSelectable >> highlightBorderColor: aColor [
 	"Set the border color"
 
 	self
-		when: RSHighlightEvent do: [ :evt |
-			self
-				record: evt shape
-				selector: #border
-				value:
-					((evt shape border ifNil: [ RSBorder new ] ifNotNil: #copy)
-						 color: aColor;
-						 yourself) ]
+		when: RSHighlightEvent
+		do: [ :evt | self setBorderColorOf: evt shape to: aColor ]
 		for: self;
 		when: RSUnHighlightEvent
 		do: [ :evt | self restore: evt shape selector: #border ]
@@ -100,29 +121,7 @@ OPRSSelectable >> onShape: aShape [
 	aShape propertyAt: self class put: self.
 	aShape
 		when: RSMouseLeftClick
-		do: [ :evt |
-			aShape canvas
-				propertyAt: OPRSSelectableCanvas
-				ifPresent: [ :selectableCanvasInteraction |
-					| currentlySelectedShapes |
-					currentlySelectedShapes := selectableCanvasInteraction
-						                           selectedShapes.
-					selectableCanvasInteraction
-						selectShapes: (evt metaKeyPressed
-								 ifTrue: [
-									 (currentlySelectedShapes includes: aShape)
-										 ifTrue: [
-										 RSGroup withAll:
-											 (currentlySelectedShapes copyWithout: aShape) ]
-										 ifFalse: [
-											 (RSGroup withAll: currentlySelectedShapes)
-												 add: aShape;
-												 yourself ] ]
-								 ifFalse: [ RSGroup with: aShape ])
-						byEvent: evt ]
-				ifAbsent: [
-					self error:
-						'OPRSSelectable requires OPRSSelectableCanvas on canvas' ] ]
+		do: [ :evt | self clicked: aShape by: evt ]
 		for: self
 ]
 
@@ -131,3 +130,17 @@ OPRSSelectable >> propertyKey [
 
 	^ propertyKey ifNil: [ propertyKey := #selectedShapes ]
 ]
+
+{ #category : #'as yet unclassified' }
+OPRSSelectable >> setBorderColorOf: aShape to: aColor [
+
+	self
+		record: aShape
+		selector: #border
+		value:
+			((aShape border
+				  ifNil: [ RSBorder new ]
+				  ifNotNil: [ :val | val copy ])
+				 color: aColor;
+				 yourself)
+]

repository/OpenPonk-Roassal3/RSCanvas.extension.st

@@ -16,17 +16,14 @@ RSCanvas >> isSelectable [
 ]
 
 { #category : #'*OpenPonk-Roassal3' }
-RSCanvas >> shapeWithActionForPositionInPixels: position [
+RSCanvas >> shapesWithActionForPosition: aPositionInSpace [
 
-	| block |
-	block := [ :list :pos | 
-	         (self
-		          propertyAt: #shapesIgnoringMouseMoveBlock
-		          ifPresent: [ :ignoredShapes | 
-		          list copyWithoutAll: ignoredShapes value ]
-		          ifAbsent: [ list ]) reverseDo: [ :s | 
-		         (s shapeWithActionForPosition: pos) ifNotNil: [ :shape | 
-			         ^ shape ] ] ].
-	block value: fixedShapes value: position.
-	block value: shapes value: (self camera fromPixelToSpace: position)
+	| result |
+	result := self shapeCollection shapesAtPoint: aPositionInSpace.
+
+	result := result select: [ :s | s hasEventCallback ].
+	self canvas
+		propertyAt: #ignoredElementsForEvents
+		ifPresent: [ :ignoredOnes | ^ result difference: ignoredOnes ].
+	^ result
 ]