Jacaranda plumbing questionYanni Chiu yanni at rogers.comWed Oct 8 01:30:41 UTC 2003
Thomas A Petersen wrote:
> Has anyone else tried to do diagram switching from
> Morphs in a diagram in Jacaranda?
>
> If so, do you have a suggestion on how to get to
> the list of diagrams to provide Jacaranda with the
> appropriate one to switch to? What I am doing just
> seems uglier than it should be.
>
> Thanks in advance,
> tap
>
> P.S. I have successfully saved and reloded my altered
> morphs through the Jacaranda file in/out mechanism.
> Jacaranda and Squeak are seriously cool.
[I've resent this message since the original was
rejected because it exceeded 100K. I've only attached
the code. I can put the examples somewhere on the
web, if anyone wants. The diagram fileout was 250K,
uncompressed, which seems surprisingly big.]
I added some inst vars to make navigation easier.
I used the explorer/inspector to set the inst
var values of existing diagrams.
File in/out worked, but old diagrams
could not be filed in. So, if everyone's diagram
morphs diverge, then we'll have problems.
I've included the changes I made to Jacaranda,
along with some code I'm using for code generation
from the diagrams. There are also example diagrams
and example generated code. Ignore the code generation
stuff, if you're just interested in the Jacaranda
changes.
You'll need ANSI-Compatibility, as well as the
Jacaranda and Connectors packages. Also, the SIF
export will require the SIF stuff (I can't
remember where I got it from), but code generation
should work without SIF.
Install "PUML-Stubs.st" and "PUML-Models.st". You'll
get undeclared messages in the Transcript due to
cross references, so order doesn't matter.
Then install "Jacaranda-mods.4.cs".
Next, from a Jacaranda Diagram Browser, file-in
"BookStore {Xbk}.14.jo". You can generate code
from the right-click menus (on Windows). Look for
the "compile ?" option.
The GIF files show you what you should see in
the diagrams. And, the *.sif files contain the
generated code.
The BookStore example is from "Execuatable UML - A Foundation
for Model-Driven Architecture" by Stephen J. Mellor
and Marc J. Balcer, ISBN 0-201-74804-5.
--yanni
-------------- next part --------------
'From Squeak3.5 of ''11 April 2003'' [latest update: #5180] on 23 September 2003 at 10:34:17 pm'!
Morph subclass: #Diagram
instanceVariableNames: 'title window annotations annotationsPanel canvas canvasScrollablePanel diagramOrganization '
classVariableNames: ''
poolDictionaries: ''
category: 'Jacaranda-Base'!
Model subclass: #DiagramOrganization
instanceVariableNames: 'name parentOrganization suborganizations diagrams '
classVariableNames: ''
poolDictionaries: ''
category: 'Jacaranda-Base'!
!Diagram methodsFor: 'accessing' stamp: 'yj 9/11/2003 16:29'!
diagramOrganization
^diagramOrganization! !
!Diagram methodsFor: 'accessing' stamp: 'yj 9/11/2003 16:29'!
diagramOrganization: anObject
diagramOrganization := anObject! !
!Diagram methodsFor: 'zti' stamp: 'yj 9/11/2003 15:56'!
systemWindow
^self owner owner! !
!DiagramOrganization methodsFor: 'addings/removals' stamp: 'yj 9/11/2003 16:29'!
addDiagram: aDiagram
self diagrams add: aDiagram.
aDiagram diagramOrganization: self.
! !
!DiagramOrganization methodsFor: 'addings/removals' stamp: 'yj 9/15/2003 16:41'!
addSuborganization: anOrganization
self suborganizations add: anOrganization.
anOrganization parentOrganization: self.
! !
!DiagramOrganization methodsFor: 'accessing' stamp: 'yj 9/15/2003 16:39'!
diagrams: anObject
"Set the value of diagrams"
diagrams _ anObject! !
!DiagramOrganization methodsFor: 'accessing' stamp: 'yj 9/15/2003 16:39'!
parentOrganization
"Answer the value of parentOrganization"
^ parentOrganization! !
!DiagramOrganization methodsFor: 'accessing' stamp: 'yj 9/15/2003 16:39'!
parentOrganization: anObject
"Set the value of parentOrganization"
parentOrganization _ anObject! !
!DiagramOrganization methodsFor: 'accessing' stamp: 'yj 9/15/2003 16:39'!
suborganizations: anObject
"Set the value of suborganizations"
suborganizations _ anObject! !
!DiagramOrganizationBrowser methodsFor: 'menu options' stamp: 'yj 9/23/2003 22:28'!
addDiagramMenuOptionsTo: aMenu
aMenu
add: 'add new diagram'
action: #addNewDiagram;
add: 'file-in'
target: self
selector: #addDiagramFromFile.
self selectedDiagram ifNotNil:
[aMenu
add: 'compile statechart'
target: UmlStatechart
selector: #compileFrom:
argument: self selectedDiagram;
add: 'remove'
action: #confirmSelectedDiagramRemoval;
add: 'move diagram'
action: #moveSelectedDiagram;
add: 'add copy'
action: #addCopyOfDiagram.
self selectedDiagram addMenuOptionsTo: aMenu].
^aMenu.! !
!DiagramOrganizationBrowser methodsFor: 'menu options' stamp: 'yj 9/23/2003 22:29'!
addSuborganizationMenuOptionsTo: aMenu
aMenu
add: 'add new suborganization' action: #addNewSuborganization;
add: 'file-in' action: #addSuborganizationFromFile;
add: 'file-out' action: #saveSelectedSuborganizationToFile.
aMenu
addLine;
add: 'compile package'
target: UmlPackage
selector: #compileFrom:
argument: self selectedSuborganization;
add: 'export SIF'
target: UmlPackage
selector: #exportSifFrom:
argument: self selectedSuborganization;
add: 'export SIF - Relationships'
target: UmlPackage
selector: #exportRelationshipsSifFrom:
argument: self selectedSuborganization;
add: 'export SIF - Objects'
target: UmlPackage
selector: #exportObjectsSifFrom:
argument: self selectedSuborganization;
addLine;
yourself.
(self selectedSuborganization ~= self diagramOrganization) &
(self selectedSuborganization notNil) ifTrue:
[aMenu
add: 'remove' action: #confirmSelectedSuborganizationRemoval;
add: 'move' action: #moveSelectedSuborganization;
add: 'change name' action: #renameSelectedSuborganization].
^aMenu.! !
!HJLabelMorph methodsFor: 'zti' stamp: 'yj 9/11/2003 23:20'!
diagram
^self owner owner owner owner! !
!JacarandaShape methodsFor: 'zti' stamp: 'yj 9/11/2003 15:54'!
diagram
^self owner owner owner owner! !
!ClassShape methodsFor: 'menus' stamp: 'yj 9/23/2003 22:27'!
addOptionsMenuItemsTo: aMenu onEvent: evt
super addOptionsMenuItemsTo: aMenu onEvent: evt.
aMenu
addLine;
addUpdating: #switchInstanceMessagesPanelPhrase
target: self
action: #switchInstanceMessagesPanel;
addUpdating: #switchClassMessagesPanelPhrase
target: self
action: #switchClassMessagesPanel;
addLine;
add: 'choose superclass'
target: self
selector: #connect;
addLine;
addUpdating: #switchAbstractPhrase
target: self
action: #switchAbstract;
addLine;
add: 'compile class'
target: UmlClass
selector: #compileFrom:
argument: self;
yourself.
self classNameTextMorph contents isEmpty
ifFalse: [aMenu addTitle: self classNameTextMorph contents].! !
!MorphConnectedConnectorBehaviour methodsFor: 'event handling' stamp: 'yj 9/23/2003 22:31'!
addYellowButtonMenuOptionsTo: aMenu onEvent: anEvent onEnd: aConstraintOrNil
aMenu
addLine;
add: 'compile relationship'
target: UmlRelationship
selector: #compileFromShape:
argument: self.
aMenu
add: 'add label' action: #addLabel;
addLine;
add: 'delete' action: #delete;
addLine;
add: '(from) double arrowhead' action: #startOnDoubleArrowhead;
add: '(from) open arrowhead' action: #startOnOpenArrowhead;
add: '(from) closed arrowhead' action: #startOnClosedArrowhead;
add: '(from) no arrowhead' action: #startOnNoArrowhead;
addLine;
add: '(to) double arrowhead' action: #endOnDoubleArrowhead;
add: '(to) open arrowhead' action: #endOnOpenArrowhead;
add: '(to) closed arrowhead' action: #endOnClosedArrowhead;
add: '(to) no arrowhead' action: #endOnNoArrowhead;
addLine;
addUpdating: #makeDashedOrSolidLinePhrase action: #toggleDashedLine;
addLine.
! !
!NCConnectorMorph methodsFor: 'zti' stamp: 'yj 9/22/2003 20:35'!
labelTextString
| labelMorph |
labelMorph := (self valueOfProperty: #connectedConstraints) detect: [:each | each isKindOf: NCLabelMorph] ifNone: [^nil].
^labelMorph label text string.
! !
!JacarandaConnector methodsFor: 'end arrowheads' stamp: 'yj 9/16/2003 22:21'!
startOnClosedArrowhead
self startOnNoArrowhead.
self startConstraint
addShape: self startConstraint class closedArrowheadShape;
step.! !
!JacarandaConnector methodsFor: 'end arrowheads' stamp: 'yj 9/16/2003 22:21'!
startOnDoubleArrowhead
self startOnNoArrowhead.
self startConstraint
addShape: self class doubleArrowheadShape;
step! !
!JacarandaConnector methodsFor: 'end arrowheads' stamp: 'yj 9/16/2003 22:21'!
startOnNoArrowhead
self startConstraint submorphs do: [:ea | self startConstraint deleteShape: ea].
! !
!JacarandaConnector methodsFor: 'end arrowheads' stamp: 'yj 9/16/2003 22:22'!
startOnOpenArrowhead
self startOnNoArrowhead.
self startConstraint
addShape: self startConstraint class openArrowheadShape;
step.! !
!JacarandaConnector methodsFor: 'zti' stamp: 'yj 9/12/2003 17:08'!
diagram
^self owner owner owner owner! !
!JacarandaConnector methodsFor: 'zti' stamp: 'yj 9/19/2003 22:24'!
isAssociation
^self startConnection class = ClassShape and: [self endConnection class = ClassShape]! !
!JacarandaConnector methodsFor: 'zti' stamp: 'yj 9/19/2003 23:04'!
isSubSuper
^self externalName = 'closed arrowhead connector'! !
!JacarandaConnector methodsFor: 'zti' stamp: 'yj 9/19/2003 21:53'!
labelTextString
| labelMorph |
labelMorph := (self valueOfProperty: #connectedConstraints) detect: [:each | each isKindOf: NCLabelMorph] ifNone: [^nil].
^labelMorph label text string.
! !
!JacarandaConnector methodsFor: 'zti' stamp: 'yj 9/21/2003 22:07'!
subtypeClassShape
"Answer the subtype side.
Assumes the closed arrow from the shape palette is used;
otherwise, more logic is needed to figure out which end to return."
^self startConnection
! !
!JacarandaConnector methodsFor: 'zti' stamp: 'yj 9/22/2003 10:19'!
supertypeClassShape
"Answer the supertype side.
Assumes the closed arrow from the shape palette is used;
otherwise, more logic is needed to figure out which end to return."
^self endConnection
! !
!JacarandaShape reorganize!
('connection' ableToConnectTo: askUserToSelectShapeToConnect attachHeadOfConnector:toConnectTo: attachTailOfConnector:toConnectTo: connect connectTo: connectorToConnectTo: preferredConnection)
('menus' addBasicMenuItemsTo:onEvent: addOptionsMenuItemsTo:onEvent: changeColor confirmDelete invokeMenu: setShapeColor:)
('group operations' addConnectedShapesTo: confirmDeleteAllConnectedMorphs connectedShapes deleteAllConnectedMorphs moveAllConnectedShapes)
('highlighting' connectableShapesAt: highlightConnectableShapesAt: turnOffHighlightedShapes turnOffHighlighting turnOnHighlighting)
('submorphs-add/remove' delete)
('event handling' handlesMouseDown: mouseDown: showExplanatoryBalloonHelp startDrag:)
('initialization' initialize)
('balloon help' selectTargetHelpText showSelectTargetBalloonHelp)
('zti' diagram)
!
-------------- next part --------------
Object subclass: #UmlNameCompartment
instanceVariableNames: 'stereotype name type properties '
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Models'!
!UmlNameCompartment methodsFor: 'accessing' stamp: 'yj 9/9/2003 19:10'!
name
^name! !
!UmlNameCompartment methodsFor: 'accessing' stamp: 'yj 9/9/2003 19:10'!
name: anObject
name := anObject! !
!UmlNameCompartment methodsFor: 'accessing' stamp: 'yj 9/11/2003 19:51'!
properties
^properties! !
!UmlNameCompartment methodsFor: 'accessing' stamp: 'yj 9/11/2003 19:51'!
properties: anObject
properties := anObject! !
!UmlNameCompartment methodsFor: 'accessing' stamp: 'yj 9/19/2003 17:08'!
propertyAt: index
^(properties isNil or: [index > properties size])
ifTrue: [nil]
ifFalse: [properties at: index]! !
!UmlNameCompartment methodsFor: 'accessing' stamp: 'yj 9/9/2003 19:06'!
stereotype
^stereotype! !
!UmlNameCompartment methodsFor: 'accessing' stamp: 'yj 9/9/2003 19:06'!
stereotype: anObject
stereotype := anObject! !
!UmlNameCompartment methodsFor: 'accessing' stamp: 'yj 9/11/2003 20:56'!
type
^type! !
!UmlNameCompartment methodsFor: 'accessing' stamp: 'yj 9/11/2003 20:56'!
type: anObject
type := anObject! !
!UmlNameCompartment methodsFor: 'initialize' stamp: 'yj 9/11/2003 21:31'!
initializeOn: aString
| firstPart lBraceIndex rBraceIndex lGuillemetIndex rGuillemetIndex nameAndType colonIndex |
lBraceIndex := aString indexOf: ${.
rBraceIndex := aString indexOf: $}.
(lBraceIndex > 0 and: [rBraceIndex > 0])
ifTrue: [
firstPart := (aString copyFrom: 1 to: lBraceIndex - 1).
properties := ((aString copyFrom: lBraceIndex + 1 to: rBraceIndex - 1) subStrings: ',')
collect: [:each | each withBlanksTrimmed].
]
ifFalse: [firstPart := aString].
lGuillemetIndex := firstPart indexOf: $<.
rGuillemetIndex := firstPart indexOf: $>.
(lGuillemetIndex > 0 and: [rGuillemetIndex > 0])
ifTrue: [
self stereotype: (firstPart copyFrom: lGuillemetIndex + 1 to: rGuillemetIndex - 1) withBlanksTrimmed asLowercase.
nameAndType := firstPart copyFrom: rGuillemetIndex + 1 to: firstPart size.
]
ifFalse: [nameAndType := firstPart].
colonIndex := nameAndType indexOf: $:.
colonIndex > 0
ifTrue: [
self name: (nameAndType copyFrom: 1 to: colonIndex - 1) withBlanksTrimmed.
self type: (nameAndType copyFrom: colonIndex + 1 to: nameAndType size) withBlanksTrimmed.
]
ifFalse: [self name: nameAndType withBlanksTrimmed].
! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
UmlNameCompartment class
instanceVariableNames: ''!
!UmlNameCompartment class methodsFor: 'instance creation' stamp: 'yj 9/15/2003 17:45'!
on: aShape
^self new initializeOn: aShape! !
Object subclass: #UmlObject
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Models'!
!UmlObject methodsFor: 'compiling' stamp: 'yj 9/12/2003 16:27'!
categoryName
^'ooa'! !
!UmlObject methodsFor: 'compiling' stamp: 'yj 9/19/2003 17:12'!
collectionMethodSource: aCollection named: methodName
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: methodName; cr.
ws tab; nextPutAll: '^(OrderedCollection new)'; cr.
aCollection asSortedCollection do: [:each | ws tab; tab; nextPutAll: 'add: ', each,';'; cr].
ws tab; tab; nextPutAll: 'yourself'.
^ws contents! !
UmlObject subclass: #UmlAttribute
instanceVariableNames: 'nameCompartment '
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Models'!
!UmlAttribute methodsFor: 'accessing' stamp: 'yj 9/11/2003 21:02'!
identifier
^self isIdentifier ifTrue: ['1'] ifFalse: ['0']! !
!UmlAttribute methodsFor: 'accessing' stamp: 'yj 9/11/2003 21:01'!
instVarName
^self name asLegalSelector! !
!UmlAttribute methodsFor: 'accessing' stamp: 'yj 9/11/2003 20:59'!
name
^self nameCompartment name! !
!UmlAttribute methodsFor: 'accessing' stamp: 'yj 9/11/2003 20:23'!
nameCompartment
^nameCompartment! !
!UmlAttribute methodsFor: 'accessing' stamp: 'yj 9/11/2003 20:23'!
nameCompartment: anObject
nameCompartment := anObject! !
!UmlAttribute methodsFor: 'accessing' stamp: 'yj 9/11/2003 20:59'!
type
^self nameCompartment type! !
!UmlAttribute methodsFor: 'compiling' stamp: 'yj 9/11/2003 21:08'!
accessorGetterMethodSource
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: self instVarName; cr.
ws tab; nextPutAll: '^', self instVarName.
^ws contents! !
!UmlAttribute methodsFor: 'compiling' stamp: 'yj 9/15/2003 13:59'!
accessorSetterMethodSource
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: self instVarName, ': anObject'; cr.
ws tab; nextPutAll: '^', self instVarName, ' := anObject'.
^ws contents! !
!UmlAttribute methodsFor: 'compiling' stamp: 'yj 9/11/2003 21:24'!
newSelfMethodSource
| ws |
ws := ReadWriteStream on: String new.
ws
nextPutAll: 'SAAttribute fromArray: #(';
nextPutAll: '0' printString; space;
nextPutAll: self identifier printString; space;
nextPutAll: self instVarName printString; space;
nextPutAll: self name printString; space;
nextPutAll: self type printString;
nextPutAll: ')';
yourself.
^ws contents! !
!UmlAttribute methodsFor: 'initialize' stamp: 'yj 9/11/2003 20:25'!
initializeOn: aString
nameCompartment := UmlNameCompartment on: aString.
! !
!UmlAttribute methodsFor: 'testing' stamp: 'yj 9/11/2003 21:23'!
isIdentifier
| props |
props := self nameCompartment properties.
^props notNil and: [props includes: 'I']! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
UmlAttribute class
instanceVariableNames: ''!
!UmlAttribute class methodsFor: 'instance creation' stamp: 'yj 9/11/2003 20:24'!
on: aString
^self new initializeOn: aString! !
UmlObject subclass: #UmlClass
instanceVariableNames: 'package nameCompartment attributes '
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Models'!
!UmlClass methodsFor: 'accessing' stamp: 'yj 9/11/2003 20:44'!
attributes
^attributes! !
!UmlClass methodsFor: 'accessing' stamp: 'yj 9/11/2003 20:44'!
attributes: anObject
attributes := anObject! !
!UmlClass methodsFor: 'accessing' stamp: 'yj 9/11/2003 14:48'!
nameCompartment
^nameCompartment! !
!UmlClass methodsFor: 'accessing' stamp: 'yj 9/11/2003 14:48'!
nameCompartment: anObject
nameCompartment := anObject! !
!UmlClass methodsFor: 'accessing' stamp: 'yj 9/11/2003 15:00'!
package
^package! !
!UmlClass methodsFor: 'accessing' stamp: 'yj 9/11/2003 15:00'!
package: anObject
package := anObject! !
!UmlClass methodsFor: 'accessing - derived' stamp: 'yj 9/11/2003 19:00'!
keyLetter
^self nameCompartment propertyAt: 2! !
!UmlClass methodsFor: 'accessing - derived' stamp: 'yj 9/11/2003 22:07'!
legalClassName
^self prefix, self name asLegalSelector capitalized! !
!UmlClass methodsFor: 'accessing - derived' stamp: 'yj 9/11/2003 20:12'!
name
^self nameCompartment name! !
!UmlClass methodsFor: 'accessing - derived' stamp: 'yj 9/11/2003 18:59'!
number
^self nameCompartment propertyAt: 1! !
!UmlClass methodsFor: 'accessing - derived' stamp: 'yj 9/15/2003 20:22'!
prefix
^self isImported
ifTrue: [(self package parent subpackages detect: [:each | each definesClass: self name]) prefix]
ifFalse: [self package prefix]! !
!UmlClass methodsFor: 'compiling' stamp: 'yj 9/14/2003 23:18'!
compile
| theMetaClass theClass |
self isImported ifFalse: [
Transcript show: self legalClassName; cr.
SAPassiveObject
subclass: self legalClassName asSymbol
instanceVariableNames: self instanceVariableNames
classVariableNames: ''
poolDictionaries: ''
category: self prefix.
theClass := (Smalltalk classNamed: self legalClassName).
theMetaClass := theClass class.
theMetaClass compile: self restoreSelfMethodSource classified: self categoryName.
theMetaClass compile: self relatedAttributesMethodSource classified: self categoryName.
self attributes do: [:each |
theClass compile: each accessorGetterMethodSource classified: 'accessing'.
theClass compile: each accessorSetterMethodSource classified: 'accessing'.
].
].
! !
!UmlClass methodsFor: 'compiling' stamp: 'yj 9/11/2003 21:13'!
instanceVariableNames
^self attributes
inject: ''
into: [:value :each | value, ' ', each instVarName].
! !
!UmlClass methodsFor: 'compiling' stamp: 'yj 9/11/2003 21:12'!
instanceVariableNamesFrom
^self attributes
inject: ''
into: [:value :each | value, ' ', each instVarName].
! !
!UmlClass methodsFor: 'compiling' stamp: 'yj 9/11/2003 21:21'!
relatedAttributesMethodSource
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: 'zzRelatedAttributes'; cr.
ws tab; nextPutAll: '^(OrderedCollection new)'; cr.
self attributes do: [:each |
ws tab; tab;
nextPutAll: 'add: (';
nextPutAll: each newSelfMethodSource;
nextPutAll: ');';
cr;
yourself.
].
ws tab; tab; nextPutAll: 'yourself'.
^ws contents! !
!UmlClass methodsFor: 'compiling' stamp: 'yj 9/11/2003 20:12'!
restoreSelfMethodSource
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: 'zzRestoreSelf'; cr.
ws tab; nextPutAll: '^self'; cr.
ws tab; tab; nextPutAll: 'zzInitialize;'; cr.
ws tab; tab; nextPutAll: 'objectName: self zzName;'; cr.
ws tab; tab; nextPutAll: 'name: ', self name printString, ';'; cr.
ws tab; tab; nextPutAll: 'number: ', self number printString, ';'; cr.
ws tab; tab; nextPutAll: 'keyLetter: ', self keyLetter printString, ';'; cr.
ws tab; tab; nextPutAll: 'yourself'.
^ws contents! !
!UmlClass methodsFor: 'initialize' stamp: 'yj 9/11/2003 20:46'!
initializeOn: aClassShape in: aPackage
package := aPackage.
nameCompartment := UmlNameCompartment on: aClassShape classNameTextMorph text string..
attributes := OrderedCollection new.
aClassShape instanceMessagesTextMorph text string
linesDo: [:each | attributes add: (UmlAttribute on: each)].
! !
!UmlClass methodsFor: 'testing' stamp: 'yj 9/11/2003 18:30'!
isImported
^self nameCompartment stereotype notNil and: [self nameCompartment stereotype asSymbol = #imported]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
UmlClass class
instanceVariableNames: ''!
!UmlClass class methodsFor: 'instance creation' stamp: 'yj 9/12/2003 16:32'!
compileFrom: aClassShape
^(self on: aClassShape) compile! !
!UmlClass class methodsFor: 'instance creation' stamp: 'yj 9/11/2003 18:56'!
on: aClassShape
^self on: aClassShape in: (UmlPackage on: aClassShape diagram diagramOrganization)! !
!UmlClass class methodsFor: 'instance creation' stamp: 'yj 9/11/2003 18:56'!
on: aClassShape in: aPackage
^self new initializeOn: aClassShape in: aPackage! !
UmlObject subclass: #UmlPackage
instanceVariableNames: 'nameCompartment parent subpackages classes relationships '
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Models'!
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/12/2003 18:12'!
classes
^classes! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/12/2003 18:12'!
classes: anObject
classes := anObject! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/15/2003 20:37'!
definesClass: className
^self classes anySatisfy: [:each | each isImported not and: [each name = className]]! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/15/2003 14:05'!
legalClassName
^self prefix, self name asLegalSelector capitalized, (self isSubsystem ifTrue: ['Subsystem'] ifFalse: [''])! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/11/2003 22:06'!
name
^self nameCompartment name! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/11/2003 18:50'!
nameCompartment
^nameCompartment! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/11/2003 18:50'!
nameCompartment: anObject
nameCompartment := anObject! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/15/2003 20:04'!
parent
"Answer the value of parent"
^ parent! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/15/2003 20:04'!
parent: anObject
"Set the value of parent"
parent _ anObject! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/11/2003 19:55'!
prefix
^self nameCompartment propertyAt: 1! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/12/2003 18:12'!
relationships
^relationships! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/12/2003 18:12'!
relationships: anObject
relationships := anObject! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/12/2003 18:06'!
subpackages
^subpackages! !
!UmlPackage methodsFor: 'accessing' stamp: 'yj 9/12/2003 18:06'!
subpackages: anObject
subpackages := anObject! !
!UmlPackage methodsFor: 'compiling' stamp: 'yj 9/15/2003 14:24'!
compile
self isSubsystem
ifTrue: [self compileSubsystem]
ifFalse: [self compileDomain].
! !
!UmlPackage methodsFor: 'compiling' stamp: 'yj 9/15/2003 14:05'!
compileDomain
| domainClass definedSubsystems |
subpackages do: [:each | each compileSubsystem].
SADomain
subclass: self legalClassName asSymbol
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: self prefix.
domainClass := Smalltalk classNamed: self legalClassName.
domainClass class compile: self domainRestoreSelfMethodSource classified: self categoryName.
definedSubsystems := subpackages collect: [:each | each legalClassName].
domainClass class compile: (self collectionMethodSource: definedSubsystems named: 'zzRelatedSubsystems') classified: self categoryName.
! !
!UmlPackage methodsFor: 'compiling' stamp: 'yj 9/15/2003 14:06'!
compileSubsystem
| theMetaClass definedRelationships definedClasses importedClasses |
classes do: [:each | each compile].
relationships do: [:each | each compile].
SASubsystem
subclass: self legalClassName asSymbol
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: self prefix.
theMetaClass := (Smalltalk classNamed: self legalClassName) class.
theMetaClass compile: self subsystemRestoreSelfMethodSource classified: self categoryName.
definedRelationships := (relationships select: [:c | c notNil]) collect: [:each | each legalClassName].
theMetaClass compile: (self collectionMethodSource: definedRelationships named: 'zzRelatedRelationships') classified: self categoryName.
definedClasses := (classes select: [:c | c isImported not]) collect: [:each | each legalClassName].
theMetaClass compile: (self collectionMethodSource: definedClasses named: 'zzRelatedObjects') classified: self categoryName.
importedClasses := (classes select: [:c | c isImported]) collect: [:each | each legalClassName].
theMetaClass compile: (self collectionMethodSource: importedClasses named: 'zzImportedObjects') classified: self categoryName.
! !
!UmlPackage methodsFor: 'compiling' stamp: 'yj 9/11/2003 22:19'!
domainRestoreSelfMethodSource
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: 'zzRestoreSelf'; cr.
ws tab; nextPutAll: '^self'; cr.
ws tab; tab; nextPutAll: 'zzInitialize;'; cr.
ws tab; tab; nextPutAll: 'domainName: self zzName;'; cr.
ws tab; tab; nextPutAll: 'name: ', self name printString, ';'; cr.
ws tab; tab; nextPutAll: 'prefix: ', self prefix printString, ';'; cr.
ws tab; tab; nextPutAll: 'yourself'.
^ws contents! !
!UmlPackage methodsFor: 'compiling' stamp: 'yj 9/18/2003 21:55'!
sifExport
^self sifExportInheritingFrom: SAMetaModelObject
! !
!UmlPackage methodsFor: 'compiling' stamp: 'yj 9/18/2003 21:48'!
sifExportCategory: categoryName inheritingFrom: superClass
SmalltalkInterchangeFileManager newForFileOut
fileName: categoryName, '.sif';
addClasses: (((SystemOrganization listAtCategoryNamed: categoryName asSymbol)
collect: [:each | Smalltalk at: each]) select: [:each | each inheritsFrom: superClass]);
fileOut
! !
!UmlPackage methodsFor: 'compiling' stamp: 'yj 9/18/2003 21:53'!
sifExportInheritingFrom: superClass
self subpackages do: [:each | self sifExportCategory: each prefix inheritingFrom: superClass].
self sifExportCategory: self prefix inheritingFrom: superClass.
! !
!UmlPackage methodsFor: 'compiling' stamp: 'yj 9/18/2003 21:56'!
sifExportObjects
^self sifExportInheritingFrom: SAObject
! !
!UmlPackage methodsFor: 'compiling' stamp: 'yj 9/18/2003 21:56'!
sifExportRelationships
^self sifExportInheritingFrom: SARelationship
! !
!UmlPackage methodsFor: 'compiling' stamp: 'yj 9/11/2003 22:05'!
subsystemRestoreSelfMethodSource
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: 'zzRestoreSelf'; cr.
ws tab; nextPutAll: '^self'; cr.
ws tab; tab; nextPutAll: 'zzInitialize;'; cr.
ws tab; tab; nextPutAll: 'subsystemName: self zzName;'; cr.
ws tab; tab; nextPutAll: 'name: ', self name printString, ';'; cr.
ws tab; tab; nextPutAll: 'subsystemPrefix: ', self prefix printString, ';'; cr.
ws tab; tab; nextPutAll: 'yourself'.
^ws contents! !
!UmlPackage methodsFor: 'initialize' stamp: 'yj 9/19/2003 22:51'!
initializeOn: aDiagramOrganization
| classDiagram |
nameCompartment := UmlNameCompartment on: aDiagramOrganization name.
subpackages := aDiagramOrganization suborganizations collect: [:each | UmlPackage basicOn: each].
subpackages isEmpty ifTrue: [
| connectors associators relNames |
classDiagram := aDiagramOrganization diagrams first.
classes := (classDiagram canvas submorphs select: [:each | each class = ClassShape])
collect: [:each | UmlClass on: each in: self].
relationships := OrderedCollection new.
relNames := Set new.
associators := UmlRelationship findAssociators: classDiagram canvas.
connectors := classDiagram canvas submorphs select: [:each | each class = JacarandaConnector and: [each isAssociation]].
connectors do: [:each | | r |
r := UmlRelationship on: each with: associators in: self.
(relNames includes: r name)
ifFalse: [relNames add: r name. relationships add: r].
].
].
! !
!UmlPackage methodsFor: 'testing' stamp: 'yj 9/15/2003 14:03'!
isSubsystem
^self subpackages isEmpty! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
UmlPackage class
instanceVariableNames: ''!
!UmlPackage class methodsFor: 'instance creation' stamp: 'yj 9/15/2003 17:55'!
basicOn: aDiagramOrganization
^self new initializeOn: aDiagramOrganization! !
!UmlPackage class methodsFor: 'instance creation' stamp: 'yj 9/12/2003 19:33'!
compileFrom: aDiagramOrganization
^(self on: aDiagramOrganization) compile! !
!UmlPackage class methodsFor: 'instance creation' stamp: 'yj 9/18/2003 21:59'!
exportObjectsSifFrom: aDiagramOrganization
^(self on: aDiagramOrganization) sifExportObjects! !
!UmlPackage class methodsFor: 'instance creation' stamp: 'yj 9/18/2003 21:58'!
exportRelationshipsSifFrom: aDiagramOrganization
^(self on: aDiagramOrganization) sifExportRelationships! !
!UmlPackage class methodsFor: 'instance creation' stamp: 'yj 9/15/2003 14:26'!
exportSifFrom: aDiagramOrganization
^(self on: aDiagramOrganization) sifExport! !
!UmlPackage class methodsFor: 'instance creation' stamp: 'yj 9/15/2003 20:49'!
on: aDiagramOrganization
| parent |
^aDiagramOrganization suborganizations notEmpty
ifTrue: [
parent := self basicOn: aDiagramOrganization.
parent subpackages do: [:each | each parent: parent].
parent
]
ifFalse: [
parent := self basicOn: aDiagramOrganization parentOrganization.
parent subpackages do: [:each | each parent: parent].
parent subpackages detect: [:each | each name = (UmlNameCompartment on: aDiagramOrganization name) name]
]! !
UmlObject subclass: #UmlRelationship
instanceVariableNames: 'package kind nameCompartment thisSide thisSidePhrase thisSideMultiplicity thisSideConditionality otherSide otherSidePhrase otherSideMultiplicity otherSideConditionality associator supertype subtypes '
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Models'!
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:41'!
associator
^associator! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:41'!
associator: anObject
associator := anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:51'!
kind
^kind! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:51'!
kind: anObject
kind := anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/11/2003 23:10'!
nameCompartment
^nameCompartment! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/11/2003 23:10'!
nameCompartment: anObject
nameCompartment := anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:41'!
otherSide
^otherSide! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:41'!
otherSide: anObject
otherSide := anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/16/2003 22:54'!
otherSideConditionality
"Answer the value of otherSideConditionality"
^ otherSideConditionality! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/16/2003 22:54'!
otherSideConditionality: anObject
"Set the value of otherSideConditionality"
otherSideConditionality _ anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/16/2003 22:54'!
otherSideMultiplicity
"Answer the value of otherSideMultiplicity"
^ otherSideMultiplicity! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/16/2003 22:54'!
otherSideMultiplicity: anObject
"Set the value of otherSideMultiplicity"
otherSideMultiplicity _ anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:52'!
otherSidePhrase
^otherSidePhrase! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:52'!
otherSidePhrase: anObject
otherSidePhrase := anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/11/2003 23:15'!
package
^package! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/11/2003 23:15'!
package: anObject
package := anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/19/2003 23:00'!
subtypes
"Answer the value of subtypes"
^ subtypes! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/19/2003 23:00'!
subtypes: anObject
"Set the value of subtypes"
subtypes _ anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/19/2003 23:00'!
supertype
"Answer the value of supertype"
^ supertype! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/19/2003 23:00'!
supertype: anObject
"Set the value of supertype"
supertype _ anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:41'!
thisSide
^thisSide! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:41'!
thisSide: anObject
thisSide := anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/16/2003 22:54'!
thisSideConditionality
"Answer the value of thisSideConditionality"
^ thisSideConditionality! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/16/2003 22:54'!
thisSideConditionality: anObject
"Set the value of thisSideConditionality"
thisSideConditionality _ anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/16/2003 22:54'!
thisSideMultiplicity
"Answer the value of thisSideMultiplicity"
^ thisSideMultiplicity! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/16/2003 22:54'!
thisSideMultiplicity: anObject
"Set the value of thisSideMultiplicity"
thisSideMultiplicity _ anObject! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:52'!
thisSidePhrase
^thisSidePhrase! !
!UmlRelationship methodsFor: 'accessing' stamp: 'yj 9/12/2003 10:52'!
thisSidePhrase: anObject
thisSidePhrase := anObject! !
!UmlRelationship methodsFor: 'accessing - derived' stamp: 'yj 9/12/2003 10:14'!
legalClassName
^self prefix, self name asLegalSelector capitalized! !
!UmlRelationship methodsFor: 'accessing - derived' stamp: 'yj 9/12/2003 10:14'!
name
^self nameCompartment name! !
!UmlRelationship methodsFor: 'accessing - derived' stamp: 'yj 9/12/2003 10:16'!
prefix
^self package prefix! !
!UmlRelationship methodsFor: 'compiling' stamp: 'yj 9/12/2003 19:50'!
compile
| theMetaClass |
Transcript show: self legalClassName; cr.
SARelationship
subclass: self legalClassName asSymbol
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: self prefix.
theMetaClass := (Smalltalk classNamed: self legalClassName) class.
theMetaClass compile: self restoreSelfMethodSource classified: self categoryName.
! !
!UmlRelationship methodsFor: 'compiling' stamp: 'yj 9/19/2003 23:01'!
restoreSelfAssociationMethodSource
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: 'zzRestoreSelf'; cr.
ws tab; nextPutAll: '^self'; cr.
ws tab; tab; nextPutAll: 'zzInitialize;'; cr.
ws tab; tab; nextPutAll: 'relationshipName: self zzName;'; cr.
ws tab; tab; nextPutAll: 'kind: ', kind printString, ';'; cr.
ws tab; tab; nextPutAll: 'thisSide: ', self thisSide legalClassName, ';'; cr.
ws tab; tab; nextPutAll: 'thisSidePhrase: ', self thisSidePhrase printString, ';'; cr.
ws tab; tab; nextPutAll: 'thisSideMultiplicity: ', self thisSideMultiplicity printString, ';'; cr.
ws tab; tab; nextPutAll: 'thisSideConditionality: nil', ';'; cr.
ws tab; tab; nextPutAll: 'otherSide: ', self otherSide legalClassName, ';'; cr.
ws tab; tab; nextPutAll: 'otherSidePhrase: ', self otherSidePhrase printString, ';'; cr.
ws tab; tab; nextPutAll: 'otherSideMultiplicity: ', self otherSideMultiplicity printString, ';'; cr.
ws tab; tab; nextPutAll: 'otherSideConditionality: nil', ';'; cr.
ws tab; tab; nextPutAll: 'associator: ', (self associator isNil ifTrue: [nil printString] ifFalse: [self associator legalClassName]), ';'; cr.
ws tab; tab; nextPutAll: 'yourself'.
^ws contents! !
!UmlRelationship methodsFor: 'compiling' stamp: 'yj 9/19/2003 23:09'!
restoreSelfMethodSource
^self isSubSuper
ifTrue: [self restoreSelfSubSuperMethodSource]
ifFalse: [self restoreSelfAssociationMethodSource]
! !
!UmlRelationship methodsFor: 'compiling' stamp: 'yj 9/21/2003 22:09'!
restoreSelfSubSuperMethodSource
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: 'zzRestoreSelf'; cr.
ws tab; nextPutAll: '^self'; cr.
ws tab; tab; nextPutAll: 'zzInitialize;'; cr.
ws tab; tab; nextPutAll: 'relationshipName: self zzName;'; cr.
ws tab; tab; nextPutAll: 'supertype: ', self supertype legalClassName, ';'; cr.
ws tab; tab; nextPutAll: 'subtypes: ((OrderedCollection new)'; cr.
(self subtypes collect: [:each | each legalClassName]) asSortedCollection
do: [:each | ws tab; tab; tab; nextPutAll: 'add: ', each, ';'; cr].
ws tab; tab; tab; nextPutAll: 'yourself);'; cr.
ws tab; tab; nextPutAll: 'yourself'.
^ws contents! !
!UmlRelationship methodsFor: 'initialize' stamp: 'yj 9/22/2003 10:20'!
connector: aConnector associators: associators in: aPackage
package := aPackage.
nameCompartment := UmlNameCompartment on: aConnector labelTextString.
aConnector isSubSuper
ifTrue: [
self supertype: (UmlClass on: aConnector supertypeClassShape in: aPackage).
self subtypes:
(((self class findSubtypeConnectors: aConnector diagram canvas)
select: [:each | each labelTextString = aConnector labelTextString])
collect: [:each | UmlClass on: each subtypeClassShape in: aPackage]).
]
ifFalse: [
self thisSide: (UmlClass on: aConnector startConnection in: aPackage).
self thisSideMultiplicity: (self multiplicity: aConnector startConstraint).
self otherSide: (UmlClass on: aConnector endConnection in: aPackage).
self otherSideMultiplicity: (self multiplicity: aConnector endConstraint).
associators do: [:each |
each startConnection = aConnector
ifTrue: [self associator: (UmlClass on: each endConnection in: aPackage)].
each endConnection = aConnector
ifTrue: [self associator: (UmlClass on: each startConnection in: aPackage)].
].
self kind: self thisSideMultiplicity, self otherSideMultiplicity.
self associator notNil ifTrue: [self kind: self kind, 'A'].
].
! !
!UmlRelationship methodsFor: 'initialize' stamp: 'yj 9/16/2003 22:52'!
multiplicity: aLineEndConstraintMorph
aLineEndConstraintMorph submorphs do: [:each |
each knownName = 'open arrowhead' ifTrue: [^'1'].
each knownName = 'double arrowhead' ifTrue: [^'M'].
].
^'1'
! !
!UmlRelationship methodsFor: 'testing' stamp: 'yj 9/19/2003 23:02'!
isSubSuper
^self supertype notNil! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
UmlRelationship class
instanceVariableNames: ''!
!UmlRelationship class methodsFor: 'instance creation' stamp: 'yj 9/12/2003 17:04'!
compileFrom: aConnector
^(self on: aConnector) compile! !
!UmlRelationship class methodsFor: 'instance creation' stamp: 'yj 9/12/2003 18:02'!
compileFromShape: aConnectorShape
^(self on: aConnectorShape connector) compile! !
!UmlRelationship class methodsFor: 'instance creation' stamp: 'yj 9/16/2003 22:02'!
findAssociators: aCanvas
^(aCanvas submorphs select: [:each | each class = JacarandaConnector])
select: [:each |
| firstClass secondClass |
firstClass := each startConnection class.
secondClass := each endConnection class.
(firstClass = ClassShape & secondClass = JacarandaConnector)
or: [firstClass = JacarandaConnector & secondClass = ClassShape]
]! !
!UmlRelationship class methodsFor: 'instance creation' stamp: 'yj 9/21/2003 21:23'!
findSubtypeConnectors: aCanvas
^(aCanvas submorphs select: [:each | each class = JacarandaConnector])
select: [:each | each isSubSuper].
! !
!UmlRelationship class methodsFor: 'instance creation' stamp: 'yj 9/19/2003 22:41'!
on: aConnector
| pkg |
pkg := UmlPackage on: aConnector diagram diagramOrganization.
^pkg relationships detect: [:each | each name = (UmlNameCompartment on: aConnector labelTextString) name]! !
!UmlRelationship class methodsFor: 'instance creation' stamp: 'yj 9/16/2003 00:53'!
on: aConnector with: associators in: aPackage
^self new connector: aConnector associators: associators in: aPackage! !
UmlObject subclass: #UmlState
instanceVariableNames: 'name number '
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Models'!
!UmlState methodsFor: 'initialize' stamp: 'yj 9/22/2003 21:11'!
initializeOn: stateMorph
| aString dotIndex |
aString := (stateMorph isKindOf: NCEllipseMorph)
ifTrue: ['0. Create']
ifFalse: [(stateMorph findDeeplyA: TextMorph) contents asString].
dotIndex := aString indexOf: $..
dotIndex > 0
ifTrue: [
self number: (aString copyFrom: 1 to: dotIndex - 1) withBlanksTrimmed.
self name: (aString copyFrom: dotIndex + 1 to: aString size) withBlanksTrimmed.
]
ifFalse: [self name: aString withBlanksTrimmed].
! !
!UmlState methodsFor: 'accessing' stamp: 'yj 9/22/2003 17:44'!
name
"Answer the value of number"
^ name! !
!UmlState methodsFor: 'accessing' stamp: 'yj 9/22/2003 17:44'!
name: anObject
"Set the value of name"
name _ anObject! !
!UmlState methodsFor: 'accessing' stamp: 'yj 9/22/2003 17:44'!
number
"Answer the value of number"
^ number! !
!UmlState methodsFor: 'accessing' stamp: 'yj 9/22/2003 17:44'!
number: anObject
"Set the value of number"
number _ anObject! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
UmlState class
instanceVariableNames: ''!
!UmlState class methodsFor: 'instance creation' stamp: 'yj 9/22/2003 21:04'!
on: stateMorph
^self new initializeOn: stateMorph! !
UmlObject subclass: #UmlStatechart
instanceVariableNames: 'classNameCompartment prefix states transitions '
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Models'!
!UmlStatechart methodsFor: 'accessing' stamp: 'yj 9/22/2003 23:16'!
classNameCompartment
"Answer the value of classNameCompartment"
^ classNameCompartment! !
!UmlStatechart methodsFor: 'accessing' stamp: 'yj 9/22/2003 23:16'!
classNameCompartment: anObject
"Set the value of classNameCompartment"
classNameCompartment _ anObject! !
!UmlStatechart methodsFor: 'accessing' stamp: 'yj 9/22/2003 23:18'!
prefix
"Answer the value of prefix"
^ prefix! !
!UmlStatechart methodsFor: 'accessing' stamp: 'yj 9/22/2003 23:16'!
prefix: anObject
"Set the value of prefix"
prefix _ anObject! !
!UmlStatechart methodsFor: 'accessing' stamp: 'yj 9/22/2003 17:27'!
states
"Answer the value of states"
^ states! !
!UmlStatechart methodsFor: 'accessing' stamp: 'yj 9/22/2003 17:27'!
states: anObject
"Set the value of states"
states _ anObject! !
!UmlStatechart methodsFor: 'accessing' stamp: 'yj 9/22/2003 17:27'!
transitions
"Answer the value of transitions"
^ transitions! !
!UmlStatechart methodsFor: 'accessing' stamp: 'yj 9/22/2003 17:27'!
transitions: anObject
"Set the value of transitions"
transitions _ anObject! !
!UmlStatechart methodsFor: 'compiling' stamp: 'yj 9/22/2003 23:20'!
compile
| theClass theMetaClass |
(self transitions
inject: Dictionary new
into: [:value : each | | key |
key := each eventName asSymbol.
(value includesKey: key)
ifTrue: [
(value at: key) eventParameters asSet = each eventParameters asSet
ifFalse: [self error: each eventName, ' parameters not consistently defined']].
value at: key put: each.
value
]) values do: [:each | each compile].
theClass := (Smalltalk classNamed: self objectLegalClassName).
theMetaClass := theClass class.
theMetaClass compile: self relatedStateTransitionsMethodSource classified: self categoryName.
! !
!UmlStatechart methodsFor: 'compiling' stamp: 'yj 9/22/2003 23:19'!
objectLegalClassName
^self prefix, self classNameCompartment name asLegalSelector capitalized! !
!UmlStatechart methodsFor: 'compiling' stamp: 'yj 9/22/2003 21:47'!
relatedStateTransitionsMethodSource
^self
collectionMethodSource: (self transitions collect: [:each | '(', each restoreSelfMethodSource, ')'])
named: 'zzRelatedStateTransitions'! !
!UmlStatechart methodsFor: 'initialize' stamp: 'yj 9/23/2003 14:33'!
initializeOn: aDiagram
| index |
index := aDiagram title indexOfSubCollection: ' Statechart'.
classNameCompartment := UmlNameCompartment on: (index = 0 ifTrue: [aDiagram title] ifFalse: [aDiagram title copyFrom: 1 to: index]).
prefix := (UmlNameCompartment on: aDiagram diagramOrganization name) propertyAt: 1.
"states := (aDiagram canvas submorphs select: [:each | each class = NCTextRectangleMorph])
collect: [:each | UmlState on: each].
"
transitions := (aDiagram canvas submorphs select: [:each | each class = NCConnectorMorph])
collect: [:each | UmlTransition on: each in: self]
! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
UmlStatechart class
instanceVariableNames: ''!
!UmlStatechart class methodsFor: 'instance creation' stamp: 'yj 9/22/2003 17:38'!
compileFrom: aDiagram
^(self on: aDiagram) compile! !
!UmlStatechart class methodsFor: 'instance creation' stamp: 'yj 9/22/2003 17:28'!
on: aDiagram
^self new initializeOn: aDiagram! !
UmlObject subclass: #UmlTransition
instanceVariableNames: 'statechart eventName eventParameters fromState toState '
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Models'!
!UmlTransition methodsFor: 'accessing' stamp: 'yj 9/22/2003 20:20'!
eventName
"Answer the value of eventName"
^ eventName! !
!UmlTransition methodsFor: 'accessing' stamp: 'yj 9/22/2003 20:20'!
eventName: anObject
"Set the value of eventName"
eventName _ anObject! !
!UmlTransition methodsFor: 'accessing' stamp: 'yj 9/22/2003 20:20'!
eventParameters
"Answer the value of eventParameters"
^ eventParameters! !
!UmlTransition methodsFor: 'accessing' stamp: 'yj 9/22/2003 20:20'!
eventParameters: anObject
"Set the value of eventParameters"
eventParameters _ anObject! !
!UmlTransition methodsFor: 'accessing' stamp: 'yj 9/22/2003 20:59'!
fromState
"Answer the value of fromState"
^ fromState! !
!UmlTransition methodsFor: 'accessing' stamp: 'yj 9/22/2003 20:59'!
fromState: anObject
"Set the value of fromState"
fromState _ anObject! !
!UmlTransition methodsFor: 'accessing' stamp: 'yj 9/23/2003 14:31'!
statechart
"Answer the value of statechart"
^ statechart! !
!UmlTransition methodsFor: 'accessing' stamp: 'yj 9/23/2003 14:31'!
statechart: anObject
"Set the value of statechart"
statechart _ anObject! !
!UmlTransition methodsFor: 'accessing' stamp: 'yj 9/22/2003 20:59'!
toState
"Answer the value of toState"
^ toState! !
!UmlTransition methodsFor: 'accessing' stamp: 'yj 9/22/2003 20:59'!
toState: anObject
"Set the value of toState"
toState _ anObject! !
!UmlTransition methodsFor: 'compiling' stamp: 'yj 9/22/2003 22:58'!
accessorGetterMethodSource: instVarName
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: instVarName; cr.
ws tab; nextPutAll: '^', instVarName.
^ws contents! !
!UmlTransition methodsFor: 'compiling' stamp: 'yj 9/22/2003 22:58'!
accessorSetterMethodSource: instVarName
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: instVarName, ': anObject'; cr.
ws tab; nextPutAll: '^', instVarName, ' := anObject'.
^ws contents! !
!UmlTransition methodsFor: 'compiling' stamp: 'yj 9/23/2003 10:12'!
compile
| theClass |
Transcript show: self eventLegalClassName; cr.
SAEvent
subclass: self eventLegalClassName asSymbol
instanceVariableNames: self eventInstanceVariableNames
classVariableNames: ''
poolDictionaries: ''
category: self prefix.
theClass := (Smalltalk classNamed: self eventLegalClassName).
self eventParameters do: [:each |
theClass compile: (self accessorGetterMethodSource: each) classified: 'accessing'.
theClass compile: (self accessorSetterMethodSource: each) classified: 'accessing'.
].
! !
!UmlTransition methodsFor: 'compiling' stamp: 'yj 9/22/2003 22:40'!
eventInstanceVariableNames
^self eventParameters
inject: ''
into: [:value :each | value, ' ', each asLegalSelector].
! !
!UmlTransition methodsFor: 'compiling' stamp: 'yj 9/22/2003 21:41'!
eventLegalClassName
^self prefix, 'Event', self eventName asLegalSelector capitalized! !
!UmlTransition methodsFor: 'compiling' stamp: 'yj 9/23/2003 14:33'!
prefix
^self statechart prefix! !
!UmlTransition methodsFor: 'compiling' stamp: 'yj 9/22/2003 21:48'!
restoreSelfMethodSource
| ws |
ws := ReadWriteStream on: String new.
ws nextPutAll: 'SAStateTransition'.
ws nextPutAll: ' from: '; nextPutAll: self fromState number printString.
ws nextPutAll: ' to: '; nextPutAll: self toState number printString.
ws nextPutAll: ' on: '; nextPutAll: self eventLegalClassName.
^ws contents
! !
!UmlTransition methodsFor: 'initialize' stamp: 'yj 9/22/2003 21:04'!
initializeOn: aConnector
| aString lParenIndex rParenIndex |
aString := aConnector labelTextString.
lParenIndex := aString indexOf: $(.
rParenIndex := aString indexOf: $).
(lParenIndex > 0 and: [rParenIndex > 0])
ifTrue: [
self eventName: (aString copyFrom: 1 to: lParenIndex - 1) withBlanksTrimmed.
self eventParameters:
(((aString copyFrom: lParenIndex + 1 to: rParenIndex - 1) subStrings: ',')
collect: [:each | each withBlanksTrimmed]).
]
ifFalse: [
self eventName: aString withBlanksTrimmed.
self eventParameters: OrderedCollection new.
].
self fromState: (UmlState on: aConnector startConnection).
self toState: (UmlState on: aConnector endConnection).
! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
UmlTransition class
instanceVariableNames: ''!
!UmlTransition class methodsFor: 'instance creation' stamp: 'yj 9/23/2003 14:32'!
on: aConnector in: aStatechart
^self new initializeOn: aConnector; statechart: aStatechart; yourself! !
-------------- next part --------------
Object subclass: #SAMetaModelObject
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Stubs'!
SAMetaModelObject subclass: #SAAttribute
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Stubs'!
SAMetaModelObject subclass: #SADomain
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Stubs'!
SAMetaModelObject subclass: #SAEvent
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Stubs'!
SAMetaModelObject subclass: #SAObject
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Stubs'!
SAObject subclass: #SAPassiveObject
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Stubs'!
SAPassiveObject subclass: #SAActiveObject
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Stubs'!
SAMetaModelObject subclass: #SARelationship
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Stubs'!
SAMetaModelObject subclass: #SAStateTransition
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Stubs'!
SAMetaModelObject subclass: #SASubsystem
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'PUML-Stubs'!
More information about the Squeak-dev mailing list |