Application create: #ZwkPetri with: (#( CommonWidgets ZwkExtensions) collect: [:each | Smalltalk at: each ifAbsent: [ Application errorPrerequisite: #ZwkPetri missing: each]])! ZwkPetri becomeDefault! KeyedCollection subclass: #TwoWayDictionary instanceVariableNames: 'forward reverse reverseAdd reverseRemove ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Graph subclass: #Net instanceVariableNames: 'name random ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Net subclass: #NetType instanceVariableNames: 'autos embeddings embByNode traceEquivalence ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Object subclass: #ColourSet instanceVariableNames: 'name colours functions ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Object subclass: #ColourWood instanceVariableNames: 'trees connections ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Object subclass: #EquivalenceClass instanceVariableNames: 'elements reference toMerge ' classVariableNames: 'FinCount RefCount SwaCount ' poolDictionaries: ''! ZwkPetri becomeDefault! Object subclass: #EquivalenceMap instanceVariableNames: 'relation map ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Object subclass: #EquivalenceRelation instanceVariableNames: 'equivalenceClasses classByElement swallowBlocks ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! GraphNode subclass: #Place instanceVariableNames: '' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! GraphNode subclass: #Transition instanceVariableNames: '' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Object subclass: #NetStructure instanceVariableNames: 'net typeByKey embeddingByNodes forbidden components relationships ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Object subclass: #PartialMap instanceVariableNames: 'source dest ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! PartialMap subclass: #MapAggregation instanceVariableNames: 'left right atBlock doBlock ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! PartialMap subclass: #RelationshipDual instanceVariableNames: 'forward reverse isTo1 isFrom1 isSymmetric isIdentic pairs oneSide inverse ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! PartialMap subclass: #TableMap instanceVariableNames: 'table image ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! TableMap subclass: #NetReduction instanceVariableNames: 'colourSets colourByImage structure ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Object subclass: #Petri instanceVariableNames: 'currents members streamPlus ' classVariableNames: 'Singleton ' poolDictionaries: ''! ZwkPetri becomeDefault! Object subclass: #PlaceReduction instanceVariableNames: 'arcsByKey nodesToAdd ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Object subclass: #Relationship instanceVariableNames: 'pairs analysis ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Relationship subclass: #RelationshipDirection instanceVariableNames: 'relate split collectionSpecies ' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! Application subclass: #ZwkPetri instanceVariableNames: '' classVariableNames: '' poolDictionaries: ''! ZwkPetri becomeDefault! !ColourSet class publicMethods ! new ^ super new colours: OrderedCollection new! new: newSize name: newName | new | ((new := super new) name: newName asSymbol; colours: ((1 to: newSize) collect: [:ix | (newName, '#', ix printString) asSymbol]) asArray; functions: IdentityDictionary new; functionsAt: new) add: (self newRelationship source: new; dest: new; addIdentityOfAll: new colours) analyse. ^ new! ! !ColourSet publicMethods ! colours ^ colours! colours: anObject colours := anObject.! functions ^ functions! functions: anObject functions := anObject.! functionsAt: aColour ^ self functions at: aColour ifAbsentPut: [OrderedCollection new]! functionsDo: aBlock ^ self functions do: [:funColl | funColl do: aBlock]! identity self assert: [ (self functions at: self) first isIdentic]. ^ (self functions at: self) first! name ^ name! name: anObject name := anObject.! newColour ^ self colours add: Object new! printOn: aStream self class printOn: aStream. aStream nextPut: $(; nextPutAll: self name; nextPut: $ . self colours size printOn: aStream. aStream nextPut: $)! size ^ self colours size! subsets | subs | subs := OrderedCollection new. self functionsDo: [:fun | (fun isIdentic not and: [fun isFrom1 and: [fun isTo1 and: [fun dest colours isSameSet: fun image]]]) ifTrue: [subs add: fun]]. ^ subs! ! !ColourWood class publicMethods ! colours: colours | new | (new := self new). colours do: [:col | new addColourSet: col]. ^ new ! colours: colours connections: connections | new | new := self new. colours do: [:col | new addColourSet: col]. connections do: [:conn | new addConnection: conn]. ^ new! new ^ super new trees: Graph new; connections: Graph new; yourself! ! !ColourWood publicMethods ! addColourSet: colSet self connections newNode data: colSet. ^ self trees newNode data: colSet! addConnection: relationship ^ ((self connections nodeAt: relationship source) connectTo: (self connections nodeAt: relationship dest)) data: relationship! connectionFromNode: from to: to self assert: [from graph == self connections and: [to graph == self connections]]. ^ (from arcTo: to ifAbsent: [^ (to arcTo: from) data inverse]) data! connections ^ connections! connections: anObject connections := anObject.! disjointOver: colCollection | image emb dest | image := Set new. colCollection do: [:colSet | emb := self embeddingOfColour: colSet. self assert: [dest isNil ifTrue: [dest := emb dest. true] ifFalse: [dest == emb dest]]. colSet colours do: [:col | (image addIfUnique: (emb at: col)) ifFalse: [^ false]]]. ^ true ! embeddingOfColour: colour ^ self embeddingOfNode: (self trees nodeAt: colour) ! embeddingOfNode: node | next emb | self assert: [node graph == self trees]. next := node parentIfNone: [^ node data identity]. emb := node pre single data. [next pre isEmpty] whileFalse: [ emb := next pre single data compositionJoin: emb. next := next parent]. ^ emb ! groupRelationshipPairs: pairs minima: min | groups | groups := (1 to: 4) asArray collect: [:i | OrderedCollection new]. pairs do: [:ar | ((ar first isFrom1 == ar last isFrom1 or: [(ar first isFrom1 ifTrue: [ar first] ifFalse: [ar last]) source colours size <= min]) and: [ar first isTo1 == ar last isTo1 or: [(ar first isTo1 ifTrue: [ar first] ifFalse: [ar last]) dest colours size <= min]]) ifTrue: [ (groups at: 2 * ((ar first isFrom1 and: [ar last isFrom1]) asInteger) + ((ar first isTo1 and: [ar last isTo1]) asInteger) + 1) add: (ar last compositionJoin: ar first inverse) analyse]]. groups := groups collect: [:gr | gr reject: [:rel | rel isIdentic]]. groups sort: [:a :b | a size >= b size]. " groups do: [:gr | gr size > 1 ifTrue: [ gr any: [:fi | merge := fi copyCollection] do: [:re | merge addMap: re ifFail: [self fail: 'ups']]. aBlock value: merge]]. " ^ groups ! join: colour parallelWith: other detect: aBlock |emb othEmb lastNd | (emb := self embeddingOfColour: colour) dest == (othEmb := self embeddingOfColour: other) dest ifTrue: [aBlock value ifTrue: [^ true]] ifFalse: [ self leafParallelsFrom: (self trees nodeAt: emb dest) to: (self trees nodeAt: othEmb dest) do: [:conn | ((othEmb inverse compositionJoin: conn) compositionJoin: emb) forward isEmpty ifTrue: [ self pushJoin: conn. aBlock value ifTrue: [^ conn]. self popJoin: conn]]]. ^ false. ! join: colour with: other detect: aBlock |emb othEmb conn lastNd | (emb := self embeddingOfColour: colour) dest == (othEmb := self embeddingOfColour: other) dest ifTrue: [aBlock value ifTrue: [^ true]] ifFalse: [ self leafConnectionsFrom: (self trees nodeAt: emb dest) to: (self trees nodeAt: othEmb dest) do: [:path | conn := self connectionFromNode: path first to: (lastNd := path at: 2). path from: 3 to: path size do: [:paNd | conn := (self connectionFromNode: lastNd to: (lastNd := paNd)) compositionJoin: conn]. conn forward isEmpty ifTrue: [ self pushJoin: conn. aBlock value ifTrue: [^ conn]. self popJoin: conn]]]. . ^ false. ! leafConnectionsFrom: node to: other do: aBlock | toLeaves | toLeaves := other leaves collect: [:leaf | self connections nodeAt: leaf data]. node leaves do: [:from | (self connections nodeAt: from data) pathsFrom: 1 to: self trees size do: [:pa | (toLeaves includes: pa last) ifTrue: [aBlock value: pa]]] " self connections do: [:conn | ((leaves includes: conn source) ifTrue: [othLeaves includes: conn dest] ifFalse: [(leaves includes: conn dest) and: [othLeaves includes: conn source]]) ifTrue: [aBlock value: conn]]. "! leafParallelsFrom: from to: to do: aBlock | embs toEmbs rootEmbs conn toConn found merge groups | embs := from leaves collect: [:leaf | self embeddingOfNode: leaf]. toEmbs := to leaves collect: [:leaf | (self embeddingOfNode: leaf)]. found := OrderedCollection new. self trees roots do: [:root | rootEmbs := root leaves collect: [:leaf | (self embeddingOfNode: leaf)]. ((conn := self mergeFunctionsFrom: rootEmbs to: embs) notNil and: [(toConn := self mergeFunctionsFrom: rootEmbs to: toEmbs) notNil]) ifTrue: [found add: (Array with: conn with: toConn)]]. groups := self groupRelationshipPairs: found minima: 0. " groups do: [:gr | gr do: aBlock]. " groups := self groupRelationshipPairs: found minima: 1. " groups do: [:gr | gr do: aBlock]. " aBlock value: (self newRelationship source: from data; dest: to data)! mergeFunctionsFrom: fromEmbs to: toEmbs | merge | fromEmbs do: [:from | toEmbs do: [:to | from source functions at: to source ifPresent: [:fun | merge isNil ifTrue: [(merge := (to compositionJoin: fun single) compositionJoin: from inverse) analyse] ifFalse: [ "self assert: [fun single isFrom1 = merge isFrom1 and: [fun single isTo1 = merge isTo1]]." merge addMap: ((to compositionJoin: fun single) compositionJoin: from inverse) ifFail: [self fail: 'cannot merge']]]]]. ^ merge isNil ifTrue: [nil] ifFalse: [merge analyse]! newColourRelationshipToArc: arc | rel | arc data: (rel := self newRelationship source: arc to data; dest: arc from data). arc to data colours do: [:col | rel origin: col image: rel dest newColour]! newColourRelationshipToArc: arc connecting: conn | rel | arc data: (rel := self newRelationship source: arc to data; dest: arc from data). arc to data colours do: [:col | rel origin: col image: (conn at: col ifAbsent: [rel dest newColour])]! popJoin: conn (conn = true or: [conn = false]) ifTrue: [^ self]. self assert: [(self trees nodeAt: conn source) initialAncestor == (self trees nodeAt: conn dest) initialAncestor]. (self trees nodeAt: conn source) initialAncestor removeWithArcs. self assert: [(self trees nodeAt: conn source) initialAncestor ~= (self trees nodeAt: conn dest) initialAncestor]. ! printTreesOn: aStream aStream printId: self; space. self trees leaves size printOn: aStream. aStream nextPutAll: ' leaves '. self trees roots size printOn: aStream. aStream printAll: ' trees'; right. ((self trees roots collect: [:root | root leaves]) select: [:leaves | leaves size > 1 ]) do: [:leaves | aStream cr. leaves do: [:leaf | aStream printId: leaf; space]]. aStream left! pushJoin: conn | root rootFrom rootTo | self assert: [conn forward isEmpty]. (rootFrom := (self trees nodeAt: conn source) initialAncestor) = (rootTo := (self trees nodeAt: conn dest) initialAncestor) ifTrue: [self fail]. root := self trees newNode data: ColourSet new. self newColourRelationshipToArc: (root connectTo: rootFrom). self newColourRelationshipToArc: (root connectTo: rootTo). " pushJoin: path | root rootFrom rootTo leafFrom leafTo emb anc lastNd treeNd | (rootFrom := (leafFrom := self trees nodeAt: (lastNd := path first) data) initialAncestor) = (rootTo := (leafTo := self trees nodeAt: path last data) initialAncestor) ifTrue: [self fail]. root := self trees newNode data: ColourSet new. emb := self newRelationship source: rootFrom data; dest: root data. self newColourRelationshipToArc: (root connectTo: rootFrom) connecting: emb. emb := (self embeddingOfNode: leafFrom). path from: 2 to: path size do: [:nd | emb := emb compositionJoin: (self connectionFromNode: nd to: lastNd). lastNd := nd]. emb := emb compositionJoin: (self embeddingOfNode: leafTo). self newColourRelationshipToArc: (root connectTo: rootTo) connecting: emb. " " path do: [:nd | anc := (treeNd := self trees nodeAt: nd data) initialAncestor. emb := lastNd isNil ifTrue: [self newRelationship source: anc data; dest: root data] ifFalse: [((self embeddingOfNode: (self trees nodeAt: lastNd data)) compositionJoin: (self connectionFromNode: nd to: lastNd)) compositionJoin: (self embeddingOfNode: treeNd) inverse]. self newColourRelationshipToArc: (root connectTo: anc) connecting: emb. lastNd := nd] " ! trees ^ trees! trees: anObject trees := anObject.! ! !EquivalenceClass class publicMethods ! finCount ^ FinCount! finCount: anObject FinCount := anObject.! new self error: 'use on:'! on: aCollection ^ super new basicElements: aCollection; toMerge: OrderedCollection new ! perfTest: num " ZwkUt spyOn: [EquivalenceClass perfTest: 10000]" | eq ran quotColl doubble lFin lRef lSwa | self refCount: 0; finCount: 0; swaCount: 0. lFin := lRef := lSwa := 0. doubble := 2000. quotColl := OrderedCollection new. ran := EsRandom newReproducible: num. eq := EquivalenceRelation new. 1 to: num do: [:i | eq relate: i to: i]. self refCount: 0; finCount: 0; swaCount: 0. lFin := lRef := lSwa := 0. 1 to: num * 3 do: [:i | eq relate: (ran nextTo: num) to: (ran nextTo: num). i \\ doubble = 0 ifTrue: [ quotColl add: ((Array new: 8) at: 1 put: ((((self refCount - lRef) / (self finCount - lFin + self swaCount - lSwa)) * 100) rounded / 100) asFloat ; at: 2 put: ((((self refCount) / (self finCount + self swaCount)) * 100) rounded / 100) asFloat ; at: 3 put: nil ; at: 4 put: self finCount; at: 5 put: self refCount; at: 6 put: self swaCount; at: 7 put: eq equivalenceClasses size; at: 8 put: i; yourself). lRef := self refCount. lFin := self finCount. lSwa := self swaCount. "doubble := doubble * 2" ]]. ^ quotColl asArray ! refCount ^ RefCount! refCount: anObject RefCount := anObject.! reset self finCount: 0; swaCount: 0; refCount: 0 ! swaCount ^ SwaCount! swaCount: anObject SwaCount := anObject.! ! !EquivalenceClass publicMethods ! addElement: newElement ^ self finalReference basicElements add: newElement ! basicElements ^ elements ! basicElements: anObject elements := anObject.! elements ^ self finalReference finalElements ! elements: anObject elements := anObject.! elementsTreeDo: aBlock self basicElements do: aBlock. self toMerge do: [:anEc | anEc elementsTreeDo: aBlock].! finalElements | merged | self assert: [self isFinal]. (merged := self toMerge) isEmpty ifFalse: [ self toMerge: OrderedCollection new. merged do: [:anEc | anEc elementsTreeDo: [:ele | self basicElements add: ele]]]. ^ self basicElements ! finalReference ^ self reference isNil ifTrue: [self class finCount: self class finCount + 1. self] ifFalse: [ self class refCount: self class refCount + 1. self reference: self reference finalReference; reference] ! isFinal ^ self reference isNil! isSameEquivalenceClass: anOtherClass ^ self finalReference == anOtherClass finalReference! printOn: aStream self class printOn: aStream. self isFinal ifTrue: [self elements asArray printOn: aStream] ifFalse: [ aStream nextPutAll: '(references '. self reference printOn: aStream. aStream nextPutAll: ')'].! reference ^ reference! reference: anObject reference := anObject.! swallow: anEC "swallow the equivalenceClass anEC and answer the updated finalReference" ^ self finalReference swallowFinal: anEC finalReference! swallowFinal: anEC "swallow the equivalenceClass anEC and answer the updated finalReference" self assert: [self isFinal and: [anEC isFinal and: [self ~~ anEC]]]. self class swaCount: self class swaCount + 1. self toMerge add: anEC. anEC reference: self. ! toMerge ^ toMerge! toMerge: anObject toMerge := anObject.! ! !EquivalenceMap class publicMethods ! addAllOn: aRelation "anwer a new instance of the receiver on the EquivalenceRelation aRelation the map values must be collections the elements at an old class are added to the value at a new class, if the new class swallows the old" ^ self new initializeOn: aRelation; addSwallowRemove; addSwallowAddAll; yourself ! onRelation: aRelation "anwer a new instance of the receiver on the EquivalenceRelation aRelation" ^ self new initializeOn: aRelation! swallowRemoveOn: aRelation "anwer a new instance of the receiver on the EquivalenceRelation aRelation the map removes keys, when an equivalence class is swallowed" ^ self new initializeOn: aRelation; addSwallowRemove; yourself! ! !EquivalenceMap publicMethods ! addColoursForBijectionsOf: relations "map the equivalenceClasses of the receiver to newly created colours per equivalenceClass of equivalenceClasse connected bijectively by relations. answer the equivalenceRelation of equivalence Class Indexes" | conns classIxRel colSet cla root colMap neutral | conns := self selectBijectionsOf: relations relating: (classIxRel := EquivalenceRelation new). self relation equivalenceClasses doWithIndex: [:noCla :ix | "ensure every node is in an equivalence class" classIxRel relate: ix to: ix]. colMap := self class on: classIxRel. neutral := ColourSet new: 1 name: 'colNeutral'. classIxRel equivalenceClasses doWithIndex: [:indexes :ix | cla := self relation equivalenceClasses at: indexes first. colMap at: indexes first put: (cla size = 1 ifTrue: [neutral] ifFalse: [colSet := ColourSet new: cla size name: 'col', ix printString]). root := self newRelationship. cla doWithIndex: [:claEle :eleIx | root relate: (colSet colours at: eleIx) to: claEle]. self at: cla first put: root]. self addCompositionOfConnections: conns. ^ colMap ! addCompositionOfConnections: connections "add compositions of relations in the OrderedCollection connections to the receiver, after removing them from connections" | ix from to atFrom atTo lastSize | [connections size = lastSize] whileFalse: [ ix := 1 + (lastSize := connections size). [(ix := ix - 1) > 0] whileTrue: [ atFrom := self at: (from := (connections at: ix) anyFrom) ifAbsent: [nil]. atTo := self at: (to := (connections at: ix) anyTo) ifAbsent: [nil]. atFrom isNil ifTrue: [atTo isNil ifFalse: [self at: from put: (atTo composition: (connections removeAtIndex: ix) reverseRelationship)]] ifFalse: [atTo isNil ifTrue: [self at: to put: (atFrom composition: (connections removeAtIndex: ix))] ifFalse: [self error: 'already mapped']]]]. connections notEmpty ifTrue: [self error: 'not everything'] ! addSwallowAddAll self addSwallowBlock: [:new :old | new notNil and: [old notNil and: [(self atEquivalenceClass: new) addAll: (self atEquivalenceClass: old)]]]! addSwallowBlock: aBlock self relation swallowBlocks addFirst: aBlock! addSwallowRemove self relation swallowBlocks add: [:new :old | old isNil ifFalse: [self map removeKey: old ifAbsent: []]].! at: ele ^ self map at: (self relation equivalenceClassAt: ele)! at: ele ifAbsent: absentBlock ^ self map at: (self relation equivalenceClassAt: ele ifAbsent: [^ absentBlock value]) ifAbsent: absentBlock! at: ele ifAbsentPut: absentBlock ^ self map at: (self relation equivalenceClassFor: ele) ifAbsentPut: absentBlock! at: ele put: anObject ^ self map at: (self relation equivalenceClassFor: ele) put: anObject! atEquivalenceClass: aClass ^ self map at: aClass! atEquivalenceClass: aClass put: anObject ^ self map at: aClass put: anObject! classesImagesDo: doBlock "evaluate doBlock for every equivalence class that is mapped answer the receiver" | image | self relation equivalenceClasses do: [:cla | doBlock value: cla value: (self map at: cla)]! classesPut: putBlock "evaluate putBlock for every equivalence class and map it to the putBlock value if it is not nil answer the receiver" | image | self relation equivalenceClasses do: [:cla | (image := putBlock value: cla) notNil ifTrue: [self map at: cla put: image]]! equivalenceClasses ^ self relation equivalenceClasses! images ^ self map values! imagesDo: aBlock self map do: aBlock! initializeOn: aRelation self relation: aRelation; map: IdentityDictionary new. ! keysAndValuesDo: aBlock self map keysAndValuesDo: [:eqClass :value | eqClass elements do: [:ele | aBlock value: ele value: value]]! map ^ map! map: anObject map := anObject.! relate: from to: to "relate the elments from and to. and map them the value at from if it exists " | toValue | toValue := self map removeKey: (self relation equivalenceClassAt: to ifAbsent: [nil]) ifAbsent: [ self map at: (self relation relate: from to: to). ^self]. self map at: (self relation relate: from to: to) ifAbsentPut: [toValue]! relation ^ relation! relation: anObject relation := anObject.! ! !EquivalenceRelation class publicMethods ! new ^ super new equivalenceClasses: Set new; swallowBlocks: #(); "do not use swallowBlocks OrderedCollection new;" classByElement: Dictionary new! test "EquivalenceRelation test" | inst coll | coll := OrderedCollection with: (inst := self new). inst relate: 'aaa' to: 'aab'; relate: 'aac' to: 'aad'; relate: 'aba' to: 'abb'; relate: 'aad' to: 'aaa'; relate: 'aaa' to: 'aad'. coll addAll: inst equivalenceClasses; add: 'is:equivalent:'. #('aaa' 'aab' 'aac' 'aad' 'aba' 'abb' 'xyz') do: [:one | coll at: coll size put: coll last, CldtConstants::LineDelimiter. #('aaa' 'aab' 'aac' 'aad' 'aba' 'abb' 'xyz') do: [:two | coll at: coll size put: coll last, ' ', one , ((inst is: one equivalent: two) ifTrue: ['~'] ifFalse: ['#']), two]]. ^ coll! ! !EquivalenceRelation publicMethods ! add: newElement to: class "answer the equivalenceClass class after having added newElement to it" (self classByElement at: newElement ifAbsentPut: [ class addElement: newElement. class]) == class ifFalse: [^ self error: 'conflict']. ^ class ! addEquivalence: aRelation aRelation equivalenceClasses do: [:cla | self relateAll: cla elements]! addEquivalenceClasses: newGroups newGroups do: [:eles | self addEquivalenceClassWithAll: eles]! addEquivalenceClassOn: newElements | cla | self equivalenceClasses add: (cla := EquivalenceClass on: newElements). newElements do: [:ele | self add: ele to: cla]. self swallowBlocks do: [:blo | blo value: cla value: nil]. ^ cla! addEquivalenceClassWith: newElement ^self addEquivalenceClassOn: (self newSetWith: newElement)! addEquivalenceClassWithAll: elements "build and answer the equivalence classes" ^ self addEquivalenceClassOn: (self newSetWithAll: elements)! addIdentityOfAll: aCollection aCollection do: [:ele | self relate: ele to: ele]! class: from swallow: to from == to ifTrue: [^ self]. self swallowBlocks do: [:blo | blo value: from value: to]. self equivalenceClasses remove: to. from swallowFinal: to. ^ from ! classByElement ^ classByElement! classByElement: anObject classByElement := anObject.! copyCollection ^ self newEquivalenceRelation addEquivalence: self; yourself! elementsByClass: aColl | dict | dict := IdentityDictionary new. aColl do: [:ele | (dict ocAt: (self equivalenceClassAt: ele)) add: ele]. ^ dict! equivalenceClassAt: anElement ^ (self classByElement at: anElement) finalReference! equivalenceClassAt: anElement ifAbsent: aBlock ^ (self classByElement at: anElement ifAbsent: [^ aBlock value]) finalReference! equivalenceClasses ^ equivalenceClasses! equivalenceClasses: anObject equivalenceClasses := anObject.! equivalenceClassesDo: aBlock " evaluate aBlock for each equivalence class (if equivalence classes are merged at least once)" self equivalenceClasses copy do: [:cla | cla isFinal ifTrue: [aBlock value: cla]]! equivalenceClassFor: anElement ^ (self classByElement at: anElement ifAbsentPut: [self addEquivalenceClassWith: anElement]) finalReference! includes: element " answer a boolean wheter an element is a member of the equivalence relation ground set " ^ self classByElement includesKey: element! is: from equivalent: to "answer aBoolean whether from and to are equivalent if absent do not insert classes" ^ (self classByElement at: from ifAbsent: [^ from = to]) finalReference == (self classByElement at: to ifAbsent: [^ false]) finalReference! relate: from to: to "relate the elments from and to. and answer the equivalence class use the equivalence class of from if it exists " | cla | ^ self class: (cla := self equivalenceClassAt: from ifAbsent: [ ^ self add: from to: (self equivalenceClassFor: to)]) swallow: (self equivalenceClassAt: to ifAbsent: [^ self add: to to: cla])! relate: from toAll: toColl "relate the elment from with all elements in toColl" toColl do: [:to | self relate: from to: to]! relateAll: aColl "relate the elment from with all elements in toColl" aColl doWithAny: [:from :to | self relate: from to: to]! relationship: rel addIfPartition: partition | next union | rel originImageDo: [:ori :ima | union := (self equivalenceClassFor: ori) elements union: (self equivalenceClassFor: ima) elements. partition equivalenceClasses conform: [:cla | (cla elements intersection: union) size > 1 ifTrue: [^ false]]]. rel originImageDo: [:ori :ima | self relate:ori to: ima]. ^ true! relationshipsPrune: node searchPartition: partition | next | next := OrderedCollection new. node removeWithArcs. node pre do: [:arc | (self relationship: arc data inverse addIfPartition: partition) ifTrue: [next add: arc from]]. node post do: [:arc | (self relationship: arc data addIfPartition: partition) ifTrue: [next add: arc to]]. next do: [:nxNo | self relationshipsSearchPrunde: nxNo]! removeEquivalenceClass: oldClass self swallowBlocks do: [:blo | blo value: nil value: oldClass]. oldClass elements do: [:ele | self classByElement removeKey: ele]. self equivalenceClasses remove: oldClass! swallowBlocks ^ swallowBlocks! swallowBlocks: anObject swallowBlocks := anObject.! ! !GraphArc publicMethods ! place "answer the place of the receiver" ^ self from isPlace ifTrue: [self from] ifFalse: [self to]! place: aPlace "set the receivers place to aPlace, fail if from and to are both nil" (self from isNil ifTrue: [self to isTransition] ifFalse: [self from isPlace]) ifTrue: [self from: aPlace] ifFalse: [self to: aPlace]. ! transition "answer the transition of the receiver" ^ self from isTransition ifTrue: [self from] ifFalse: [self to]! ! !GraphNode publicMethods ! name ^self data! name: newName self data: newName! ! !MapAggregation class publicMethods ! inverseOf: aMap ^ self new left: aMap; source: aMap dest; dest: aMap source; atBlock: [:ori :absent | self error: 'inverse at: not supported']; doBlock: [:doit :fail | aMap inverseDo: doit ifFail: fail] ! of: leftMap composition: rightMap ^ self new initialize: leftMap composition: rightMap; left: leftMap; right: rightMap; atBlock: [:ori :absent | leftMap at: (rightMap at: ori ifAbsent: absent) ifAbsent: [self fail: 'dangling']]; doBlock: [:doit :fail | leftMap composition: rightMap do: doit ifFail: fail] ! of: leftMap union: rightMap (leftMap source == rightMap source and: [leftMap dest == rightMap dest]) ifFalse: [self error: 'union fit']. ^ self new source: leftMap source; dest: leftMap dest left: leftMap; right: rightMap; atBlock: [:ori :absent | | gotLe gotRi imaLe imaRi | gotLe := gotRi := true. imaLe := leftMap at: ori ifAbsent: [gotLe := false]. imaRi := rightMap at: ori ifAbsent: [gotRi := false]. gotLe ifTrue: [imaLe = imaRi ifTrue: [imaLe] ifFalse: [self error: 'conflict']] ifFalse: [gotRi ifTrue: [imaRi] ifFalse: absent]]; doBlock: [:doit :fail | self error: 'union does not implement doBlock'] ! of: leftMap with: rightMap ^ self new left: leftMap; right: rightMap; initializeAggregation! ! !MapAggregation publicMethods ! at: anOrigin ifAbsentPut: aBlock "answer the image of anOrigin if present otherwise aBlock value" ^ self atBlock value: anOrigin value: [aBlock value. self fail: 'cannot put']! atBlock ^ atBlock! atBlock: anObject atBlock := anObject.! doBlock ^ doBlock! doBlock: anObject doBlock := anObject.! initializeAggregation "initialize the receiver, for left and right and answer the receiver" self subclassResponsibility! left ^ left! left: anObject left := anObject.! originImageDo: aBlock "execute the two argument block aBlock for every origin image pair" ^self doBlock value: aBlock value: [^ self error: 'originImageDo']! originImageDo: doit ifFail: fail "execute the two argument block aBlock for every origin image pair" ^self doBlock value: doit value: [^ fail value]! right ^ right! right: anObject right := anObject.! species ^ TableMap! ! !Net class publicMethods ! fromPtnFile: aFile " make a new instance from the contents of a file with the path derived from the pathname " ^ self new name: 'ptn::', aFile fileDescriptor path; fromPtnStream: (ReadStream on: aFile contents); yourself! newMS "answer a new MultiSet of our MultiSet class" ^Bag new! reset self testNet: nil! ! !Net publicMethods ! addNode: aNode "answer aNode after having added it to the receiver" self assert: [aNode isTransition or: [aNode isPlace]]. ^ super addNode: aNode! edwm: numsPar "Net testNet: (Net new edwm: #(6 5 4))" "uniform" "Net testNet: (Net new edwm: #(7 6 4 3 1 3))" "ausgefranst bei packing" "Net testNet: (Net new edwm: #(7 6 4 3 1 1))" "enden ausgefranst, aber alle Anfänge bei defining" "Net testNet: (Net new edwm: #(11 6 4 3 3 1))" "Anfange und Ende ausgefranst" | ships nums | nums := #(7 5 4 3 1 5) copyReplaceFrom: 1 to: numsPar size with: numsPar. self name: 'edwm: ', nums asArray printString. self newPlace: 'defining'; newPlace: 'done'. self edwmOrder: '1' ships: #(#(1)) start: 1 finish: 5. self edwmOrder: '2' ships: #(#(2) #(3)) start: 1 finish: 5. 3 to: nums first + 3 do: [:aufIx | ships := (1 to: (self random nextTo: (nums at: 4))) collect: [:shipIx | (1 to: (self random nextTo: (nums at: 3 ))) collect: [:q | 2 + (self random nextTo: (nums at: 2))]]. self edwmOrder: aufIx printString ships: ships start: (self random nextFrom: 1 to: (nums at: 5)) finish: (self random nextFrom: (nums at: 6) to: 5)]. ! edwmFrom: from order: suf parts: nums to: to to > 0 ifTrue: [self edwmFrom: from order: 'allocating', suf parts: nums]. to > 1 ifTrue: [self edwmFrom: 'allocating', suf order: 'shipping', suf parts: nums]. to > 2 ifTrue: [self edwmFrom: 'shipping', suf order: 'packing', suf parts: nums]. ! edwmOrder: suf from: from trans: trans to: to parts: nums pos: startPos | tra pla pref prePref ppNam posIx nam | pref := to first asString. pref = 'a' ifTrue: [prePref := 'o'. ppNam := 'allocate', suf]. pref = 's' ifTrue: [prePref := 'a'. ppNam := 'ship', suf]. pref = 'p' ifTrue: [prePref := 's'. ppNam := 'pack', suf]. self assert: [prePref notNil]. (self nodeAt: from ifAbsent: [self newPlace: from]) connectTo: (tra := self newTransition: trans). tra connectTo: (pla := self nodeAt: to ifAbsent: [self newPlace: to]). posIx := startPos - 1. nums do: [:partIx | posIx := posIx + 1. pla connectTo: (tra := self newTransition: ppNam, '/', posIx printString). tra connectTo: pla. (self nodeAt: (nam := prePref, 'Part', partIx printString) ifAbsent: [self newPlace: nam]) connectTo: tra. (self nodeAt: (nam :=prePref, 'Pos', suf, '/', posIx printString) ifAbsent: [self newPlace: nam]) connectTo: tra. pref = 'p' ifFalse: [ tra connectTo: (self nodeAt: (nam := pref, 'Part', partIx printString) ifAbsent: [self newPlace: nam])]. tra connectTo: (self newPlace: pref, 'Pos', suf, '/', posIx printString)]. ! edwmOrder: suf ships: ships start: start finish: finish | next last tra posIx shiSuf| last := 'defining'. posIx := 1. ships doWithIndex: [:parts :shipIx | shiSuf := suf, '/', shipIx printString. next := 'allocating', suf. ((shipIx > 1 or: [start <= 1]) and: [shipIx < ships size or: [finish >= 1]]) ifTrue: [ self edwmOrder: suf from: last trans: (shipIx = 1 ifTrue: ['startA', suf] ifFalse: ['next', shiSuf]) to: next parts: parts pos: posIx]. last := next. next := 'shipping', shiSuf. ((shipIx > 1 or: [start <= 2]) and: [shipIx < ships size or: [finish >= 2]]) ifTrue: [ self edwmOrder: suf from: last trans: 'startS', shiSuf to: next parts: parts pos: posIx]. last := next. next := 'packing', shiSuf. ((shipIx > 1 or: [start <= 3]) and: [shipIx < ships size or: [finish >= 3]]) ifTrue: [ self edwmOrder: suf from: last trans: 'startP', shiSuf to: next parts: parts pos: posIx]. last := next. posIx := posIx + parts size]. finish = 4 ifTrue: [ (self nodeAt: last) connectTo: (tra := self newTransition: 'next', suf). tra connectTo: (self nodeAt: 'allocating', suf)]. finish = 5 ifTrue: [ (self nodeAt: last) connectTo: (tra := self newTransition: 'finish', suf). tra connectTo: (self nodeAt: 'done')]. ! fromPtnStream: src "Net fromPtnFile" | word parser useTree getName warn isolated | warn := ''. getName := [ |na | (na := src nextWordOfLine) copyFrom: (na indexOf: $.) + 1 to: na size]. useTree := [:tree :key | | node | (node := tree at: key ifAbsent: [self error: 'unknown word']) class = Dictionary ifTrue: [useTree value: node value: src nextWordOrEol] ifFalse: [node value]]. parser := Dictionary new at: 'net' put: (Dictionary new at: 'add' put: (Dictionary new at: 'place' put: [self newPlace: (getName value)]; at: 'transition' put: [self newTransition: (getName value)]; at: 'arc' put: [self connect: (getName value) to: (getName value)]; at: 'inhibitor' put: [warn := warn, CldtConstants::Cr, 'ignore inhibitor from ', getName value, ' to ', getName value]; yourself); "net add" at: 'reset' put: []; at: 'state' put: []; yourself); "net" at: 'set' put: (Dictionary new at: 'input' put: []; yourself); yourself. [ [src atEnd not and: [(word := src nextWordOrEol) = ##eol or: [(word first = $*) and: [src nextLine. true]]]] whileTrue: []. src atEnd] whileFalse: [ useTree value: parser value: word. [src nextWordOrEol = ##eol] whileFalse: []]. (isolated := self removeIsolatedPlaces) notEmpty ifTrue: [warn := warn, ' removed isolated places ', isolated asArray printString]. warn isEmpty ifFalse: [(CwMessagePrompter confirm: warn) ifFalse: [^ nil]].! name ^ name! name: anObject name := anObject.! newArc ^super newArc data: 1; yourself! newNode: aNodeClass named: aName ^self newNode: aNodeClass indexed: aName named: aName ! newPlace ^self addNode: Place new! newPlace: aName ^self newPlace name: aName; yourself! newTransition ^self addNode: Transition new! newTransition: aName ^self newTransition name: aName; yourself! places ^ self nodes select: [:nd | nd isPlace]! printOn: aStream | word | aStream nextPut: (word := self class name) first asLowercase; nextPutAll: (word copyFrom: 2). (word := self name asString) isEmpty ifFalse: [aStream nextPut: word first asUppercase; nextPutAll: (word copyFrom: 2)]. ! printStatsOn: aStream | arcs | arcs := 0. self transitions do: [:tra | arcs := arcs + tra pre size + tra post size]. aStream nextPutAll: self transitions size printString, ' transitions, '; nextPutAll: self places size printString, ' places, '; nextPutAll: self nodes size printString, ' nodes, '; nextPutAll: arcs printString, ' arcs' ! random random isNil ifTrue: [self random: (EsRandom newReproducible: 456)]. ^ random! random: anObject random := anObject.! removeIsolatedPlaces "answer the isolated places after removing them from the receiver" ^ (self places select: [:pla | pla pre isEmpty and: [pla post isEmpty]]) collect: [:pla | pla removeWithArcs]! sortNodes self nodes: (self nodes asSortedCollection: [:a :b | a isTransition = b isTransition ifTrue: [a name <= b name] ifFalse: [a isTransition]]) asOrderedCollection! transitions ^ self nodes select: [:nd | nd isTransition]! ! !NetReduction class publicMethods ! on: aStructure ^ (self source: aStructure net dest: NetType new) structure: aStructure ! ! !NetReduction publicMethods ! addInfosToTree: tree tree infos add: (self printStringDo: [:s | self printStatsOn: s]); add: (self printStringDo: [:s | self printColoursOn: s]); add: (self printStringDo: [:s | self printColouredAreasOn: s]) ! check ^ self colourSets conform: [:col | | res | res := true. col functionsDo: [:fun | self assert: [res := res and: [fun source == col and: [fun dest class == col class]]]]. res]! colour: colourOne leq: colourTwo | one two | ^ (one := colourOne name size) = (two := colourTwo name size) ifTrue: [colourOne name <= colourTwo name] ifFalse: [one < two]! colourArcs "colour the arcs with as little colour functions as possible" | rels imaArc colFrom colTo | rels := IdentityDictionary new. self source arcsDo: [:arc | imaArc := (self at: arc from) arcTo: (self at: arc to). (rels at: imaArc ifAbsentPut: [self newRelationship source: (self colourByImage at: imaArc from) source; dest: (self colourByImage at: imaArc to) source]) origin: ((self colourByImage at: imaArc from) originOf: arc from) image: ((self colourByImage at: imaArc to) originOf: arc to) ]. rels keysAndValuesDo: [:arc :func | self colourByImage at: arc put: (self colourExpressionOf: func analyse)].! colourByImage ^ colourByImage! colourByImage: anObject colourByImage := anObject.! colourByRelationships: maxLength self relationshipsAdd: (self structure relationships: Dictionary new; yourself). self structure relationshipsCompose: maxLength. self colourNodesForBijectionsOf: self structure relationships; colourArcs. ! colourExpressionOf: relShip "find a relationship expression equalin relShip add new primitiv relationships to the colours if necessary" | colFrom colTo new | ((colFrom := relShip source) functionsAt: (colTo := relShip dest)) do: [:old | self assert: [old source class == ColourSet and: [old dest class == ColourSet]]. (old isSameRelationship: relShip) ifTrue: [old source colours. ^ old]]. self assert: [colFrom class == ColourSet and: [colTo class == ColourSet]]. new := relShip copyCollection analyse; source: colFrom; dest: colTo. (colFrom functionsAt: colTo) add: new. (colTo functionsAt: colFrom) add: new inverse. self assert: [new source class = ColourSet and: [new dest class = ColourSet and: [new inverse source class = ColourSet and: [new inverse dest class = ColourSet]]]]. ^ new ! colourNodesForBijectionsOf: relations "analyze the structure of relationsships using reduced to nodeRelation" | imageRel conns | conns := self selectBijectionsOf: relations relating: (imageRel := self newEquivalenceRelation addIdentityOfAll: self dest nodes). self colourSets: OrderedCollection new "with: (ColourSet new: 1 name: 'col1'))"; colourByImage: Dictionary new; colourNodesForEquivalence: imageRel connections: conns ! colourNodesForConnectionCompositions: connections "add compositions of relations in the OrderedCollection connections to the receiver, after removing them from connections" | lastSize rest atSource atDest | rest := connections. [lastSize = (lastSize := rest size)] whileFalse: [ rest := rest reject: [:conn | atSource := self colourByImage at: conn source ifAbsent: [nil]. atDest := self colourByImage at: conn dest ifAbsent: [nil]. atSource isNil ifTrue: [atDest notNil and: [self colourByImage at: conn source put: (conn inverse composition: atDest). true]] ifFalse: [atDest isNil ifTrue: [self colourByImage at: conn dest put: (conn composition: atSource)]. true]]]. self assert: [rest isEmpty] ! colourNodesForEquivalence: imageRel connections: conns "map the equivalenceClasses of the receiver to newly created colours per equivalenceClass of equivalenceClasse connected bijectively by relations" | colSet origs root ima | imageRel equivalenceClassesDo: [:imaCla | origs := self originsAllOf: (ima := imaCla elements any). "colSet := origs size = 1 ifTrue: [self colourSets first] ifFalse: [" colSet := self colourSets add: (ColourSet new: origs size name: 'col', (self colourSets size + 1) printString). root := self newRelationship source: colSet; dest: ima. colSet colours with: origs do: [:col :or | root origin: col image: or]. self colourByImage at: ima put: root analyse]. self colourNodesForConnectionCompositions: conns. ! colourRelationships1to1Equivalence: equivalence | rels fun | rels := Set new. self dest arcsDo: [:arc | ((fun := self colourByImage at: arc) isTo1 and: [fun isFrom1]) ifTrue: [ equivalence relate: arc from to: arc to. (fun source = fun dest or: [rels includes: fun inverse]) ifFalse: [rels add: fun]]]. ^ rels asOrderedCollection! colourSets ^ colourSets! colourSets: anObject colourSets := anObject.! colourSubsets | dict subs | dict := Dictionary new. self colourSets classesImagesDo: [:cla :col | (subs := col subsets) isEmpty ifFalse: [ dict at: col put: subs]]. ^ dict! combineColours1to1 "reduce the receivers dest by a colour morphism" | search red colWood equi | (colWood := ColourWood colours: self colourSets connections: (self colourRelationships1to1Equivalence: (equi := self newEquivalenceRelation))). equi equivalenceClassesDo: [:cla | cla elements do: [:from | cla elements do: [:to | colWood join: (self colourByImage at: from) source with: (self colourByImage at: to) source detect: [ self size. true]]]]. red := self class on: (NetStructure from: self dest). (search := GraphSearch found: [:fr | self halt]) referenceReduce relation: (self newEquivalenceRelation relateAll: self dest nodes); mapsFilter: [:maps | self maps: maps filter: search reduce relation inColourWood: colWood]. ^ Array with: red with: (red mergeSearch: search; composition: self analyseColourWood: colWood) colourArcs ! composition: first ^ (super composition: first) structure: first structure; yourself ! composition: first analyseColourWood: wood | comp map woodEmb mapEmb new | (comp := self composition: first) colourSets: OrderedCollection new; colourByImage: Dictionary new; renameImage. map := comp woodColour: wood map: first colourSets size. self reverse keysAndValuesDo: [:ima :midColl | new := self newRelationship. midColl do: [:mid | woodEmb := wood embeddingOfColour: (first colourByImage at: mid) source. mapEmb := map at: woodEmb dest. new dest: mid. new source isNil ifTrue: [new source: mapEmb source] ifFalse: [self assert: [new source == mapEmb source]]. new := new union: ((first colourByImage at: mid) compositionJoin: (woodEmb inverse compositionJoin: mapEmb))]. comp colourByImage at: ima put: (new dest: ima; analyse)]. ^ comp ! connectAreaOrigin: origin | ima connectAdd | connectAdd := [:from :to :addArc | | imArc | (imArc := from arcTo: to ifAbsent: [nil]) isNil ifTrue: [from connectTo: to like: addArc] ifFalse: [imArc data: imArc data + addArc data]]. ima := self at: origin. origin pre do: [:arc | connectAdd value: (self at: arc from) value: ima value: arc]. origin post do: [:arc | connectAdd value: ima value: (self at: arc to) value: arc]. ! copyCollection ^ super copyCollection colourSets: self colourSets "copyCollection"; colourByImage: self colourByImage "copyCollection"; structure: self structure! create1to1 self assert: [self dest isEmpty]. self source nodes do: [:nd | self origin: nd image: (self dest newNodeLike: nd)]. self source arcsDo: [:arc | (self dest newArcFrom: (self at: arc from) to: (self at: arc to)) data: arc data copy]! functionNames: aStream | pref nam | self colourSets do: [:col | pref := (col name copyReplaceFrom: 1 to: 3 with: 'fun'),'->'. col functions keysAndValuesDo: [:dstCol :funColl | funColl do: [:fc | aStream printId: fc put: [:s | s nextPutAll: (nam := pref, (fc isIdentic ifTrue: ['=id'] ifFalse: [(dstCol name copyFrom: 4)]))]. fc == fc inverse ifFalse: [ aStream printId: fc inverse put: [:s | s nextPutAll: (nam copyReplaceFrom: pref size - 1 to: pref size with: '<-')]]]]]. ! injectiveInColourWood: wood ! isEquivalence: equivalence disjointInColourWood: wood ^ equivalence equivalenceClasses conform: [:cla | wood disjointOver: (cla elements collect: [:nd | (self colourByImage at: nd) source])]! maps: mapCollection filter: equivalence inColourWood: wood | stack conf lastEqui currEqui res | lastEqui := equivalence. res := mapCollection select: [:map | stack := OrderedCollection new. currEqui := lastEqui copyCollection. conf := map keysAndValuesConform: [:from :to | currEqui relate: from to: to. (stack add: (wood join: (self colourByImage at: from) source with: (self colourByImage at: to) source detect: [self isEquivalence: currEqui disjointInColourWood: wood])) ~= false]. conf ifTrue: [lastEqui := currEqui] ifFalse: [stack reverseDo: [:conn | wood popJoin: conn]]. conf]. ^ res! maps: mapCollection filter: equivalence parallelColourWood: wood | stack conf lastEqui currEqui res | lastEqui := equivalence. res := mapCollection select: [:map | stack := OrderedCollection new. currEqui := lastEqui copyCollection. map keysAndValuesDo: [:from :to | (from ~= to and: [('alloc*' match: from name) and: ['alloc*' match: to name]]) ifTrue: [self halt]]. conf := map keysAndValuesConform: [:from :to | currEqui relate: from to: to. (stack add: (wood join: (self colourByImage at: from) source parallelWith: (self colourByImage at: to) source detect: ["((from name copyFrom: 1 to: 3), '*' match: to name) ifFalse: [self halt]." self isEquivalence: currEqui disjointInColourWood: wood])) ~= false]. conf ifTrue: [lastEqui := currEqui] ifFalse: [stack reverseDo: [:conn | wood popJoin: conn]]. conf]. ^ res! mergeSearch: search | final type emb dict | self assert: [self dest isEmpty]. search structure: self structure; reduce: (EquivalenceMap onRelation: self structure newEquivalenceRelation); toDo: OrderedCollection new. self source places do: [:pla | search reduce at: pla put: PlaceReduction new]. self source transitions do: [:tra | search reduce at: tra put: tra. type := (emb := self structure embeddingAtTrans: tra) source. type transitions single pre do: [:arc | | pla | (search reduce at: (pla := emb at: arc from)) mergeArc: (pla arcTo: tra) at: (type traceAt: arc from) search: search]. type transitions single post do: [:arc | | pla | (search reduce at: (pla := emb at: arc to)) mergeArc: (tra arcTo: pla) at: (type traceAt: arc to) search: search]]. search toDo removeDo: [: pla | (search reduce at: pla) mergeArcsSearch: search]. dict := IdentityDictionary new. search reduce keysAndValuesDo: [:ori :ima | self assert: [ori isTransition or: [ima nodesToAdd isEmpty]]. self origin: ori image: (dict at: ima ifAbsentPut: [self dest newNodeLike: ori])]; imagesDo: [:tra | tra class == Transition ifTrue: [ tra prePost do: [:arc | | redArc | redArc := (self at: arc from) arcTo: (self at: arc to) ifAbsent: [(self at: arc from) connectTo: (self at: arc to) like: arc. nil]. redArc isNil ifFalse: [redArc data: redArc data + arc data]]]]. self assert: [self isMorphism and: [self isEpi]]. ! newConnectedAreaOrigin: origin | new | self origin: origin image: (new := self dest newNode: origin class) ifFail: [self error: 'conflict']. self connectAreaOrigin: origin. ^ new ! printColouredNode: node on: aStream | col | aStream printId: node; space; nextPutAll: (self colourByImage at: node) source name! printColouredPostsOn: aStream self functionNames: aStream. self dest nodes doWithIndex: [:nd :ix | self printColouredNode: nd on: aStream cr. aStream nextPutAll: ' => ('. nd post do: [:arc | aStream nextPutAll: ' ='. (self colourByImage at: arc) printFunctionSuffixOn: aStream. aStream nextPutAll: '=>'. arc data printIdOn: aStream. self printColouredNode: arc to on: aStream]. aStream nextPut: $)]. ! printColoursOn: aStream | byCol | self colourSets isNil ifTrue: [aStream nextPutAll: 'no colours defined'. ^ self]. self functionNames: aStream. byCol := IdentityDictionary new. self colourByImage keysAndValuesDo: [:ima :rel | ima isNode ifTrue: [(byCol ocAt: rel source) add: ima] ifFalse: [(byCol ocAt: rel) add: ima]]. self colourSets doWithIndex: [:col :ix | col printOn: aStream cr. aStream space printIdAll: (byCol at: col). self colourSets from: ix to: self colourSets size do: [:dstCol | col functions at: dstCol ifPresent: [:funcs | funcs size > (col = dstCol) asInteger ifTrue: [ aStream cr; tab; nextPutAll: 'to '. dstCol printOn: aStream. aStream space. funcs do: [:fc | fc isIdentic ifFalse: [ aStream space; printId: fc; space. fc printAnalysisOn: aStream. aStream space printIdAll: (byCol at: fc ifAbsent: [#()])]. aStream nextPutAll: ' inverse='; printId: fc inverse. aStream space; printIdAll: (byCol at: fc inverse ifAbsent: [#()]). aStream nextPutAll: ', ']]]]]. ! printDetailsOn: aStream aStream cr; nextPutAll: 'structure: '; printDetailsOrStats: self structure. super printDetailsOn: aStream. aStream cr; nextPutAll: 'colours and colourFunctions: '; right. self printColoursOn: aStream. aStream left. self colourByImage isNil ifFalse: [ aStream cr; nextPutAll: 'node and arc colouring of dest: '; right. self printColouredPostsOn: aStream. aStream left]. ! printStatsOn: aStream | funcNames | super printStatsOn: aStream. aStream nextPutAll: ', ', self structure types size printString, ' types, '; nextPutAll: self colourSets size printString, ' colourSets'! reduceConnectedColours "reduce the receivers dest by a colour morphism" | search red colWood equi | red := self class on: (NetStructure from: self dest). colWood := ColourWood colours: self colourSets. (search := GraphSearch found: [:fr | self halt]) referenceReduce relation: (self newEquivalenceRelation relateAll: self dest nodes); mapsFilter: [:maps | self maps: maps filter: search reduce relation parallelColourWood: colWood]. ^ (red mergeSearch: search; composition: self analyseColourWood: colWood) colourArcs ! reduceConnectedColours1to1 "reduce the receivers dest by a colour morphism" | search red colWood equi | red := self class on: (NetStructure from: self dest). (colWood := ColourWood colours: self colourSets connections: (self colourRelationships1to1Equivalence: (self newEquivalenceRelation))). (search := GraphSearch found: [:fr | self halt]) referenceReduce relation: (self newEquivalenceRelation relateAll: self dest nodes); mapsFilter: [:maps | self maps: maps filter: search reduce relation inColourWood: colWood]. ^ (red mergeSearch: search; composition: self analyseColourWood: colWood) colourArcs ! reduceConnectedEquivalence: relation "reduce the receivers source by the equivalenceRelation relation, only for connected nodes" | search | (search := GraphSearch found: [:fr | self halt]) referenceReduce mapsFilter: [:maps | maps]; relation: relation. self mergeSearch: search! reduceForEquivalence: relation ifFail: failBlock "reduce the receivers source by the equivalenceRelation relation. for every failing source transition evaluate failBlock with the failing transition as argument answer aBoolean indicating success" | success | success := true. self reduceForEquivalence: relation nodeClass: [:cla | cla elements any class]. relation equivalenceClasses do: [:cla | | preMS postMS first | (first := cla elements any) isTransition ifTrue: [ preMS := self atMS: first preMS. postMS := self atMS: first postMS. (cla elements conform: [:ori | (preMS isSameMS: (self atMS: ori preMS)) and: [postMS isSameMS: (self atMS: ori postMS)]]) ifFalse: [success := false. cla elements do: failBlock]. self connectAreaOrigin: first]]. ^success! reduceForEquivalence: relation nodeClass: nodeClass "initialize the receiver mapping every class of the equivalenceRelation relation to a new node of the class indicated by the one argument block nodeClass. do not map, if nodeClass answers nil" | cla node | " self source nodes do: [:nod | relation relate: nod to: nod]." "ensure every node is in an equivalence class" self dest: NetType new; colourByImage: (EquivalenceMap onRelation: relation). relation equivalenceClasses do: [:eqCla | (cla := nodeClass value: eqCla) notNil ifTrue: [ node := self dest addNode: cla new. eqCla elements do: [:ori | self origin: ori image: node ifFail: [self error: 'ambigous groupings']]]].! selectBijectionsOf: relationships relating: imageRel "answer a minimal collection of conencting bijective relationsships from relationships that expand the classIndex EquivalenceRelation imageRel maximally" | conns | conns := OrderedCollection new. relationships keysAndValuesDo: [:path :rel | (imageRel is: path first equivalent: path last) ifFalse: [ (rel isTo1 and: [rel isFrom1 and: [rel forward size = (self originsAllOf: path first) size and: [rel reverse size = (self originsAllOf: path last) size]]]) ifTrue: [ imageRel relate: path first to: path last. conns add: rel]]]. ^conns ! species ^ self class! structure ^ structure! structure: anObject structure := anObject.! woodColour: wood map: lastIndex | map col emb ix | ix := lastIndex. map := Dictionary new. wood trees roots do: [:root | emb := self newRelationship source: (self colourSets add: (ColourSet new: root data colours size name: 'col', (ix := ix + 1) printString)); dest: root data. emb source colours with: emb dest colours do: [:o :i | emb origin: o image:i]. map atAbsent: root data put: emb]. ^ map. ! ! !NetStructure class publicMethods ! from: net ^ self new net: net; useIndexMapOf: net; createTransitionTypes! new ^ super new embeddingByNodes: Dictionary new; typeByKey: Dictionary new; relationships: Dictionary new! ! !NetStructure publicMethods ! combine: num newTypeSearch: search | toDo ima | toDo := OrderedCollection new. self types do: [:typ | typ transitions size = num ifTrue: [toDo addAll: typ embeddings]]. toDo copy do: [:emb | toDo do: [ :othEmb | ((emb image includesAny: othEmb image) and: [(emb image isSameSet: othEmb image) not]) ifTrue: [ search image: (emb image union: othEmb image); mapOne: emb; mapTwo: othEmb. self combineNewType: search]]. toDo remove: emb].! combineLocalMonoTypes: num ^ self combine: num newTypeSearch: self newLocalMonoTypeSearcher! combineNewType: search "answer a type embedding for the type of the union of the images of mapOne and mapTwo create the type if necessary" ^ self embeddingAtNodes: search image ifAbsent: [ search found]! combineNotForbidden: search "if the union of the images of mapOne and mapTwo of search is does not touch forbidden, the do search" ((self forbiddenAt: search mapOne) includesAny: search mapTwo image) ifFalse: [search found] ! combineTypes: num ^ self combine: num newTypeSearch: self newTypeSearcher.! components ^ components! components: anObject components := anObject.! copyCollection ^ self copy net: self net; typeByKey: self typeByKey copyCollection; embeddingByNodes: self embeddingByNodes copyCollection ! createAutosEmbeddingsCombining: mapOne with: mapTwo "create the autos and embeddings for the new type at the source of mapOne assume the type contains only the initial embedding" | image oneByNd com comOne comTwo inv continue | self assert: [mapOne source == mapTwo source]. image := (inv := mapOne source embeddings single inverse) origin. com := (mapOne origin intersection: mapTwo origin) asOrderedCollection. comOne := mapOne atAll: com. comTwo := mapTwo atAll: com. mapOne dest embeddingPairsWith: mapTwo dest imageUnionSize: image size do: [:embOne :embTwo :currIma | continue := true. mapOne dest autos conform: [:auOne | mapTwo dest autos conform: [:auTwo | (comOne with: comTwo conform: [:ndOne :ndTwo | (embOne at: (auOne at: ndOne)) == (embTwo at: (auTwo at: ndTwo))]) ifTrue: [(currIma isSameSet: image) ifTrue: [ mapOne source autosAdd: (inv composition: ((embOne composition: (auOne composition: mapOne)) union: (embTwo composition: (auTwo composition: mapTwo))))] ifFalse: [self embeddingAtNodes: currIma ifAbsent: [ self embeddingAdd: ((embOne composition: (auOne composition: mapOne)) union: (embTwo composition: (auTwo composition: mapTwo) ))]. continue := false]]. continue]. continue]]. self assert: [mapOne dest areAutosValid].! createLocalMonoForbidden: search | im typ | self assert: [search mapOne dest == self net and: [search mapTwo dest == self net and: [search mapOne source transitions size = 1 and: [search mapTwo source transitions size = 1]]]]. (typ := search mapOne source) == search mapTwo source ifFalse: [^ self]. typ autos do: [:auto | (typ nodes conform: [:nd | im := search mapOne at: (auto at: nd). (search mapTwo image includes: im) not or: [(search mapTwo at: nd) == im]]) ifTrue: [ (self forbidden at: search mapOne ifAbsentPut: [self newSet]) add: (search mapTwo at: typ transitions single). (self forbidden at: search mapTwo ifAbsentPut: [self newSet]) add: (search mapOne at: typ transitions single). ^ self]]. ! createTransitionTypes | type mono ix | self net transitions do: [: trans | type := (self typeByKey at: trans areaKey ifAbsentPut: [OrderedCollection with: (NetType fromTransition: trans)]) single. mono := TableMap source: type dest: self net. mono origin: type transitions first image: trans. type transitions single areaByDataPair with: trans areaByDataPair do: [:tyOc :trOc | tyOc with: trOc do: [:tyPla :trPla | mono origin: tyPla image: trPla]]. self assert: [mono isMorphism and: [mono isMono and: [mono isFolding]]]. self embeddingAdd: mono]. ix := 0. self types do: [:ty | ty nameWithNodes: 'y', (ix := ix + 1) printString]! embeddingAdd: aMono | tra | self assert: [aMono dest == self net]. tra := (tra := aMono source transitions) size = 1 ifTrue: [aMono at: tra single] ifFalse: [self newSetWithAll: (aMono atAll: tra)]. self embeddingByNodes at: tra put: aMono. aMono source embeddingAdd: aMono. ! embeddingAtNodes: nodesOrCollection ifAbsent: aBlock ^ self embeddingAtTrans: (nodesOrCollection isCollection ifTrue: [nodesOrCollection select: [:nd | nd isTransition]] ifFalse: [nodesOrCollection]) ifAbsent: aBlock ! embeddingAtTrans: transOrCollection ^ self embeddingAtTrans: transOrCollection ifAbsent: [self fail: 'missing'] ! embeddingAtTrans: transOrCollection ifAbsent: aBlock ^ self embeddingByNodes at: (transOrCollection isCollection ifFalse: [transOrCollection] ifTrue: [transOrCollection size = 1 ifTrue: [transOrCollection single] ifFalse: [self newSetWithAll: transOrCollection]]) ifAbsent: aBlock ! embeddingByNodes ^ embeddingByNodes! embeddingByNodes: anObject embeddingByNodes := anObject.! embeddingsByTransitions | dict | dict := IdentityDictionary new. self net transitions do: [:tra | dict at: tra put: (self embeddingAtTrans: tra)]. ^ dict ! equivalenceForMembership: membership | first relation | relation := self newEquivalenceRelation. first := Dictionary new. membership keysAndValuesDo: [:nod :mbrId | relation relate: nod to: (first at: mbrId ifAbsentPut: [nod])]. first := nil. "relate all nodes, not contained in membership" self net nodes do: [:nd | relation equivalenceClassAt: nd ifAbsent: [ first isNil ifTrue: [first := nd] ifFalse: [relation relate: first to: nd]]]. ^ relation! expandBy1LocalMono: anEmb "answer all local mono type embedding for each possible images one transition bigger than anEmb image add these types if necessary assume enEmb is local Mono and anEmb source is an initialized type" | search found newEmb | (search := self newLocalMonoTypeSearcher) mapOne: anEmb. found := OrderedCollection new. anEmb image graphNeighbours do: [:nd | nd isTransition ifTrue: [ search mapTwo: (self embeddingAtTrans: nd); image: (anEmb image union: search mapTwo image). self combineNewType: search. newEmb := self embeddingAtNodes: search image ifAbsent:[nil]. newEmb isNil ifFalse: [found add: newEmb]]]. ^ found! forbidden ^ forbidden! forbidden: anObject forbidden := anObject.! forbiddenAt: anEmb | for | ^ self forbidden at: anEmb ifAbsentPut: [ for := self newSet. anEmb image do: [:nd | nd isTransition ifTrue: [ self forbidden at: (self embeddingAtTrans: nd) ifPresent: [:coll | for addAll: coll]]]. for]! membership: mShip addForType: type type embeddings do: [:emb | type autos do: [:auto | (MapAggregation of: emb composition: auto) originImageDo: [:ori :ima | (mShip at: ima ifAbsentPut: [self newSet]) add: ori]]]. ^ mShip! membershipAddRelationship: rel compatibleOneSide: mShip | mark mbrVal| rel oneSide do: [:one | mbrVal := mShip ocAt: one. (rel allAt: one) do: [:at1 | ((mShip at: at1) isSameSet: mbrVal) ifFalse: [^ self]]]. rel pairs keysAndValuesDo: [:from :to | ((mShip at: from) isSameSet: (mShip at: to)) ifFalse: [^ self]]. mark := Array with: rel with: #oneSide. rel oneSide do: [:one | (mShip ocAt: one) add: mark]. rel pairs keysDo: [:one | (mShip ocAt: one) add: mark]. ! membershipAddRelationships: mShip | mark | self relationships do: [:rel | mark := Array with: rel with: #origin. rel origin do: [:ori | (mShip at: ori ifAbsentPut: [self newSet]) add: mark]. rel isSymmetric ifFalse: [ mark := Array with: rel with: #image. rel image do: [:ima | (mShip at: ima ifAbsentPut: [self newSet]) add: mark]]]. self membershipAddRelationshipsCompatibleOneSide: mShip. ^ mShip ! membershipAddRelationshipsCompatibleOneSide: mShip self relationships do: [:rel | rel oneSide isNil ifFalse: [ self membershipAddRelationship:rel compatibleOneSide: mShip]]! membershipForTypes | mShip | mShip := IdentityDictionary new. self types do: [:typ | self membership: mShip addForType: typ]. ^ mShip ! net ^ net! net: anObject net := anObject.! newLocalMonoTypeSearcher | search | search := self newTypeSearcher. self forbidden isNil ifTrue: [ self forbidden: IdentityDictionary new. self combine: 1 newTypeSearch: (search via: self search: [:rec :sr | rec createLocalMonoForbidden: sr]). "self net transitions do: [:tra | self forbidden at: (self embeddingAtTrans: tra) ifAbsentPut: [#()]]" ]. ^ search via: self search: [:rec :sr | rec combineNotForbidden: sr]! newLocalMonoTypesExpandingAll: embeddingColl "expand each type embedding in embeddingColl until there are new types created" | oldSize oldEmbs newEmbs | newEmbs := embeddingColl. oldSize := self types size. [self types size = oldSize] whileTrue: [ oldEmbs := newEmbs. newEmbs := OrderedCollection new. oldEmbs do: [:emb | newEmbs addAll: (self expandBy1LocalMono: emb)]. self assert: [newEmbs notEmpty]]. ! newType: search | emb trans | self assert: [search mapOne image includesAny: search mapTwo image]. emb := NetType fromTransitions: (trans := search image select: [:nd | nd isTransition]). self embeddingAdd: emb. (self typeByKey ocAt: (self typeKeyFor: trans)) add: emb source. emb source nameWithNodes: 'y', self types size printString. self createAutosEmbeddingsCombining: ( search mapOne inverse compositionJoin: emb) with: (search mapTwo inverse compositionJoin: emb). ! newTypeSearcher ^(GraphSearch found: [:srch | self newType: srch]) referenceMapOneTwo! printDetailsOn: aStream aStream printDetails: self net; cr; nextPutAll: 'net: '; printDetailsOrStats: self net; cr; nextPutAll: 'types: '; nextPutAll: self types size printString; right. self typeByKey keysAndValuesDo: [:key :types | aStream cr; nextPutAll: key printString; nextPutAll: ' -> '. types size = 1 ifTrue: [aStream printDetailsOrStats: types first] ifFalse: [ aStream nextPutAll: types size printString; nextPutAll: ' types '; right. types do: [:tp | aStream cr; printDetailsOrStats: tp]. aStream left]]. aStream left; cr; nextPutAll: 'embeddingByNodes '; nextPutAll: self embeddingByNodes size printString. self printRelationshipsStatsOn: aStream ! printRelationshipsStatsOn: aStream | dict cnt | dict := Dictionary new. self relationships keysAndValuesDo: [:pa :rel | dict at: pa size put: (dict at: pa size ifAbsent: [0]) + 1]. cnt := dict size. self relationships size printOn: aStream. aStream nextPutAll: ' relationships('. 2 to: 50 do: [:ix | (dict at: ix ifAbsent: [0] ifPresent: [:num | cnt := cnt - 1. num]) printOn: aStream. cnt <= 0 ifTrue: [aStream nextPut: $). ^ self] ifFalse: [aStream space]]! printStatsOn: aStream aStream printId: self net; space; nextPutAll: self net nodes size printString; nextPutAll: ' nodes, '; nextPutAll: self types size printString, ' types, ' , self embeddingByNodes size printString, ' embeddingByNodes, '. self printRelationshipsStatsOn: aStream ! reductionConnectedForMembership: mShip ^ (NetReduction on: self) reduceConnectedEquivalence: (self equivalenceForMembership: mShip) ! reductionConnectedRelationships: relLength ^ self relationshipsFromTypes; relationshipsCompose: relLength; reductionConnectedForMembership: (self membershipAddRelationships: Dictionary new). ! reductionForEquivalence: relation | map | map := self reductionForEquivalence: relation ifFail: [:t | self error: 'reduction failed']. map isMorphism ifFalse: [self error: 'not a morphism']. map isFolding ifFalse: [self error: 'not a folding']. " map isLocalMono ifFalse: [self error: 'not local mono']." ^ map! reductionForEquivalence: relation ifFail: failBlock ^ (NetReduction on: self) reduceForEquivalence: relation ifFail: failBlock; yourself ! reductionForTypeGroupings | map embs | [map isNil] whileTrue: [ embs := OrderedCollection new. map := self reductionForEquivalence: (self equivalenceForMembership: self membershipForTypes) ifFail: [:t | embs add: (self embeddingAtTrans: t)]. embs isEmpty ifTrue: [^ map]. self newLocalMonoTypesExpandingAll: embs].! relationshipAt: path ^ self relationshipAt: path ifAbsentPut: [self fail]! relationshipAt: path ifAbsentPut: aBlock ^ self relationships at: path ifAbsentPut: [ self relationships at: path reverse ifPresent: [: rel | ^ rel inverse ]. aBlock value]! relationshipOrigin: from image: to path: path (self relationshipAt: path ifAbsentPut: [ (self newRelationship source: path first; dest: path last)]) origin: from image: to ! relationships ^ relationships! relationships: anObject relationships := anObject.! relationshipsAnalyse self relationships: (self relationships keysAndValuesSelect: [:path :rel | rel analyse. rel isIdentic not or: [path first ~= path last or: [path size > 3]]])! relationshipsCompose: maxLength "compose paths of length with all other paths" | gra dataPa | gra := Graph new. self relationshipsAnalyse. self relationships do: [:rel | gra connectDataFrom: rel source to: rel dest arc: rel]. gra pathsFrom: 2 to: maxLength do: [:pa | self relationshipAt: (dataPa := pa collect: [:nd | nd data]) ifAbsentPut: [((self relationshipAt: (dataPa copyFrom: pa size - 1)) compositionJoin: (self relationshipAt: (dataPa copyFrom: 1 to: pa size - 1))) analyse]].! relationshipsFromTypes self relationships: Dictionary new. self types do: [:typ | typ embeddings do: [:emb | typ places do: [:from | typ places do: [:to | from = to ifFalse: [self relationshipOrigin: (emb at: from) image: (emb at: to) path: (Array with: (typ traceEquivalence equivalenceClassAt: from) with: (typ traceEquivalence equivalenceClassAt: to))]]]]]. self relationshipsAnalyse.! transitionEmbeddingsExpandingLocalMono: anEmb "answer one transition embedding that expand anEmb local mono for every image assume enEmb is local Mono and anEmb source is an initialized type" | res trans srcImage toDo mono maxEmbs maxInter inter | res := OrderedCollection new. srcImage := self newSetWithAll: anEmb image. toDo := self newSet. srcImage do: [:ele | ele isTransition ifFalse: [toDo addAll: ele prePostNodes]]. toDo := toDo difference: srcImage. [toDo notEmpty] whileTrue: [ trans := toDo any. mono :=(self embeddingAtTrans: trans) select: [:ori :ima | srcImage includes: ima]. maxEmbs := Dictionary new. self typeEmbeddingsExpanding: mono select: [:image | (inter := srcImage intersection: image) notEmpty and: [(toDo remove: (image detect: [:no | no isTransition]) ifAbsent: [maxEmbs := nil]) notNil and: [maxEmbs notNil]]] do: [:emb | maxEmbs at: inter put: emb. true]. maxEmbs notNil ifTrue: [ (maxEmbs keys maximasPO: [:a :b | a subsetPO: b]) do: [:key | res add: (maxEmbs at: key)]]]. ^ res ! typeAutosOf: emb connectedTo: othEmb conflicts: conflicts "answer the automorphisms of the source of typeEmbedding emb that a) are connected with othEmb, that is there is a node such that the images by emb auto and othEmb are equivalent withing conflicts relation b) all imagePairs are not in conflict regarding the equivalenceMap conflicts if all autos are conflicting, then expand conflicts to contain the transitions" | nodeRel typ ima othIma found res all | all := true. nodeRel := conflicts relation. res := (typ := emb source) autos select: [:auto | found := nil. typ nodes findFirst: [:src | (nodeRel is: (ima := emb at: (auto at: src)) equivalent: (othIma := othEmb at: src)) ifTrue: [ (src isTransition and: [typ transitions size = 1]) ifTrue: [^#()]. found isNil ifTrue: [found := true]] ifFalse: [ ((conflicts at: ima) includesAny: (nodeRel equivalenceClassAt: othIma) elements) ifTrue: [found := false]]. found = false]. found = false ifFalse: [all := false]. found = true]. all ifTrue: [ typ transitions do: [:src | (conflicts at: (ima := emb at: src)) addAll: (nodeRel equivalenceClassAt: (othIma := othEmb at: src)) elements. (conflicts at: othIma) addAll: (nodeRel equivalenceClassAt: ima) elements]]. ^ res ! typeByKey ^ typeByKey! typeByKey: anObject typeByKey := anObject.! typeEmbeddingsExpanding: aMorph select: imaSelect do: aBlock "call the imageSelect block for each possible image of the expansion of aMorph if imaSelect evalevaluates to true evaluate aBlock for each expansion of aMorph to a total morphism with this image until aBlock evaluates for the first time to true assume that aMorph source is an initialized type" | oldImage total | oldImage := self newSetWithAll: aMorph image. aMorph source embeddings do: [:emb | ((emb image includesAll: oldImage) and: [imaSelect value: emb image]) ifTrue: [ aMorph source autos detect: [:auto | ((total := aMorph union: (MapAggregation of: emb composition: auto) ifFail: [nil]) isNil ifFalse: [aBlock value: total]) = true] ifNone: []]]. ! typeFilter "answer the filter for my transition types" ^ [:obj :block | obj isPlace ifTrue: [block value: ##PlaceType] ifFalse: [ obj isTransition ifTrue: [block value: (self typeOfTransition: obj)]]]! typeForTree: tree createEmbeddings: aBlock | type perms key embs | perms := NetType minimalPermutationsOfTypeTree: tree. key := NetType typeKeyFromTree: tree permutation: perms first. ^ self types at: key ifAbsent: [ self types at: key put: (type := NetType fromKey: key permutations: perms). type useIndexMapOf: self; sortIndex: self types size; embeddings: (aBlock value: type). self embeddingByNodes addAll: type embeddings. type]! typeKey ^ (((self transitions collect: [:tra | (self typeOfTransition: tra) name]) asSortedCollection: [:a :b | (a sequenceLess: b) ~= false]) asOrderedCollection addFirst: self places size; addFirst: self transitions size; yourself) asArray ! typeKeyFor: transColl | plaColl | plaColl := self newSet. ^ (((transColl collect: [:tra | plaColl addAll: tra prePostNodes. (self typeOfTransition: tra) name]) asSortedCollection: [:a :b | (a sequenceLess: b) ~= false]) asOrderedCollection addFirst: plaColl size; addFirst: transColl size; yourself) asArray ! typeMSFrom: aCollection "answer the filter for my transition types" ^ Net newMS filter: self typeFilter addAll: aCollection; yourself! typeOfTransition: aTransition ^ (self embeddingAtTrans: aTransition) source ! types | oc | oc := OrderedCollection new. self typeByKey values do: [:coll | oc addAll: coll]. ^ oc! ! !NetType class publicMethods ! fromTransition: aTransition ^self new addNodesAndArcsLike: (Array with: aTransition); createTransitionAutos; yourself! fromTransitions: aColl | new dict emb | dict := (new := self new) addNodesAndArcsLike: aColl. emb := TableMap source: new dest: aColl any graph. dict keysAndValuesDo: [:ima :ori | emb origin: ori image: ima]. ^ emb ! ! !NetType publicMethods ! areAutosValid | ori set | ori := self nodes asArray. set := Set new. ^ self autos notEmpty and: [ (self autos conform: [:aut | set addIfUnique: (aut atAll: ori)]) and: [ set includes: ori]]! autos ^ autos! autos: anObject autos := anObject.! autos: aType match: matchBlock do: doBlock self autos do: [:myAuto | aType autos do: [:othAuto | (matchBlock value: myAuto value: othAuto) ifTrue: [doBlock value: myAuto value: othAuto]]]! autos: aType match: matchBlock firstDo: doBlock ^ self autos: aType match: matchBlock do: [:myAu :othAu | ^ doBlock value: myAu value: othAu] ! autosAdd: anAuto self assert: [anAuto source = self and: [anAuto dest = self and: [anAuto isIso]]]. self autos add: anAuto! buildTraceEquivalence self traceEquivalence: self newEquivalenceRelation. self autos do: [:auto | self nodes do: [:node | self traceEquivalence relate: node to: (auto at: node)]].! createAutosCombining: mapOne with: mapTwo | image oneByNd com comOne comTwo inv | self assert: [self autos isEmpty and: [mapOne source == self and: [mapTwo source == self]]]. image := (inv := self embeddings single inverse) origin. com := (mapOne origin intersection: mapTwo origin) asOrderedCollection. comOne := mapOne atAll: com. comTwo := mapTwo atAll: com. oneByNd := Dictionary new. mapOne dest embeddings do: [:emb | (image includesAll: emb image) ifTrue: [oneByNd at: emb image put: emb]]. mapTwo dest embeddings do: [:embTwo | (image includesAll: embTwo image) ifTrue: [ oneByNd keysAndValuesDo: [:imOne :embOne | (image isSameSet: (embTwo image union: imOne)) ifTrue: [ mapOne dest autos do: [:auOne | mapTwo dest autos do: [:auTwo | (comOne with: comTwo conform: [:ndOne :ndTwo | (embOne at: (auOne at: ndOne)) == (embTwo at: (auTwo at: ndTwo))]) ifTrue: [ self autosAdd: (inv composition: (( embOne composition: (auOne composition: mapOne)) union: (embTwo composition: (auTwo composition: mapTwo))))]]]]]]]. self assert: [self areAutosValid].! createTransitionAutos "create the automorphisms" | search map | map := TableMap source: self dest: self. map origin: self transitions single image: self transitions single. (search := GraphSearch found: [:srch | self autos add: srch map copyCollection]) map: map node: nil arc: nil. self transitions single areaByDataPair do: [:coll | coll size = 1 ifTrue: [map origin: coll single image: coll single] ifFalse: [search := search viaPermutations: coll andSearch: [:from :to :srch | srch map origin: from image: to. srch found. srch map removeOrigin: from]]]. search found. self assert: [self autos notEmpty].! defaultName: aNode aNode name: aNode class name first asString, (self transitions size + self places size) printString ! embByNode ^ embByNode! embByNode: anObject embByNode := anObject.! embeddingAdd: aMono self assert: [aMono source = self and: [aMono isMorphism and: [aMono isMono]]]. self embeddings add: aMono. aMono image do: [:nd | (self embByNode setAt: nd) add: aMono]! embeddingPairsWith: aType imageUnionSize: anInteger do: aBlock "evaluate aBlock for each pair of an embedding of the receiver and an embedding of aType for which the union of the images has size anInteger block arguments: embedding of receiver, embedding of aType, union of images" | union stopper | self assert: [anInteger > self size and: [anInteger > aType size and: [anInteger < (self size + aType size)]]]. "other cases are not implemented!!" aType embeddings do: [:anEmb | stopper := Set new. anEmb image do: [:nd | (nd isTransition or: [anEmb image includesAll: nd prePostNodes]) ifFalse: [ self embByNode at: nd ifPresent: [:embSet | embSet do: [:myEmb | (stopper addIfUnique: myEmb) ifTrue: [ (union := myEmb image union: anEmb image) size =anInteger ifTrue: [ aBlock value: myEmb value: anEmb value: union]]]]]]].! embeddings ^ embeddings! embeddings: anObject embeddings := anObject.! embeddingsAtAll: aCollection do: aBlock "evaluate aBlock at least once for each image of each embedding auto composition" | srcColl | srcColl := aCollection asArray. (self autos collect: [:auto | auto atAll: srcColl]) asSet do: [:autoIm | self embeddings do: [:emb | (aBlock value: (emb atAll: autoIm)) = true ifTrue: [^true]]] ! imagesAutoEmbeddingsDo: aBlock "evaluate aBlock once for each image and embedding auto composition if aBlock answers true, skip the remainin autos for this image" | image | self embeddings do: [:emb | image := self newSetWithAll: emb image. self autos detect: [:auto | (aBlock value: image value: (MapAggregation of: emb composition: auto)) = true]]! imagesEmbeddingsAutosDo: aBlock "evaluate aBlock once for each image and embedding auto composition" | image | self embeddings do: [:emb | image := self newSetWithAll: emb image. self autos do: [:auto | aBlock value: image value: (MapAggregation of: emb composition: auto)]]! initialize: size super initialize: size. self embeddings: OrderedCollection new; autos: OrderedCollection new; embByNode: Dictionary new! lssPO: two ^ self class typeKey: self typeKey lssPO: two typeKey! nameWithNodes: aName self name: aName. self nodes doWithIndex: [:nd :ix | nd name: aName, nd class name first asLowercase asString, ix printString]! nodesAutoEquivalence "answer an EquivalenceRelation of the nodes of the receiver, for " | rel all pair | rel := EquivalenceRelation new: (all := self nodes) size. all do: [:nod | (rel includes: nod) ifFalse: [ self autos do: [:auto | rel relate: nod to: (auto at: nod)]]]. ^ rel! pairsAutoEquivalence "answer aCollection of the equivalenceClasses of pairs of nodes of the receiver, for the equivalence relation do not include a pair (y x) if (x y) is already included, and neither (x x) pairs" | rel all pair reverse | rel := EquivalenceRelation new. (all := self nodes) doWithIndex: [:left :ix | all from: ix+1 to: all size do: [:right | pair := Array with: left with: right. ((rel includes: pair) or: [rel includes: pair reverse]) ifFalse: [ self autos do: [:auto | rel relate: pair to: (auto atAll: pair)]]]]. rel equivalenceClasses do: [:class | class == (rel equivalenceClassAt: class elements first reverse ifAbsent: [class]) ifFalse: [rel removeClass: class]]. "because class is not symmetric and reverse class exists" ^ rel ! traceAt: aNode "answer the trace equivalence class of a Node within the receiver" self assert: [aNode graph == self]. ^ self traceEquivalence equivalenceClassAt: aNode! traceEquivalence traceEquivalence isNil ifTrue: [self buildTraceEquivalence]. ^ traceEquivalence! traceEquivalence: anObject traceEquivalence := anObject.! ! !Object publicMethods ! newEquivalenceRelation ^ EquivalenceRelation new useIndexMapOf: self! newRelationship ^ RelationshipDual new useIndexMapOf: self! ! !PartialMap class publicMethods ! source: sourceNet dest: destNet ^ self new source: sourceNet; dest: destNet! ! !PartialMap publicMethods ! addIdentityOfAll: aCollection aCollection do: [:orig | self origin: orig image: orig]! addMap: aMap ifFail: aBlock "answer the receiver after adding all mappings from aMap answer aBlock value if a conflict occurs" self assert: [self source == aMap source and: [self dest == aMap dest]]. aMap originImageDo: [:or :im | self origin: or image: im ifFail: [^ aBlock value]]. ! allAt: anOrigin "answer the collection of images of anOrigin if present otherwise aBlock value" ^self allAt: anOrigin ifAbsent: [self fail]! allAt: anOrigin ifAbsent: aBlock "answer the collection of images of anOrigin if present otherwise aBlock value" self subclassResponsibility! areSelected: selBlock areaArcs1to1: arcBlock "answer aBoolean whether the arcs between two corresponding nodes, selected by selBlock are 1tot1 using arcBlock" | imaPost selArcs| self originImageDo: [:ori :ima | imaPost := ima postByTo. ori postByTo keysAndValuesDo: [:to :arcs | (selArcs :=arcs select: selBlock) isEmpty ifFalse: [ (((imaPost removeKey: (self at: to) ifAbsent: [#()]) select: selBlock) with: selArcs is1to1: arcBlock) ifFalse: [^ false]]]. imaPost do: [:arcs | (arcs select: selBlock) isEmpty ifFalse: [^false]]]. ^ true ! at: anOrigin "answer the image of anOrigin if present otherwise raise an error" ^ self at: anOrigin ifAbsent: [self error: 'missing origin ', anOrigin printString]! at: anOrigin ifAbsentPut: aBlock "answer the image of anOrigin if present otherwise put aBlock value" self subclassResponsibility! atMS: originMS "answer the image of the multiset originMS, raise an error if outside origin" | res | res := Net newMS. originMS doWithOccurrences: [:node :occ | res add: (self at: node) withOccurrences: occ]. ^ res ! composition: aMap "answer the composition of the receiver and aMap as a new Map" ^ self composition: aMap ifFail: [self error: 'composition']! composition: aMap do: doBlock ifFail: failBlock "evaluate the doBlock with every origin image pair of the receiver and aMap" aMap originImageDo: [:or :im | self at: im ifAbsent: failBlock ifPresent: [:final | doBlock value: or value: final]] ifFail: failBlock. ! composition: aMap ifFail: aBlock "answer the composition of the receiver and aMap as a new Map" | new err | err := [^ aBlock value]. new := self speciesNew initialize: self composition: aMap. self composition: aMap do: [:or :im | new origin: or image: im ifFail: err] ifFail: err. ^ new! compositionJoin: aMap "answer as a new Mapthe composition of the receiver and aMap where they fit together (dont fail for dangling images of the receiver)" ^ self compositionJoin: aMap ifFail: [self fail: 'compositionJoin:'] ! compositionJoin: aMap ifFail: aBlock "answer as a new Mapthe composition of the receiver and aMap where they fit together (dont fail for dangling images of the receiver)" | new | new := self speciesNew initialize: self composition: aMap. aMap originImageDo: [:or :im | self at: im ifAbsent: [] ifPresent: [:final | new origin: or image: final ifFail: [^ aBlock value]]]. ^ new ! copyCollection self subclassResponsibility! copyEmpty | new | ^ self speciesNew source: self source; dest: self dest; yourself! dest ^ dest! dest: anObject dest := anObject.! expandMultiInjections: aList "answer the collection of all expansions of the receiver that are injections for every pair of collections of aList" | exp index node leaf | node := [:children :from :to | | old | (old := self at: from ifAbsent: [nil]) isNil ifTrue: [ self origin: from image: to. children value. self removeOrigin: from] ifFalse: [old = to ifTrue: [children value]]]. leaf := [(index := index -1) < 1 ifTrue: [exp add: self copy] ifFalse: [(aList at: index) key injectionsTo: (aList at: index) value node: node leaf: leaf]]. index := aList size + 1. exp := OrderedCollection new. leaf value. ^ exp! expandRemoveSingletonInjections: aList "expand the receiver by all singleton injections in aList. remove those and empties from aList answer the reduced list if expansion possible, nil otherwise" ^ aList select: [:ass | ass key isCollection = ass value isCollection ifFalse: [self error: 'isCollection ~=']. ass key isCollection ifFalse: [ self origin: ass key image: ass value ifFail: [^nil]. false] ifTrue: [ ass key size > ass value size ifTrue: [self error: 'size >']. ass key notEmpty and: [ass value size > 1 or: [ self origin: ass key first image: ass value first ifFail: [^nil]. false]]]]! expandRemoveUniqueInjections: aList "expand the receiver by all unique injections in aList. remove those from aList answer aBoolean indication whether it was possible" | reduced orColl imColl anImage | (reduced := self expandRemoveSingletonInjections: aList) isNil ifTrue: [^ nil]. reduced := reduced collect: [:ass | imColl := ass value copy. orColl := ass key select: [:ori | (anImage := self at: ori ifAbsent: [nil]) notNil ifTrue: [imColl remove: anImage ifAbsent: [^nil]]. anImage isNil]. Association key: orColl value: imColl]. ^ self expandRemoveSingletonInjections: reduced ! expansionsOfInjections: aList "answer the collection of all expansions of the receiver that are injections for every pair of collections of aList" | single multis | ^(multis := (single := self copy) expandRemoveUniqueInjections: aList) isNil ifTrue: [#()] ifFalse: [single expandMultiInjections: multis]! image "answer the image set" | image | image := self newSet. self originImageDo: [:ori :ima | image add: ima]. ^image! imageSize "answer the size of the image set" ^self image size! initialize: leftMap composition: rightMap "initialize the receiver for composition and answer the receiver" self assert: [rightMap dest == leftMap source]. self source: rightMap source; dest: leftMap dest ! inverse "answer the inverse of the receiver as a new Map" | new | (new := self speciesNew) source: self dest; dest: self source. self inverseDo: [:or :im | new origin: or image: im ifFail: [self fail: 'inverse']] ifFail: [self fail: 'inverse']. ^ new! inverseDo: doBlock ifFail: failBlock "answer the inverse of the receiver as a new Map" self originImageDo: [:or :im | doBlock value: im value: or] ifFail: [^ failBlock value]! isEpi | im | "answer true if receiver is monomorph" ^ (self image isSameSet: self dest nodes)! isFolding | im | "answer true if receiver is a Folding, that is map transitions to transitions and places to places" self originImageDo: [:origin :image | origin isTransition == image isTransition ifFalse: [ ^false]]. ^true. ! isIdentic | im | "answer true if receiver is a localmono " self originImageDo: [:ori :ima | ori = ima ifFalse: [^ false]]. ^true! isIso ^ self isMorphism and: [self isMono and: [self isEpi]]! isLocalMono | im | "answer true if receiver is a localmono " self originImageDo: [:ori :ima | ori isTransition = ima isTransition ifFalse: [^ false]. ori isTransition ifTrue: [ ori pre size = ima pre size ifFalse: [^false]. ori post size = ima post size ifFalse: [^false]]]. ^true! isMono | im | "answer true if receiver is monomorph" ^ self imageSize == self originSize! isMorphism | im | "answer true if receiver is a morphism" self isTotal ifFalse: [^ false]. ^ self source transitions conform: [:trans | self isMorphismAt: trans]! isMorphismAt: ori | im | "answer true if receiver is a morphism locally within the area of the origin ori" ^ ori isPlace or: [ (im := self at: ori) isTransition ifTrue: [ (im preMS isSameMS: (self atMS: ori preMS)) and: [im postMS isSameMS: (self atMS: ori postMS)]] ifFalse: [ ((im := Net newMS add: im; yourself) isSameMS: (self atMS: ori preMS)) and: [im isSameMS: (self atMS: ori postMS)]]]! isPartialMorphism | im | "answer true if receiver is a partial morphism" self originImageDo: [:ori :ima | (ori net == self source and: [ima net == self dest and: [ori isPlace or: [self isMorphismAt: ori]]]) ifFalse: [^ false]]. ^ true! isRestrictionOf: aMap "answer true if receiver is a restricion of aMap" self originImageDo: [:ori :ima | (aMap at: ori ifAbsent: [^ false]) = ima ifFalse: [^ false]]. ^ true! isSameRelationship: other "answer a boolean, whether the receiver and other represent the same relationship" self origin size = other originSize ifFalse: [^ false]. self source = other source ifFalse: [^ false]. self dest = other dest ifFalse: [^ false]. other originImagesAllDo: [:ori :imaColl | self assert: [imaColl notEmpty]. (imaColl isSameSet: (self allAt: ori ifAbsent: [^ false])) ifFalse: [ ^ false]]. ^ true! isTotal | im | "answer true if receiver is a total map, false if it is only partial" ^ (self origin isSameSet: self source nodes)! origin "answer the set of origins" | origin | origin := Set new. self originImageDo: [:ori :ima | origin add: ori]. ^origin! origin: anOrigin image: anImage "add the tuple anOrigin anImage to the receiver" self origin: anOrigin image: anImage ifFail: [self fail].! originImageDo: aBlock "execute the two argument block aBlock for every origin image pair" self originImageDo: aBlock ifFail: [^ self fail: 'originImageDo']! originImageDo: doBlock ifFail: failBlock "execute the two argument block aBlock for every origin image pair" self originImagesAllDo: [:ori :imaColl | self assert: [imaColl notEmpty]. imaColl do: [:ima | doBlock value: ori value ima]] ifFail: failBlock! originImagesAllDo: doBlock "execute the two argument block aBlock for every origin image pair" self originImagesAllDo: doBlock ifFail: [self fail]! originImagesAllDo: doBlock ifFail: failBlock "execute the two argument block aBlock for every origin image pair" self subclassResponsibility! originOf: anImage "answer the set of origins of anImage" ^ (self originsAllOf: anImage ifAbsent: [^ self fail]) single! originsAllOf: anImage "answer the set of origins of anImage" ^ self originsAllOf: anImage ifAbsent: [self fail]! originsAllOf: anImage ifAbsent: aBlock "answer the set of origins of anImage or aBlock value if absent" | origins | origins := OrderedCollection new. self originImageDo: [:ori :ima | anImage = ima ifTrue: [origins add: ori]]. ^origins! originsByImage "answer a dictionary with the images as keys and ordered collections of their origins as values" | new | new := Dictionary new. self originImageDo: [:or :im | (new ocAt: im) add: or]. ^ new! originSize "answer the size of the set of origins" ^self origin size! printAnalysisOn: aStream | one two | aStream cr; nextPutAll: ((one := self source nodes size) = (two := self originSize) ifTrue: ['isTotal '] ifFalse: [(one - two) printString, 'unmapped sources']); nextPutAll: ((one := self dest nodes size) = (two := self imageSize) ifTrue: ['isEpi '] ifFalse: [(one - two) printString, 'unmapped dests']). self isMono ifTrue: [aStream nextPutAll: 'isMono '] ifFalse: [self isLocalMono ifTrue: [aStream nextPutAll: 'isLocalMono ']]. self isMorphism ifFalse: [aStream nextPutAll: 'isNOTmorphism ']. self isFolding ifTrue: [aStream nextPutAll: 'isFolding ']. self isIdentic ifTrue: [aStream nextPutAll: 'isIdentic ']. ! printDetailsOn: aStream | oc | aStream cr; nextPutAll: 'source: '; printDetailsOrStats: self source; cr; nextPutAll: 'dest: '; printDetailsOrStats: self dest; cr; nextPutAll: 'image <- all origins of:'; right. oc := OrderedCollection new. self originsByImage keysAndValuesDo: [:im :origs | | line | line := (aStream printIdString: im), ' <--- '. (origs collect: [:ori | aStream printIdString: ori]) asSortedCollection do: [:str | line := line, ' ', str]. oc add: line]. oc asSortedCollection do: [:line | aStream cr; nextPutAll: line]. aStream left. ! printImageOriginsOn: aStream "print the origins of each image" | oc | oc := OrderedCollection new. self originSetByimage keysAndValuesDo: [:im :origs | oc add: (aStream printBlockString: [:s | s printId: im; nextPutAll: ' <--- '. (origs collect: [:ori | aStream printIdString: ori]) asSortedCollection do: [:ori | s nextPutAll: ori; space]])]. oc asSortedCollection do: [:line | aStream cr; nextPutAll: line]. ! printOn: aStream "Append to the argument aStream, a sequence of characters that describes the receiver. Fail if aStream is not a kind of Stream." aStream nextPutAll: self class name asLc1; nextPut: $[. self source printOn: aStream. aStream nextPutAll: '->'. self dest printOn: aStream. aStream nextPut: $]. ! printStatsOn: aStream aStream nextPutAll: self source nodes size printString; nextPutAll: ' -> '; nextPutAll: self dest nodes size printString; nextPutAll: ' nodes' ! relationshipsAdd: holder self source arcs do: [:arc | holder relationshipOrigin: arc from image: arc to path: (Array with: (self at: arc from) with: (self at: arc to))]! renameImage "rename the image with common patterns" | ix | ix := 0. self dest nodes do: [:nd | nd name: nil]. self reverse keysAndValuesDo: [:im :origs | im name: (origs collect: [:orig | orig name]) pattern, im class name first asString, (ix := ix + 1) printString]. self dest sortNodes! restrictionPO: aMap "answer true if receiver is an restriction of (or =) aMap false if aMap is an restriction of receiver nil if not comparable" self originImageDo: [:ori :ima | (aMap at: ori ifAbsent: [^ (aMap isRestritionOf: self) ifTrue: [false] ifFalse: [nil]]) = ima ifFalse: [^ nil]]. ^ true! reverse "answer a Dictionary with image -> set of origins" | mShip | mShip := IdentityDictionary new. self originImageDo: [:or :ima | (mShip at: ima ifAbsentPut: [Set new]) add: or]. ^ mShip! select: aBlock "answer the a new Map, containing the image origin pairs of the receiver, that are selected by aBlock" | new | new := TableMap source: self source dest: self dest. self originImageDo: [:or :im | (aBlock value: or value: im) ifTrue: [new origin: or image: im ifFail: [self error: 'restrict']]]. ^ new ! sortedReverse "answer an array of sorted associations" ^ self reverse asAssociations sort: [:a :b | a key name <= b key name]! source ^ source! source: anObject source := anObject.! species ^ self subclassResponsibility! speciesNew ^ self species new useIndexMapOf: self; yourself! union: aMap "answer the union of the receiver and aMap" ^ self union: aMap ifFail: [self error: 'union']! union: aMap ifFail: aBlock "answer the union of the receiver and aMap as a new Map" ^ self copyEmpty addMap: self ifFail: [^ aBlock value]; addMap: aMap ifFail: [^ aBlock value] ! ! !Petri class publicMethods ! doesNotUnderstand: aMessage "die Message wird unverändert ans singleton weitergeschickt damit wir im Transcript die Message einfach an die Klasse schicken können" ^ self singleton perform: aMessage selector withArguments: aMessage arguments ! help "print help on Transcript" "Petri help" self helpOn: Transcript! helpOn: aStream "print help informatiion to aStream" aStream cr; nextPutAll: self controller name, ' ', self controller versionName, self controller timeStamp printString, ' copyright: '; cr; tab; nextPutAll: 'walter keller (wkeller@tiscalinet.ch, http://home.tiscalinet.ch/wkeller)'; cr; tab; nextPutAll: 'phd at ifi, university of zurich (http://www.ifi.unizh.ch)' ; cr; nextPutAll: 'help for interface class Petri'; cr; tab; nextPutAll: 'a message sent to class ''Petri'' is forwarded to the instance ''Petri singleton'''; cr; tab; nextPutAll: 'Petri addNetEdwm "creates an example net and loads is as the last member of Petri singleton"'; cr; tab; nextPutAll: 'Petri toColours "adds different stages of a colour analysis on the source member"'; cr; tab; nextPutAll: 'Petri all; printStats "prints the statistics for all member of Petri singleton"'; cr; tab; nextPutAll: 'Petri last; printDetails "prints the details of the last member of Petri singleton"'; cr; tab; nextPutAll: 'Petri all; printDetails "prints the details of all members of Petri singleton"'; cr; tab; nextPutAll: 'Petri cutToFirst "removes all but the first member"'; cr; tab; nextPutAll: 'Petri reset "re initialisation"'; cr; tab; nextPutAll: 'Petri help "print this text"'; cr; nextPutAll: 'Further information: instructions on cd or browse instance methods of Petri'; cr ! new ^ super new reset! reset self singleton: nil! singleton Singleton isNil ifTrue: [Singleton := self new]. ^ Singleton! singleton: anObject Singleton := anObject.! ! !Petri publicMethods ! addNet1 "add a net consisting of 1 transition one input- and and two output places" | net t | t := (net := Net new) newTransition. net newPlace connectTo: t. t connectTo: net newPlace. t connectTo: net newPlace. ^ self add: net.! addNet3 "add a net consisting of 3 transitions and 5 places" | net | net := Net new. 1 to: 5 do: [:ix | net newPlace: 'p', ix printString]. 1 to: 3 do: [:ix | net newTransition: 't', ix printString. net connect: 'p', ix printString to: 't', ix printString. net connect: 'p', (ix+1) printString to: 't', ix printString. net connect: 't', ix printString to: 'p', (ix+2) printString]. net connect: 'p2' to: 't3'. net connect: 'p5' to: 't1'. net connect: 'p5' to: 't2'. ^ self add: net.! addNetDotted "add a net with dotted structure" "Petri addNetDotted" | net leaf nest | leaf := [:pref :tcon :pcon | | t p | 1 to: 2 do: [:ix |net newPlace: pref,'.p', ix printString; newTransition: pref,'.t', ix printString]. tcon isNil ifFalse: [net connect: tcon to: pref,'.p1']. net connect: pref, '.p1' to: pref,'.t1'; connect: pref, '.t1' to: pref,'.p2'; connect: pref, '.p2' to: pref,'.t2'. pcon isNil ifFalse: [net connect: pref,'.t2' to: pcon]. pref, '.t1']. nest := [:level :pref | level < 1 ifTrue: [leaf value: pref value: nil value: nil] ifFalse: [ |one two | one := nest value: level - 1 value: pref, '.one', level printString. nest value: level - 1 value: (two := pref, '.two', level printString). leaf value: pref value: one value: two, '.p2'. one]]. self add: (net := Net new). nest value: 3 value: 'nest'. ^ net! addNetEdwm "add an EDWM (standard example from PhDnetNet) in default size" "Petri addNetEdwm" ^ self addNetEdwm: #(4 5) ! addNetEdwm: anArray "add an EDWM (standard example from PhDnetNet) in size specified" ^ self add: (Net new edwm: anArray) ! addNetFromPtn "add a Net from an inputfile in PTN format" "Petri addNetFromPtn" | file | ^ (file := self filePrompter: 'enter a PTN Filename') isNil ifFalse: [self add: (Net fromPtnFile: file)] ! all "set current to the last member" self currents: ##all. ^ self members! currents ^ currents! currents: anObject currents := anObject.! cutTo: aNumber "drop all members except first aNumber" aNumber + 1 to: self members size do: [:i | self members removeLast]. self members isEmpty ifTrue: [self streamPlus: nil]! cutToFirst "drop all members except first" self cutTo: 1! do: aBlock "evaluate a block for each current member" self doWithIndex: [:mbr :ix | aBlock value: mbr]! doWithIndex: aBlock "evaluate a block for each current member" (self currents == ##last) ifTrue: [aBlock value: self members last value: self members size] ifFalse: [(self currents == ##all) ifTrue: [self members doWithIndex: aBlock] ifFalse: [currents do: [:index | aBlock value: (self members at: index) value: index]]]! filePrompter: aTitle "prompt for a file name and answer its contents" | fName file | [(fName := CwFileSelectionPrompter new title: aTitle; prompt) isNil] whileFalse: [ (file := CfsReadFileStream open: fName) isCfsError ifFalse: [^ file]. (CwMessagePrompter confirm: fName printString, CldtConstants::Cr asString, file message, CldtConstants::Cr asString, 'retry?' title: 'error in file open') ifFalse: [^ nil]]. ^ nil ! first "set current to the last member" self currents: #(1). ^ self members first! last "set current to the last member" self currents: ##last. ! members ^ members! members: anObject members := anObject.! newStream self streamPlus isNil ifTrue: [ self streamPlus: (WriteStreamPlus with: '') printIdBlockDuplicateResolver]. ^ (WriteStreamPlus with: '') printIdBlock: self streamPlus printIdBlock; isStoppedBlockOnceOnly! printDetails "Petri printDetails" "print current areas i.e. net details" | str | str := self newStream. self doWithIndex: [:mbr :ix | str cr; nextPutAll: 'member ', ix printString, ': ' ; printDetailsOrStats: mbr]. Transcript nextPutAll: str contents.! printStats "print current statistics" "Petri printStats" | stream | stream := self newStream. self do: [:mbr | stream cr; printStats: mbr]. Transcript nextPutAll: stream contents! reset "clear members" self last; members: OrderedCollection new; streamPlus: nil! sourceColouredReduction self members reverseDo: [:mbr | (mbr class = NetReduction and: [mbr colourSets notNil]) ifTrue: [^ mbr]]. self error: 'no reduction with colours found'! sourceNet self members reverseDo: [:mbr | (mbr class = Net) ifTrue: [^ mbr]]. ^ self addNetEdwm! sourceReduction self members reverseDo: [:mbr | (mbr class = NetReduction) ifTrue: [^ mbr]]. ^ self toConnectedMembershipReduction! sourceStructure self members reverseDo: [:mbr | (mbr class = NetStructure) ifTrue: [^ mbr]]. ^ self toStructure ! streamPlus ^ streamPlus! streamPlus: anObject streamPlus := anObject.! timingsConnectedReduction "procduce timings for diffferent sizes of EDWM" "Petri timingsConnectedReduction" | net str red oc | ^( (5 to: 15 by: 10) collect: [:sz | (oc := OrderedCollection with: 0 with: 0). self class controller reset. System globalGarbageCollect. oc add: ( Time millisecondsToRun: [net := Net new edwm: (Array with: sz with: sz + 3 with: sz + 11)]). oc add: ( Time millisecondsToRun: [str := NetStructure from: net]). oc add: ( Time millisecondsToRun: [red := str reductionConnectedForMembership: str membershipForTypes]). oc add: ( Time millisecondsToRun: [red renameImage]). oc add: str net name; add: red dest nodes size; at: 1 put: net arcs size; at: 2 put: (oc at: 3) + (oc at: 4) + (oc at: 5) + (oc at: 6); asArray]) inspect; yourself ! toColours "add a colour analysis" "Petri toColours" ^ (self add: (self sourceReduction copyCollection)) colourByRelationships: 1; renameImage ! toColours2 "add a colour analysis with path length 2" "Petri toColours2" ^ (self add: (self sourceReduction copyCollection)) colourByRelationships: 2! toCombinedLocalMonoTypes "combine types with overlapping image to new localMono Types. Warning: it takes a long time on big nets!! " "Petri singleton toCombinedLocalMonoTypes" 1 to: 2 do: [:count | self add: (self sourceStructure copyCollection combineLocalMonoTypes: count)] ! toCombinedTypes "combine types with overlapping image. Warning: it takes a long time on big nets!! " "Petri toCombinedTypes" 1 to: 2 do: [:count | self add: (self sourceStructure copyCollection combineTypes: count)]! toConnectedMembershipReduction "comput a reduction of the source net structure by neighbourhood merging compatible with type membership" "Petri singleton toConnectedMembershipReduction" | ns | ^ self add: ((ns := self sourceStructure) reductionConnectedForMembership: ns membershipForTypes) renameImage ! toConnectedReduction "compute a reduction of the source net structure by neighbourhood merging" "Petri toConnectedReduction" | ns | (self add: (NetReduction on: (ns := self sourceStructure))) reduceConnectedEquivalence: (ns newEquivalenceRelation addEquivalenceClassWithAll: ns net nodes; yourself); renameImage! toConnectedRelationshipsReduction "compose relationships paths in the source net and compute the reduction" "Petri toConnectedRelationshipsReduction" ^ (self add: (self sourceStructure reductionConnectedRelationships: 2)) renameImage ! toExpandedProblematicTypes "combine types with overlapping image to new localMono Types. Warning: it takes a long time on big nets!! " "Petri singleton toExpandedProblematicTypes" | ns newEmbs | ns := self add: self sourceStructure copyCollection. newEmbs := (OrderedCollection with: ns types any) collect: [:ty | ty embeddings any]. ns newLocalMonoTypesExpandingAll: newEmbs! toReducedColours "reduce the colours of the last reduction by using the ColourRelationships" "Petri toReducedColours" ^ self add: self sourceColouredReduction copyCollection reduceConnectedColours ! toReducedColours1to1 "reduce the colours of the last reduction by using the 1 to 1 relationships" "Petri toReducedColours1to1" ^ self add: self sourceColouredReduction copy reduceConnectedColours1to1 renameImage ! toStructure "Petri toStructure" ^ self add: (NetStructure from: self sourceNet) ! toTypeMembershipClassification "classify the Nodes by type membership. Do not bother if it is not a morphism" "Petri toTypeMembershipClassification" | ns | ns := self sourceStructure. self add: (ns reductionForEquivalence: (ns equivalenceForMembership: ns membershipForTypes) ifFail: [:t | ]; yourself). ! toTypeMembershipReduction "classify the Nodes by type membership. expand problematic types until this yields a morphism" "Petri toTypeMembershipReduction" ^ self add: self sourceStructure reductionForTypeGroupings! ! !Petri privateMethods ! add: anInstance "clear instances" ^ self members add: anInstance. ! ! !Place publicMethods ! isPlace ^true! isTransition ^false! merge: aPlace search: search | myReduction | (search reduce relation is: self equivalent: aPlace) ifTrue: [^ self]. ((myReduction := search reduce at: self) merge: (search reduce at: aPlace)) == myReduction ifTrue: [search reduce relate: self to: aPlace] "keep PlaceReduction and relation in sync!!" ifFalse: [search reduce relate: aPlace to: self]. search toDo add: self! ! !PlaceReduction class publicMethods ! new ^ super new initialize! ! !PlaceReduction publicMethods ! arcsAt: aKey ^ self arcsByKey at: aKey ifAbsentPut: [OrderedCollection new] ! arcsByKey ^ arcsByKey! arcsByKey: anObject arcsByKey := anObject.! initialize self arcsByKey: IdentityDictionary new ; nodesToAdd: OrderedCollection new! keysAndArcsTreeDo: aBlock self arcsByKey keysAndValuesDo: [:key :arcColl | arcColl do: [:arc | aBlock value: key value: arc]]. self nodesToAdd do: [:node | node keysAndArcsTreeDo: aBlock].! merge: aReduction ^ self arcsByKey size >= aReduction arcsByKey size ifTrue: [self nodesToAdd add: aReduction. self] ifFalse: [aReduction nodesToAdd add: self. aReduction] ! mergeArc: anArc at: aKey search: search (self arcsAt: aKey) detect: [:myA | myA transition merge: anArc transition search: search] ifNone: [(self arcsAt: aKey) add: anArc]! mergeArcsSearch: search | list | list := self nodesToAdd. self nodesToAdd: OrderedCollection new. list do: [:aNode | aNode keysAndArcsTreeDo: [:key :arc | self mergeArc: arc at: key search: search]]. ! nodesToAdd ^ nodesToAdd! nodesToAdd: anObject nodesToAdd := anObject.! nodesToAddDo: aBlock aBlock value: self. self nodesToAdd do: [:nd | nd nodesToAddDo: aBlock]! ! !Relationship class publicMethods ! cyclic ^ ##cyclic ! defaultCollectionSpecies ^Set ! from1 ^ ##from1 ! identic ^ ##identic ! newDirection ^self newDirectionCollectionSpecies: self defaultCollectionSpecies ! newDirectionCollectionSpecies: species ^RelationshipDirection newCollectionSpecies: species ! newDual ^self newDualCollectionSpecies: self defaultCollectionSpecies ! newDualCollectionSpecies: species ^RelationshipDual newCollectionSpecies: species ! newTrivialOn: aCollection ^self newDual addTrivialOn: aCollection ! symmetric ^ ##symmetric ! test "Relationship test" | rel | ^ Array with: ((rel := self newDual) relate: 1 to: 'a'; relate: 2 to: 'b'; relate: 22 to: 'b'; analyze) " with: (self reverseOf: rel) " ! to1 ^ ##to1 ! ! !Relationship publicMethods ! addTrivialOn: aCollection "relate the elments from aCollection to itself " aCollection do: [:ele | self relate: ele to: ele] ! analysis ^ analysis! analysis: anObject analysis := anObject.! analyze | is1 isId isSym to1set res | is1 := isId := true. to1set := self newSet. self pairs: Dictionary new. self fromToAllDo: [:from :toAll | toAll size = 1 ifTrue: [to1set add: from] ifFalse: [is1 := false]. (is1 and: [isId and: [from ~= toAll any]]) ifTrue: [isId := false]]. res := OrderedCollection new. is1 ifTrue: [res add: self class to1]. (is1 and: [isId]) ifTrue: [res add: self class identic]. is1 := isSym := true. self fromAllToDo: [:fromAll :to | fromAll size = 1 ifTrue: [(to1set includes: fromAll any) ifTrue: [self pairs at: fromAll any put: to]] ifFalse: [is1 := false]. (isSym and: [(self toAllFrom: to ifAbsent: [#()]) isSameSet: fromAll]) ifFalse: [isSym := false]]. is1 ifTrue: [res add: self class from1]. isSym ifTrue: [res add: self class symmetric]. (is1 and: [(res includes: self class to1) and: [self analyzeCyclic]]) ifTrue: [res add: self class cyclic]. self analysis: res asArray. ! analyzeCyclic | cycle ele coll | cycle := self newSet. ele := self anyTo. [cycle includes: ele] whileFalse: [ cycle add: ele. (coll := self toAllFrom: ele ifAbsent: [^ false ]) size = 1 ifFalse: [^ false]. ele := coll any]. ^cycle size = self toSize! anyFrom self fromToAllDo: [:from :toAll | ^ from]. self error: 'empty'! anyTo self fromAllToDo: [:fromAll :to | ^ to]. self error: 'empty'! composition: aRelationship "answer a new Relationship eqaling the receiver composed with aRelationship" ^ self composition: aRelationship ifFail: [self error: 'fail']! composition: aRelationship do: doBlock ifFail: failBlock "evaluate a doBlock for from toAll pair of the composition of the receiver and the failBlock for every dangling path" | toAll | self fromToAllDo: [:from :middleAll | toAll := OrderedCollection new. middleAll do: [:middle | toAll addAll: (aRelationship toAllFrom: middle ifAbsent: [failBlock value: middle. #()])]. doBlock value: from value: toAll]! composition: aRelationship ifFail: failBlock "answer a copy of the receiver composed with aRelationship" | new | new := self class newDual. self composition: aRelationship do: [:from :toAll | new relate: from toAll: toAll] ifFail: [:middle | ^failBlock value]. ^ new analyze! fromAllTo: to ^ self fromAllTo: to ifAbsent: [self error: 'absent'] ! fromAllTo: to ifAbsent: aBlock ^ self subclassResponsibility! fromAllToDo: aBlock ^ self subclassResponsibility! fromSize self subclassResponsibility! fromTo: to | coll | ^ (coll := self fromAllTo: to) size = 1 ifTrue: [coll any] ifFalse: [self error: 'not unique']! fromToAll | oc | oc := OrderedCollection new. self fromAlltoDo: [:fromAll :to | oc add: to]. ^ oc! fromToAllDo: aBlock ^ self subclassResponsibility! fromToDo: aBlock self fromToAllDo: [:from :toAll | toAll do: [:to | aBlock value: from value: to]]! isCyclic ^ self analysis includes: self class cyclic! isFrom1 ^ self analysis includes: self class from1! isIdentic ^ self analysis includes: self class identic! isSameRelationship: anOther self fromSize = anOther fromSize ifFalse: [^ false]. self toSize = anOther toSize ifFalse: [^ false]. anOther fromToAllDo: [:from :toAll | (toAll isSameSet: (self toAllFrom: from ifAbsent: [^false])) ifFalse: [^ false]]. ^ true! isSymmetric "answer true if receiver is symmetric" ^ self analysis includes: self class symmetric ! isTo1 ^ self analysis includes: self class to1! pairs ^ pairs! pairs: anObject pairs := anObject.! printNames: names on: aStream aStream nextPutAll: (names at: self ifAbsent: [^ self printOn: aStream]) ! printOn: aStream | first | self class printOn: aStream. aStream nextPut: $(. self analysis isNil ifTrue: [aStream nextPut: $?] ifFalse: [ first := true. self analysis do: [:ele | first ifTrue: [first := false] ifFalse: [aStream nextPut: $ ]. aStream nextPutAll: ((String new: ele basicSize) replaceFrom: 1 to: ele basicSize with: ele)]]. aStream nextPut: $). ! relate: from to: to self subclassResponsibility! relate: from toAll: toAll toAll do: [:to | self relate: from to: to]! reverseAnalysis ^ self analysis isNil ifTrue: [nil] ifFalse: [self analysis collect: [:ele | ele = self class to1 ifTrue: [self class from1] ifFalse: [ele = self class from1 ifTrue: [self class to1] ifFalse: [ele]]]]! reverseRelationship | new | new := self class newDual. self fromToDo: [:from :to | new relate: to to: from]. ^ new analysis: self reverseAnalysis ! toAllFrom: to ^ self toAllFrom: to ifAbsent: [self error: 'absent'] ! toAllFrom: to ifAbsent: aBlock ^ self subclassResponsibility! toFrom: from | coll | ^ (coll := self toAllFrom: from) size = 1 ifTrue: [coll any] ifFalse: [self error: 'not unique']! toSize self subclassResponsibility! weight: from to: to ^ (self toAllFrom: from ifAbsent: [^ 0]) occurrencesOf: to ! ! !RelationshipDirection class publicMethods ! new ^ self newCollectionSpecies: Set ! newCollectionSpecies: aSpecies ^ super new relate: Dictionary new; collectionSpecies: aSpecies; yourself! ! !RelationshipDirection publicMethods ! analyzeSplitPairs: newPairs | single image | single := Set new. image := Set new. self fromToAllDo: [:src :toColl | toColl size = 1 ifTrue: [ (newPairs includes: src) ifFalse: [ ((image includes: src) or: [single includes: toColl any]) ifTrue: [^ nil]. single add: src. image add: toColl any]]]. ^ ((single union: image) includesAll: self relate keys) ifTrue: [single] ifFalse: [nil] ! collectionSpecies ^ collectionSpecies! collectionSpecies: anObject collectionSpecies := anObject.! computeSplitPairs: newPairs self split: (self analyzeSplitPairs: newPairs)! fromSize ^ self relate size! fromToAllDo: aBlock ^ self relate keysAndValuesDo: aBlock! relate ^ relate! relate: anObject relate := anObject.! relate: from to: to (self relate at: from ifAbsentPut: [self collectionSpecies new]) add: to! split ^ split! split: anObject split := anObject.! toAllFrom: from ifAbsent: aBlock ^ self relate at: from ifAbsent: aBlock! ! !RelationshipDual class publicMethods ! new ^ super new forward: Dictionary new; reverse: Dictionary new; yourself! ! !RelationshipDual publicMethods ! allAt: anOrigin ifAbsent: aBlock ^self forward at: anOrigin ifAbsent: aBlock! analyse self analyseForward. self isSymmetric ifTrue: [ self isFrom1: self isTo1. self isIdentic ifFalse: [self analyseSidedness]] ifFalse: ["self analyseSidednessPlus." self isFrom1: (self reverse conform: [:oriColl | self assert: [oriColl notEmpty]. oriColl size = 1])]. self basicInverse isNil ifFalse: [self inverseAnalyse] ! analyseForward self isSymmetric: true; isIdentic: (self source == self dest); isTo1: true. self originImagesAllDo: [:ori :imaColl | self assert: [imaColl notEmpty]. imaColl size = 1 ifTrue: [ori = imaColl single ifFalse: [self isIdentic: false]] ifFalse: [self isTo1: false]. self isSymmetric ifTrue: [((self originsAllOf: ori ifAbsent: [#()]) isSameSet: imaColl) ifFalse: [self isSymmetric: false]] ifFalse: [self isTo1 ifFalse: [^ self isIdentic: false]]]. self isIdentic: (self isIdentic and: [self isTo1]). ! analyseSidedness | many | self assert: [self isSymmetric]. many := self newSet. self pairs: Dictionary new; oneSide: self newSet. self originImagesAllDo: [:ori :imaColl | self assert: [imaColl notEmpty]. (imaColl includes: ori) ifTrue: [^ self oneSide: nil; pairs: nil]. imaColl size = 1 ifTrue: [ (self allAt: imaColl single) size = 1 ifTrue: [(self pairs includesKey: imaColl single) ifFalse: [self pairs at: ori put: imaColl single]] " ifFalse: [ symmetry will do it downwards self oneSide add: imaColl single. many add: ori]" ] ifFalse: [ self oneSide add: ori. many addAll: imaColl]]. (self oneSide includesAny: many) ifTrue: [self oneSide: nil; pairs: nil] ifFalse: [self assert: [((self oneSide union: many) union: (self pairs keys union: self pairs values)) isSameSet: self origin]].! analyseSidednessPlus | many int one oneNew two twoNew | one := self newSet. two := self newSet. (int := self origin intersection: self image) isEmpty ifTrue: [^ self]. oneNew := self origin difference: int. twoNew := self image difference: int. [oneNew isEmpty and: [twoNew isEmpty]] whileFalse: [ oneNew do: [:n | (two includes: n) ifTrue: [^ false]. one add: n. twoNew addAll: ((self allAt: n) difference: two)]. oneNew := self newSet. twoNew do: [:n | (one includes: n) ifTrue: [^ false]. two add: n. oneNew addAll: ((self originsAllOf: n) difference: one)]. twoNew := self newSet]. ((one conform: [:ori | (self allAt: ori) size = 1]) or: [two conform: [:ima | (self originsAllOf: ima) size = 1]]) ifFalse: [^ false]. self fail: 'passiert das doch einmal???????????^'. self isTo1: (one conform: [:ori | (self allAt: ori) size = 1]). many := self newSet. self pairs: Dictionary new; oneSide: self newSet. self originImagesAllDo: [:ori :imaColl | self assert: [imaColl notEmpty]. imaColl size = 1 ifTrue: [(self allAt: imaColl single) size = 1 ifTrue: [(self pairs includesKey: imaColl single) ifFalse: [self pairs at: ori put: imaColl single]] ifFalse: [ self oneSide add: imaColl single. many add: ori]] ifFalse: [ self oneSide add: ori. many addAll: imaColl]]. (self oneSide includesAny: many) ifTrue: [self oneSide: nil; pairs: nil] ifFalse: [self assert: [((self oneSide union: many) union: (self pairs keys union: self pairs values)) isSameSet: self origin]].! at: anOrigin ifAbsentPut: aBlock ^(self forward at: anOrigin ifAbsentPut: [OrderedCollection with: aBlock value]) single! basicInverse ^ inverse! composition: aRel ifFail: aBlock "answer as a new relationship composition of the receiver and aMap where they fit together (dont fail for dangling images of the receiver)" | new | new := self speciesNew initialize: self composition: aRel. aRel originImageDo: [:or :im | (self forward at: im ifAbsent: [aBlock value. #()]) do: [:final | new origin: or image: final ifFail: aBlock "should not"]]. ^ new ! compositionJoin: aRel ifFail: aBlock "answer as a new relationship composition of the receiver and aMap where they fit together (dont fail for dangling images of the receiver)" | new | new := self speciesNew initialize: self composition: aRel. aRel originImageDo: [:or :im | (self forward at: im ifAbsent: [#()]) do: [:final | new origin: or image: final ifFail: [self fail: 'should not']]]. ^ new ! copyCollection ^ self copyEmpty forward: self forward copyCollection; reverse: self reverse copyCollection; yourself ! forward ^ forward! forward: anObject forward := anObject.! image ^ self reverse keys! imageSize ^ self reverse size! inverse self basicInverse isNil ifTrue: [self inverseCreate]. ^ self basicInverse! inverse: anObject inverse := anObject.! inverseAnalyse self inverse isTo1: self isFrom1; isFrom1: self isTo1; isSymmetric: self isSymmetric; isIdentic: self isIdentic; pairs: self pairs; oneSide: self oneSide! inverseCreate self inverse: (self speciesNew inverse: self; source: self dest; dest: self source; forward: self reverse; reverse: self forward; yourself). self isAnalysed ifTrue: [self inverseAnalyse].! isAnalysed ^self isFrom1 notNil! isEmpty ^self forward isEmpty! isFrom1 ^ isFrom1! isFrom1: anObject isFrom1 := anObject.! isIdentic ^ isIdentic! isIdentic: anObject isIdentic := anObject.! isSymmetric ^ isSymmetric! isSymmetric: anObject isSymmetric := anObject.! isTo1 ^ isTo1! isTo1: anObject isTo1 := anObject.! oneSide ^ oneSide! oneSide: anObject oneSide := anObject.! origin ^ self forward keys! origin: anOrigin image: anImage ifFail: aBlock "if the receiver does not map anOrigin, map it to anImage otherwise if it is not mapped to anImage execute aBlock" (self forward at: anOrigin ifAbsentPut: [self newSet]) add: anImage. (self reverse at: anImage ifAbsentPut: [self newSet]) add: anOrigin.! originAllImagesDo: aBlock "execute the two argument block aBlock for every origin with all its images" self forward keysAndValuesDo: [:ori :imaColl | imaColl isEmpty ifFalse: [aBlock value: ori value: imaColl]]! originImageDo: aBlock ifFail: fail "execute the two argument block aBlock for every origin image pair" self forward keysAndValuesDo: [:ori :imaColl | imaColl do: [:ima | aBlock value: ori value: ima]]! originImagesAllDo: doBlock ifFail: failBlock "execute the two argument block aBlock for every origin with all its images" self forward keysAndValuesDo: [:ori :imaColl | self assert: [imaColl notEmpty]. doBlock value: ori value: imaColl]! originsAllImageDo: aBlock "execute the two argument block aBlock for every all origins of each image" self reverse keysAndValuesDo: [:ima :oriColl | oriColl isEmpty ifFalse: [aBlock value: oriColl value: ima]]! originsAllOf: anImage ifAbsent: aBlock ^self reverse at: anImage ifAbsent: aBlock! originSize ^ self forward size! pairs ^ pairs! pairs: anObject pairs := anObject.! printAnalysisOn: aStream self isAnalysed ifFalse: [aStream nextPut: '??? '. ^ self]. self isTo1 ifTrue: [aStream nextPutAll: 'to1 ']. self isFrom1 ifTrue: [aStream nextPutAll: 'from1 ']. self isSymmetric ifTrue: [aStream nextPutAll: 'symmetric ']. self isIdentic ifTrue: [aStream nextPutAll: 'identic ']. self oneSide isNil ifTrue: [(self isTo1 or: [self isFrom1 or: [self isSymmetric]]) ifFalse: [aStream nextPutAll: 'general ']] ifFalse: [aStream nextPutAll: 'sided ']. ! printFunctionSuffixOn: aStream aStream printId: self. self isIdentic ifFalse: [ aStream space; nextPut: (self isFrom1 ifTrue: [$1] ifFalse: [$m]); nextPut: $:; nextPut: (self isTo1 ifTrue: [$1] ifFalse: [$n])]! printOn: aStream | curr | super printOn: aStream. self isAnalysed ifTrue: [ curr := aStream current. aStream currentPut: $ . self printAnalysisOn: aStream. aStream currentPut: curr]. ! removeOrigin: anOrigin "remove the mapping from anOrigin from the receiver" (self forward removeKey: anOrigin) do: [:ima | (self reverse at: ima) remove: anOrigin]! reverse ^ reverse! reverse: anObject reverse := anObject.! reverseRelationship ^ self class new forward: self reverse; reverse: self forward; analysis: self reverseAnalysis; yourself! species ^ RelationshipDual! toSize ^ self reverse fromSize! ! !TableMap class publicMethods ! fromGroupings: groupings ^ self new addGroupings: groupings! identityOn: aGraph ^ (self source: aGraph dest: aGraph) addIdentityOfAll: aGraph nodes! new ^ super new table: Dictionary new! ! !TableMap publicMethods ! at: anOrigin ifAbsentPut: aBlock "answer the image of anOrigin if present otherwise aBlock value" | value | ^ self table at: anOrigin ifAbsentPut: [ value := aBlock value. self image: nil. value]! copy "copy of Dictionary reuses Associations, deepCopy copies keys ans values also...." ^ self copyCollection ! copyCollection ^ self copyEmpty table: self table copyCollection; yourself ! image "answer the image set" image isNil ifTrue: [self image: (self dest newSetWithAll: self table values)]. ^ image! image: anObject image := anObject.! origin "answer the origin collection" ^ self table keys! origin: anOrigin image: anImage ifFail: aBlock "if the receiver does not map anOrigin, map it to anImage otherwise if it is not mapped to anImage execute aBlock" anImage == (self at: anOrigin ifAbsentPut: [anImage]) ifFalse: aBlock! originImageDo: aBlock ifFail: fail "execute the two argument block aBlock for every origin image pair" self table keysAndValuesDo: aBlock! removeOrigin: anOrigin "remove the mapping from anOrigin from the receiver" ^self table removeKey: anOrigin! species ^ TableMap! table ^ table! table: anObject table := anObject.! ! !Transition publicMethods ! areaKey ^ (self areaDataByNode values asSortedCollection: [:a :b | (a sequenceLess: b) ~= false]) asArray! isPlace ^false! isTransition ^true! merge: aTrans search: search | maps | (search reduce relation is: self equivalent: aTrans) ifTrue: [^ true]. (search relation is: self equivalent: aTrans) ifFalse: [^ false]. (maps := self mergeMapsTo: aTrans search: search) size = 0 ifTrue: [^ false]. search reduce relate: self to: aTrans. maps do: [:one | one keysAndValuesDo: [:ori :ima |ori merge: ima search: search]]. ^ true! mergeMapsTo: aTrans search: search "answer all valid maps from the receiver to aTrans, as an OrderedCollection of Dictionaries the variations here are local mono: curInt notEmpty weak torsionFree: curInt isSameSet: redInt torsionFree: dito and all images in redInt must match choice: answer only a selectin of the maps" | res map myEmb othEmb redInt fixPoints myNd othNd myRed othRed | res := OrderedCollection new. map := IdentityDictionary new. myEmb := search structure embeddingAtTrans: self. othEmb := search structure embeddingAtTrans: aTrans. self assert: [myEmb source == othEmb source and: [myEmb dest = self graph and: [othEmb dest = self graph and: [aTrans graph = self graph]]]]. redInt := (search reduce atAll: (myEmb image)) intersection: (search reduce atAll: (othEmb image)). myEmb source autos do: [:auto | fixPoints := redInt species new. ((myEmb source nodes conform: [:tyNd | map at: (myNd := myEmb at: (auto at: tyNd)) put: (othNd := othEmb at: tyNd). (myRed := search reduce at: myNd) = (search reduce at: othNd) ifTrue: [fixPoints add: myRed]. search relation is: myNd equivalent: othNd]) and: [fixPoints notEmpty and: [fixPoints = redInt]]) ifTrue: [res add: map copyCollection]]. res isEmpty ifFalse: [res := search mapsFilter value: res]. ^ res "isEmpty ifTrue: [res] ifFalse: [Array with: (res at: (search structure net random nextTo: res size))]"! typeKeyUsing: aPO "answer the receivers representation as typeKey using the partialOrder aPO" ^Array with: (aPO ratingOf: self) with: (self typeKeyUsing: aPO arcs: self pre) with: (self typeKeyUsing: aPO arcs: self post)! typeKeyUsing: aPO arcs: arcCollection "answer the arcs representation as typeKey using the partialOrder aPO" | arr ix | arr := Array new: arcCollection size * 2. ix := 0. (aPO sort: arcCollection) do: [:ar | arr at: (ix := ix + 1) put: ar expression. arr at: (ix := ix + 1) put: (aPO ratingOf: ar place)]. ^arr! ! !TwoWayDictionary class publicMethods ! basicNew: size forward: forClass reverse: revClass ^ self basicNew forward: (forClass new: size); reverse: (revClass new: size)! new ^ self new: 0 forward: Dictionary reverse: Dictionary! new: size ^ self new: size forward: Dictionary reverse: Dictionary! new: size forward: forClass reverse: revClass ^ (self basicNew: size forward: forClass reverse: revClass) initializeReverseToIdentityCollection! new: size forward: forClass reverse: revClass collection: collClass ^ (self basicNew: size forward: forClass reverse: revClass) initializeReverseToClass: collClass! newIdId ^ self new: 0 forward: IdentityDictionary reverse: IdentityDictionary! test "TwoWayDictionary test" | new coll | (new := self new) at: 'eins' put: 1; at: 'zwei' put: 2; at: 'drei' put: 3; at: 'einsB' put: 1; at: 'zweiB' put: 2; at: 'einsC' put: 1. (coll := OrderedCollection with: new with: new printString) add: 'reverse = ',new reverse printString; add: 'at: eins = ', (new at: 'eins') printString; add: 'at: # ifAbsent: = ', (new at: '#' ifAbsent: ['absentBlock']) printString; add: 'keyAtValue: 2 = ', (new keyAtValue: 2) printString; add: 'keyAtValue: 99 ifAbsent: = ', (new keyAtValue: 99 ifAbsent: ['absentBlock']) printString; add: 'allKeysAtValue: 1 = ', (new allKeysAtValue: 1) printString; add: 'allKeysAtValue: 99 = ', (new allKeysAtValue: 99) printString; add: 'allKeysAtValue: 99 ifAbsent: = ', (new allKeysAtValue: 99 ifAbsent: ['absentBlock']) printString; add: 'allKeysByValuesDo: ='. new allKeysByValuesDo: [:keys :value | coll at: coll size put: coll last, ' ', keys printString, ' -> ', value printString]. coll add: 'at: einsB put: 22 = ', (new at: 'einsB' put: 22) printString; add: 'reverse = ', new reverse printString. ^ coll! ! !TwoWayDictionary publicMethods ! allKeysAtValue: aValue "Answer the collection of keys that in the receiver are associated with a value, anEmpty colllection if none" ^ self reverse at: aValue ifAbsent: [#()]! allKeysAtValue: aValue ifAbsent: anExceptionBlock "Answer the collection of keys that in the receiver are associated with a value" ^ self reverse at: aValue ifAbsent: anExceptionBlock! allKeysByValuesDo: aBlock "Answer the collection of keys that in the receiver are associated with a value" self reverse keysAndValuesDo: [:value :keys | aBlock value: keys value: value]! at: aKey ifAbsent: anExceptionBlock "Answer the Object of the receiver that is associated with an Object equivalent to the Object aKey. If an equivalent key is not found answer the result of evaluating the zero argument block, anExceptionBlock. Fail if aKey is not found and anExceptionBlock is not a zero-argument Block." ^ self forward at: aKey ifAbsent: anExceptionBlock! at: aKey ifAbsentPut: aBlock "Answer the element associated with aKey. If the receiver does not contain aKey, add aKey associated with the value of aBlock and return the value of the block." | new | ^self forward at: aKey ifAbsentPut: [self reverseAdd value: self reverse value: (new := aBlock value) value: aKey. new]! at: aKey put: anObject "Answer anObject after associating the argument anObject with the argument Object aKey, in the receiver. If the receiver does not contain a key equivalent to aKey, then create a new entry in the receiver for aKey." self forward at: aKey ifAbsentPut: [anObject] ifPresentPut: [:old |self reverseRemove value: self reverse value: old value: aKey. anObject]. self reverseAdd value: self reverse value: anObject value: aKey. ^ anObject! copy ^ self shallowCopy forward: self forward copy; reverse: self reverse copy ! deepCopy ^ self shallowCopy forward: self forward deepCopy; reverse: self reverse deepCopy ! do: aBlock ^ self forward do: aBlock ! forward ^ forward! forward: anObject forward := anObject.! includes: anObject "Answer a Boolean which is true if anObject is equivalent to one of the receiver's elements and false otherwise." ^self reverse includesKey: anObject! includesKey: aKey "Answer a Boolean which is true if the receiver has a key equivalent to the Object aKey, and false otherwise." ^self forward includesKey: aKey! initializeReverseToBijection self reverseAdd: [:rev :key :val | rev at: key ifAbsentPut: [val] ifPresent: [rev error: 'bijection duplicate']]; reverseRemove: [:rev :key :val | rev removeKey: key ifAbsent: [rev error: 'bijection missing']]! initializeReverseToClass: aClass self reverseAdd: [:rev :key :val | (rev at: key ifAbsentPut: [aClass new]) add: val]; reverseRemove: [:rev :key :val | ((rev at: key ifAbsent: [rev error: 'reverse missing']) remove: val ifAbsent: [rev error: 'missing in reverse']; isEmpty) ifTrue: [rev removeKey: key]] ! initializeReverseToIdentityCollection self reverseAdd: [:rev :key :val | (rev at: key ifAbsentPut: [OrderedCollection new]) add: val]; reverseRemove: [:rev :key :val | | oc index | (index := (oc := rev at: key ifAbsent: [rev error: 'reverse missing']) findFirst: [:ele | ele == val]) == 0 ifTrue: [rev error: 'missing in reverse'] ifFalse: [(oc removeFastAtIndex: index; isEmpty) ifTrue: [rev removeKey: key]]] ! keyAtValue: anObject ifAbsent: anExceptionBlock "Answer the key in the receiver which is associated with a value which is equivalent to the Object anObject. If the receiver does not contain a value equivalent to anObject, answer the result of evaluating the zero argument block, anExceptionBlock. If more than one key is associated with anObject, return any of them. Fail if anObject is not found and anExceptionBlock is not a zero-argument Block." ^ (self reverse at: anObject ifAbsent: [^ anExceptionBlock value]) first! keysAndValuesDo: aBlock self forward keysAndValuesDo: aBlock! keysDo: aBlock ^ self forward keysDo: aBlock ! new: size ^ self shallowCopy forward: (self forward class new: size); reverse: (self reverse class new: size) ! removeKey: aKey ifAbsent: anExceptionBlock "Answer an Object which is the value associated with an Object equivalent to the Object aKey, after removing them from the receiver. If an key equivalent to aKey cannot be found, answer the result of evaluating the zero argument block, anExceptionBlock. Fail if anExceptionBlock is not a zero-argument Block." | value | value := self forward removeKey: aKey ifAbsent: [^anExceptionBlock value]. self reverseRemvove value: self reverse value: value value: aKey. ^ value! reverse ^ reverse! reverse: anObject reverse := anObject.! reverseAdd ^ reverseAdd! reverseAdd: anObject reverseAdd := anObject.! reverseRemove ^ reverseRemove! reverseRemove: anObject reverseRemove := anObject.! size ^ self forward size! species ^ self ! ! !ZwkPetri class publicMethods ! loaded self reset. Petri help. ! removing "The default behavior for the receiver before it is to be removed is to do nothing. Override this method to eliminate any instances of its classes that may exist in known class, pool or global variables. NOTE: #failedRemove will be called if the receiver was unable to be removed." self reset.! reset ZwkExtensions reset. IndexMap reset. Petri reset. EquivalenceClass reset. Smalltalk at: #sortSize put: 0; at: #sortCnt put: 0 ! ! TwoWayDictionary initializeAfterLoad! Net initializeAfterLoad! NetType initializeAfterLoad! ColourSet initializeAfterLoad! ColourWood initializeAfterLoad! EquivalenceClass initializeAfterLoad! EquivalenceMap initializeAfterLoad! EquivalenceRelation initializeAfterLoad! Place initializeAfterLoad! Transition initializeAfterLoad! NetStructure initializeAfterLoad! PartialMap initializeAfterLoad! MapAggregation initializeAfterLoad! RelationshipDual initializeAfterLoad! TableMap initializeAfterLoad! NetReduction initializeAfterLoad! Petri initializeAfterLoad! PlaceReduction initializeAfterLoad! Relationship initializeAfterLoad! RelationshipDirection initializeAfterLoad! ZwkPetri initializeAfterLoad! ZwkPetri loaded!