From e57eb33f4b03ee5098f80e18068ad943403323d8 Mon Sep 17 00:00:00 2001 From: Pierre Laborde Date: Tue, 2 Dec 2025 14:38:38 +0100 Subject: [PATCH] Write an interaction example to create a bounbing box creator (with projected shapes) Refactoring of InteractionsStrategy and unit-tests Fix GeoBoundingBoxProjectedProcessData computing Better render for GeoShapes (using duplicated effect) DShapeLayer: can remove all shapes Fix footnotes elements events managing. Add tests for TGeoProjectorProcessData traits Add utils to project a BoundingBox --- ...oViewBoundingBoxCreatorController.class.st | 168 ++++++++++++++++++ src/GeoView-Examples/GeoViewExamples.class.st | 82 ++++++++- ...ctGeoViewInteractionsStrategyTest.class.st | 107 +++++++++++ ...eoProjectorProcessDataUserForTest.class.st | 7 + .../GeoViewDShapesLayerTest.class.st | 15 ++ src/GeoView-Tests/GeoViewElementTest.class.st | 6 + .../GeoViewInteractionsStrategyTest.class.st | 21 +++ .../TGeoProjectorProcessDataTest.class.st | 113 ++++++++++++ ...stractGeoViewInteractionsStrategy.class.st | 132 ++++++++++++++ ...eoBoundingBoxProjectedProcessData.class.st | 13 +- src/GeoView/GeoShapeProcessData.class.st | 7 +- src/GeoView/GeoViewDShapesLayer.class.st | 13 ++ src/GeoView/GeoViewElement.class.st | 22 ++- .../GeoViewInteractionsStrategy.class.st | 145 ++++----------- src/GeoView/TGeoProjectorProcessData.trait.st | 28 ++- 15 files changed, 753 insertions(+), 126 deletions(-) create mode 100644 src/GeoView-Examples/GeoViewBoundingBoxCreatorController.class.st create mode 100644 src/GeoView-Tests/AbstractGeoViewInteractionsStrategyTest.class.st create mode 100644 src/GeoView-Tests/GeoProjectorProcessDataUserForTest.class.st create mode 100644 src/GeoView-Tests/GeoViewInteractionsStrategyTest.class.st create mode 100644 src/GeoView-Tests/TGeoProjectorProcessDataTest.class.st create mode 100644 src/GeoView/AbstractGeoViewInteractionsStrategy.class.st diff --git a/src/GeoView-Examples/GeoViewBoundingBoxCreatorController.class.st b/src/GeoView-Examples/GeoViewBoundingBoxCreatorController.class.st new file mode 100644 index 0000000..3e6afc6 --- /dev/null +++ b/src/GeoView-Examples/GeoViewBoundingBoxCreatorController.class.st @@ -0,0 +1,168 @@ +Class { + #name : #GeoViewBoundingBoxCreatorController, + #superclass : #BlEventListener, + #instVars : [ + 'isOnCreation', + 'boundingBox', + 'helperShape', + 'geoView', + 'key' + ], + #category : #'GeoView-Examples-Utils' +} + +{ #category : #'dnd handlers' } +GeoViewBoundingBoxCreatorController >> dragEvent: anEvent [ + + | coordinates width height | + self isOnCreation ifFalse: [ ^ self ]. + + anEvent consume. + + coordinates := geoView absoluteCoordinatesFromGlobalPoint: + anEvent position. + coordinates ifNil: [ ^ self ]. + + boundingBox ifNil: [ + boundingBox := GeoBoundingBox new key: self getNewKey. + boundingBox strokeStyle: (Color random asSmockStrokeStyle width: 2). + boundingBox topLeftAbsoluteCoordinates: coordinates. + geoView addObject: boundingBox ]. + + boundingBox bottomRightAbsoluteCoordinates: coordinates. + geoView updateObject: boundingBox. + + "update helper" + (boundingBox notNil and:[ boundingBox isValid ]) ifTrue: [ | formulas | + formulas := GeodesicVincentyFormulas new. + width := formulas distanceInMetersFrom: boundingBox topLeftAbsoluteCoordinates to: boundingBox topRightAbsoluteCoordinates. + height := formulas distanceInMetersFrom: boundingBox topLeftAbsoluteCoordinates to: boundingBox bottomLeftAbsoluteCoordinates. + helperShape text: (width rounded) printString, 'M x ', (height rounded) printString, 'M'. + helperShape coordinates: ((geoView localPointFromAbsoluteCoordinates: boundingBox topLeftAbsoluteCoordinates)). + ]. + self helpersLayer updateDShape: helperShape. +] + +{ #category : #'dnd handlers' } +GeoViewBoundingBoxCreatorController >> dragStartEvent: anEvent [ + + self isOnCreation ifFalse:[ ^ self ]. + + anEvent consume. +] + +{ #category : #'dnd handlers' } +GeoViewBoundingBoxCreatorController >> dropEvent: anEvent [ + + self isOnCreation ifFalse:[ ^ self ]. + + anEvent consume. + + (boundingBox topLeftAbsoluteCoordinates isValid and: [ + boundingBox bottomRightAbsoluteCoordinates isValid ]) ifFalse: [ + geoView removeObject: boundingBox. + key := key - 1 ]. + + self stopCreation +] + +{ #category : #private } +GeoViewBoundingBoxCreatorController >> getNewKey [ + + key ifNil:[ key := 0 ]. + key := key + 1. + ^ key +] + +{ #category : #private } +GeoViewBoundingBoxCreatorController >> helpersLayer [ + + ^ geoView getLayer: #helpers +] + +{ #category : #accessing } +GeoViewBoundingBoxCreatorController >> isOnCreation [ + + ^ isOnCreation ifNil: [ isOnCreation := false ] +] + +{ #category : #accessing } +GeoViewBoundingBoxCreatorController >> isOnCreation: anObject [ + + isOnCreation := anObject +] + +{ #category : #'keyboard handlers' } +GeoViewBoundingBoxCreatorController >> keyUpEvent: anEvent [ + + self isOnCreation ifFalse: [ ^ self ]. + anEvent key = KeyboardKey escape ifFalse: [ ^ self ]. + + anEvent consume. + self stopCreation +] + +{ #category : #'mouse handlers' } +GeoViewBoundingBoxCreatorController >> mouseMoveEvent: anEvent [ + + | coordinates | + self isOnCreation ifFalse:[ ^ self ]. + + coordinates := geoView absoluteCoordinatesFromGlobalPoint: anEvent position. + coordinates ifNil:[ ^ self ]. + + helperShape coordinates: ((geoView localPointFromAbsoluteCoordinates: coordinates) + (0@ -20)). + helperShape text: 'Create from: ', ((coordinates latitudeInDegrees ifNil:['--']) asString, '° '), ((coordinates longitudeInDegrees ifNil:['--']) asString, '°'). + + self helpersLayer updateDShape: helperShape +] + +{ #category : #'api - hooks' } +GeoViewBoundingBoxCreatorController >> onInstalledIn: aGeoView [ + + super onInstalledIn: aGeoView. + + geoView := aGeoView +] + +{ #category : #'api - hooks' } +GeoViewBoundingBoxCreatorController >> onUninstalledIn: aGeoView [ + + self stopCreation. + geoView := nil. + + super onUninstalledIn: aGeoView. +] + +{ #category : #API } +GeoViewBoundingBoxCreatorController >> startCreation [ + "the object to create" + + self isOnCreation: true. + geoView interactionsStrategy allowMapMoving: false. + + geoView focused: true. + + "the object to help user (show a text)" + helperShape ifNil: [ helperShape := SmockDText new key: -100 ]. + helperShape + text: nil; + setDrawModeDevice; + smockFont: (SmockFont defaultFont fontSize: 10); + fillColor: Color white; + effect: (SmockBackgroundEffect new + fillColor: (Color black alpha: 0.66); + padding: (SmockInsets all: 3)). + + self helpersLayer addDShape: helperShape +] + +{ #category : #API } +GeoViewBoundingBoxCreatorController >> stopCreation [ + + self isOnCreation: false. + self helpersLayer removeAllDShapes. + boundingBox := nil. + + geoView interactionsStrategy allowMapMoving: true. +] diff --git a/src/GeoView-Examples/GeoViewExamples.class.st b/src/GeoView-Examples/GeoViewExamples.class.st index abae5e2..57f13bb 100644 --- a/src/GeoView-Examples/GeoViewExamples.class.st +++ b/src/GeoView-Examples/GeoViewExamples.class.st @@ -12,6 +12,51 @@ GeoViewExamples class >> createAndStartTask: aBlockClosure [ yourself ] +{ #category : #'private - bloc' } +GeoViewExamples class >> createBlButton: aText [ + "Code created with Pyramid editor" + "self createBlButton: 'My button'" + + ^ BlElement new + background: (BlPaintBackground new + paint: (BlColorPaint new + color: (Color r: 1.0 g: 1.0 b: 1.0 alpha: 1.0); + yourself); + opacity: 1.0; + yourself); + border: (BlBorderBuilder new + paint: (BlColorPaint new + color: (Color r: 0.10166177908113393 g: 0.7135874877810362 b: 0.9921798631476051 alpha: 1.0); + yourself); + width: 2; + lineCap: BlStrokeLineCap round; + lineJoin: BlStrokeLineJoin round; + build); + geometry: (BlRoundedRectangleGeometry cornerRadius: 4); + id: #button; + addChildren: {(BlTextElement new + text: (BlRopedText new + rope: (BlAttributeRope attributes: {(BlTextForegroundAttribute new + paint: (Color r: 0.2668621700879765 g: 0.2668621700879765 b: 0.2668621700879765 alpha: 1.0); + yourself)} rope: (BlCollectionRope new + collection: (aText ifNil:['Button']); + yourself)); + yourself); + id: #text; + constraintsDo: [:constraints | constraints horizontal fitContent. + constraints vertical fitContent. + constraints frame horizontal alignCenter. + constraints frame vertical alignCenter. + constraints position: 3.0 @ 3.0 ]; + layout: BlBasicLayout uniqueInstance; + yourself)}; + constraintsDo: [:constraints | constraints horizontal fitContent. + constraints vertical fitContent. + constraints padding: (BlInsets all: 8.0) ]; + layout: BlFrameLayout new; + yourself +] + { #category : #private } GeoViewExamples class >> createGeoBoundingBoxes: aQuantity [ @@ -204,6 +249,41 @@ GeoViewExamples class >> createTissotIndicatorCircles [ ^ circles ] +{ #category : #'examples - interactions' } +GeoViewExamples class >> exampleBoundingBoxCreator [ + "This example show how to create several BoundingBoxes from scratch" + + | element layer button controller | + element := GeoViewElement new id: #geoView. + + "OSM layer" + element addLayer: (GeoViewMapTilesLayer newWithOpenStreetMap). + + "Bounding box layer" + layer := GeoViewDomainObjectsLayer new name: #boundingbox. + layer setProcessData: (GeoBoundingBoxProjectedProcessData new) forClass: GeoBoundingBox. + element addLayer: layer. + + "Helpers layer" + layer := GeoViewDShapesLayer new name: #helpers. + element addLayer: layer. + + "Create interaction button and event handlers" + controller := GeoViewBoundingBoxCreatorController new. + element addEventHandler: controller. + + button := self createBlButton: 'Create Bounding Box'. + button addEventHandlerOn: BlClickEvent do: [ :e | + e consume. + controller isOnCreation + ifFalse:[ controller startCreation ] + ifTrue:[ controller stopCreation ]. + ]. + element addChild: button. + + ^ self openViewInWindow: element +] + { #category : #'examples - interactions' } GeoViewExamples class >> exampleCitiesHover [ "This example show how to implement a mouse hover interaction to do something" @@ -1429,7 +1509,7 @@ GeoViewExamples class >> largest50Countries [ ^positions ] -{ #category : #private } +{ #category : #'private - bloc' } GeoViewExamples class >> openViewInWindow: aGeoViewElement [ "open the view in a window" diff --git a/src/GeoView-Tests/AbstractGeoViewInteractionsStrategyTest.class.st b/src/GeoView-Tests/AbstractGeoViewInteractionsStrategyTest.class.st new file mode 100644 index 0000000..fd060ac --- /dev/null +++ b/src/GeoView-Tests/AbstractGeoViewInteractionsStrategyTest.class.st @@ -0,0 +1,107 @@ +" +An AbstractGeoViewInteractionsStrategyTest is a test class for testing the behavior of AbstractGeoViewInteractionsStrategy +" +Class { + #name : #AbstractGeoViewInteractionsStrategyTest, + #superclass : #TestCase, + #instVars : [ + 'strategy' + ], + #category : #'GeoView-Tests-Events' +} + +{ #category : #testing } +AbstractGeoViewInteractionsStrategyTest class >> isAbstract [ + + ^ self == AbstractGeoViewInteractionsStrategyTest +] + +{ #category : #running } +AbstractGeoViewInteractionsStrategyTest >> setUp [ + + super setUp. + + strategy := self strategyClass new +] + +{ #category : #running } +AbstractGeoViewInteractionsStrategyTest >> strategyClass [ + + self subclassResponsibility +] + +{ #category : #tests } +AbstractGeoViewInteractionsStrategyTest >> testAllowMapMoving [ + + self assert: strategy allowMapMoving. + + strategy allowMapMoving: false. + self deny: strategy allowMapMoving. + + strategy allowMapMoving: true. + self assert: strategy allowMapMoving +] + +{ #category : #tests } +AbstractGeoViewInteractionsStrategyTest >> testAllowMapScaling [ + + self assert: strategy allowMapScaling. + + strategy allowMapScaling: false. + self deny: strategy allowMapScaling. + + strategy allowMapScaling: true. + self assert: strategy allowMapScaling +] + +{ #category : #tests } +AbstractGeoViewInteractionsStrategyTest >> testGeoView [ + + | geoView | + geoView := GeoViewElement new. + + self assert: strategy geoView isNil. + + strategy geoView: geoView. + self assert: strategy geoView notNil. + + strategy geoView: nil. + self assert: strategy geoView isNil. + +] + +{ #category : #tests } +AbstractGeoViewInteractionsStrategyTest >> testIsMultipleSelection [ + + self assert: strategy isMultipleSelection. + + strategy isMultipleSelection: false. + self deny: strategy isMultipleSelection. + + strategy isMultipleSelection: true. + self assert: strategy isMultipleSelection +] + +{ #category : #tests } +AbstractGeoViewInteractionsStrategyTest >> testPickingRadius [ + + self assert: strategy pickingRadius equals: strategy class defaultPickingRadius. + + strategy pickingRadius: 10. + self assert: strategy pickingRadius equals: 10. + + strategy pickingRadius: nil. + self assert: strategy pickingRadius equals: strategy class defaultPickingRadius. +] + +{ #category : #tests } +AbstractGeoViewInteractionsStrategyTest >> testSelectionFilterBlock [ + + self assert: strategy selectionFilterBlock isNil. + + strategy selectionFilterBlock: [ :e | true ]. + self assert: strategy selectionFilterBlock notNil. + + strategy selectionFilterBlock: nil. + self assert: strategy selectionFilterBlock isNil. +] diff --git a/src/GeoView-Tests/GeoProjectorProcessDataUserForTest.class.st b/src/GeoView-Tests/GeoProjectorProcessDataUserForTest.class.st new file mode 100644 index 0000000..bd28667 --- /dev/null +++ b/src/GeoView-Tests/GeoProjectorProcessDataUserForTest.class.st @@ -0,0 +1,7 @@ +Class { + #name : #GeoProjectorProcessDataUserForTest, + #superclass : #GeoViewDomainProcessData, + #traits : 'TGeoProjectorProcessData', + #classTraits : 'TGeoProjectorProcessData classTrait', + #category : #'GeoView-Tests-Utils' +} diff --git a/src/GeoView-Tests/GeoViewDShapesLayerTest.class.st b/src/GeoView-Tests/GeoViewDShapesLayerTest.class.st index 6d43f08..d1ef02a 100644 --- a/src/GeoView-Tests/GeoViewDShapesLayerTest.class.st +++ b/src/GeoView-Tests/GeoViewDShapesLayerTest.class.st @@ -87,6 +87,21 @@ GeoViewDShapesLayerTest >> testHaveDomainObjects [ self deny: layer haveDomainObjects ] +{ #category : #tests } +GeoViewDShapesLayerTest >> testRemoveAllDShapes [ + + | shape1 shape2 | + shape1 := SmockDCircle key: 1. + shape2 := SmockDCircle key: 2. + layer + addDShape: shape1; + addDShape: shape2. + + layer removeAllDShapes. + self assert: layer displayModel size equals: 0. + self assert: layer graphicModel getDatas size equals: 0 +] + { #category : #tests } GeoViewDShapesLayerTest >> testRemoveDShape [ diff --git a/src/GeoView-Tests/GeoViewElementTest.class.st b/src/GeoView-Tests/GeoViewElementTest.class.st index 7997cf5..c1d1d62 100644 --- a/src/GeoView-Tests/GeoViewElementTest.class.st +++ b/src/GeoView-Tests/GeoViewElementTest.class.st @@ -304,6 +304,12 @@ GeoViewElementTest >> testFootnotes [ self assert: geoView footnotes isNil. ] +{ #category : #tests } +GeoViewElementTest >> testFootnotesElement [ + + self assert: geoView footnotesElement notNil +] + { #category : #tests } GeoViewElementTest >> testInteractionsStrategy [ diff --git a/src/GeoView-Tests/GeoViewInteractionsStrategyTest.class.st b/src/GeoView-Tests/GeoViewInteractionsStrategyTest.class.st new file mode 100644 index 0000000..e35294a --- /dev/null +++ b/src/GeoView-Tests/GeoViewInteractionsStrategyTest.class.st @@ -0,0 +1,21 @@ +Class { + #name : #GeoViewInteractionsStrategyTest, + #superclass : #AbstractGeoViewInteractionsStrategyTest, + #category : #'GeoView-Tests-Events' +} + +{ #category : #running } +GeoViewInteractionsStrategyTest >> strategyClass [ + + ^ GeoViewInteractionsStrategy +] + +{ #category : #tests } +GeoViewInteractionsStrategyTest >> testAllowMapMoving [ + + super testAllowMapMoving. + + strategy isMapMoving: true. + strategy allowMapMoving: false. + self deny: strategy isMapMoving. +] diff --git a/src/GeoView-Tests/TGeoProjectorProcessDataTest.class.st b/src/GeoView-Tests/TGeoProjectorProcessDataTest.class.st new file mode 100644 index 0000000..2e9c1f9 --- /dev/null +++ b/src/GeoView-Tests/TGeoProjectorProcessDataTest.class.st @@ -0,0 +1,113 @@ +" +A TGeoProjectorProcessDataTest is a test class for testing the behavior of TGeoProjectorProcessData +" +Class { + #name : #TGeoProjectorProcessDataTest, + #superclass : #TestCase, + #instVars : [ + 'processData' + ], + #category : #'GeoView-Tests-Projections' +} + +{ #category : #running } +TGeoProjectorProcessDataTest >> setUp [ + + super setUp. + + processData := GeoProjectorProcessDataUserForTest new. + self setUpProcessData +] + +{ #category : #running } +TGeoProjectorProcessDataTest >> setUpProcessData [ + + processData processor: GeoViewModel new. + processData processor projection: GeoViewMercatorProjection new. +] + +{ #category : #tests } +TGeoProjectorProcessDataTest >> testGeodesicFormulas [ + + self assert: processData geodesicFormulas class equals: GeodesicVincentyFormulas. + + processData geodesicFormulas: nil. + self assert: processData geodesicFormulas class equals: GeodesicVincentyFormulas. +] + +{ #category : #tests } +TGeoProjectorProcessDataTest >> testProjectBoundingBox [ + + | boundingBox result | + boundingBox := GeoBoundingBox new. + + "not valid bounding box" + result := processData projectBoundingBox: boundingBox. + self assert: result isEmpty. + + boundingBox topLeftAbsoluteCoordinates: AbsoluteCoordinates frBrest. + result := processData projectBoundingBox: boundingBox. + self assert: result isEmpty. + + "valid bounding box" + boundingBox bottomRightAbsoluteCoordinates: AbsoluteCoordinates frLyon. + + result := processData projectBoundingBox: boundingBox. + self assert: result size equals: 4. +] + +{ #category : #tests } +TGeoProjectorProcessDataTest >> testProjectCircleRadiusInMeters [ + + "not valid datas" + | result | + result := processData projectCircle: AbsoluteCoordinates new radiusInMeters: 1000. + self assert: result isEmpty. + + "valid datas" + result := processData projectCircle: AbsoluteCoordinates zero radiusInMeters: 0. + self assert: result notEmpty. + + result := processData projectCircle: AbsoluteCoordinates zero radiusInMeters: 1000. + self assert: result notEmpty. + + result := processData projectCircle: AbsoluteCoordinates frBrest radiusInMeters: 100000. + self assert: result notEmpty. +] + +{ #category : #tests } +TGeoProjectorProcessDataTest >> testProjectGeodesicFromTo [ + + | result | + "not valid" + result := processData projectGeodesicFrom: AbsoluteCoordinates new to: AbsoluteCoordinates frNevers. + self assert: result isEmpty. + + "valid" + result := processData projectGeodesicFrom: AbsoluteCoordinates frBrest to: AbsoluteCoordinates frNevers. + self assert: result size equals: 1. + + "valid with several polylines in mercator" + result := processData projectGeodesicFrom: AbsoluteCoordinates usaNewYork to: AbsoluteCoordinates ausSydney. + self assert: result size equals: 2. + +] + +{ #category : #tests } +TGeoProjectorProcessDataTest >> testProjectionQuality [ + + self assert: processData projectionQuality equals: #high. + + processData projectionQuality: #medium. + self assert: processData projectionQuality equals: #medium. + + processData projectionQuality: nil. + self assert: processData projectionQuality equals: #high. +] + +{ #category : #tests } +TGeoProjectorProcessDataTest >> testUsingVincentyFormulas [ + + processData usingVincentyFormulas. + self assert: processData geodesicFormulas class equals: GeodesicVincentyFormulas. +] diff --git a/src/GeoView/AbstractGeoViewInteractionsStrategy.class.st b/src/GeoView/AbstractGeoViewInteractionsStrategy.class.st new file mode 100644 index 0000000..359d5d3 --- /dev/null +++ b/src/GeoView/AbstractGeoViewInteractionsStrategy.class.st @@ -0,0 +1,132 @@ +Class { + #name : #AbstractGeoViewInteractionsStrategy, + #superclass : #BlEventListener, + #instVars : [ + 'geoView', + 'allowMapMoving', + 'allowMapScaling', + 'isMultipleSelection', + 'pickingRadius', + 'selectionFilterBlock' + ], + #category : #'GeoView-Events' +} + +{ #category : #accessing } +AbstractGeoViewInteractionsStrategy class >> defaultPickingRadius [ + + ^ 5 +] + +{ #category : #testing } +AbstractGeoViewInteractionsStrategy class >> isAbstract [ + + ^ self == AbstractGeoViewInteractionsStrategy +] + +{ #category : #map } +AbstractGeoViewInteractionsStrategy >> allowMapMoving [ + + ^ allowMapMoving ifNil:[ allowMapMoving := true ] +] + +{ #category : #map } +AbstractGeoViewInteractionsStrategy >> allowMapMoving: anObject [ + + allowMapMoving := anObject +] + +{ #category : #map } +AbstractGeoViewInteractionsStrategy >> allowMapScaling [ + + ^ allowMapScaling ifNil:[ allowMapScaling := true ] +] + +{ #category : #map } +AbstractGeoViewInteractionsStrategy >> allowMapScaling: anObject [ + + allowMapScaling := anObject +] + +{ #category : #'mouse handlers' } +AbstractGeoViewInteractionsStrategy >> clickEvent: anEvent [ + + anEvent + ifPrimary: [ self primaryClickEvent: anEvent ] + secondary: [ self secondaryClickEvent: anEvent ] + middle: [ self middleClickEvent: anEvent ] + other: [ self otherClickEvent: anEvent ] +] + +{ #category : #accessing } +AbstractGeoViewInteractionsStrategy >> geoView [ + + ^ geoView +] + +{ #category : #accessing } +AbstractGeoViewInteractionsStrategy >> geoView: anObject [ + + geoView := anObject +] + +{ #category : #selection } +AbstractGeoViewInteractionsStrategy >> isMultipleSelection [ + + ^ isMultipleSelection ifNil:[ isMultipleSelection := true ] +] + +{ #category : #selection } +AbstractGeoViewInteractionsStrategy >> isMultipleSelection: aBoolean [ + + isMultipleSelection := aBoolean +] + +{ #category : #'mouse handlers' } +AbstractGeoViewInteractionsStrategy >> middleClickEvent: anEvent [ + + +] + +{ #category : #'mouse handlers' } +AbstractGeoViewInteractionsStrategy >> otherClickEvent: anEvent [ + + +] + +{ #category : #picking } +AbstractGeoViewInteractionsStrategy >> pickingRadius [ + "Consider this radius as a device coordinates (i.e. pixels)" + + ^ pickingRadius ifNil: [ pickingRadius := self class defaultPickingRadius ] +] + +{ #category : #picking } +AbstractGeoViewInteractionsStrategy >> pickingRadius: aNumber [ + + pickingRadius := aNumber +] + +{ #category : #'mouse handlers' } +AbstractGeoViewInteractionsStrategy >> primaryClickEvent: anEvent [ + + +] + +{ #category : #'mouse handlers' } +AbstractGeoViewInteractionsStrategy >> secondaryClickEvent: anEvent [ + + +] + +{ #category : #selection } +AbstractGeoViewInteractionsStrategy >> selectionFilterBlock [ + + ^ selectionFilterBlock +] + +{ #category : #selection } +AbstractGeoViewInteractionsStrategy >> selectionFilterBlock: aSelectFilterBlock [ + + selectionFilterBlock := aSelectFilterBlock +] diff --git a/src/GeoView/GeoBoundingBoxProjectedProcessData.class.st b/src/GeoView/GeoBoundingBoxProjectedProcessData.class.st index 3f17e4f..fe8fcf7 100644 --- a/src/GeoView/GeoBoundingBoxProjectedProcessData.class.st +++ b/src/GeoView/GeoBoundingBoxProjectedProcessData.class.st @@ -33,17 +33,16 @@ GeoBoundingBoxProjectedProcessData >> processCreatedData: aKey incoming: aGeoBou { #category : #processing } GeoBoundingBoxProjectedProcessData >> processUpdatedData: aKey incoming: aGeoBoundingBox with: aDMultiPolylines context: aContext [ - | dMultiPolylines points | + | dMultiPolylines points polylines | dMultiPolylines := aDMultiPolylines. - super processUpdatedData: aKey incoming: aGeoBoundingBox with: aDMultiPolylines context: aContext. + super processUpdatedData: aKey incoming: aGeoBoundingBox with: dMultiPolylines context: aContext. points := OrderedCollection new. + dMultiPolylines removePolylines. - aDMultiPolylines addPolylines: (self projectGeodesicFrom: aGeoBoundingBox topLeftAbsoluteCoordinates to: aGeoBoundingBox topRightAbsoluteCoordinates). - aDMultiPolylines addPolylines: (self projectGeodesicFrom: aGeoBoundingBox topRightAbsoluteCoordinates to: aGeoBoundingBox bottomRightAbsoluteCoordinates). - aDMultiPolylines addPolylines: (self projectGeodesicFrom: aGeoBoundingBox bottomRightAbsoluteCoordinates to: aGeoBoundingBox bottomLeftAbsoluteCoordinates). - aDMultiPolylines addPolylines: (self projectGeodesicFrom: aGeoBoundingBox bottomLeftAbsoluteCoordinates to: aGeoBoundingBox topLeftAbsoluteCoordinates). + polylines := self projectBoundingBox: aGeoBoundingBox. + polylines ifNotNil:[ :e | dMultiPolylines addPolylines: e ]. - ^dMultiPolylines + ^ dMultiPolylines ] diff --git a/src/GeoView/GeoShapeProcessData.class.st b/src/GeoView/GeoShapeProcessData.class.st index 0f459e4..161ced4 100644 --- a/src/GeoView/GeoShapeProcessData.class.st +++ b/src/GeoView/GeoShapeProcessData.class.st @@ -31,8 +31,11 @@ GeoShapeProcessData >> processCreatedData: aKey incoming: aGeoShape with: aDShap dShape isComposite ifFalse: [ dShape fillStyle: aGeoShape fillStyle copy. dShape strokeStyle: aGeoShape strokeStyle copy. - dShape strokeStyle ifNotNil: [ :e | - dShape effect: (SmockDuplicateEffect new strokeColor: (Color black); strokeWidth: (e width + 2); yourself) + dShape strokeStyle ifNotNil: [ :e | | style paint | + style := dShape strokeStyle copy. + paint := dShape strokeStyle isColor ifTrue:[ (dShape strokeStyle paint copy) twiceDarker ] ifFalse:[ Color black ]. + style paint: paint; width: (dShape strokeStyle width + 1.5). + dShape effect: (SmockDuplicateEffect new strokeStyle: style) ]. ]. diff --git a/src/GeoView/GeoViewDShapesLayer.class.st b/src/GeoView/GeoViewDShapesLayer.class.st index f1e7292..e2e848b 100644 --- a/src/GeoView/GeoViewDShapesLayer.class.st +++ b/src/GeoView/GeoViewDShapesLayer.class.st @@ -95,6 +95,19 @@ GeoViewDShapesLayer >> populatePickingResult: aPickingResult at: index with: aGS ^ pickingElement ] +{ #category : #'API -- DShapes' } +GeoViewDShapesLayer >> removeAllDShapes [ + + | toRemove | + toRemove := OrderedCollection new. + + self displayModelMutex critical: [ + toRemove addAll: self displayModel values + ]. + + ^ self removeDShapes: toRemove +] + { #category : #'API -- DShapes' } GeoViewDShapesLayer >> removeDShape: aDShape [ diff --git a/src/GeoView/GeoViewElement.class.st b/src/GeoView/GeoViewElement.class.st index 8f685b7..aeb9a8b 100644 --- a/src/GeoView/GeoViewElement.class.st +++ b/src/GeoView/GeoViewElement.class.st @@ -75,6 +75,9 @@ GeoViewElement >> initializeFootnotesElements [ | element | element := GeoViewFootnotesElement id: #footnotes. + "Non interactive BlElement" + element preventMeAndChildrenMouseEvents. + element constraintsDo: [ :c | c horizontal matchParent. c vertical matchParent. @@ -127,9 +130,15 @@ GeoViewElement >> newInteractionsStrategy [ { #category : #'strategy management' } GeoViewElement >> removeInteractionsStrategy [ - interactionsStrategy ifNil:[ ^ self ]. - self removeEventHandler: interactionsStrategy. - interactionsStrategy := nil. + interactionsStrategy ifNil: [ ^ self ]. + + interactionsStrategy geoView: nil. + + (self layerListElement hasEventHandler: interactionsStrategy) + ifTrue: [ + self layerListElement removeEventHandler: interactionsStrategy ]. + + interactionsStrategy := nil ] { #category : #'strategy management' } @@ -137,9 +146,12 @@ GeoViewElement >> setInteractionsStrategy: aBlEventListener [ self removeInteractionsStrategy. - aBlEventListener ifNil:[ ^ self ]. + aBlEventListener ifNil: [ ^ self ]. + interactionsStrategy := aBlEventListener. - self addEventHandler: aBlEventListener. + interactionsStrategy geoView: self. + + self layerListElement addEventHandler: aBlEventListener ] { #category : #private } diff --git a/src/GeoView/GeoViewInteractionsStrategy.class.st b/src/GeoView/GeoViewInteractionsStrategy.class.st index b19712e..64683d2 100644 --- a/src/GeoView/GeoViewInteractionsStrategy.class.st +++ b/src/GeoView/GeoViewInteractionsStrategy.class.st @@ -4,52 +4,20 @@ This class provided classical mouse and keyboard ergonomic to move, scale and se " Class { #name : #GeoViewInteractionsStrategy, - #superclass : #BlEventListener, + #superclass : #AbstractGeoViewInteractionsStrategy, #instVars : [ - 'allowMapMoving', - 'allowMapScaling', 'isMapMoving', 'mouseDownPosition', - 'pickingRadius', - 'lastMouseMoveEventTimestamp', - 'isMultipleSelection', - 'selectionFilterBlock' + 'lastMouseMoveEventTimestamp' ], #category : #'GeoView-Events' } -{ #category : #accessing } -GeoViewInteractionsStrategy >> allowMapMoving [ - - ^ allowMapMoving ifNil:[ allowMapMoving := true ] -] - -{ #category : #accessing } +{ #category : #map } GeoViewInteractionsStrategy >> allowMapMoving: anObject [ - allowMapMoving := anObject -] - -{ #category : #accessing } -GeoViewInteractionsStrategy >> allowMapScaling [ - - ^ allowMapScaling ifNil:[ allowMapScaling := true ] -] - -{ #category : #accessing } -GeoViewInteractionsStrategy >> allowMapScaling: anObject [ - - allowMapScaling := anObject -] - -{ #category : #'mouse handlers' } -GeoViewInteractionsStrategy >> clickEvent: anEvent [ - - anEvent - ifPrimary: [ self primaryClickEvent: anEvent ] - secondary: [ ] - middle: [ ] - other: [ ] + super allowMapMoving: anObject. + self isMapMoving: nil ] { #category : #accessing } @@ -64,18 +32,6 @@ GeoViewInteractionsStrategy >> isMapMoving: aBoolean [ isMapMoving := aBoolean ] -{ #category : #accessing } -GeoViewInteractionsStrategy >> isMultipleSelection [ - - ^ isMultipleSelection ifNil:[ isMultipleSelection := true ] -] - -{ #category : #accessing } -GeoViewInteractionsStrategy >> isMultipleSelection: aBoolean [ - - isMultipleSelection := aBoolean -] - { #category : #'mouse handlers' } GeoViewInteractionsStrategy >> mouseDownEvent: anEvent [ @@ -100,8 +56,10 @@ GeoViewInteractionsStrategy >> mouseMoveEvent: anEvent [ "optimize mouse event processing" lastMouseMoveEventTimestamp ifNotNil:[ | duration | + self flag:'labordep: use SmockCommandRunner to sample events'. duration := anEvent timestamp - lastMouseMoveEventTimestamp. - duration < self pulsePeriodInMs ifTrue:[ ^ self ]. + "BlHostPulseLoop>>defaultPulsePeriod" + duration < 15 milliSecond ifTrue:[ ^ self ]. ]. lastMouseMoveEventTimestamp := anEvent timestamp copy. @@ -114,7 +72,7 @@ GeoViewInteractionsStrategy >> mouseMoveEvent: anEvent [ { #category : #'mouse handlers' } GeoViewInteractionsStrategy >> mouseUpEvent: anEvent [ - + self isMapMoving: false ] @@ -122,18 +80,20 @@ GeoViewInteractionsStrategy >> mouseUpEvent: anEvent [ GeoViewInteractionsStrategy >> mouseWheelEvent: anEvent [ "Scale the map(zoom in or zoom out) but stay centered behind the mouse position" - | element point mapProjection graphicProjection geoPoint geoPointPx geoCenterPx difPx geoPointPxNew newPointPx geoPointFinal | + | point mapProjection graphicProjection geoPoint geoPointPx geoCenterPx difPx geoPointPxNew newPointPx geoPointFinal | self allowMapScaling ifFalse:[ ^ self ]. - element := anEvent currentTarget. - point := element localPointFromGlobalPoint: anEvent position. + + anEvent consume. + + point := self geoView localPointFromGlobalPoint: anEvent position. - mapProjection := element mapProjection ifNil:[ ^ self ]. - graphicProjection := element displayToGraphicProjection ifNil:[ ^ self ]. + mapProjection := self geoView mapProjection ifNil:[ ^ self ]. + graphicProjection := self geoView displayToGraphicProjection ifNil:[ ^ self ]. - geoPoint := element absoluteCoordinatesFromLocalPoint: point. + geoPoint := self geoView absoluteCoordinatesFromLocalPoint: point. geoPointPx := graphicProjection projCartToPixel: (mapProjection projLatLonToCart: geoPoint). - geoCenterPx := graphicProjection projCartToPixel: (mapProjection projLatLonToCart: element geoCenter). + geoCenterPx := graphicProjection projCartToPixel: (mapProjection projLatLonToCart: self geoView geoCenter). geoPointPx ifNil:[ ^ self ]. geoCenterPx ifNil:[ ^ self ]. @@ -143,8 +103,8 @@ GeoViewInteractionsStrategy >> mouseWheelEvent: anEvent [ "Scale" anEvent isScrollDown - ifTrue: [ element scaleDown ] - ifFalse:[ anEvent isScrollUp ifTrue: [ element scaleUp ] ifFalse:[ ^ self ] ]. + ifTrue: [ self geoView scaleDown ] + ifFalse:[ anEvent isScrollUp ifTrue: [ self geoView scaleUp ] ifFalse:[ ^ self ] ]. self allowMapMoving ifFalse:[ ^ self ]. @@ -154,56 +114,43 @@ GeoViewInteractionsStrategy >> mouseWheelEvent: anEvent [ "add the previous diff in pixels to get new center in pixel" newPointPx := geoPointPxNew + difPx. "Compute new position in cartesian for new center" - geoPointFinal := element absoluteCoordinatesFromLocalPoint: newPointPx. - element geoCenter: geoPointFinal. + geoPointFinal := self geoView absoluteCoordinatesFromLocalPoint: newPointPx. + self geoView geoCenter: geoPointFinal. ] { #category : #'events - processing' } GeoViewInteractionsStrategy >> moveMap: anEvent [ - | point difPx geoCenterPx element | + | point difPx geoCenterPx | self allowMapMoving ifFalse:[ ^ self ]. - element := anEvent currentTarget ifNil: [ ^ self ]. + + anEvent consume. point := anEvent position. difPx := self mouseDownPosition - point. difPx := difPx x @ difPx y. - geoCenterPx := element globalPointFromAbsoluteCoordinates: element geoCenter. + geoCenterPx := self geoView globalPointFromAbsoluteCoordinates: self geoView geoCenter. geoCenterPx ifNil: [ ^ self ]. geoCenterPx := geoCenterPx + difPx. "Update mouse down position with this event" self mouseDownPosition: point copy. - element centerOnGlobalPoint: geoCenterPx. -] - -{ #category : #picking } -GeoViewInteractionsStrategy >> pickingRadius [ - "Consider this radius as a device coordinates (i.e. pixels)" - - ^ pickingRadius ifNil: [ pickingRadius := 5 ] -] - -{ #category : #picking } -GeoViewInteractionsStrategy >> pickingRadius: aNumber [ - - pickingRadius := aNumber + self geoView centerOnGlobalPoint: geoCenterPx. ] { #category : #'mouse handlers' } GeoViewInteractionsStrategy >> primaryClickEvent: anEvent [ "pick the geoview on click" - | element point pickingResult event | + | point pickingResult event | self flag:'laborde, need to report bloc bug because there is a click with a drag... patch with checking mouse down position'. self isMapMoving ifTrue:[^ self]. - element := anEvent currentTarget. point := anEvent position. - pickingResult := element pickAt: point radius: self pickingRadius. + pickingResult := self geoView pickAt: point radius: self pickingRadius. self selectionFilterBlock ifNotNil:[ pickingResult := pickingResult applyFilter: self selectionFilterBlock ]. @@ -211,7 +158,7 @@ GeoViewInteractionsStrategy >> primaryClickEvent: anEvent [ "send picking event" event := GeoViewPickingEvent new. event pickingResult: pickingResult. - element dispatchEvent: event. + self geoView dispatchEvent: event. "process selection events" (anEvent modifiers isCtrl and:[ self isMultipleSelection ]) @@ -226,13 +173,13 @@ GeoViewInteractionsStrategy >> primaryClickEvent: anEvent [ notSelected ifNotEmpty: [ event := GeoViewObjectSelectionAdded new. event objectIndexesList: notSelected. - element dispatchEvent: event + self geoView dispatchEvent: event ]. selected ifNotEmpty: [ event := GeoViewObjectSelectionRemoved new. event objectIndexesList: selected. - element dispatchEvent: event + self geoView dispatchEvent: event ]. ] ifTrue:[ "doing nothing here : stay the selection" ] ] @@ -245,39 +192,19 @@ GeoViewInteractionsStrategy >> primaryClickEvent: anEvent [ "When a minimum of 1 object is under the mouse (without Ctrl key press), select only the first object" event := GeoViewObjectSelectionChanged new. event objectIndexesList: (OrderedCollection with: pickingResult firstElement objectIndex) ]. - element dispatchEvent: event ] -] - -{ #category : #accessing } -GeoViewInteractionsStrategy >> pulsePeriodInMs [ - "BlHostPulseLoop>>defaultPulsePeriod" - - ^ 15 milliSecond -] - -{ #category : #accessing } -GeoViewInteractionsStrategy >> selectionFilterBlock [ - - ^ selectionFilterBlock -] - -{ #category : #accessing } -GeoViewInteractionsStrategy >> selectionFilterBlock: aSelectFilterBlock [ - - selectionFilterBlock := aSelectFilterBlock + self geoView dispatchEvent: event ] ] { #category : #'events - processing' } GeoViewInteractionsStrategy >> sendMouseCoordinatesChanged: anEvent [ - | element coordinates event | - element := anEvent currentTarget. + | coordinates event | "Calculate the absolute coordinates (lat/lon) under the mouse cursor" - coordinates := element absoluteCoordinatesFromGlobalPoint: anEvent position. + coordinates := self geoView absoluteCoordinatesFromGlobalPoint: anEvent position. coordinates ifNil:[ ^ self ]. event := GeoViewCursorCoordinatesChangedEvent new. event absoluteCoordinates: coordinates. - element dispatchEvent: event. + self geoView dispatchEvent: event. ] diff --git a/src/GeoView/TGeoProjectorProcessData.trait.st b/src/GeoView/TGeoProjectorProcessData.trait.st index 8fce7ef..e975026 100644 --- a/src/GeoView/TGeoProjectorProcessData.trait.st +++ b/src/GeoView/TGeoProjectorProcessData.trait.st @@ -68,11 +68,31 @@ TGeoProjectorProcessData >> mediumProjectionQuality [ self projectionQuality: #medium ] +{ #category : #projector } +TGeoProjectorProcessData >> projectBoundingBox: aBoundingBox [ + "Project an object which is used TGeoToolsBoundingBox" + + | polylines | + aBoundingBox isValid ifFalse:[ ^ #( ) ]. + + polylines := OrderedCollection new. + + polylines addAll: (self projectGeodesicFrom: aBoundingBox topLeftAbsoluteCoordinates to: aBoundingBox topRightAbsoluteCoordinates). + polylines addAll: (self projectGeodesicFrom: aBoundingBox topRightAbsoluteCoordinates to: aBoundingBox bottomRightAbsoluteCoordinates). + polylines addAll: (self projectGeodesicFrom: aBoundingBox bottomRightAbsoluteCoordinates to: aBoundingBox bottomLeftAbsoluteCoordinates). + polylines addAll: (self projectGeodesicFrom: aBoundingBox bottomLeftAbsoluteCoordinates to: aBoundingBox topLeftAbsoluteCoordinates). + + ^ polylines + +] + { #category : #projector } TGeoProjectorProcessData >> projectCircle: anAbsolutePosition radiusInMeters: aRadiusInMeters [ "Project a circle and return a list of cartesians DPolyline. Each polylines corresponding to an angle sampling to compose the circle" | precision polylines from first | + anAbsolutePosition isValid ifFalse:[ ^ #( ) ]. + precision := 10. polylines := OrderedCollection new. @@ -109,6 +129,8 @@ TGeoProjectorProcessData >> projectGeodesicFrom: aFromAbsolutePosition to: aToAb "Project a geodesic (a line between two geo positions) and return a list of cartesians DPolyline" | from to distance firstAzimuth n step polylines points currentPoly previousStepGeo | + (aFromAbsolutePosition isValid not or:[aToAbsolutePosition isValid not]) ifTrue:[ ^ #( ) ]. + from := aFromAbsolutePosition. to := aToAbsolutePosition. @@ -171,12 +193,14 @@ TGeoProjectorProcessData >> projectGeodesicFrom: aFromAbsolutePosition to: aToAb TGeoProjectorProcessData >> projectionQuality [ ^ projectionQuality ifNil: [ - self highProjectionQuality. - projectionQuality ] + self highProjectionQuality. + projectionQuality ] ] { #category : #accessing } TGeoProjectorProcessData >> projectionQuality: aSymbol [ + + projectionQuality := aSymbol ] { #category : #'quality ' }