--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PEGFsa.st Fri Jul 24 15:37:23 2015 +0100
@@ -0,0 +1,714 @@
+"{ 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 ]
+! !
+