Portability fix: override #new for class that implements #initialize
#initialize is not sent by default.
"{ Package: 'stx:goodies/petitparser/compiler' }"
"{ NameSpace: Smalltalk }"
Object subclass:#PEGFsa
instanceVariableNames:'states startState name distances priorities'
classVariableNames:''
poolDictionaries:''
category:'PetitCompiler-FSA'
!
!PEGFsa class methodsFor:'instance creation'!
new
"return an initialized instance"
^ self basicNew initialize.
! !
!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 ]
! !