hg/stx-goodies-petitparser: comparison compiler/PEGFsa.st

equal deleted inserted replaced

-:e29bd90f388e
+:ff58cd9f1f3c
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+"{ NameSpace: Smalltalk }"
+Object subclass:#PEGFsa
+	instanceVariableNames:'states startState name distances priorities'
+	classVariableNames:''
+	poolDictionaries:''
+	category:'PetitCompiler-FSA'
+!
+!PEGFsa methodsFor:'accessing'!
+allTransitions
+^ self allTransitions: IdentitySet new
+!
+allTransitions: collection
+self states do: [ :s | collection addAll: s transitions  ].
+^ collection
+!
+forwardTransitions
+| backTransitions |
+backTransitions := self backTransitions.
+^ self allTransitions reject: [ :t | backTransitions includes: t ]
+!
+minPriority
+"this is the worst estimate"
+^ (self states size) negated
+!
+name
+^ name
+!
+name: anObject
+name := anObject
+!
+prefix
+^ 'fsa_'
+!
+startState
+^ startState
+!
+stateNamed: name
+^ states detect: [ :e | e name = name ]
+!
+states
+^ states
+!
+suffix
+^ ''
+!
+transitionFrom: from to: to
+^ from transitions detect: [ :t | t destination = to ]
+!
+transitionsFor: state
+self assert: (states includes: state).
+^ state transitions
+! !
+!PEGFsa methodsFor:'analysis'!
+backTransitions
+|  transitionSet |
+transitionSet := IdentitySet new.
+self computeDistances.
+self backTransitionsFrom: startState openSet: IdentitySet new transitionSet: transitionSet.
+^ transitionSet
+!
+backTransitionsFrom: state openSet: openSet transitionSet: transitionSet
+(openSet includes: state) ifTrue: [
+^ self
+].
+openSet add: state.
+state transitions do: [ :t |
+((openSet includes: t destination) and: [self is: state furtherThan: t destination]) ifTrue: [
+transitionSet add: t
+].
+self backTransitionsFrom: t destination openSet: openSet copy transitionSet: transitionSet
+]
+!
+computeDistances
+| queue openSet |
+distances := IdentityDictionary new.
+queue := OrderedCollection with: startState.
+openSet := IdentitySet new.
+distances at: startState put: 0.
+[ queue isEmpty not ] whileTrue: [
+| state |
+state := queue removeFirst.
+openSet add: state.
+state transitions do: [ :t |
+(openSet includes: (t destination)) ifFalse: [
+distances at: (t destination ) put: ((distances at: state) + 1).
+queue addLast: (t destination)
+]
+]
+].
+^ distances
+!
+computePriorities
+| queue openSet |
+self flag: 'not working...'.
+priorities := IdentityDictionary new.
+queue := OrderedCollection with: startState.
+openSet := IdentitySet new.
+priorities at: startState put: (startState priorityIfNone: 0).
+[ queue isEmpty not ] whileTrue: [
+| state |
+state := queue removeFirst.
+openSet add: state.
+state transitions do: [ :t |
+(openSet includes: (t destination)) ifFalse: [
+priorities at: (t destination ) put: ((priorities at: state) + t priority).
+queue addLast: (t destination)
+]
+]
+].
+^ priorities
+!
+epsilonDestinationsFrom: state
+| openSet |
+openSet := IdentitySet new.
+self epsilonDestinationsFrom: state openSet: openSet.
+^ openSet
+!
+epsilonDestinationsFrom: state openSet: openSet
+(openSet includes: state) ifTrue: [
+^ self
+].
+openSet add: state.
+((self transitionsFor: state) select: [ :t | t isEpsilon ]) do: [ :t |
+self epsilonDestinationsFrom: t destination openSet: openSet
+]
+!
+finalStates
+^ self reachableStates select: [ :s | s isFinal ]
+!
+is: state furtherThan: anotherState
+^ (distances at: state) >= (distances at: anotherState)
+!
+isBackTransition: t
+^ self backTransitions includes: t
+!
+joinPoints
+^ self joinTransitions collect: [ :t | t destination ]
+!
+joinTransitions
+| joinTransitions transitions  size |
+joinTransitions := IdentitySet new.
+transitions := self allTransitions asOrderedCollection.
+size := transitions size.
+(1 to: size - 1) do: [ :index1 |
+(index1 + 1 to: size)  do: [ :index2 |
+((transitions at: index1) destination == (transitions at: index2) destination) ifTrue: [
+joinTransitions add: (transitions at: index1).
+joinTransitions add: (transitions at: index2).
+]
+]
+].
+^ joinTransitions
+!
+minimumPriority
+!
+nonFinalStates
+^ self states reject: [ :s | s isFinal ]
+!
+reachableStates
+^ self statesReachableFrom: startState
+!
+statePairs
+|  pairs ordered |
+pairs := OrderedCollection new.
+ordered := self topologicalOrder.
+1 to: (ordered size - 1) do: [ :index1 |
+(index1 + 1) to: ordered size do: [ :index2 |
+pairs add: (PEGFsaPair with: (ordered at: index1) with: (ordered at: index2))
+		]
+].
+self assert: (pairs allSatisfy: [ :e | e class == PEGFsaPair ]).
+^ pairs
+!
+statesReachableFrom: state
+| openSet |
+self assert: state isNil not.
+openSet := IdentitySet new.
+self statesReachableFrom: state openSet: openSet.
+^ openSet
+!
+statesReachableFrom: state openSet: openSet
+(openSet contains: [:e | e == state]) ifTrue: [
+^ self
+].
+openSet add: state.
+(self transitionsFor: state) do: [ :t |
+self statesReachableFrom: t destination openSet: openSet
+]
+!
+topologicalOrder
+| collection |
+collection := OrderedCollection new.
+self statesReachableFrom: startState openSet: collection.
+^ collection
+! !
+!PEGFsa methodsFor:'comparing'!
+= anotherFsa
+"
+Please note what the compare does. IMO nothing useful for no.
+For comparing if two FSA's are equivalent, use isIsomorphicTo:
+"
+(self == anotherFsa)  ifTrue: [ ^ true ].
+(self class == anotherFsa class) ifFalse: [ ^ false ].
+(startState = anotherFsa startState) ifFalse: [ ^ false ].
+(name = anotherFsa name) ifFalse: [ ^ false ].
+(states size = anotherFsa states size) ifFalse: [ ^ false ].
+states do: [:s |
+(anotherFsa states contains: [ :e | e = s ]) ifFalse: [ ^ false ].
+].
+^ true
+!
+hash
+^ states hash bitXor: (startState bitXor: name)
+!
+isIsomorphicTo: anotherFsa
+| topologicalOrder anotherTopologicalOrder  |
+"
+Please not that this version of comparison is sensitive to the order
+in which the transitions in state are ordered.
+"
+topologicalOrder := self topologicalOrder.
+anotherTopologicalOrder := anotherFsa topologicalOrder.
+topologicalOrder size == anotherTopologicalOrder size ifFalse: [ ^ false ].
+topologicalOrder with: anotherTopologicalOrder do: [ :s1 :s2 |
+(s1 canBeIsomorphicTo: s2) ifFalse: [ ^ false ]
+].
+^ true
+"
+transitions := topologicalOrder flatCollect: [ :s | s transitions ].
+anotherTransitions := anotherTopologicalOrder flatCollect: [ :s | s transitions ].
+"
+! !
+!PEGFsa methodsFor:'copying'!
+postCopy
+| map |
+super postCopy.
+map := IdentityDictionary new.
+states do: [ :s |
+map at: s put: s copy.
+].
+states := map values asIdentitySet.
+startState := map at: startState.
+states do: [ :s |
+s transitions do: [:t |
+t destination: (map at: t destination)
+]
+]
+! !
+!PEGFsa methodsFor:'gt'!
+gtGraphViewIn: composite
+<gtInspectorPresentationOrder: 41>
+composite roassal2
+title: 'Graph';
+initializeView: [ RTMondrian new ];
+painting: [ :view |
+self viewGraphOn: view.
+].
+!
+gtStringViewIn: composite
+<gtInspectorPresentationOrder: 40>
+composite text
+title: 'Textual Representation';
+display: [ :fsa | fsa asString  ]
+!
+viewGraphOn: b
+b shape circle size: 50.
+b shape color: Color gray muchLighter muchLighter.
+b shape withText: #gtName.
+b nodes: (self nonFinalStates).
+b shape circle size: 50.
+b shape color: Color gray muchLighter.
+b shape withText: #gtName.
+b nodes: (self finalStates).
+b shape arrowedLine.
+b edges
+connectToAll: [ :state |
+state transitions 	select: [:t | (self isBackTransition:t)  not]
+thenCollect: #destination ]
+labelled: [ :t | (self transitionFrom: t key to: t value) gtName  ].
+b shape arrowedLine.
+b shape color: Color red.
+b edges
+connectToAll: [ :state |
+state transitions 	select: [:t | (self isBackTransition: t) ]
+thenCollect: #destination ]
+labelled: [ :t | (self transitionFrom: t key to: t value) gtName  ].
+b layout horizontalTree  .
+b layout layout horizontalGap: 30.
+^ b
+! !
+!PEGFsa methodsFor:'initialization'!
+initialize
+states := IdentitySet new.
+! !
+!PEGFsa methodsFor:'modifications'!
+addState: state
+self assert: (states includes: state) not.
+states add: state
+!
+addTransitionFrom: fromState to: toState
+^ self addTransitionFrom: fromState to: toState priority: 0
+!
+addTransitionFrom: fromState to: toState on: character
+self addTransitionFrom: fromState to: toState on: character priority: 0
+!
+addTransitionFrom: fromState to: toState on: character priority: priority
+| transition |
+transition := PEGFsaTransition new
+addCharacter: character;
+destination: toState;
+priority: priority;
+yourself.
+fromState addTransition: transition
+!
+addTransitionFrom: fromState to: toState onCharacterSet: characterSet
+self addTransitionFrom: fromState to: toState onCharacterSet: characterSet priority: 0
+!
+addTransitionFrom: fromState to: toState onCharacterSet: characterSet priority: priority
+| transition |
+transition := PEGFsaTransition new
+characterSet: characterSet;
+destination: toState;
+priority: priority;
+yourself.
+fromState addTransition: transition
+!
+addTransitionFrom: fromState to: toState priority: priority
+| transition |
+self assert: (states includes: fromState).
+self assert: (states includes: toState).
+transition := PEGFsaTransition new
+destination: toState;
+priority: priority;
+yourself.
+fromState addTransition: transition.
+!
+adopt: fsa
+states addAll: fsa reachableStates.
+!
+finalState: state
+self assert: state isFinal not.
+state final: true.
+!
+fixFinalStatePriorities
+self finalStates do: [ :s |
+s hasPriority ifFalse: [ s priority: 0 ]
+]
+!
+removeState: state
+self assert: (states includes: state).
+states remove: state.
+!
+replace: state with: anotherState
+| transitions  |
+self assert: (state class == PEGFsaState).
+self assert: (anotherState class == PEGFsaState).
+transitions := self allTransitions.
+transitions do: [ :t |
+(t destination == state) ifTrue: [
+t destination: anotherState.
+]
+].
+states := startState reachableStates.
+!
+startState: state
+self assert: (states includes: state).
+startState := state
+! !
+!PEGFsa methodsFor:'printing'!
+asString
+| stream  |
+stream := WriteStream on: ''.
+self topologicalOrder do: [ :state |
+state printOn: stream.
+stream nextPutAll: '> '.
+(self transitionsFor: state) do: [ :transition |
+stream nextPut: (Character codePoint: 13).
+stream nextPut: (Character codePoint: 9).
+transition printOn: stream.
+].
+stream nextPut: (Character codePoint: 13).
+].
+"	stream nextPutAll: 'finals: '.
+(states select: [:s | s isFinal ]) do: [:e | e printOn: stream ].
+stream nextPut: (Character codePoint: 13).
+"
+^ stream contents.
+! !
+!PEGFsa methodsFor:'testing'!
+canHavePPCId
+^ true
+!
+checkConsistency
+self assert: (states includes: startState).
+states do: [ :s | s transitions do: [ :t |
+self assert: (states includes: t destination).
+] ].
+^ true
+!
+checkFinalStatesPriorities
+self assert: (self finalStates allSatisfy: #hasPriority)
+!
+checkSanity
+self checkConsistency.
+self checkTransitionsIdentity.
+self checkFinalStatesPriorities.
+!
+checkTransitionsIdentity
+| bag set |
+bag := IdentityBag new.
+set := IdentitySet new.
+bag := self allTransitions: bag.
+set := self allTransitions: set.
+self assert: bag size == set size.
+!
+isDeterministic
+self reachableStates do: [ :state |
+state transitionPairs do: [ :pair |
+((pair first intersection: pair second) includes: true) ifTrue: [
+^ false
+]
+]
+].
+^ true
+!
+isReachableState: state
+^ self reachableStates includes: state
+!
+isStartState: state
+^ startState == state
+!
+isWithoutEpsilons
+self reachableStates do: [ :state |
+state transitions do: [ :t |
+t isEpsilon ifTrue: [ ^ false ]
+]
+].
+^ true
+! !
+!PEGFsa methodsFor:'transformations'!
+compact
+self fixFinalStatePriorities.
+self determinize.
+self minimize.
+self checkSanity.
+!
+determinize
+| joinDictionary |
+self removeEpsilons.
+self removeUnreachableStates.
+self removeLowPriorityTransitions.
+self mergeTransitions.
+joinDictionary := Dictionary new.
+self topologicalOrder do: [:state | state determinize: joinDictionary ].
+states	 := startState reachableStates.
+self removeUnreachableStates.
+self removeLowPriorityTransitions.
+self mergeTransitions.
+!
+mergeTransitions
+| toRemove |
+self reachableStates do: [ :state |
+toRemove := OrderedCollection new.
+state transitionPairs do:[ :pair |
+(pair first destination = pair second destination) ifTrue: [
+pair first mergeWith: pair second.
+toRemove add: pair second.
+]
+].
+toRemove do: [ :t |
+state removeTransition: t
+]
+]
+!
+minimize
+| pair |
+pair := self statePairs detect:  [ :p | p first equals: p second ] ifNone: [ nil ].
+[ pair isNil not ] whileTrue: [
+"Join priorities, because equivalency of priorities does not imply from the equeality of states"
+pair first joinPriority: pair second newState: pair first.
+pair first joinName: pair second newState: pair first.
+self replace: pair second with: pair first.
+self mergeTransitions.
+pair := self statePairs detect:  [ :p | p first equals: p second ] ifNone: [ nil ].
+	].
+!
+removeEpsilonTransition: transition source: state
+^ self removeEpsilonTransition: transition source: state openSet: IdentitySet new
+!
+removeEpsilonTransition: transition source: source openSet: openSet
+| destination |
+(openSet includes: transition) ifTrue: [ self error: 'loop in epsilons?!!' ].
+openSet add: transition.
+destination := transition destination.
+"First Remove Recursively"
+((self transitionsFor: destination ) select: [ :t | t isEpsilon  ]) do: [ :t |
+self removeEpsilonTransition: t source: destination openSet: openSet
+].
+(transition priority abs) timesRepeat: [
+(self statesReachableFrom: destination) do: [ :s |
+s decreasePriority.
+s transitions do: [ :t | t decreasePriority  ]
+]
+].
+(destination transitions) do: [ :t |
+source addTransition: (t copy)
+].
+destination hasPriority ifTrue: [
+source hasPriority ifTrue: [
+"self assert: source priority == destination priority"
+self flag: 'I am not 100% sure about this case'
+].
+source priority: destination priority
+].
+destination isFinal ifTrue: [
+source final: true.
+source retval: destination retval.
+].
+source removeTransition: transition.
+!
+removeEpsilons
+states do: [ :state |
+self removeEpsilonsFor: state
+]
+!
+removeEpsilonsFor: state
+(self transitionsFor: state) copy do: [ :t |
+t isEpsilon ifTrue: [
+self removeEpsilonTransition: t source: state
+]
+]
+!
+removeLowPriorityTransitions
+states do: [ :state |
+self removeLowPriorityTransitionsFor: state
+]
+!
+removeLowPriorityTransitionsFor: state
+state hasPriority ifFalse: [ ^ self ].
+state isFinal ifFalse: [ ^ self ].
+state transitions do: [ :t |
+(t priority < state priority) ifTrue: [
+state removeTransition: t
+]
+]
+!
+removeUnreachableStates
+| reachable toRemove |
+reachable := self reachableStates.
+toRemove := OrderedCollection new.
+states do: [ :s |
+(reachable includes: s) ifFalse: [
+toRemove add: s
+]
+].
+toRemove do: [ :s | states remove: s ]
+! !

changeset 503	ff58cd9f1f3c
parent 502	1e45d3c96ec5
child 504	0fb1f0799fc1