From 6d55d2475e64e494e300a57d752ed3d47a766c5a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mathieu=20Magu=C3=A9r=C3=A8s?= Date: Tue, 19 May 2026 17:14:31 +0200 Subject: [PATCH 01/22] add a tab that allows handling BlElement depending on its type --- .../PyramidBlocGeometryPlugin.class.st | 94 ----------- .../PyramidSaveModelVerifier.class.st | 5 +- src/Pyramid/PyramidEditorPlugin.class.st | 158 ++++++++++++++++++ .../PyramidGeometryCommand.class.st | 12 +- .../PyramidIconInputPresenter.class.st | 68 ++++++++ ...oundedRectangleCornerRadiiCommand.class.st | 12 +- .../PyramidToButtonEndIconCommand.class.st | 29 ++++ .../PyramidToButtonIconCommand.class.st | 31 ++++ .../PyramidToButtonLabelCommand.class.st | 22 +++ .../PyramidToImageInnerImageCommand.class.st | 28 ++++ .../PyramidToLabelTextCommand.class.st | 23 +++ 11 files changed, 378 insertions(+), 104 deletions(-) delete mode 100644 src/Pyramid-Bloc/PyramidBlocGeometryPlugin.class.st create mode 100644 src/Pyramid/PyramidEditorPlugin.class.st rename src/{Pyramid-Bloc => Pyramid}/PyramidGeometryCommand.class.st (53%) create mode 100644 src/Pyramid/PyramidIconInputPresenter.class.st rename src/{Pyramid-Bloc => Pyramid}/PyramidRoundedRectangleCornerRadiiCommand.class.st (62%) create mode 100644 src/Pyramid/PyramidToButtonEndIconCommand.class.st create mode 100644 src/Pyramid/PyramidToButtonIconCommand.class.st create mode 100644 src/Pyramid/PyramidToButtonLabelCommand.class.st create mode 100644 src/Pyramid/PyramidToImageInnerImageCommand.class.st create mode 100644 src/Pyramid/PyramidToLabelTextCommand.class.st diff --git a/src/Pyramid-Bloc/PyramidBlocGeometryPlugin.class.st b/src/Pyramid-Bloc/PyramidBlocGeometryPlugin.class.st deleted file mode 100644 index 63799cd9..00000000 --- a/src/Pyramid-Bloc/PyramidBlocGeometryPlugin.class.st +++ /dev/null @@ -1,94 +0,0 @@ -Class { - #name : #PyramidBlocGeometryPlugin, - #superclass : #Object, - #traits : 'TPyramidPlugin', - #classTraits : 'TPyramidPlugin classTrait', - #instVars : [ - 'propertiesManager' - ], - #category : #'Pyramid-Bloc-plugin-bloc-geometry' -} - -{ #category : #accessing } -PyramidBlocGeometryPlugin class >> cornerRadii [ - - | property | - property := PyramidProperty new - name: 'Corner radius'; - command: PyramidRoundedRectangleCornerRadiiCommand new; - inputPresenterClass: - PyramidCornerRadiiInputPresenter; - yourself. - property inputPresenterModel help: - 'Change the corner radius of the geometry. For example: - - "10" to set a radius of 10 px on each corner. - - "10 20" to set a radius of 10 px on the top-left and bottom-right corner and 20 px on the top-right and bottom-left corner. - - "10 20 30 40" to set a radius of 10 px on top-left, 20 px on top-right, 30 px on bottom-right and 40 px on bottom-left.'. - ^ property -] - -{ #category : #accessing } -PyramidBlocGeometryPlugin class >> geometry [ - - | property | - property := PyramidProperty new - name: 'Geo'; - command: PyramidGeometryCommand new; - inputPresenterClass: PyramidMagicButtonsInputPresenter; - yourself. - self geometryClasses do: [ :each | - property inputPresenterModel addButtonModel: - each asPyramidMagicButton ]. - ^ property -] - -{ #category : #'as yet unclassified' } -PyramidBlocGeometryPlugin class >> geometryClasses [ - - ^ { - BlRectangleGeometry. - BlRoundedRectangleGeometry. - BlSquareGeometry. - BlEllipseGeometry. - BlCircleGeometry. - BlAnnulusSectorGeometry. - BlTriangleGeometry. - BlLineGeometry . - BlPolylineGeometry. - BlBezierCurveGeometry. - BlPolygonGeometry } -] - -{ #category : #adding } -PyramidBlocGeometryPlugin >> addPanelsOn: aPyramidSimpleWindow [ - - aPyramidSimpleWindow at: #tabRight addItem: [ :builder | - builder - makeTab: self propertiesManager mainPresenter - label: 'Geo' - icon: (Smalltalk ui icons iconNamed: #box) - order: 4 ] -] - -{ #category : #connecting } -PyramidBlocGeometryPlugin >> connectOn: aPyramidEditor [ - - propertiesManager projectModel: aPyramidEditor projectModel. - propertiesManager commandExecutor: - aPyramidEditor commandExecutor -] - -{ #category : #initialization } -PyramidBlocGeometryPlugin >> initialize [ - - propertiesManager := PyramidPropertiesManagerForSelection new. - - propertiesManager addProperty: self class geometry. - propertiesManager addProperty: self class cornerRadii. -] - -{ #category : #adding } -PyramidBlocGeometryPlugin >> propertiesManager [ - - ^ propertiesManager -] diff --git a/src/Pyramid-Bloc/PyramidSaveModelVerifier.class.st b/src/Pyramid-Bloc/PyramidSaveModelVerifier.class.st index d8425326..6374cc47 100644 --- a/src/Pyramid-Bloc/PyramidSaveModelVerifier.class.st +++ b/src/Pyramid-Bloc/PyramidSaveModelVerifier.class.st @@ -47,9 +47,10 @@ PyramidSaveModelVerifier class >> classPackageIsEqual [ PyramidSaveModelVerifier class >> methodIsValid [ ^ self new - verifyBlock: [ :model | model savingMethodName isValidSelector ]; + verifyBlock: [ :model | + OCScanner isSelector: model savingMethodName ]; showBlock: [ :view | view showMethodIsNotValidError ]; - yourself. + yourself ] { #category : #constructor } diff --git a/src/Pyramid/PyramidEditorPlugin.class.st b/src/Pyramid/PyramidEditorPlugin.class.st new file mode 100644 index 00000000..fe8ffb80 --- /dev/null +++ b/src/Pyramid/PyramidEditorPlugin.class.st @@ -0,0 +1,158 @@ +Class { + #name : #PyramidEditorPlugin, + #superclass : #Object, + #traits : 'TPyramidPlugin', + #classTraits : 'TPyramidPlugin classTrait', + #instVars : [ + 'propertiesManager' + ], + #category : #'Pyramid-plugin-editor' +} + +{ #category : #accessing } +PyramidEditorPlugin class >> cornerRadii [ + + | property | + property := PyramidProperty new + name: 'Corner radius'; + command: PyramidRoundedRectangleCornerRadiiCommand new; + inputPresenterClass: PyramidCornerRadiiInputPresenter; + yourself. + property inputPresenterModel help: + 'Change the corner radius of the geometry. For example: + - "10" to set a radius of 10 px on each corner. + - "10 20" to set a radius of 10 px on the top-left and bottom-right corner and 20 px on the top-right and bottom-left corner. + - "10 20 30 40" to set a radius of 10 px on top-left, 20 px on top-right, 30 px on bottom-right and 40 px on bottom-left.'. + ^ property +] + +{ #category : #accessing } +PyramidEditorPlugin class >> geometry [ + + | property | + property := PyramidProperty new + name: 'Geo'; + command: PyramidGeometryCommand new; + inputPresenterClass: PyramidMagicButtonsInputPresenter; + yourself. + self geometryClasses do: [ :each | + property inputPresenterModel addButtonModel: + each asPyramidMagicButton ]. + ^ property +] + +{ #category : #'as yet unclassified' } +PyramidEditorPlugin class >> geometryClasses [ + + ^ { + BlRectangleGeometry. + BlRoundedRectangleGeometry. + BlSquareGeometry. + BlEllipseGeometry. + BlCircleGeometry. + BlAnnulusSectorGeometry. + BlTriangleGeometry. + BlLineGeometry. + BlPolylineGeometry. + BlBezierCurveGeometry. + BlPolygonGeometry } +] + +{ #category : #'as yet unclassified' } +PyramidEditorPlugin class >> toButtonEndIcon [ + + | property | + property := PyramidProperty new + name: 'EndIcon'; + command: PyramidToButtonEndIconCommand new; + inputPresenterClass: PyramidIconInputPresenter; + yourself. + ^ property +] + +{ #category : #'as yet unclassified' } +PyramidEditorPlugin class >> toButtonIcon [ + + | property | + property := PyramidProperty new + name: 'Icon'; + command: PyramidToButtonIconCommand new; + inputPresenterClass: PyramidIconInputPresenter; + yourself. + ^ property +] + +{ #category : #'as yet unclassified' } +PyramidEditorPlugin class >> toButtonLabel [ + + | property | + property := PyramidProperty new + name: 'Text'; + command: PyramidToButtonLabelCommand new; + inputPresenterClass: PyramidTextInputPresenter; + yourself. + ^ property +] + +{ #category : #'as yet unclassified' } +PyramidEditorPlugin class >> toImageInnerImage [ + + | property | + property := PyramidProperty new + name: 'InnerImage'; + command: PyramidToImageInnerImageCommand new; + inputPresenterClass: PyramidIconInputPresenter; + yourself. + ^ property +] + +{ #category : #'as yet unclassified' } +PyramidEditorPlugin class >> toLabelText [ + + | property | + property := PyramidProperty new + name: 'Text'; + command: PyramidToLabelTextCommand new; + inputPresenterClass: PyramidTextInputPresenter; + yourself. + ^ property +] + +{ #category : #adding } +PyramidEditorPlugin >> addPanelsOn: aPyramidSimpleWindow [ + + aPyramidSimpleWindow at: #tabRight addItem: [ :builder | + builder + makeTab: propertiesManager mainPresenter + label: 'Editor' + icon: (Smalltalk ui icons iconNamed: #box) + order: 5 ] +] + +{ #category : #connecting } +PyramidEditorPlugin >> connectOn: aPyramidEditor [ + + propertiesManager projectModel: aPyramidEditor projectModel. + propertiesManager commandExecutor: aPyramidEditor commandExecutor +] + +{ #category : #initialization } +PyramidEditorPlugin >> initialize [ + + propertiesManager := PyramidPropertiesManagerForSelection new. + + "BlElements properties" + propertiesManager addProperty: self class geometry. + propertiesManager addProperty: self class cornerRadii. + + "ToButton properties" + propertiesManager addProperty: self class toButtonLabel. + propertiesManager addProperty: self class toButtonIcon. + propertiesManager addProperty: self class toButtonEndIcon. + + "ToImage properties" + propertiesManager addProperty: self class toImageInnerImage. + + "ToLabel properties" + propertiesManager addProperty: self class toLabelText +] diff --git a/src/Pyramid-Bloc/PyramidGeometryCommand.class.st b/src/Pyramid/PyramidGeometryCommand.class.st similarity index 53% rename from src/Pyramid-Bloc/PyramidGeometryCommand.class.st rename to src/Pyramid/PyramidGeometryCommand.class.st index 411acf89..67711ebc 100644 --- a/src/Pyramid-Bloc/PyramidGeometryCommand.class.st +++ b/src/Pyramid/PyramidGeometryCommand.class.st @@ -1,16 +1,22 @@ Class { #name : #PyramidGeometryCommand, #superclass : #PyramidAbstractBlocCommand, - #category : #'Pyramid-Bloc-plugin-bloc-geometry' + #category : #'Pyramid-plugin-editor' } -{ #category : #'as yet unclassified' } +{ #category : #testing } +PyramidGeometryCommand >> canBeUsedFor: anObject [ + + ^ (super canBeUsedFor: anObject) and: [ anObject class = BlElement ] +] + +{ #category : #getter } PyramidGeometryCommand >> getValueFor: aBlElement [ ^ aBlElement geometry ] -{ #category : #'as yet unclassified' } +{ #category : #setter } PyramidGeometryCommand >> setValueFor: aBlElement with: anArgument [ aBlElement geometry: anArgument diff --git a/src/Pyramid/PyramidIconInputPresenter.class.st b/src/Pyramid/PyramidIconInputPresenter.class.st new file mode 100644 index 00000000..f4fcc832 --- /dev/null +++ b/src/Pyramid/PyramidIconInputPresenter.class.st @@ -0,0 +1,68 @@ +Class { + #name : #PyramidIconInputPresenter, + #superclass : #PyramidInputPresenter, + #instVars : [ + 'textInput', + 'button', + 'list', + 'whenValueChangedDo' + ], + #category : #'Pyramid-specs-custom' +} + +{ #category : #layout } +PyramidIconInputPresenter >> defaultLayout [ + + ^ SpBoxLayout newHorizontal + spacing: 2; + add: textInput; + add: button width: 24; + yourself +] + +{ #category : #initialization } +PyramidIconInputPresenter >> initializePresenters [ + + whenValueChangedDo := [ :v | ]. + list := SpFilteringListPresenter new. + list items: + Smalltalk ui icons allIconNames asSortedCollection asArray. + list display: [ :name | name ]. + list displayIcon: [ :name | Smalltalk ui icons iconNamed: name ]. + textInput := SpTextInputFieldPresenter new. + textInput whenSubmitDo: [ :text | whenValueChangedDo value: text ]. + button := SpButtonPresenter new + help: 'Select an icon'; + icon: (Smalltalk ui icons iconNamed: #image); + action: [ self openIconModal ]; + yourself +] + +{ #category : #'as yet unclassified' } +PyramidIconInputPresenter >> openIconModal [ + + | window dialog | + window := list asModalWindow. + window title: 'Choose an icon'. + window centered. + dialog := window open. + dialog isOk ifFalse: [ ^ self ]. + self value: list selectedItem. + whenValueChangedDo value: list selectedItem +] + +{ #category : #'as yet unclassified' } +PyramidIconInputPresenter >> value [ + ^ textInput text +] + +{ #category : #'as yet unclassified' } +PyramidIconInputPresenter >> value: aString [ + + textInput text: (aString ifNil: [ '' ]) +] + +{ #category : #'as yet unclassified' } +PyramidIconInputPresenter >> whenValueChangedDo: aBlock [ + whenValueChangedDo := aBlock +] diff --git a/src/Pyramid-Bloc/PyramidRoundedRectangleCornerRadiiCommand.class.st b/src/Pyramid/PyramidRoundedRectangleCornerRadiiCommand.class.st similarity index 62% rename from src/Pyramid-Bloc/PyramidRoundedRectangleCornerRadiiCommand.class.st rename to src/Pyramid/PyramidRoundedRectangleCornerRadiiCommand.class.st index f239660b..617f15d5 100644 --- a/src/Pyramid-Bloc/PyramidRoundedRectangleCornerRadiiCommand.class.st +++ b/src/Pyramid/PyramidRoundedRectangleCornerRadiiCommand.class.st @@ -1,24 +1,26 @@ Class { #name : #PyramidRoundedRectangleCornerRadiiCommand, #superclass : #PyramidAbstractBlocCommand, - #category : #'Pyramid-Bloc-plugin-bloc-geometry' + #category : #'Pyramid-plugin-editor' } { #category : #testing } PyramidRoundedRectangleCornerRadiiCommand >> canBeUsedFor: anObject [ ^ (super canBeUsedFor: anObject) and: [ - anObject geometry class = BlRoundedRectangleGeometry ] + anObject class = BlElement and: [ + anObject geometry class = BlRoundedRectangleGeometry ] ] ] -{ #category : #'as yet unclassified' } +{ #category : #getter } PyramidRoundedRectangleCornerRadiiCommand >> getValueFor: aBlElement [ ^ aBlElement geometry cornerRadii ] -{ #category : #'as yet unclassified' } +{ #category : #setter } PyramidRoundedRectangleCornerRadiiCommand >> setValueFor: aBlElement with: anArgument [ - aBlElement geometry: (BlRoundedRectangleGeometry cornerRadii: anArgument) + aBlElement geometry: + (BlRoundedRectangleGeometry cornerRadii: anArgument) ] diff --git a/src/Pyramid/PyramidToButtonEndIconCommand.class.st b/src/Pyramid/PyramidToButtonEndIconCommand.class.st new file mode 100644 index 00000000..cc65026c --- /dev/null +++ b/src/Pyramid/PyramidToButtonEndIconCommand.class.st @@ -0,0 +1,29 @@ +Class { + #name : #PyramidToButtonEndIconCommand, + #superclass : #PyramidAbstractBlocCommand, + #category : #'Pyramid-plugin-editor' +} + +{ #category : #testing } +PyramidToButtonEndIconCommand >> canBeUsedFor: anObject [ + + ^ (super canBeUsedFor: anObject) and: [ anObject class = ToButton ] +] + +{ #category : #getter } +PyramidToButtonEndIconCommand >> getValueFor: aToButton [ + | form | + aToButton endIcon ifNil: [ ^ '' ]. + form := aToButton endIcon image innerFormImage. + ^ Smalltalk ui icons allIconNames + detect: [ :name | (Smalltalk ui icons iconNamed: name) = form ] + ifNone: [ '' ] +] + +{ #category : #setter } +PyramidToButtonEndIconCommand >> setValueFor: aToButton with: aSymbol [ + | icon | + icon := ToIcon new. + icon iconImage: (Smalltalk ui icons iconNamed: aSymbol). + aToButton endIcon: icon. +] diff --git a/src/Pyramid/PyramidToButtonIconCommand.class.st b/src/Pyramid/PyramidToButtonIconCommand.class.st new file mode 100644 index 00000000..90047c19 --- /dev/null +++ b/src/Pyramid/PyramidToButtonIconCommand.class.st @@ -0,0 +1,31 @@ +Class { + #name : #PyramidToButtonIconCommand, + #superclass : #PyramidAbstractBlocCommand, + #category : #'Pyramid-plugin-editor' +} + +{ #category : #testing } +PyramidToButtonIconCommand >> canBeUsedFor: anObject [ + + ^ (super canBeUsedFor: anObject) and: [ anObject class = ToButton ] +] + +{ #category : #getter } +PyramidToButtonIconCommand >> getValueFor: aToButton [ + + | form | + aToButton icon ifNil: [ ^ '' ]. + form := aToButton icon image innerFormImage. + ^ Smalltalk ui icons allIconNames + detect: [ :name | (Smalltalk ui icons iconNamed: name) = form ] + ifNone: [ '' ] +] + +{ #category : #setter } +PyramidToButtonIconCommand >> setValueFor: aToButton with: aSymbol [ + + | icon | + icon := ToIcon new. + icon iconImage: (Smalltalk ui icons iconNamed: aSymbol). + aToButton icon: icon +] diff --git a/src/Pyramid/PyramidToButtonLabelCommand.class.st b/src/Pyramid/PyramidToButtonLabelCommand.class.st new file mode 100644 index 00000000..4591d27e --- /dev/null +++ b/src/Pyramid/PyramidToButtonLabelCommand.class.st @@ -0,0 +1,22 @@ +Class { + #name : #PyramidToButtonLabelCommand, + #superclass : #PyramidAbstractBlocCommand, + #category : #'Pyramid-plugin-editor' +} + +{ #category : #testing } +PyramidToButtonLabelCommand >> canBeUsedFor: anObject [ + + ^ (super canBeUsedFor: anObject) and: [ anObject class = ToButton ] +] + +{ #category : #getter } +PyramidToButtonLabelCommand >> getValueFor: aToButton [ + + ^ aToButton labelText ifNil: [ '' ] +] + +{ #category : #setter } +PyramidToButtonLabelCommand >> setValueFor: aToButton with: aString [ + aToButton labelText: aString +] diff --git a/src/Pyramid/PyramidToImageInnerImageCommand.class.st b/src/Pyramid/PyramidToImageInnerImageCommand.class.st new file mode 100644 index 00000000..745bdc9c --- /dev/null +++ b/src/Pyramid/PyramidToImageInnerImageCommand.class.st @@ -0,0 +1,28 @@ +Class { + #name : #PyramidToImageInnerImageCommand, + #superclass : #PyramidAbstractBlocCommand, + #category : #'Pyramid-plugin-editor' +} + +{ #category : #testing } +PyramidToImageInnerImageCommand >> canBeUsedFor: anObject [ + + ^ (super canBeUsedFor: anObject) and: [ anObject class = ToImage ] +] + +{ #category : #getter } +PyramidToImageInnerImageCommand >> getValueFor: aToImage [ + + | form | + aToImage innerFormImage ifNil: [ ^ '' ]. + form := aToImage innerFormImage. + ^ Smalltalk ui icons allIconNames + detect: [ :name | (Smalltalk ui icons iconNamed: name) = form ] + ifNone: [ '' ] +] + +{ #category : #setter } +PyramidToImageInnerImageCommand >> setValueFor: aToImage with: aSymbol [ + + aToImage innerImage: (Smalltalk ui icons iconNamed: aSymbol) +] diff --git a/src/Pyramid/PyramidToLabelTextCommand.class.st b/src/Pyramid/PyramidToLabelTextCommand.class.st new file mode 100644 index 00000000..dd347bbb --- /dev/null +++ b/src/Pyramid/PyramidToLabelTextCommand.class.st @@ -0,0 +1,23 @@ +Class { + #name : #PyramidToLabelTextCommand, + #superclass : #PyramidAbstractBlocCommand, + #category : #'Pyramid-plugin-editor' +} + +{ #category : #testing } +PyramidToLabelTextCommand >> canBeUsedFor: anObject [ + + ^ (super canBeUsedFor: anObject) and: [anObject class = ToLabel] +] + +{ #category : #getter } +PyramidToLabelTextCommand >> getValueFor: aToLabel [ + + ^ aToLabel text asString ifNil: [ '' ] +] + +{ #category : #setter } +PyramidToLabelTextCommand >> setValueFor: aToLabel with: aString [ + + aToLabel text: aString +] From 2e8ba2bd53df9cdeab65f8613bb3eae1d5ccd03e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mathieu=20Magu=C3=A9r=C3=A8s?= Date: Thu, 21 May 2026 14:29:29 +0200 Subject: [PATCH 02/22] Rename input fields' names and fix an error regarding the elements selection --- .../PyramidSelectionMakerExtension.class.st | 14 +++++++++++-- src/Pyramid/PyramidEditorPlugin.class.st | 4 ++-- src/Pyramid/PyramidGeometryCommand.class.st | 3 +-- .../PyramidToButtonLabelCommand.class.st | 12 ++++++----- .../PyramidToImageInnerImageCommand.class.st | 21 +++++++------------ .../PyramidToLabelTextCommand.class.st | 8 +++---- 6 files changed, 33 insertions(+), 29 deletions(-) diff --git a/src/Pyramid-Bloc/PyramidSelectionMakerExtension.class.st b/src/Pyramid-Bloc/PyramidSelectionMakerExtension.class.st index f067f356..a02676ee 100644 --- a/src/Pyramid-Bloc/PyramidSelectionMakerExtension.class.st +++ b/src/Pyramid-Bloc/PyramidSelectionMakerExtension.class.st @@ -186,12 +186,22 @@ PyramidSelectionMakerExtension >> selectAllElementsInBound: aBound [ { #category : #'as yet unclassified' } PyramidSelectionMakerExtension >> selectFirstElementAt: aPosition [ - | selectedElements | + | selectedElements filtered isInnerOfImage isInnerOfLabel isLabelOfButton | self projectModel ifNil: [ ^ { } ]. selectedElements := self projectModel allElements select: [ :each | each boundsInSpace containsPoint: aPosition ]. selectedElements ifEmpty: [ ^ { } ]. - ^ { selectedElements last } + filtered := selectedElements reject: [ :e | + isInnerOfImage := e class = BlElement and: [ + e parent class = ToImage ]. + isInnerOfLabel := e class = ToLabelMonoLineInnerElement + and: [ e parent class = ToLabel ]. + isLabelOfButton := e class = ToLabel and: [ + e parent parent class = ToButton ]. + isInnerOfImage or: [ + isInnerOfLabel or: [ isLabelOfButton ] ] ]. + filtered ifEmpty: [ ^ { selectedElements last } ]. + ^ { filtered last } ] { #category : #accessing } diff --git a/src/Pyramid/PyramidEditorPlugin.class.st b/src/Pyramid/PyramidEditorPlugin.class.st index fe8ffb80..64da94cf 100644 --- a/src/Pyramid/PyramidEditorPlugin.class.st +++ b/src/Pyramid/PyramidEditorPlugin.class.st @@ -63,7 +63,7 @@ PyramidEditorPlugin class >> toButtonEndIcon [ | property | property := PyramidProperty new - name: 'EndIcon'; + name: 'End Icon'; command: PyramidToButtonEndIconCommand new; inputPresenterClass: PyramidIconInputPresenter; yourself. @@ -99,7 +99,7 @@ PyramidEditorPlugin class >> toImageInnerImage [ | property | property := PyramidProperty new - name: 'InnerImage'; + name: 'Image'; command: PyramidToImageInnerImageCommand new; inputPresenterClass: PyramidIconInputPresenter; yourself. diff --git a/src/Pyramid/PyramidGeometryCommand.class.st b/src/Pyramid/PyramidGeometryCommand.class.st index 67711ebc..39c7f9e6 100644 --- a/src/Pyramid/PyramidGeometryCommand.class.st +++ b/src/Pyramid/PyramidGeometryCommand.class.st @@ -6,8 +6,7 @@ Class { { #category : #testing } PyramidGeometryCommand >> canBeUsedFor: anObject [ - - ^ (super canBeUsedFor: anObject) and: [ anObject class = BlElement ] + ^ (super canBeUsedFor: anObject) and: [ anObject class = BlElement ] ] { #category : #getter } diff --git a/src/Pyramid/PyramidToButtonLabelCommand.class.st b/src/Pyramid/PyramidToButtonLabelCommand.class.st index 4591d27e..30b6c128 100644 --- a/src/Pyramid/PyramidToButtonLabelCommand.class.st +++ b/src/Pyramid/PyramidToButtonLabelCommand.class.st @@ -7,16 +7,18 @@ Class { { #category : #testing } PyramidToButtonLabelCommand >> canBeUsedFor: anObject [ - ^ (super canBeUsedFor: anObject) and: [ anObject class = ToButton ] + ^ (super canBeUsedFor: anObject) and: [ + anObject class = ToButton ] ] { #category : #getter } -PyramidToButtonLabelCommand >> getValueFor: aToButton [ +PyramidToButtonLabelCommand >> getValueFor: anObject [ - ^ aToButton labelText ifNil: [ '' ] + ^ anObject labelText ifNil: [ '' ] ] { #category : #setter } -PyramidToButtonLabelCommand >> setValueFor: aToButton with: aString [ - aToButton labelText: aString +PyramidToButtonLabelCommand >> setValueFor: anObject with: aString [ + + anObject labelText: aString ] diff --git a/src/Pyramid/PyramidToImageInnerImageCommand.class.st b/src/Pyramid/PyramidToImageInnerImageCommand.class.st index 745bdc9c..fbcfcd7e 100644 --- a/src/Pyramid/PyramidToImageInnerImageCommand.class.st +++ b/src/Pyramid/PyramidToImageInnerImageCommand.class.st @@ -6,23 +6,18 @@ Class { { #category : #testing } PyramidToImageInnerImageCommand >> canBeUsedFor: anObject [ - - ^ (super canBeUsedFor: anObject) and: [ anObject class = ToImage ] + ^ (super canBeUsedFor: anObject) and: [ anObject class = ToImage ] ] { #category : #getter } -PyramidToImageInnerImageCommand >> getValueFor: aToImage [ - - | form | - aToImage innerFormImage ifNil: [ ^ '' ]. - form := aToImage innerFormImage. - ^ Smalltalk ui icons allIconNames - detect: [ :name | (Smalltalk ui icons iconNamed: name) = form ] - ifNone: [ '' ] +PyramidToImageInnerImageCommand >> getValueFor: anObject [ + anObject innerFormImage ifNil: [ ^ '' ]. + ^ Smalltalk ui icons allIconNames + detect: [ :name | (Smalltalk ui icons iconNamed: name) = anObject innerFormImage ] + ifNone: [ '' ] ] { #category : #setter } -PyramidToImageInnerImageCommand >> setValueFor: aToImage with: aSymbol [ - - aToImage innerImage: (Smalltalk ui icons iconNamed: aSymbol) +PyramidToImageInnerImageCommand >> setValueFor: anObject with: aSymbol [ + anObject innerImage: (Smalltalk ui icons iconNamed: aSymbol) ] diff --git a/src/Pyramid/PyramidToLabelTextCommand.class.st b/src/Pyramid/PyramidToLabelTextCommand.class.st index dd347bbb..bfaebdac 100644 --- a/src/Pyramid/PyramidToLabelTextCommand.class.st +++ b/src/Pyramid/PyramidToLabelTextCommand.class.st @@ -7,17 +7,15 @@ Class { { #category : #testing } PyramidToLabelTextCommand >> canBeUsedFor: anObject [ - ^ (super canBeUsedFor: anObject) and: [anObject class = ToLabel] + ^ (super canBeUsedFor: anObject) and: [ anObject class = ToLabel ] ] { #category : #getter } PyramidToLabelTextCommand >> getValueFor: aToLabel [ - - ^ aToLabel text asString ifNil: [ '' ] + ^ aToLabel text asString ifNil: [ '' ] ] { #category : #setter } PyramidToLabelTextCommand >> setValueFor: aToLabel with: aString [ - - aToLabel text: aString + aToLabel text: aString ] From d7123d75a9ddf2e7b2915a223a7494b322734ff4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mathieu=20Magu=C3=A9r=C3=A8s?= Date: Thu, 28 May 2026 11:45:17 +0200 Subject: [PATCH 03/22] add 'Ant Icon' and 'Material Icon' for ToButton and ToImage use ToImage instead of ToIcon for ToButton generalize element selection using parentsShouldSerializeChildren use PyramidExternalRessourceProxy for the serialization --- .../PyramidSelectionMakerExtension.class.st | 13 +- .../PyramidExternalRessourceProxy.class.st | 16 ++ .../PyramidIconInputPresenter.class.st | 182 ++++++++++++++++-- .../PyramidToButtonEndIconCommand.class.st | 47 ++++- .../PyramidToButtonIconCommand.class.st | 46 ++++- .../PyramidToImageInnerImageCommand.class.st | 46 ++++- 6 files changed, 293 insertions(+), 57 deletions(-) diff --git a/src/Pyramid-Bloc/PyramidSelectionMakerExtension.class.st b/src/Pyramid-Bloc/PyramidSelectionMakerExtension.class.st index a02676ee..8713a645 100644 --- a/src/Pyramid-Bloc/PyramidSelectionMakerExtension.class.st +++ b/src/Pyramid-Bloc/PyramidSelectionMakerExtension.class.st @@ -186,20 +186,13 @@ PyramidSelectionMakerExtension >> selectAllElementsInBound: aBound [ { #category : #'as yet unclassified' } PyramidSelectionMakerExtension >> selectFirstElementAt: aPosition [ - | selectedElements filtered isInnerOfImage isInnerOfLabel isLabelOfButton | + | selectedElements filtered | self projectModel ifNil: [ ^ { } ]. selectedElements := self projectModel allElements select: [ :each | each boundsInSpace containsPoint: aPosition ]. selectedElements ifEmpty: [ ^ { } ]. - filtered := selectedElements reject: [ :e | - isInnerOfImage := e class = BlElement and: [ - e parent class = ToImage ]. - isInnerOfLabel := e class = ToLabelMonoLineInnerElement - and: [ e parent class = ToLabel ]. - isLabelOfButton := e class = ToLabel and: [ - e parent parent class = ToButton ]. - isInnerOfImage or: [ - isInnerOfLabel or: [ isLabelOfButton ] ] ]. + filtered := selectedElements select: [ :e | + e parentsShouldSerializeChildren ]. filtered ifEmpty: [ ^ { selectedElements last } ]. ^ { filtered last } ] diff --git a/src/Pyramid/PyramidExternalRessourceProxy.class.st b/src/Pyramid/PyramidExternalRessourceProxy.class.st index 049fdf16..c1035b96 100644 --- a/src/Pyramid/PyramidExternalRessourceProxy.class.st +++ b/src/Pyramid/PyramidExternalRessourceProxy.class.st @@ -33,6 +33,22 @@ PyramidExternalRessourceProxy class >> fromTarget: aTarget selector: aSelector a postConstructionBlock: aBlock) ] +{ #category : #converting } +PyramidExternalRessourceProxy >> asBlBackground [ + + ^ BlBackground image: self +] + +{ #category : #testing } +PyramidExternalRessourceProxy >> asElement [ + + (self pyramidExternalRessourceObject isKindOf: Form ) ifTrue: [ ^ BlElement new + extent: self extent; + background: self; + yourself ]. + ^ self pyramidExternalRessourceObject asElement +] + { #category : #converting } PyramidExternalRessourceProxy >> asStashConstructor [ diff --git a/src/Pyramid/PyramidIconInputPresenter.class.st b/src/Pyramid/PyramidIconInputPresenter.class.st index f4fcc832..66e1a33f 100644 --- a/src/Pyramid/PyramidIconInputPresenter.class.st +++ b/src/Pyramid/PyramidIconInputPresenter.class.st @@ -4,31 +4,170 @@ Class { #instVars : [ 'textInput', 'button', - 'list', - 'whenValueChangedDo' + 'whenValueChangedDo', + 'categoryList', + 'iconList' ], #category : #'Pyramid-specs-custom' } +{ #category : #adding } +PyramidIconInputPresenter class >> toploAntIconCategory [ + + ^ self + toploIconThemeCategoryFromClass: ToAntDesignIconProvider + withCategoryPrefix: 'Ant Design - ' +] + +{ #category : #adding } +PyramidIconInputPresenter class >> toploIconThemeCategoryFromClass: aClass withCategoryPrefix: aString [ + + | categoriesMethods | + categoriesMethods := aClass class methods select: [ :method | + method selector first = $_ and: [ + ($_ split: method selector) last = 'loaded' ] ]. + + ^ categoriesMethods collect: [ :method | + | prefix elementSelectors elements | + prefix := ($_ split: method selector) second. + + elementSelectors := (aClass perform: method selector) collect: [ + :suffix | prefix , '_' , suffix ]. + + elements := elementSelectors collect: [ :selector | + PyramidLibraryElement new + name: selector; + icon: (Smalltalk ui icons iconNamed: #blank); + block: [ + | image | + image := ToImage new + extent: 48 asPoint; + innerImage: + (PyramidExternalRessourceProxy new + pyramidExternalRessourceSource: + (PyramidExternalRessourceSource + new + postConstructionBlock: [ :obj | + obj constraints horizontal + matchParent. + obj constraints vertical + matchParent ]; + target: BlSvgConverter; + selector: #convertFromString:; + arguments: + { (PyramidExternalRessourceProxy + new + + pyramidExternalRessourceSource: + (PyramidExternalRessourceSource + new + target: aClass; + selector: + selector asSymbol; + arguments: { }; + yourself); + yourself) }; + yourself); + yourself). + { image } ]; + yourself ]. + PyramidLibraryCategory new + name: aString , prefix; + icon: (Smalltalk ui icons iconNamed: #image); + elements: elements; + yourself ] +] + +{ #category : #adding } +PyramidIconInputPresenter class >> toploMaterialIconCategory [ + + ^ self + toploIconThemeCategoryFromClass: ToMaterialDesignIconProvider + withCategoryPrefix: 'Material Design - ' +] + +{ #category : #private } +PyramidIconInputPresenter >> buildIconPickerPresenter [ + | categories presenter | + categories := OrderedCollection new. + categories add: (PyramidLibraryCategory new + name: 'Smalltalk Icons'; + icon: (Smalltalk ui icons iconNamed: #image); + elements: + (Smalltalk ui icons allIconNames asSortedCollection collect: [ + :name | + PyramidLibraryElement new + name: name; + icon: (Smalltalk ui icons iconNamed: name); + yourself ]); + yourself). + categories addAll: self class toploAntIconCategory. + categories addAll: self class toploMaterialIconCategory. + categoryList := SpFilteringListPresenter new. + categoryList + items: categories asArray; + display: [ :category | category name ]; + displayIcon: [ :category | category icon ]; + itemFilter: [ :category :filter | + filter isEmpty or: [ + category name asLowercase includesSubstring: filter asLowercase ] ]. + iconList := SpListPresenter new. + iconList + display: [ :element | element name ]; + displayIcon: [ :element | + [ element asForm scaledToSize: 16 @ 16 ] + on: Error + do: [ element icon ifNil: [ #blank ] ] ]. + categoryList whenSelectionChangedDo: [ :selection | + selection isEmpty + ifTrue: [ iconList items: #( ) ] + ifFalse: [ + iconList items: selection selectedItem elements asArray ] ]. + categories isNotEmpty ifTrue: [ categoryList selectIndex: 1 ]. + presenter := SpPresenter new. + presenter layout: (SpBoxLayout newHorizontal + add: categoryList width: 220; + add: iconList; + yourself). + ^ presenter +] + { #category : #layout } PyramidIconInputPresenter >> defaultLayout [ - ^ SpBoxLayout newHorizontal - spacing: 2; - add: textInput; - add: button width: 24; - yourself + spacing: 2; + add: textInput; + add: button width: 24; + yourself +] + +{ #category : #private } +PyramidIconInputPresenter >> iconFormFromName: aSymbol [ + + | iconImage element | + iconImage := Smalltalk ui icons iconNamed: aSymbol. + iconImage = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ + element := (PyramidToploThemePlugin + toploIconThemeCategoryFromClass: + ToAntDesignIconProvider + withCategoryPrefix: '') , (PyramidToploThemePlugin + toploIconThemeCategoryFromClass: + ToMaterialDesignIconProvider + withCategoryPrefix: '') + inject: nil + into: [ :found :cat | + found ifNil: [ + cat elements + detect: [ :e | e name = aSymbol ] + ifNone: [ nil ] ] ]. + element ifNotNil: [ ^ element block value first innerFormImage ] ]. + ^ iconImage ] { #category : #initialization } PyramidIconInputPresenter >> initializePresenters [ whenValueChangedDo := [ :v | ]. - list := SpFilteringListPresenter new. - list items: - Smalltalk ui icons allIconNames asSortedCollection asArray. - list display: [ :name | name ]. - list displayIcon: [ :name | Smalltalk ui icons iconNamed: name ]. textInput := SpTextInputFieldPresenter new. textInput whenSubmitDo: [ :text | whenValueChangedDo value: text ]. button := SpButtonPresenter new @@ -38,31 +177,34 @@ PyramidIconInputPresenter >> initializePresenters [ yourself ] -{ #category : #'as yet unclassified' } +{ #category : #private } PyramidIconInputPresenter >> openIconModal [ - | window dialog | - window := list asModalWindow. + | modalPresenter window dialog selected | + modalPresenter := self buildIconPickerPresenter. + window := modalPresenter asModalWindow. window title: 'Choose an icon'. window centered. dialog := window open. dialog isOk ifFalse: [ ^ self ]. - self value: list selectedItem. - whenValueChangedDo value: list selectedItem + selected := iconList selectedItem. + selected ifNil: [ ^ self ]. + self value: selected name. + whenValueChangedDo value: selected name ] -{ #category : #'as yet unclassified' } +{ #category : #accessing } PyramidIconInputPresenter >> value [ ^ textInput text ] -{ #category : #'as yet unclassified' } +{ #category : #accessing } PyramidIconInputPresenter >> value: aString [ textInput text: (aString ifNil: [ '' ]) ] -{ #category : #'as yet unclassified' } +{ #category : #accessing } PyramidIconInputPresenter >> whenValueChangedDo: aBlock [ whenValueChangedDo := aBlock ] diff --git a/src/Pyramid/PyramidToButtonEndIconCommand.class.st b/src/Pyramid/PyramidToButtonEndIconCommand.class.st index cc65026c..2d32c877 100644 --- a/src/Pyramid/PyramidToButtonEndIconCommand.class.st +++ b/src/Pyramid/PyramidToButtonEndIconCommand.class.st @@ -1,6 +1,9 @@ Class { #name : #PyramidToButtonEndIconCommand, #superclass : #PyramidAbstractBlocCommand, + #instVars : [ + 'endIconName' + ], #category : #'Pyramid-plugin-editor' } @@ -12,18 +15,42 @@ PyramidToButtonEndIconCommand >> canBeUsedFor: anObject [ { #category : #getter } PyramidToButtonEndIconCommand >> getValueFor: aToButton [ - | form | - aToButton endIcon ifNil: [ ^ '' ]. - form := aToButton endIcon image innerFormImage. - ^ Smalltalk ui icons allIconNames - detect: [ :name | (Smalltalk ui icons iconNamed: name) = form ] - ifNone: [ '' ] + + ^ endIconName ifNil: [ ^ '' ] ] { #category : #setter } PyramidToButtonEndIconCommand >> setValueFor: aToButton with: aSymbol [ - | icon | - icon := ToIcon new. - icon iconImage: (Smalltalk ui icons iconNamed: aSymbol). - aToButton endIcon: icon. + + endIconName := aSymbol. + aToButton endIcon: (self toImageFromName: aSymbol) +] + +{ #category : #private } +PyramidToButtonEndIconCommand >> toImageFromName: aSymbol [ + + | element | + (Smalltalk ui icons iconNamed: aSymbol) + = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ + element := (PyramidToploThemePlugin + toploIconThemeCategoryFromClass: + ToAntDesignIconProvider + withCategoryPrefix: '') , (PyramidToploThemePlugin + toploIconThemeCategoryFromClass: + ToMaterialDesignIconProvider + withCategoryPrefix: '') + inject: nil + into: [ :found :cat | + found ifNil: [ + cat elements + detect: [ :e | e name = aSymbol ] + ifNone: [ nil ] ] ]. + element ifNotNil: [ ^ element block value first ] ]. + ^ ToImage new + innerImage: (PyramidExternalRessourceProxy fromSource: + (PyramidExternalRessourceSource + target: Object + selector: #iconNamed: + arguments: { aSymbol })); + yourself ] diff --git a/src/Pyramid/PyramidToButtonIconCommand.class.st b/src/Pyramid/PyramidToButtonIconCommand.class.st index 90047c19..0219cb52 100644 --- a/src/Pyramid/PyramidToButtonIconCommand.class.st +++ b/src/Pyramid/PyramidToButtonIconCommand.class.st @@ -1,6 +1,9 @@ Class { #name : #PyramidToButtonIconCommand, #superclass : #PyramidAbstractBlocCommand, + #instVars : [ + 'iconName' + ], #category : #'Pyramid-plugin-editor' } @@ -13,19 +16,42 @@ PyramidToButtonIconCommand >> canBeUsedFor: anObject [ { #category : #getter } PyramidToButtonIconCommand >> getValueFor: aToButton [ - | form | - aToButton icon ifNil: [ ^ '' ]. - form := aToButton icon image innerFormImage. - ^ Smalltalk ui icons allIconNames - detect: [ :name | (Smalltalk ui icons iconNamed: name) = form ] - ifNone: [ '' ] + ^ iconName ifNil: [ ^ '' ] + ] { #category : #setter } PyramidToButtonIconCommand >> setValueFor: aToButton with: aSymbol [ - | icon | - icon := ToIcon new. - icon iconImage: (Smalltalk ui icons iconNamed: aSymbol). - aToButton icon: icon + iconName := aSymbol. + aToButton icon: (self toImageFromName: aSymbol) +] + +{ #category : #private } +PyramidToButtonIconCommand >> toImageFromName: aSymbol [ + + | element | + (Smalltalk ui icons iconNamed: aSymbol) + = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ + element := (PyramidToploThemePlugin + toploIconThemeCategoryFromClass: + ToAntDesignIconProvider + withCategoryPrefix: '') , (PyramidToploThemePlugin + toploIconThemeCategoryFromClass: + ToMaterialDesignIconProvider + withCategoryPrefix: '') + inject: nil + into: [ :found :cat | + found ifNil: [ + cat elements + detect: [ :e | e name = aSymbol ] + ifNone: [ nil ] ] ]. + element ifNotNil: [ ^ element block value first ] ]. + ^ ToImage new + innerImage: (PyramidExternalRessourceProxy fromSource: + (PyramidExternalRessourceSource + target: Object + selector: #iconNamed: + arguments: { aSymbol })); + yourself ] diff --git a/src/Pyramid/PyramidToImageInnerImageCommand.class.st b/src/Pyramid/PyramidToImageInnerImageCommand.class.st index fbcfcd7e..01f20541 100644 --- a/src/Pyramid/PyramidToImageInnerImageCommand.class.st +++ b/src/Pyramid/PyramidToImageInnerImageCommand.class.st @@ -1,6 +1,9 @@ Class { #name : #PyramidToImageInnerImageCommand, #superclass : #PyramidAbstractBlocCommand, + #instVars : [ + 'iconName' + ], #category : #'Pyramid-plugin-editor' } @@ -10,14 +13,43 @@ PyramidToImageInnerImageCommand >> canBeUsedFor: anObject [ ] { #category : #getter } -PyramidToImageInnerImageCommand >> getValueFor: anObject [ - anObject innerFormImage ifNil: [ ^ '' ]. - ^ Smalltalk ui icons allIconNames - detect: [ :name | (Smalltalk ui icons iconNamed: name) = anObject innerFormImage ] - ifNone: [ '' ] +PyramidToImageInnerImageCommand >> getValueFor: aToImage [ + + ^ iconName ifNil: [ ^ '' ] ] { #category : #setter } -PyramidToImageInnerImageCommand >> setValueFor: anObject with: aSymbol [ - anObject innerImage: (Smalltalk ui icons iconNamed: aSymbol) +PyramidToImageInnerImageCommand >> setValueFor: aToImage with: aSymbol [ + + iconName := aSymbol. + aToImage innerImage: (self toImageFromName: aSymbol) +] + +{ #category : #private } +PyramidToImageInnerImageCommand >> toImageFromName: aSymbol [ + + | element | + (Smalltalk ui icons iconNamed: aSymbol) + = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ + element := (PyramidToploThemePlugin + toploIconThemeCategoryFromClass: + ToAntDesignIconProvider + withCategoryPrefix: '') , (PyramidToploThemePlugin + toploIconThemeCategoryFromClass: + ToMaterialDesignIconProvider + withCategoryPrefix: '') + inject: nil + into: [ :found :cat | + found ifNil: [ + cat elements + detect: [ :e | e name = aSymbol ] + ifNone: [ nil ] ] ]. + element ifNotNil: [ ^ element block value first ] ]. + ^ ToImage new + innerImage: (PyramidExternalRessourceProxy fromSource: + (PyramidExternalRessourceSource + target: Object + selector: #iconNamed: + arguments: { aSymbol })); + yourself ] From fe88e369649608603ce753d8e1d27ad16403a3f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mathieu=20Magu=C3=A9r=C3=A8s?= Date: Wed, 3 Jun 2026 10:25:34 +0200 Subject: [PATCH 04/22] update methods and fix an issue with the filter in the presenter --- .../PyramidToploThemePlugin.class.st | 8 +- .../PyramidIconInputPresenter.class.st | 156 ++++++++++-------- .../PyramidToButtonEndIconCommand.class.st | 31 +--- .../PyramidToButtonIconCommand.class.st | 31 +--- .../PyramidToImageInnerImageCommand.class.st | 31 +--- 5 files changed, 94 insertions(+), 163 deletions(-) diff --git a/src/Pyramid-Toplo/PyramidToploThemePlugin.class.st b/src/Pyramid-Toplo/PyramidToploThemePlugin.class.st index b1164fa2..dca929dd 100644 --- a/src/Pyramid-Toplo/PyramidToploThemePlugin.class.st +++ b/src/Pyramid-Toplo/PyramidToploThemePlugin.class.st @@ -45,9 +45,7 @@ PyramidToploThemePlugin class >> defaultThemeSettingOn: aBuilder [ PyramidToploThemePlugin class >> toploAntIconCategory [ - ^ PyramidToploThemePlugin - toploIconThemeCategoryFromClass: ToAntDesignIconProvider - withCategoryPrefix: 'Ant Design - ' + ^ PyramidIconInputPresenter toploAntIconCategory ] { #category : #adding } @@ -140,9 +138,7 @@ PyramidToploThemePlugin class >> toploLibraryCategory [ PyramidToploThemePlugin class >> toploMaterialIconCategory [ - ^ PyramidToploThemePlugin - toploIconThemeCategoryFromClass: ToMaterialDesignIconProvider - withCategoryPrefix: 'Material Design - ' + ^ PyramidIconInputPresenter toploMaterialIconCategory ] { #category : #adding } diff --git a/src/Pyramid/PyramidIconInputPresenter.class.st b/src/Pyramid/PyramidIconInputPresenter.class.st index 66e1a33f..55b83f06 100644 --- a/src/Pyramid/PyramidIconInputPresenter.class.st +++ b/src/Pyramid/PyramidIconInputPresenter.class.st @@ -11,6 +11,38 @@ Class { #category : #'Pyramid-specs-custom' } +{ #category : #private } +PyramidIconInputPresenter class >> findToploIconNamed: aSymbol [ + ^ (self + toploIconThemeCategoryFromClass: ToAntDesignIconProvider + withCategoryPrefix: '') , + (self + toploIconThemeCategoryFromClass: ToMaterialDesignIconProvider + withCategoryPrefix: '') + inject: nil + into: [ :found :cat | + found ifNil: [ + cat elements + detect: [ :e | e name = aSymbol ] + ifNone: [ nil ] ] ] +] + +{ #category : #private } +PyramidIconInputPresenter class >> toImageFromName: aSymbol [ + | element | + (Smalltalk ui icons iconNamed: aSymbol) + = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ + element := self findToploIconNamed: aSymbol. + element ifNotNil: [ ^ element block value first ] ]. + ^ ToImage new + innerImage: (PyramidExternalRessourceProxy fromSource: + (PyramidExternalRessourceSource + target: Object + selector: #iconNamed: + arguments: { aSymbol })); + yourself +] + { #category : #adding } PyramidIconInputPresenter class >> toploAntIconCategory [ @@ -88,48 +120,59 @@ PyramidIconInputPresenter class >> toploMaterialIconCategory [ { #category : #private } PyramidIconInputPresenter >> buildIconPickerPresenter [ - | categories presenter | - categories := OrderedCollection new. - categories add: (PyramidLibraryCategory new - name: 'Smalltalk Icons'; - icon: (Smalltalk ui icons iconNamed: #image); - elements: - (Smalltalk ui icons allIconNames asSortedCollection collect: [ - :name | - PyramidLibraryElement new - name: name; - icon: (Smalltalk ui icons iconNamed: name); - yourself ]); - yourself). - categories addAll: self class toploAntIconCategory. - categories addAll: self class toploMaterialIconCategory. - categoryList := SpFilteringListPresenter new. - categoryList - items: categories asArray; - display: [ :category | category name ]; - displayIcon: [ :category | category icon ]; - itemFilter: [ :category :filter | - filter isEmpty or: [ - category name asLowercase includesSubstring: filter asLowercase ] ]. - iconList := SpListPresenter new. - iconList - display: [ :element | element name ]; - displayIcon: [ :element | - [ element asForm scaledToSize: 16 @ 16 ] - on: Error - do: [ element icon ifNil: [ #blank ] ] ]. - categoryList whenSelectionChangedDo: [ :selection | - selection isEmpty - ifTrue: [ iconList items: #( ) ] - ifFalse: [ - iconList items: selection selectedItem elements asArray ] ]. - categories isNotEmpty ifTrue: [ categoryList selectIndex: 1 ]. - presenter := SpPresenter new. - presenter layout: (SpBoxLayout newHorizontal - add: categoryList width: 220; - add: iconList; - yourself). - ^ presenter + + | categories presenter | + categories := OrderedCollection new. + categories add: (PyramidLibraryCategory new + name: 'Smalltalk Icons'; + icon: (Smalltalk ui icons iconNamed: #image); + elements: + (Smalltalk ui icons allIconNames asSortedCollection collect: [ + :name | + PyramidLibraryElement new + name: name asString; + icon: (Smalltalk ui icons iconNamed: name); + yourself ]); + yourself). + + categories addAll: self class toploAntIconCategory. + categories addAll: self class toploMaterialIconCategory. + + categoryList := SpListPresenter new. + categoryList + items: categories asArray; + display: [ :category | category name ]; + displayIcon: [ :category | category icon ]. + + + iconList := SpFilteringListPresenter new. + iconList + display: [ :element | element name ]; + displayIcon: [ :element | + | icon | + icon := element icon. + (icon isNil or: [ icon = (Smalltalk ui icons iconNamed: #blank) ]) + ifTrue: [ + [ element asForm scaledToSize: 16 @ 16 ] + on: Error + do: [ Smalltalk ui icons iconNamed: #blank ] ] + ifFalse: [ icon ] ]; + itemFilter: [ :element :filter | + filter isEmpty or: [ + element asLowercase includesSubstring: filter asLowercase ] ]. + + categoryList whenSelectionChangedDo: [ :selection | + selection isEmpty + ifTrue: [ iconList items: #( ) ] + ifFalse: [ + iconList items: selection selectedItem elements asArray ] ]. + categories isNotEmpty ifTrue: [ categoryList selectIndex: 1 ]. + presenter := SpPresenter new. + presenter layout: (SpBoxLayout newHorizontal + add: categoryList width: 220; + add: iconList; + yourself). + ^ presenter -> iconList ] { #category : #layout } @@ -141,29 +184,6 @@ PyramidIconInputPresenter >> defaultLayout [ yourself ] -{ #category : #private } -PyramidIconInputPresenter >> iconFormFromName: aSymbol [ - - | iconImage element | - iconImage := Smalltalk ui icons iconNamed: aSymbol. - iconImage = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ - element := (PyramidToploThemePlugin - toploIconThemeCategoryFromClass: - ToAntDesignIconProvider - withCategoryPrefix: '') , (PyramidToploThemePlugin - toploIconThemeCategoryFromClass: - ToMaterialDesignIconProvider - withCategoryPrefix: '') - inject: nil - into: [ :found :cat | - found ifNil: [ - cat elements - detect: [ :e | e name = aSymbol ] - ifNone: [ nil ] ] ]. - element ifNotNil: [ ^ element block value first innerFormImage ] ]. - ^ iconImage -] - { #category : #initialization } PyramidIconInputPresenter >> initializePresenters [ @@ -180,8 +200,10 @@ PyramidIconInputPresenter >> initializePresenters [ { #category : #private } PyramidIconInputPresenter >> openIconModal [ - | modalPresenter window dialog selected | - modalPresenter := self buildIconPickerPresenter. + | result modalPresenter window dialog selected | + result := self buildIconPickerPresenter. + modalPresenter := result key. + iconList := result value. window := modalPresenter asModalWindow. window title: 'Choose an icon'. window centered. diff --git a/src/Pyramid/PyramidToButtonEndIconCommand.class.st b/src/Pyramid/PyramidToButtonEndIconCommand.class.st index 2d32c877..8c69013e 100644 --- a/src/Pyramid/PyramidToButtonEndIconCommand.class.st +++ b/src/Pyramid/PyramidToButtonEndIconCommand.class.st @@ -23,34 +23,5 @@ PyramidToButtonEndIconCommand >> getValueFor: aToButton [ PyramidToButtonEndIconCommand >> setValueFor: aToButton with: aSymbol [ endIconName := aSymbol. - aToButton endIcon: (self toImageFromName: aSymbol) -] - -{ #category : #private } -PyramidToButtonEndIconCommand >> toImageFromName: aSymbol [ - - | element | - (Smalltalk ui icons iconNamed: aSymbol) - = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ - element := (PyramidToploThemePlugin - toploIconThemeCategoryFromClass: - ToAntDesignIconProvider - withCategoryPrefix: '') , (PyramidToploThemePlugin - toploIconThemeCategoryFromClass: - ToMaterialDesignIconProvider - withCategoryPrefix: '') - inject: nil - into: [ :found :cat | - found ifNil: [ - cat elements - detect: [ :e | e name = aSymbol ] - ifNone: [ nil ] ] ]. - element ifNotNil: [ ^ element block value first ] ]. - ^ ToImage new - innerImage: (PyramidExternalRessourceProxy fromSource: - (PyramidExternalRessourceSource - target: Object - selector: #iconNamed: - arguments: { aSymbol })); - yourself + aToButton endIcon: (PyramidIconInputPresenter toImageFromName: aSymbol) ] diff --git a/src/Pyramid/PyramidToButtonIconCommand.class.st b/src/Pyramid/PyramidToButtonIconCommand.class.st index 0219cb52..203b067b 100644 --- a/src/Pyramid/PyramidToButtonIconCommand.class.st +++ b/src/Pyramid/PyramidToButtonIconCommand.class.st @@ -24,34 +24,5 @@ PyramidToButtonIconCommand >> getValueFor: aToButton [ PyramidToButtonIconCommand >> setValueFor: aToButton with: aSymbol [ iconName := aSymbol. - aToButton icon: (self toImageFromName: aSymbol) -] - -{ #category : #private } -PyramidToButtonIconCommand >> toImageFromName: aSymbol [ - - | element | - (Smalltalk ui icons iconNamed: aSymbol) - = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ - element := (PyramidToploThemePlugin - toploIconThemeCategoryFromClass: - ToAntDesignIconProvider - withCategoryPrefix: '') , (PyramidToploThemePlugin - toploIconThemeCategoryFromClass: - ToMaterialDesignIconProvider - withCategoryPrefix: '') - inject: nil - into: [ :found :cat | - found ifNil: [ - cat elements - detect: [ :e | e name = aSymbol ] - ifNone: [ nil ] ] ]. - element ifNotNil: [ ^ element block value first ] ]. - ^ ToImage new - innerImage: (PyramidExternalRessourceProxy fromSource: - (PyramidExternalRessourceSource - target: Object - selector: #iconNamed: - arguments: { aSymbol })); - yourself + aToButton icon: (PyramidIconInputPresenter toImageFromName: aSymbol) ] diff --git a/src/Pyramid/PyramidToImageInnerImageCommand.class.st b/src/Pyramid/PyramidToImageInnerImageCommand.class.st index 01f20541..ec7f3b1e 100644 --- a/src/Pyramid/PyramidToImageInnerImageCommand.class.st +++ b/src/Pyramid/PyramidToImageInnerImageCommand.class.st @@ -22,34 +22,5 @@ PyramidToImageInnerImageCommand >> getValueFor: aToImage [ PyramidToImageInnerImageCommand >> setValueFor: aToImage with: aSymbol [ iconName := aSymbol. - aToImage innerImage: (self toImageFromName: aSymbol) -] - -{ #category : #private } -PyramidToImageInnerImageCommand >> toImageFromName: aSymbol [ - - | element | - (Smalltalk ui icons iconNamed: aSymbol) - = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ - element := (PyramidToploThemePlugin - toploIconThemeCategoryFromClass: - ToAntDesignIconProvider - withCategoryPrefix: '') , (PyramidToploThemePlugin - toploIconThemeCategoryFromClass: - ToMaterialDesignIconProvider - withCategoryPrefix: '') - inject: nil - into: [ :found :cat | - found ifNil: [ - cat elements - detect: [ :e | e name = aSymbol ] - ifNone: [ nil ] ] ]. - element ifNotNil: [ ^ element block value first ] ]. - ^ ToImage new - innerImage: (PyramidExternalRessourceProxy fromSource: - (PyramidExternalRessourceSource - target: Object - selector: #iconNamed: - arguments: { aSymbol })); - yourself + aToImage innerImage: (PyramidIconInputPresenter toImageFromName: aSymbol) ] From 0c1222958fba655928b3a8f677e9a8d99d041877 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mathieu=20Magu=C3=A9r=C3=A8s?= Date: Thu, 4 Jun 2026 13:23:10 +0200 Subject: [PATCH 05/22] Add a feature that allows opening the interface in a window --- .../PyramidPluginOpenInWindow.class.st | 95 +++++++++++++++++++ .../PyramidDynamicLayoutStrategy.class.st | 2 +- src/Pyramid/PyramidPanelModel.class.st | 11 +++ .../PyramidToolbarPanelBuilder.class.st | 16 +++- src/Pyramid/PyramidWindow.class.st | 4 +- 5 files changed, 124 insertions(+), 4 deletions(-) create mode 100644 src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st diff --git a/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st b/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st new file mode 100644 index 00000000..91d853dd --- /dev/null +++ b/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st @@ -0,0 +1,95 @@ +Class { + #name : #PyramidPluginOpenInWindow, + #superclass : #Object, + #traits : 'TPyramidPlugin + TPyramidEditorExtension', + #classTraits : 'TPyramidPlugin classTrait + TPyramidEditorExtension classTrait', + #instVars : [ + 'button', + 'spacePlugin', + 'builder', + 'projectModel', + 'savePlugin' + ], + #category : #'Pyramid-Bloc-plugin-openinwindow' +} + +{ #category : #adding } +PyramidPluginOpenInWindow >> addPanelsOn: aPyramidSimpleWindow [ + + aPyramidSimpleWindow + at: #topRight + addItem: [ :b | b makeButtonWithIcon: self button order: 1 ]. +] + +{ #category : #accessing } +PyramidPluginOpenInWindow >> builder [ + ^ builder +] + +{ #category : #accessing } +PyramidPluginOpenInWindow >> button [ + + ^ button +] + +{ #category : #connecting } +PyramidPluginOpenInWindow >> connectOn: aPyramidEditor [ + spacePlugin := aPyramidEditor plugins + detect: [ :p | p isKindOf: PyramidSpacePlugin ] + ifNone: [ ]. + spacePlugin ifNotNil: [ builder := spacePlugin builder ]. + projectModel := aPyramidEditor projectModel. + savePlugin := aPyramidEditor plugins + detect: [ :p | p isKindOf: PyramidSavePlugin ] + ifNone: [ ] +] + +{ #category : #initialization } +PyramidPluginOpenInWindow >> initialize [ + button := SpButtonPresenter new + icon: self openInWindowIcon; + help: 'Open interface in a separate window.'; + action: [ self openSpaceInWindow ]; + yourself +] + +{ #category : #'as yet unclassified' } +PyramidPluginOpenInWindow >> openInWindowIcon [ + + ^ Smalltalk ui icons iconNamed: #glamorousInspect +] + +{ #category : #'as yet unclassified' } +PyramidPluginOpenInWindow >> openSpaceInWindow [ + + | elements stash newElements space | + projectModel ifNil: [ ^ self inform: 'No project found.' ]. + + elements := projectModel firstLevelElements asOrderedCollection. + elements ifEmpty: [ ^ self inform: 'Nothing to display.' ]. + + elements size = 1 + ifTrue: [ + stash := BlSerializer + serialize: elements first + with: BlStashSerializer. + newElements := { stash materializeAsBlElement } ] + ifFalse: [ + | container | + container := BlElement new + extent: 4000 @ 2000; + yourself. + elements do: [ :each | + stash := BlSerializer serialize: each with: BlStashSerializer. + container addChild: stash materializeAsBlElement ]. + newElements := { container } ]. + + space := newElements first openInNewSpace. + newElements size > 1 ifTrue: [ + space root addChildren: newElements allButFirst ] +] + +{ #category : #accessing } +PyramidPluginOpenInWindow >> projectModel [ + ^ projectModel +] diff --git a/src/Pyramid/PyramidDynamicLayoutStrategy.class.st b/src/Pyramid/PyramidDynamicLayoutStrategy.class.st index 8503c2a0..3865f975 100644 --- a/src/Pyramid/PyramidDynamicLayoutStrategy.class.st +++ b/src/Pyramid/PyramidDynamicLayoutStrategy.class.st @@ -59,6 +59,6 @@ PyramidDynamicLayoutStrategy >> topLayoutFor: aWindow [ layout add: SpNullPresenter new expand: true. layout add: (aWindow services at: #topCenter) presenter expand: true. layout add: SpNullPresenter new expand: true. - layout add: (aWindow services at: #topRight) presenter expand: false. + layout add: (aWindow services at: #topRight) presenter expand: true. ^ layout ] diff --git a/src/Pyramid/PyramidPanelModel.class.st b/src/Pyramid/PyramidPanelModel.class.st index b9485ade..2008dc09 100644 --- a/src/Pyramid/PyramidPanelModel.class.st +++ b/src/Pyramid/PyramidPanelModel.class.st @@ -42,6 +42,17 @@ PyramidPanelModel class >> toolbarHorizontal [ yourself ] +{ #category : #'as yet unclassified' } +PyramidPanelModel class >> toolbarHorizontalEnd [ + + ^ self new + builder: (PyramidToolbarPanelBuilder new + isHorizontal: true; + alignEnd: true; + yourself); + yourself +] + { #category : #'as yet unclassified' } PyramidPanelModel class >> toolbarVertical [ diff --git a/src/Pyramid/PyramidToolbarPanelBuilder.class.st b/src/Pyramid/PyramidToolbarPanelBuilder.class.st index cb40c62d..d412d69d 100644 --- a/src/Pyramid/PyramidToolbarPanelBuilder.class.st +++ b/src/Pyramid/PyramidToolbarPanelBuilder.class.st @@ -3,11 +3,24 @@ Class { #superclass : #PyramidPanelBuilder, #instVars : [ 'item', - 'isHorizontal' + 'isHorizontal', + 'alignEnd' ], #category : #'Pyramid-views' } +{ #category : #accessing } +PyramidToolbarPanelBuilder >> alignEnd [ + + ^ alignEnd ifNil: [ false ] +] + +{ #category : #accessing } +PyramidToolbarPanelBuilder >> alignEnd: aBoolean [ + +alignEnd := aBoolean +] + { #category : #accessing } PyramidToolbarPanelBuilder >> height [ @@ -69,6 +82,7 @@ PyramidToolbarPanelBuilder >> presenterOf: aCollectionOfItems [ | layout | layout := self layout. + self alignEnd ifTrue: [ layout hAlignEnd ]. aCollectionOfItems sorted do: [ :each | each addOnLayout: layout ]. ^ SpPresenter new layout: layout; diff --git a/src/Pyramid/PyramidWindow.class.st b/src/Pyramid/PyramidWindow.class.st index 17d650ef..230862c4 100644 --- a/src/Pyramid/PyramidWindow.class.st +++ b/src/Pyramid/PyramidWindow.class.st @@ -70,11 +70,11 @@ PyramidWindow >> close [ PyramidWindow >> initialize [ title := self class defaultTitle. - whenClosedDo := [ ]. + whenClosedDo := [ ]. PyramidPanelModel toolbarHorizontal installOn: self at: #topLeft. PyramidPanelModel toolbarHorizontal installOn: self at: #topCenter. - PyramidPanelModel toolbarHorizontal installOn: self at: #topRight. + PyramidPanelModel toolbarHorizontalEnd installOn: self at: #topRight. PyramidPanelModel presenter installOn: self at: #space. PyramidPanelModel tab installOn: self at: #tabLeft. PyramidPanelModel tab installOn: self at: #tabRight. From 8a69e6e12cb04f9c415f9daf9e29581a0459b1de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mathieu=20Magu=C3=A9r=C3=A8s?= Date: Thu, 4 Jun 2026 13:38:27 +0200 Subject: [PATCH 06/22] fix problems with PyramidGeometryCommand and PyramidRoundedRectangleCornerRadiiCommand --- src/Pyramid/PyramidGeometryCommand.class.st | 7 ++++--- .../PyramidRoundedRectangleCornerRadiiCommand.class.st | 6 +++--- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Pyramid/PyramidGeometryCommand.class.st b/src/Pyramid/PyramidGeometryCommand.class.st index 39c7f9e6..4cc0574b 100644 --- a/src/Pyramid/PyramidGeometryCommand.class.st +++ b/src/Pyramid/PyramidGeometryCommand.class.st @@ -6,17 +6,18 @@ Class { { #category : #testing } PyramidGeometryCommand >> canBeUsedFor: anObject [ - ^ (super canBeUsedFor: anObject) and: [ anObject class = BlElement ] + + ^ (super canBeUsedFor: anObject) and: [ anObject class = BlElement ] ] { #category : #getter } -PyramidGeometryCommand >> getValueFor: aBlElement [ +PyramidGeometryCommand >> getValueFor: aBlElement [ ^ aBlElement geometry ] { #category : #setter } -PyramidGeometryCommand >> setValueFor: aBlElement with: anArgument [ +PyramidGeometryCommand >> setValueFor: aBlElement with: anArgument [ aBlElement geometry: anArgument ] diff --git a/src/Pyramid/PyramidRoundedRectangleCornerRadiiCommand.class.st b/src/Pyramid/PyramidRoundedRectangleCornerRadiiCommand.class.st index 617f15d5..28389f8d 100644 --- a/src/Pyramid/PyramidRoundedRectangleCornerRadiiCommand.class.st +++ b/src/Pyramid/PyramidRoundedRectangleCornerRadiiCommand.class.st @@ -5,7 +5,7 @@ Class { } { #category : #testing } -PyramidRoundedRectangleCornerRadiiCommand >> canBeUsedFor: anObject [ +PyramidRoundedRectangleCornerRadiiCommand >> canBeUsedFor: anObject [ ^ (super canBeUsedFor: anObject) and: [ anObject class = BlElement and: [ @@ -13,13 +13,13 @@ PyramidRoundedRectangleCornerRadiiCommand >> canBeUsedFor: anObject [ ] { #category : #getter } -PyramidRoundedRectangleCornerRadiiCommand >> getValueFor: aBlElement [ +PyramidRoundedRectangleCornerRadiiCommand >> getValueFor: aBlElement [ ^ aBlElement geometry cornerRadii ] { #category : #setter } -PyramidRoundedRectangleCornerRadiiCommand >> setValueFor: aBlElement with: anArgument [ +PyramidRoundedRectangleCornerRadiiCommand >> setValueFor: aBlElement with: anArgument [ aBlElement geometry: (BlRoundedRectangleGeometry cornerRadii: anArgument) From 009fe3d1d27b80d0e73d9eecb7190d69c6a874f4 Mon Sep 17 00:00:00 2001 From: Mathieu Magueres Date: Mon, 8 Jun 2026 10:07:36 +0200 Subject: [PATCH 07/22] update the button icon and apply the theme to the new window + arrange the methods --- .../PyramidPluginOpenInWindow.class.st | 45 +++++++++---------- .../TPyramidEditorExtension.trait.st | 12 ++--- 2 files changed, 26 insertions(+), 31 deletions(-) diff --git a/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st b/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st index 91d853dd..3d49ec86 100644 --- a/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st +++ b/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st @@ -53,40 +53,35 @@ PyramidPluginOpenInWindow >> initialize [ yourself ] -{ #category : #'as yet unclassified' } +{ #category : #private } PyramidPluginOpenInWindow >> openInWindowIcon [ - ^ Smalltalk ui icons iconNamed: #glamorousInspect + | svgString coloredSvg blElement | + svgString := ToMaterialDesignIconProvider sharp_openinnew. + coloredSvg := svgString + copyReplaceAll: '> openSpaceInWindow [ - | elements stash newElements space | + | elements container stash space currentTheme | projectModel ifNil: [ ^ self inform: 'No project found.' ]. - elements := projectModel firstLevelElements asOrderedCollection. elements ifEmpty: [ ^ self inform: 'Nothing to display.' ]. - - elements size = 1 - ifTrue: [ - stash := BlSerializer - serialize: elements first - with: BlStashSerializer. - newElements := { stash materializeAsBlElement } ] - ifFalse: [ - | container | - container := BlElement new - extent: 4000 @ 2000; - yourself. - elements do: [ :each | - stash := BlSerializer serialize: each with: BlStashSerializer. - container addChild: stash materializeAsBlElement ]. - newElements := { container } ]. - - space := newElements first openInNewSpace. - newElements size > 1 ifTrue: [ - space root addChildren: newElements allButFirst ] + currentTheme := builder space root localTheme. + container := BlElement new + extent: 4000 @ 2000; + yourself. + elements do: [ :each | + stash := BlSerializer serialize: each with: BlStashSerializer. + container addChild: stash materializeAsBlElement ]. + space := container openInNewSpace. + currentTheme ifNotNil: [ space toTheme: currentTheme ] ] { #category : #accessing } diff --git a/src/Pyramid-Bloc/TPyramidEditorExtension.trait.st b/src/Pyramid-Bloc/TPyramidEditorExtension.trait.st index 231adbff..6dcdca47 100644 --- a/src/Pyramid-Bloc/TPyramidEditorExtension.trait.st +++ b/src/Pyramid-Bloc/TPyramidEditorExtension.trait.st @@ -11,37 +11,37 @@ TPyramidEditorExtension >> currentTransformTranslation [ ^ matrix x @ matrix y ] -{ #category : #'as yet unclassified' } +{ #category : #displaying } TPyramidEditorExtension >> elementAtDisplays [ ^ (self builder elementAt: #displays) ] -{ #category : #'as yet unclassified' } +{ #category : #displaying } TPyramidEditorExtension >> elementAtDisplaysAddons [ ^ self elementAtDisplays childWithId: #displaysAddons ] -{ #category : #'as yet unclassified' } +{ #category : #displaying } TPyramidEditorExtension >> elementAtEvents [ ^ self builder elementAt: #events ] -{ #category : #'as yet unclassified' } +{ #category : #displaying } TPyramidEditorExtension >> elementAtMain [ ^ self builder elementAt: #main ] -{ #category : #'as yet unclassified' } +{ #category : #displaying } TPyramidEditorExtension >> elementAtTransforms [ ^ (self builder elementAt: #transforms) ] -{ #category : #'as yet unclassified' } +{ #category : #displaying } TPyramidEditorExtension >> elementAtWidgets [ ^ self builder elementAt: #widgets From 8ee8a1e05e8ac7a7b7807d7a6916fd677057a39a Mon Sep 17 00:00:00 2001 From: Mathieu Magueres Date: Tue, 9 Jun 2026 09:15:35 +0200 Subject: [PATCH 08/22] Use a Form as innerImage instead of a ToImage to avoid nesting ToImage inside ToImage --- .../PyramidIconInputPresenter.class.st | 40 +++++++++++++------ .../PyramidToImageInnerImageCommand.class.st | 3 +- 2 files changed, 30 insertions(+), 13 deletions(-) diff --git a/src/Pyramid/PyramidIconInputPresenter.class.st b/src/Pyramid/PyramidIconInputPresenter.class.st index 55b83f06..8b9b6d9f 100644 --- a/src/Pyramid/PyramidIconInputPresenter.class.st +++ b/src/Pyramid/PyramidIconInputPresenter.class.st @@ -27,20 +27,36 @@ PyramidIconInputPresenter class >> findToploIconNamed: aSymbol [ ifNone: [ nil ] ] ] ] +{ #category : #private } +PyramidIconInputPresenter class >> innerElementFromName: aSymbol [ + + (Smalltalk ui icons iconNamed: aSymbol) + = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ + | element | + element := self findToploIconNamed: aSymbol. + element ifNotNil: [ ^ element block value first asForm ] ]. + ^ PyramidExternalRessourceProxy fromSource: + (PyramidExternalRessourceSource + target: Object + selector: #iconNamed: + arguments: { aSymbol }) +] + { #category : #private } PyramidIconInputPresenter class >> toImageFromName: aSymbol [ - | element | - (Smalltalk ui icons iconNamed: aSymbol) - = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ - element := self findToploIconNamed: aSymbol. - element ifNotNil: [ ^ element block value first ] ]. - ^ ToImage new - innerImage: (PyramidExternalRessourceProxy fromSource: - (PyramidExternalRessourceSource - target: Object - selector: #iconNamed: - arguments: { aSymbol })); - yourself + + (Smalltalk ui icons iconNamed: aSymbol) + = (Smalltalk ui icons iconNamed: #blank) ifTrue: [ + | element | + element := self findToploIconNamed: aSymbol. + element ifNotNil: [^ element block value first ] ]. + ^ ToImage new + innerImage: (PyramidExternalRessourceProxy fromSource: + (PyramidExternalRessourceSource + target: Object + selector: #iconNamed: + arguments: { aSymbol })); + yourself ] { #category : #adding } diff --git a/src/Pyramid/PyramidToImageInnerImageCommand.class.st b/src/Pyramid/PyramidToImageInnerImageCommand.class.st index ec7f3b1e..b38914ac 100644 --- a/src/Pyramid/PyramidToImageInnerImageCommand.class.st +++ b/src/Pyramid/PyramidToImageInnerImageCommand.class.st @@ -22,5 +22,6 @@ PyramidToImageInnerImageCommand >> getValueFor: aToImage [ PyramidToImageInnerImageCommand >> setValueFor: aToImage with: aSymbol [ iconName := aSymbol. - aToImage innerImage: (PyramidIconInputPresenter toImageFromName: aSymbol) + aToImage innerImage: + (PyramidIconInputPresenter innerElementFromName: aSymbol) ] From 4f2b11028737e9baa49385f9a4c4b3e1c704e3a2 Mon Sep 17 00:00:00 2001 From: Mathieu Magueres Date: Tue, 30 Jun 2026 11:14:55 +0200 Subject: [PATCH 09/22] add 'metadata' method and add some tests --- .../PyramidMainExtension.class.st | 22 ++++ .../PyramidPluginOpenInWindow.class.st | 61 +++++++--- src/Pyramid-Bloc/PyramidSavePlugin.class.st | 83 ++++++++------ .../PyramidSavingService.class.st | 65 +++++++++-- .../PyramidMetaDataTest.class.st | 66 +++++++++++ .../PyramidOpenInWindowTest.class.st | 105 ++++++++++++++++++ 6 files changed, 341 insertions(+), 61 deletions(-) create mode 100644 src/Pyramid-Tests/PyramidMetaDataTest.class.st create mode 100644 src/Pyramid-Tests/PyramidOpenInWindowTest.class.st diff --git a/src/Pyramid-Bloc/PyramidMainExtension.class.st b/src/Pyramid-Bloc/PyramidMainExtension.class.st index 22978ac1..e28d815f 100644 --- a/src/Pyramid-Bloc/PyramidMainExtension.class.st +++ b/src/Pyramid-Bloc/PyramidMainExtension.class.st @@ -17,9 +17,30 @@ Class { 'gridColor', 'selectionWidgetExtension' ], + #classInstVars : [ + 'currentGridWindowSize' + ], #category : #'Pyramid-Bloc-plugin-space-extensions' } +{ #category : #accessing } +PyramidMainExtension class >> currentGridWindowSize [ + + ^ currentGridWindowSize +] + +{ #category : #accessing } +PyramidMainExtension class >> currentGridWindowSize: aPoint [ + + currentGridWindowSize := aPoint. + +] + +{ #category : #'class initialization' } +PyramidMainExtension class >> initialize [ + currentGridWindowSize := 800 @ 600 +] + { #category : #accessing } PyramidMainExtension >> borderElement [ @@ -104,6 +125,7 @@ PyramidMainExtension >> extent: aPoint [ self elementAtWidgets extent: aPoint. self sizeElement extent: aPoint. self gridWindowSize: aPoint. + self class currentGridWindowSize: aPoint.workplacePropertiesView workplaceSizeValue: aPoint. self createGrid ] diff --git a/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st b/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st index 3d49ec86..f92f899b 100644 --- a/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st +++ b/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st @@ -8,7 +8,8 @@ Class { 'spacePlugin', 'builder', 'projectModel', - 'savePlugin' + 'savePlugin', + 'space' ], #category : #'Pyramid-Bloc-plugin-openinwindow' } @@ -26,6 +27,12 @@ PyramidPluginOpenInWindow >> builder [ ^ builder ] +{ #category : #accessing } +PyramidPluginOpenInWindow >> builder: anObject [ + +builder := anObject +] + { #category : #accessing } PyramidPluginOpenInWindow >> button [ @@ -68,23 +75,49 @@ PyramidPluginOpenInWindow >> openInWindowIcon [ { #category : #private } PyramidPluginOpenInWindow >> openSpaceInWindow [ + | elements container stash currentTheme windowSize | + elements := projectModel firstLevelElements asOrderedCollection. + currentTheme := nil. + builder ifNotNil: [ :aBuilder | + aBuilder space ifNotNil: [ :aSpace | + aSpace root ifNotNil: [ :aRoot | currentTheme := aRoot localTheme ] ] ]. - | elements container stash space currentTheme | - projectModel ifNil: [ ^ self inform: 'No project found.' ]. - elements := projectModel firstLevelElements asOrderedCollection. - elements ifEmpty: [ ^ self inform: 'Nothing to display.' ]. - currentTheme := builder space root localTheme. - container := BlElement new - extent: 4000 @ 2000; - yourself. - elements do: [ :each | - stash := BlSerializer serialize: each with: BlStashSerializer. - container addChild: stash materializeAsBlElement ]. - space := container openInNewSpace. - currentTheme ifNotNil: [ space toTheme: currentTheme ] +windowSize := [ + | mainExtension | + mainExtension := builder extensions + detect: [ :e | e isKindOf: PyramidMainExtension ] + ifNone: [ nil ]. + mainExtension sizeElement extent ] + on: Error + do: [ PyramidMainExtension currentGridWindowSize ]. + + container := BlElement new + constraintsDo: [ :c | + c horizontal matchParent. + c vertical matchParent ]; + yourself. + elements do: [ :each | + stash := BlSerializer serialize: each with: BlStashSerializer. + container addChild: stash materializeAsBlElement ]. + space := container openInNewSpace. + space extent: windowSize. + currentTheme ifNotNil: [ space toTheme: currentTheme ]. + ^ space ] { #category : #accessing } PyramidPluginOpenInWindow >> projectModel [ ^ projectModel ] + +{ #category : #accessing } +PyramidPluginOpenInWindow >> projectModel: anObject [ + +projectModel := anObject +] + +{ #category : #accessing } +PyramidPluginOpenInWindow >> space [ + +^ space +] diff --git a/src/Pyramid-Bloc/PyramidSavePlugin.class.st b/src/Pyramid-Bloc/PyramidSavePlugin.class.st index f80c61ad..d61c10a5 100644 --- a/src/Pyramid-Bloc/PyramidSavePlugin.class.st +++ b/src/Pyramid-Bloc/PyramidSavePlugin.class.st @@ -17,17 +17,36 @@ Class { { #category : #'instance creation' } PyramidSavePlugin class >> openOn: aCollectionOfBlElement saveModel: aSaveModel [ - - | editor savePlugin | - editor := PyramidEditor buildEditor. - savePlugin := editor plugins select: [ :each | each class = self ]. - savePlugin size = 1 ifFalse: [ - Error signal: - 'Wrong installation of SavePlugin. Should only be one instance.' ]. - savePlugin := savePlugin asArray first. - editor projectModel firstLevelElements addAll: aCollectionOfBlElement. - savePlugin openOn: aSaveModel. - editor open + | editor savePlugin windowSize mainExtension spacePlugin | + editor := PyramidEditor buildEditor. + savePlugin := editor plugins select: [ :each | each class = self ]. + savePlugin size = 1 ifFalse: [ + Error signal: + 'Wrong installation of SavePlugin. Should only be one instance.' ]. + savePlugin := savePlugin asArray first. + editor projectModel firstLevelElements addAll: aCollectionOfBlElement. + + windowSize := [ + | metaDataSelector savingClass | + metaDataSelector := (aSaveModel savingMethodName , 'MetaData') asSymbol. + savingClass := self class environment classNamed: aSaveModel savingClassName. + savingClass perform: metaDataSelector. + PyramidSavingService currentProjectWindowSize ] + on: Error + do: [ nil ]. + + windowSize ifNotNil: [ + spacePlugin := editor plugins + detect: [ :p | p isKindOf: PyramidSpacePlugin ] + ifNone: [ nil ]. + spacePlugin ifNotNil: [ + mainExtension := spacePlugin builder extensions + detect: [ :e | e isKindOf: PyramidMainExtension ] + ifNone: [ nil ]. + mainExtension ifNotNil: [ mainExtension extent: windowSize ] ] ]. + + savePlugin openOn: aSaveModel. + editor open ] { #category : #adding } @@ -135,31 +154,23 @@ PyramidSavePlugin >> projectModel: aPyramidProjectModel [ { #category : #actions } PyramidSavePlugin >> saveAction [ - "Action executed by a save button from UI, this method catch exceptions when needed to doesn't expose directly a debugger but an info window" - - [ - self savingService save. - self inputsController isSaved. - ] - on: Error - do: [ :e | - - "Pyramid level error" - (e isKindOf: PyramidSaveError) ifTrue:[ - ^ UIManager default - alert: 'Cannot save the project, open project configuration to setup a valid saving location.' - title: 'Project configuration problem' - ]. - - "Serializer level error" - (e isKindOf: BlocSerializationError) ifTrue:[ - (UIManager default - confirm: 'Error when saving the project: ', e messageText asString, ' - Debug this error ?' - label: 'Error') - ifTrue:[e debug] ifFalse:[^ self]. - ]. - ] + [ + self savingService save. + self inputsController isSaved. + PyramidSavingService currentSaveModel: self saveModel ] + on: Error + do: [ :e | + (e isKindOf: PyramidSaveError) ifTrue: [ + ^ UIManager default + alert: 'Cannot save the project, open project configuration to setup a valid saving location.' + title: 'Project configuration problem' ]. + (e isKindOf: BlocSerializationError) ifTrue: [ + (UIManager default + confirm: 'Error when saving the project: ' , e messageText asString , ' + Debug this error ?' + label: 'Error') + ifTrue: [ e debug ] + ifFalse: [ ^ self ] ] ] ] { #category : #accessing } diff --git a/src/Pyramid-Bloc/PyramidSavingService.class.st b/src/Pyramid-Bloc/PyramidSavingService.class.st index e158c9b0..e5a1a54e 100644 --- a/src/Pyramid-Bloc/PyramidSavingService.class.st +++ b/src/Pyramid-Bloc/PyramidSavingService.class.st @@ -9,7 +9,9 @@ Class { 'currentMethodBuilder', 'stash', 'ston', - 'currentMethodBuilderSelector' + 'currentMethodBuilderSelector', + 'currentSaveModel', + 'currentProjectWindowSize' ], #category : #'Pyramid-Bloc-plugin-save' } @@ -41,6 +43,26 @@ PyramidSavingService class >> currentMethodBuilderSelector: anObject [ currentMethodBuilderSelector := anObject ] +{ #category : #accessing } +PyramidSavingService class >> currentProjectWindowSize [ + ^ currentProjectWindowSize +] + +{ #category : #accessing } +PyramidSavingService class >> currentProjectWindowSize: aPoint [ + currentProjectWindowSize := aPoint +] + +{ #category : #accessing } +PyramidSavingService class >> currentSaveModel [ + ^ currentSaveModel +] + +{ #category : #accessing } +PyramidSavingService class >> currentSaveModel: aSaveModel [ + currentSaveModel := aSaveModel +] + { #category : #'as yet unclassified' } PyramidSavingService class >> saveMethodBuilderSettingOn: aBuilder [ @@ -91,6 +113,17 @@ PyramidSavingService class >> ston [ yourself ] +{ #category : #'as yet unclassified' } +PyramidSavingService >> buildMetaDataMethod [ + | methodName windowSize | + methodName := self saveModel savingMethodName , 'MetaData'. + windowSize := PyramidMainExtension currentGridWindowSize. + ^ '<1s>"Pyramid project metadata"%PyramidSavingService currentProjectWindowSize: <2p> @ <3p>' + expandMacrosWith: methodName + with: windowSize x + with: windowSize y +] + { #category : #testing } PyramidSavingService >> canSave [ "Verify: @@ -114,22 +147,32 @@ PyramidSavingService >> methodBuilder [ ^ self class currentMethodBuilder ] -{ #category : #testing } +{ #category : #'as yet unclassified' } PyramidSavingService >> save [ + | class | + self canSave ifFalse: [ self errorCannotSave ]. + class := self saveModel isClassSide + ifTrue: [ self savingClass classSide ] + ifFalse: [ self savingClass ]. + self methodBuilder classifier + ifNil: [ class compile: self savingMethod ] + ifNotNil: [ + class + compile: self savingMethod + classified: self methodBuilder classifier ]. + self saveMetaData +] - | class | - self canSave ifFalse: [ self errorCannotSave ]. +{ #category : #'as yet unclassified' } +PyramidSavingService >> saveMetaData [ + | class metaDataMethod | + self canSave ifFalse: [ self errorCannotSave ]. class := self saveModel isClassSide ifTrue: [ self savingClass classSide ] ifFalse: [ self savingClass ]. - - self methodBuilder classifier - ifNil: [ class compile: self savingMethod ] - ifNotNil: [ - class - compile: self savingMethod - classified: self methodBuilder classifier ] + metaDataMethod := self buildMetaDataMethod. + class compile: metaDataMethod classified: #'pyramid-metadata' ] { #category : #accessing } diff --git a/src/Pyramid-Tests/PyramidMetaDataTest.class.st b/src/Pyramid-Tests/PyramidMetaDataTest.class.st new file mode 100644 index 00000000..009a0f54 --- /dev/null +++ b/src/Pyramid-Tests/PyramidMetaDataTest.class.st @@ -0,0 +1,66 @@ +Class { + #name : #PyramidMetaDataTest, + #superclass : #TestCase, + #instVars : [ + 'testClass', + 'service' + ], + #category : #'Pyramid-Tests-cases-MetaData' +} + +{ #category : #running } +PyramidMetaDataTest >> setUp [ + testClass := self class classInstaller make: [ :aClassBuilder | + aClassBuilder + name: 'PyramidMetaDataTestClass'; + package: 'Pyramid-Tests-cases-plugin-save' ]. + service := PyramidSavingService new + saveModel: (PyramidSaveModel new + savingMethodName: 'testInterface'; + savingClassName: 'PyramidMetaDataTestClass'; + savingPackageName: 'Pyramid-Tests-cases-plugin-save'; + projectModel: PyramidProjectModel new; + yourself); + yourself. +] + +{ #category : #running } +PyramidMetaDataTest >> tearDown [ + testClass ifNotNil: [ testClass removeFromSystem ]. + PyramidSavingService currentProjectWindowSize: nil. +] + +{ #category : #tests } +PyramidMetaDataTest >> testBuildMetaDataMethod [ + | service saveModel result | + saveModel := PyramidSaveModel new + savingMethodName: 'testInterface'; + yourself. + service := PyramidSavingService new + saveModel: saveModel; + yourself. + result := service buildMetaDataMethod. + self assert: (result includesSubstring: 'testInterfaceMetaData'). + self assert: (result includesSubstring: 'pyMetaData'). + self assert: (result includesSubstring: 'PyramidSavingService currentProjectWindowSize:') +] + +{ #category : #tests } +PyramidMetaDataTest >> testMetaDataSetsWindowSize [ + + | expectedSize metaDataSelector | + "1. Fixe la taille courante dans Pyramid" + expectedSize := PyramidMainExtension currentGridWindowSize. + + "2. Génère et compile la méthode metaData via saveMetaData" + service saveMetaData. + + "3. Performe la méthode générée comme le ferait openOn:saveModel:" + metaDataSelector := (#testInterface , 'MetaData') asSymbol. + testClass perform: metaDataSelector. + + "4. Vérifie que la taille lue est bien celle qui était dans Pyramid" + self + assert: PyramidSavingService currentProjectWindowSize + equals: expectedSize +] diff --git a/src/Pyramid-Tests/PyramidOpenInWindowTest.class.st b/src/Pyramid-Tests/PyramidOpenInWindowTest.class.st new file mode 100644 index 00000000..c898ae47 --- /dev/null +++ b/src/Pyramid-Tests/PyramidOpenInWindowTest.class.st @@ -0,0 +1,105 @@ +Class { + #name : #PyramidOpenInWindowTest, + #superclass : #TestCase, + #instVars : [ + 'window', + 'windowSize', + 'projectModel', + 'openedSpaces' + ], + #category : #'Pyramid-Tests-cases-plugin-openInWindow' +} + +{ #category : #running } +PyramidOpenInWindowTest >> setUp [ + + super setUp. + projectModel := PyramidProjectModel new. + window := PyramidPluginOpenInWindow new. + window projectModel: projectModel. + window builder: PyramidSpaceBuilder new. + windowSize := PyramidMainExtension currentGridWindowSize. +] + +{ #category : #running } +PyramidOpenInWindowTest >> tearDown [ + + PyramidMainExtension currentGridWindowSize: windowSize. + super tearDown +] + +{ #category : #tests } +PyramidOpenInWindowTest >> testOpenSpaceInWindowAddsProjectElements [ + + | space | + + space := window openSpaceInWindow. + self assert: space root children size equals: 1. + self + assert: space root children first children size + equals: window projectModel firstLevelElements size +] + +{ #category : #tests } +PyramidOpenInWindowTest >> testOpenSpaceInWindowContainerMatchesParent [ + | space container | + space := window openSpaceInWindow. + container := space root children first. + self assert: container constraints horizontal resizer equals: BlLayoutResizer matchParent. + self assert: container constraints vertical resizer equals: BlLayoutResizer matchParent. +] + +{ #category : #tests } +PyramidOpenInWindowTest >> testOpenSpaceInWindowUsesBuilderTheme [ + + | initialSpace rootElement theme openedSpace | + theme := ToRawDarkTheme new. + rootElement := BlElement new. + rootElement localTheme: theme. + + initialSpace := BlSpace new. + initialSpace root: rootElement. + + window builder: (PyramidSpaceBuilder new space: initialSpace). + + openedSpace := window openSpaceInWindow. + + self assert: openedSpace root localTheme equals: theme +] + +{ #category : #tests } +PyramidOpenInWindowTest >> testOpenSpaceInWindowWithBuilderHavingNilSpace [ + | space | + window builder: (PyramidSpaceBuilder new space: nil). + space := window openSpaceInWindow. + self assert: space isNotNil +] + +{ #category : #tests } +PyramidOpenInWindowTest >> testOpenSpaceInWindowWithBuilderSpaceHavingNilRoot [ + + | initialSpace space | + initialSpace := BlSpace new. + window builder: (PyramidSpaceBuilder new space: initialSpace). + space := window openSpaceInWindow. + self assert: space isNotNil +] + +{ #category : #tests } +PyramidOpenInWindowTest >> testWindowDefaultExtent [ + + | space | + PyramidMainExtension defaultExtent. + space := window openSpaceInWindow. + self assert: space extent equals: 800 @ 600 +] + +{ #category : #tests } +PyramidOpenInWindowTest >> testWindowExtentUsesConfiguredGridSize [ + + | space | + PyramidMainExtension currentGridWindowSize: 2000 @ 1000. + space := window openSpaceInWindow. + + self assert: space extent equals: 2000 @ 1000 +] From cd65cc67bf56668cb126ac82f4af0da5ee754013 Mon Sep 17 00:00:00 2001 From: Mathieu Magueres Date: Tue, 7 Jul 2026 15:30:31 +0200 Subject: [PATCH 10/22] Add properties to metadata method --- .../PyramidMainExtension.class.st | 175 ++++++++++++------ .../PyramidPluginOpenInWindow.class.st | 75 +++++--- src/Pyramid-Bloc/PyramidSavePlugin.class.st | 80 +++++--- .../PyramidSavingService.class.st | 49 +++-- .../PyramidVisualPystonForCly.class.st | 35 +++- src/Pyramid-IDE/PyramidWorld.class.st | 3 +- .../AnObsoletePyramidMetaDataTest.class.st | 9 + .../PyramidOpenInWindowTest.class.st | 3 +- 8 files changed, 285 insertions(+), 144 deletions(-) create mode 100644 src/Pyramid-Tests/AnObsoletePyramidMetaDataTest.class.st diff --git a/src/Pyramid-Bloc/PyramidMainExtension.class.st b/src/Pyramid-Bloc/PyramidMainExtension.class.st index e28d815f..ac62f49c 100644 --- a/src/Pyramid-Bloc/PyramidMainExtension.class.st +++ b/src/Pyramid-Bloc/PyramidMainExtension.class.st @@ -18,27 +18,68 @@ Class { 'selectionWidgetExtension' ], #classInstVars : [ - 'currentGridWindowSize' + 'currentGridWindowSize', + 'currentGridVisibility', + 'currentGridSpacing', + 'currentGridColor' ], #category : #'Pyramid-Bloc-plugin-space-extensions' } +{ #category : #accessing } +PyramidMainExtension class >> currentGridColor [ + +^ currentGridColor +] + +{ #category : #accessing } +PyramidMainExtension class >> currentGridColor: aColor [ + +currentGridColor := aColor +] + +{ #category : #accessing } +PyramidMainExtension class >> currentGridSpacing [ + +^ currentGridSpacing +] + +{ #category : #accessing } +PyramidMainExtension class >> currentGridSpacing: anInteger [ + + currentGridSpacing := anInteger +] + +{ #category : #accessing } +PyramidMainExtension class >> currentGridVisibility [ + ^ currentGridVisibility + + +] + +{ #category : #accessing } +PyramidMainExtension class >> currentGridVisibility: aBoolean [ + currentGridVisibility := aBoolean +] + { #category : #accessing } PyramidMainExtension class >> currentGridWindowSize [ + ^ currentGridWindowSize + - ^ currentGridWindowSize ] { #category : #accessing } PyramidMainExtension class >> currentGridWindowSize: aPoint [ - - currentGridWindowSize := aPoint. - + currentGridWindowSize := aPoint ] { #category : #'class initialization' } PyramidMainExtension class >> initialize [ - currentGridWindowSize := 800 @ 600 + + currentGridWindowSize := nil. + currentGridVisibility := nil. + currentGridSpacing:= nil ] { #category : #accessing } @@ -61,23 +102,23 @@ PyramidMainExtension >> containerElement [ { #category : #'as yet unclassified' } PyramidMainExtension >> createGrid [ - "Remove the current all the line of the grid" + self gridElement removeChildWithId: #gridHorizontal. self gridElement removeChildWithId: #gridVertical. self gridElement removeChildWithId: #pixelGrid. "Create the grid if gridVisibility is true" - gridVisibility ifTrue: [ self grid: self gridElement - cellSpacing: self gridSpacing - color: self gridColor - width: (self gridWindowSize x) - height: (self gridWindowSize y). - self selectionWidgetExtension movingLap: self gridSpacing - ] - ifFalse: [ self selectionWidgetExtension movingLap: 1 ]. - - + gridVisibility + ifTrue: [ + self + grid: self gridElement + cellSpacing: self gridSpacing + color: self gridColor + width: self gridWindowSize x + height: self gridWindowSize y. + self selectionWidgetExtension movingLap: self gridSpacing ] + ifFalse: [ self selectionWidgetExtension movingLap: 1 ] ] { #category : #accessing } @@ -101,22 +142,27 @@ PyramidMainExtension >> defaultGridColor [ { #category : #'as yet unclassified' } PyramidMainExtension >> defaultGridSpacing [ "Default spacing value of the grid" + ^ 10 ] { #category : #'as yet unclassified' } PyramidMainExtension >> defaultGridVisibility [ - "Default visibility value of the grid" - ^ false + "Default visibility value of the grid" + ^ (PyramidSavingService currentProjectMetaData + ifNotNil: [ :md | md at: #gridVisibility ifAbsent: [ nil ] ]) + ifNil: [ false ] ] { #category : #accessing } PyramidMainExtension >> editor: aPyramidEditor [ aPyramidEditor window at: #topRight addItem: [ :buttonBuilder | - buttonBuilder makeButtonWithIcon: self workplacePropertiesButton order: 10 ]. - + buttonBuilder + makeButtonWithIcon: self workplacePropertiesButton + order: 10 ]. self getSelectionWidgetExtension: aPyramidEditor. + ] { #category : #geometry } @@ -125,7 +171,7 @@ PyramidMainExtension >> extent: aPoint [ self elementAtWidgets extent: aPoint. self sizeElement extent: aPoint. self gridWindowSize: aPoint. - self class currentGridWindowSize: aPoint.workplacePropertiesView workplaceSizeValue: aPoint. + self class currentGridWindowSize: aPoint. self createGrid ] @@ -207,6 +253,12 @@ PyramidMainExtension >> gridColor [ ^ gridColor ] +{ #category : #accessing } +PyramidMainExtension >> gridColor: aColor [ + +gridColor := aColor +] + { #category : #'as yet unclassified' } PyramidMainExtension >> gridDefaultValueInitializer [ @@ -228,9 +280,22 @@ PyramidMainExtension >> gridSpacing [ ^ gridSpacing ] +{ #category : #accessing } +PyramidMainExtension >> gridSpacing: anInteger [ + + gridSpacing := anInteger. +] + { #category : #accessing } PyramidMainExtension >> gridVisibility [ - ^ gridVisibility + + ^ gridVisibility +] + +{ #category : #accessing } +PyramidMainExtension >> gridVisibility: aBoolean [ + + gridVisibility := aBoolean ] { #category : #accessing } @@ -265,24 +330,34 @@ PyramidMainExtension >> initialize [ whenWorkplaceValuesChangedDo: [ :point | self extent: point ]; whenVisibilityChangedDo: [ - self switchGridvisibility. - self createGrid ]; + gridVisibility := workplacePropertiesView + visibilityButton + state. + self class currentGridVisibility: + gridVisibility. + self createGrid ]; spacingTextValue: self defaultGridSpacing; whenSpacingTextChangedDo: [ :value | - (self checkZeroOrSubZeroGridSpacingValue: value) - ifTrue: [ - self defaultGridSpacing <= 0 ifTrue: [ - gridSpacing := 1. - ^ self ]. - gridSpacing := self defaultGridSpacing ] - ifFalse: [ gridSpacing := value ]. - self createGrid ]; + (self + checkZeroOrSubZeroGridSpacingValue: + value) + ifTrue: [ + self defaultGridSpacing <= 0 + ifTrue: [ + gridSpacing := 1. + ^ self ]. + gridSpacing := self + defaultGridSpacing ] + ifFalse: [ gridSpacing := value ]. + self class currentGridSpacing: + gridSpacing. + self createGrid ]; gridColorValue: self defaultGridColor; whenColorValuesChangedDo: [ :color | - gridColor := color. - self createGrid ]; + gridColor := color. self class currentGridColor: color. + self createGrid ]; yourself. - + self defaultGridSpacing <= 0 ifTrue: [ gridSpacing := 1 ]. workplacePropertiesView spacingText value: gridSpacing. @@ -293,8 +368,8 @@ PyramidMainExtension >> initialize [ help: 'Edit the properties of the workplace'; action: [ - self workplacePropertiesPopover popup. - self refreshPopupWorkplaceProperties ]; + self workplacePropertiesPopover popup. + self refreshPopupWorkplaceProperties ]; yourself. "Creation of the pop-up" @@ -308,8 +383,8 @@ PyramidMainExtension >> initialize [ containerElement := BlElement new id: #MainExtension_containerElement; constraintsDo: [ :c | - c vertical matchParent. - c horizontal matchParent ]; + c vertical matchParent. + c horizontal matchParent ]; clipChildren: false; zIndex: 0; yourself. @@ -320,8 +395,8 @@ PyramidMainExtension >> initialize [ border: self defaultBorder; outskirts: BlOutskirts outside; constraintsDo: [ :c | - c vertical matchParent. - c horizontal matchParent ]; + c vertical matchParent. + c horizontal matchParent ]; clipChildren: false; zIndex: 1; preventMeAndChildrenMouseEvents; @@ -331,10 +406,10 @@ PyramidMainExtension >> initialize [ gridElement := BlElement new id: #MainExtension_gridElement; constraintsDo: [ :c | - c vertical matchParent. - c horizontal matchParent ]; + c vertical matchParent. + c horizontal matchParent ]; zIndex: 2. - + borderElement addChild: gridElement. sizeElement := BlElement new @@ -342,7 +417,7 @@ PyramidMainExtension >> initialize [ extent: self defaultExtent; clipChildren: false; addChildren: { - containerElement . + containerElement. borderElement } yourself ] @@ -405,14 +480,6 @@ PyramidMainExtension >> sizeElement [ ^ sizeElement ] -{ #category : #'as yet unclassified' } -PyramidMainExtension >> switchGridvisibility [ - "Switch the visibility from true to false or false to true" - gridVisibility := self gridVisibility not. - - ^ self gridVisibility -] - { #category : #accessing } PyramidMainExtension >> workplacePropertiesButton [ diff --git a/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st b/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st index f92f899b..2329ebe9 100644 --- a/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st +++ b/src/Pyramid-Bloc/PyramidPluginOpenInWindow.class.st @@ -11,9 +11,24 @@ Class { 'savePlugin', 'space' ], + #classInstVars : [ + 'currentTheme' + ], #category : #'Pyramid-Bloc-plugin-openinwindow' } +{ #category : #accessing } +PyramidPluginOpenInWindow class >> currentTheme [ + + ^ currentTheme +] + +{ #category : #accessing } +PyramidPluginOpenInWindow class >> currentTheme: aTheme [ + + currentTheme := aTheme +] + { #category : #adding } PyramidPluginOpenInWindow >> addPanelsOn: aPyramidSimpleWindow [ @@ -75,34 +90,38 @@ PyramidPluginOpenInWindow >> openInWindowIcon [ { #category : #private } PyramidPluginOpenInWindow >> openSpaceInWindow [ - | elements container stash currentTheme windowSize | - elements := projectModel firstLevelElements asOrderedCollection. - currentTheme := nil. - builder ifNotNil: [ :aBuilder | - aBuilder space ifNotNil: [ :aSpace | - aSpace root ifNotNil: [ :aRoot | currentTheme := aRoot localTheme ] ] ]. - -windowSize := [ - | mainExtension | - mainExtension := builder extensions - detect: [ :e | e isKindOf: PyramidMainExtension ] - ifNone: [ nil ]. - mainExtension sizeElement extent ] - on: Error - do: [ PyramidMainExtension currentGridWindowSize ]. - - container := BlElement new - constraintsDo: [ :c | - c horizontal matchParent. - c vertical matchParent ]; - yourself. - elements do: [ :each | - stash := BlSerializer serialize: each with: BlStashSerializer. - container addChild: stash materializeAsBlElement ]. - space := container openInNewSpace. - space extent: windowSize. - currentTheme ifNotNil: [ space toTheme: currentTheme ]. - ^ space + + | elements container stash currentTheme windowSize | + elements := projectModel firstLevelElements asOrderedCollection. + currentTheme := nil. + builder ifNotNil: [ :aBuilder | + aBuilder space ifNotNil: [ :aSpace | + aSpace root ifNotNil: [ :aRoot | currentTheme := aRoot localTheme ] ] ]. + + windowSize := [ + | mainExtension | + mainExtension := builder extensions + detect: [ :e | + e isKindOf: PyramidMainExtension ] + ifNone: [ nil ]. + mainExtension + ifNotNil: [ mainExtension sizeElement extent ] + ifNil: [ 800 @ 600 ] ] + on: Error + do: [ 800 @ 600 ]. + + container := BlElement new + constraintsDo: [ :c | + c horizontal matchParent. + c vertical matchParent ]; + yourself. + elements do: [ :each | + stash := BlSerializer serialize: each with: BlStashSerializer. + container addChild: stash materializeAsBlElement ]. + space := container openInNewSpace. + space extent: windowSize. + currentTheme ifNotNil: [ space toTheme: currentTheme ]. + ^ space ] { #category : #accessing } diff --git a/src/Pyramid-Bloc/PyramidSavePlugin.class.st b/src/Pyramid-Bloc/PyramidSavePlugin.class.st index d61c10a5..d7c1600d 100644 --- a/src/Pyramid-Bloc/PyramidSavePlugin.class.st +++ b/src/Pyramid-Bloc/PyramidSavePlugin.class.st @@ -17,36 +17,56 @@ Class { { #category : #'instance creation' } PyramidSavePlugin class >> openOn: aCollectionOfBlElement saveModel: aSaveModel [ - | editor savePlugin windowSize mainExtension spacePlugin | - editor := PyramidEditor buildEditor. - savePlugin := editor plugins select: [ :each | each class = self ]. - savePlugin size = 1 ifFalse: [ - Error signal: - 'Wrong installation of SavePlugin. Should only be one instance.' ]. - savePlugin := savePlugin asArray first. - editor projectModel firstLevelElements addAll: aCollectionOfBlElement. - - windowSize := [ - | metaDataSelector savingClass | - metaDataSelector := (aSaveModel savingMethodName , 'MetaData') asSymbol. - savingClass := self class environment classNamed: aSaveModel savingClassName. - savingClass perform: metaDataSelector. - PyramidSavingService currentProjectWindowSize ] - on: Error - do: [ nil ]. - - windowSize ifNotNil: [ - spacePlugin := editor plugins - detect: [ :p | p isKindOf: PyramidSpacePlugin ] - ifNone: [ nil ]. - spacePlugin ifNotNil: [ - mainExtension := spacePlugin builder extensions - detect: [ :e | e isKindOf: PyramidMainExtension ] - ifNone: [ nil ]. - mainExtension ifNotNil: [ mainExtension extent: windowSize ] ] ]. - - savePlugin openOn: aSaveModel. - editor open + + | editor savePlugin metaData mainExtension spacePlugin | + PyramidSavingService currentProjectMetaData: nil. + PyramidMainExtension currentGridWindowSize: nil. + editor := PyramidEditor buildEditor. + savePlugin := editor plugins select: [ :each | each class = self ]. + savePlugin size = 1 ifFalse: [ + Error signal: + 'Wrong installation of SavePlugin. Should only be one instance.' ]. + savePlugin := savePlugin asArray first. + editor projectModel firstLevelElements addAll: aCollectionOfBlElement. + + [ + | metaDataSelector savingClass | + metaDataSelector := (aSaveModel savingMethodName , 'MetaData') + asSymbol. + savingClass := self class environment classNamed: + aSaveModel savingClassName. + savingClass perform: metaDataSelector ] + on: Error + do: [ nil ]. + + metaData := PyramidSavingService currentProjectMetaData. + savePlugin openOn: aSaveModel. + editor open. + + metaData ifNotNil: [ + spacePlugin := editor plugins + detect: [ :p | p isKindOf: PyramidSpacePlugin ] + ifNone: [ nil ]. + spacePlugin ifNotNil: [ + mainExtension := spacePlugin builder extensions + detect: [ :e | + e isKindOf: PyramidMainExtension ] + ifNone: [ nil ]. + mainExtension ifNotNil: [ + (metaData at: #windowSize ifAbsent: [ nil ]) ifNotNil: [ :size | + mainExtension extent: size. + mainExtension workplacePropertiesView workplaceSizeValue: size. ]. + (metaData at: #gridVisibility ifAbsent: [ nil ]) ifNotNil: [ + :visibility | mainExtension gridVisibility: visibility ]. + (metaData at: #gridSpacing ifAbsent: [ nil ]) ifNotNil: [ + :spacing | + mainExtension gridSpacing: spacing. + mainExtension workplacePropertiesView spacingText value: + spacing ]. + (metaData at: #gridColor ifAbsent: [ nil ]) ifNotNil: [ :color | + mainExtension gridColor: color. + mainExtension workplacePropertiesView gridColorValue: color. + mainExtension createGrid ] ] ] ] ] { #category : #adding } diff --git a/src/Pyramid-Bloc/PyramidSavingService.class.st b/src/Pyramid-Bloc/PyramidSavingService.class.st index e5a1a54e..92aa230a 100644 --- a/src/Pyramid-Bloc/PyramidSavingService.class.st +++ b/src/Pyramid-Bloc/PyramidSavingService.class.st @@ -11,7 +11,7 @@ Class { 'ston', 'currentMethodBuilderSelector', 'currentSaveModel', - 'currentProjectWindowSize' + 'currentProjectMetaData' ], #category : #'Pyramid-Bloc-plugin-save' } @@ -44,13 +44,15 @@ PyramidSavingService class >> currentMethodBuilderSelector: anObject [ ] { #category : #accessing } -PyramidSavingService class >> currentProjectWindowSize [ - ^ currentProjectWindowSize +PyramidSavingService class >> currentProjectMetaData [ + +^ currentProjectMetaData ] { #category : #accessing } -PyramidSavingService class >> currentProjectWindowSize: aPoint [ - currentProjectWindowSize := aPoint +PyramidSavingService class >> currentProjectMetaData: aDictionary [ + +currentProjectMetaData := aDictionary ] { #category : #accessing } @@ -115,13 +117,21 @@ PyramidSavingService class >> ston [ { #category : #'as yet unclassified' } PyramidSavingService >> buildMetaDataMethod [ - | methodName windowSize | - methodName := self saveModel savingMethodName , 'MetaData'. - windowSize := PyramidMainExtension currentGridWindowSize. - ^ '<1s>"Pyramid project metadata"%PyramidSavingService currentProjectWindowSize: <2p> @ <3p>' - expandMacrosWith: methodName - with: windowSize x - with: windowSize y + + | methodName windowSize gridVisibility gridSpacing gridColor | + methodName := self saveModel savingMethodName , 'MetaData'. + windowSize := PyramidMainExtension currentGridWindowSize. + gridVisibility := PyramidMainExtension currentGridVisibility. + gridSpacing := PyramidMainExtension currentGridSpacing. + gridColor := PyramidMainExtension currentGridColor. + ^ '<1s>"Pyramid project metadata"%PyramidSavingService currentProjectMetaData: (Dictionary newat: #windowSize put: <2p> @ <3p>;at: #gridVisibility put: <4p>;at: #gridSpacing put: <5p>;at: #gridColor put: <6p>;yourself)' + expandMacrosWithArguments: { + methodName. + windowSize x. + windowSize y. + gridVisibility. + gridSpacing. + gridColor } ] { #category : #testing } @@ -165,14 +175,13 @@ PyramidSavingService >> save [ { #category : #'as yet unclassified' } PyramidSavingService >> saveMetaData [ - - | class metaDataMethod | - self canSave ifFalse: [ self errorCannotSave ]. - class := self saveModel isClassSide - ifTrue: [ self savingClass classSide ] - ifFalse: [ self savingClass ]. - metaDataMethod := self buildMetaDataMethod. - class compile: metaDataMethod classified: #'pyramid-metadata' + | class metaDataMethod | + self canSave ifFalse: [ self errorCannotSave ]. + class := self saveModel isClassSide + ifTrue: [ self savingClass classSide ] + ifFalse: [ self savingClass ]. + metaDataMethod := self buildMetaDataMethod. + class compile: metaDataMethod classified: #'pyramid-metadata' ] { #category : #accessing } diff --git a/src/Pyramid-Bloc/PyramidVisualPystonForCly.class.st b/src/Pyramid-Bloc/PyramidVisualPystonForCly.class.st index bd92ec7f..9549ef2d 100644 --- a/src/Pyramid-Bloc/PyramidVisualPystonForCly.class.st +++ b/src/Pyramid-Bloc/PyramidVisualPystonForCly.class.st @@ -207,21 +207,38 @@ PyramidVisualPystonForCly >> openEditor [ { #category : #accessing } PyramidVisualPystonForCly >> openInNewSpace [ - | class elements space | + | class elements space theme windowSize | class := method classBinding value. elements := class isMeta ifTrue: [ - (method classBinding value instanceSide perform: - method selector) materializeAsBlElement ] + (method classBinding value instanceSide perform: + method selector) materializeAsBlElement ] ifFalse: [ - (method classBinding value new perform: method selector) - materializeAsBlElement ]. - + (method classBinding value new perform: + method selector) materializeAsBlElement ]. elements isCollection ifFalse: [ elements := { elements } ]. - elements ifEmpty: [ ^ self ]. - space := elements first openInNewSpace. - space root addChildren: elements allButFirst + + windowSize := [ + | metaDataSelector | + metaDataSelector := (method selector , 'MetaData') + asSymbol. + method classBinding value instanceSide perform: + metaDataSelector. + PyramidSavingService currentProjectMetaData + at: #windowSize + ifAbsent: [ nil ] ] + on: Error + do: [ nil ]. + windowSize ifNil: [ windowSize := 800 @ 600 ]. + + space := BlSpace new. + space extent: windowSize. + theme := PyramidPluginOpenInWindow currentTheme. + theme ifNotNil: [ space toTheme: theme ]. + space root addChildren: elements. + space show. + ^ space ] { #category : #initialization } diff --git a/src/Pyramid-IDE/PyramidWorld.class.st b/src/Pyramid-IDE/PyramidWorld.class.st index 6866c0ce..c0dbb7ea 100644 --- a/src/Pyramid-IDE/PyramidWorld.class.st +++ b/src/Pyramid-IDE/PyramidWorld.class.st @@ -1101,8 +1101,9 @@ PyramidWorld class >> startBrowseSources [ { #category : #actions } PyramidWorld class >> startNewDesign [ -