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

equal deleted inserted replaced

-:1e45d3c96ec5
+:b5316ef15274
 	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
 !
 backTransitions := self backTransitions.
 ^ self allTransitions reject: [ :t | backTransitions includes: t ]
 !
 minPriority
-"this is the worst estimate"
+| priority |
-^ (self states size) negated
+"	defaultPriority := self states size negated.
+self finalStates isEmpty ifTrue: [ ^ defaultPriority ].
+^ (self finalStates collect: [ :e | e priorityIfNone: defaultPriority  ]) min
+"
+priority := -1.
+self allTransitions do: [ :t | t isEpsilon ifTrue: [ priority := priority + t priority ] ].
+^ priority
 !
 name
 ^ name
 !
 name: anObject
 name := anObject
 !
-prefix
+retvals
-^ 'fsa_'
+^ (self finalStates flatCollect: [ :e | e retvals collect: #value ]) asIdentitySet
 !
 startState
+self assert: (states includes: startState).
 ^ startState
 !
 stateNamed: name
 ^ states detect: [ :e | e name = name ]
 states
 ^ states
 !
-suffix
+states: whatever
-^ ''
+states := whatever
 !
 transitionFrom: from to: to
 ^ from transitions detect: [ :t | t destination = to ]
 !
 ]
 !
 finalStates
-^ self reachableStates select: [ :s | s isFinal ]
+^ self states select: [ :s | s isFinal ]
+!
+hasDistinctRetvals
+| finalStates retvals |
+finalStates := self finalStates.
+(finalStates anySatisfy: [ :s | s isMultivalue  ]) ifTrue: [ ^ false ].
+retvals := finalStates collect: [:s | s retval].
+(finalStates size == 1) ifTrue: [ ^ true ].
+(retvals asSet size == 1) ifTrue: [ ^ true ].
+"final states leads only to final states with the same retval"
+(finalStates allSatisfy: [ :s |
+(self statesReachableFrom: s) allSatisfy: [ :rs | rs retval value isNil or: [ rs retval value == s retval value ] ]
+]) ifTrue: [ ^ true ].
+^ false
 !
 is: state furtherThan: anotherState
 ^ (distances at: state) >= (distances at: anotherState)
 !
 isBackTransition: t
 ^ self backTransitions includes: t
+!
+isWithoutPriorities
+^ self states allSatisfy: [ :s |
+s hasPriority not or: [
+s stateInfos allSatisfy: [ :i | i priority == 0 ]
+]
+].
 !
 joinPoints
 ^ self joinTransitions collect: [ :t | t destination ]
 !
 !
 statePairs
 |  pairs ordered |
 pairs := OrderedCollection new.
-ordered := self topologicalOrder.
+ordered := self states asOrderedCollection.
 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))
 		]
 ].
 !PEGFsa methodsFor:'comparing'!
 = anotherFsa
 "
-Please note what the compare does. IMO nothing useful for no.
+Please note what the compare does. IMO nothing useful for now.
 For comparing if two FSA's are equivalent, use isIsomorphicTo:
 "
 (self == anotherFsa)  ifTrue: [ ^ true ].
 ! !
 !PEGFsa methodsFor:'gt'!
 gtGraphViewIn: composite
-<gtInspectorPresentationOrder: 41>
+<gtInspectorPresentationOrder: 0>
 composite roassal2
 title: 'Graph';
 initializeView: [ RTMondrian new ];
 painting: [ :view |
 self viewGraphOn: view.
 b layout layout horizontalGap: 30.
 ^ b
 ! !
+!PEGFsa methodsFor:'ids'!
+defaultName
+^ #fsa
+!
+hasName
+^ name isNil not
+!
+prefix
+^ nil
+!
+suffix
+^ nil
+! !
 !PEGFsa methodsFor:'initialization'!
 initialize
 states := IdentitySet new.
 ! !
 self assert: (states includes: state) not.
 states add: state
 !
 addTransitionFrom: fromState to: toState
-^ self addTransitionFrom: fromState to: toState priority: 0
+| transition |
+self assert: (states includes: fromState).
+self assert: (states includes: toState).
+transition := PEGFsaEpsilonTransition new
+destination: toState;
+priority: 0;
+yourself.
+fromState addTransition: transition.
 !
 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
+transition := PEGFsaCharacterTransition new
 addCharacter: character;
 destination: toState;
 priority: priority;
 yourself.
 self addTransitionFrom: fromState to: toState onCharacterSet: characterSet priority: 0
 !
 addTransitionFrom: fromState to: toState onCharacterSet: characterSet priority: priority
 | transition |
-transition := PEGFsaTransition new
+transition := PEGFsaCharacterTransition new
 characterSet: characterSet;
 destination: toState;
 priority: priority;
 yourself.
 fromState addTransition: transition
 !
+addTransitionFrom: fromState to: toState onPredicate: block
+self addTransitionFrom: fromState to: toState onPredicate: block priority: 0
+!
+addTransitionFrom: fromState to: toState onPredicate: block priority: priority
+| transition |
+transition := PEGFsaPredicateTransition new
+predicate: block;
+destination: toState;
+priority: priority;
+yourself.
+fromState addTransition: transition
+!
 addTransitionFrom: fromState to: toState priority: priority
 | transition |
+"should not use minus priority epsilons any more"
+self assert: (priority == 0).
 self assert: (states includes: fromState).
 self assert: (states includes: toState).
-transition := PEGFsaTransition new
+transition := PEGFsaEpsilonTransition new
 destination: toState;
 priority: priority;
 yourself.
 fromState addTransition: transition.
 adopt: fsa
 states addAll: fsa reachableStates.
 !
+decreasePriority
+^ self decreasePriorityBy: 1
+!
+decreasePriorityBy: value
+self states select: [ :s | s hasPriority ] thenDo: [ :s |
+s decreasePriorityBy: value.
+].
+self allTransitions do: [ :t |
+t decreasePriorityBy: value
+]
+!
 finalState: state
 self assert: state isFinal not.
 state final: true.
+state priority: 0.
 !
 fixFinalStatePriorities
 self finalStates do: [ :s |
 s hasPriority ifFalse: [ s priority: 0 ]
 ]
 !
+minimize
+^ PEGFsaMinimizator new minimize: self
+!
+removePriorities
+self states select: [ :s| s hasPriority ] thenDo: [ :s |
+s priority: 0
+].
+self allTransitions do: [ :t |
+t priority: 0
+]
+!
 removeState: state
 self assert: (states includes: state).
 states remove: state.
 !
 replace: state with: anotherState
 | transitions  |
-self assert: (state class == PEGFsaState).
+self assert: (state isKindOf: PEGFsaState).
-self assert: (anotherState class == PEGFsaState).
+self assert: (anotherState isKindOf: PEGFsaState).
 transitions := self allTransitions.
 transitions do: [ :t |
 (t destination == state) ifTrue: [
 t destination: anotherState.
 ]
 ].
-states := startState reachableStates.
+state == startState ifTrue: [ startState := anotherState ].
+states remove: state.
+states add: anotherState.
+!
+retval: returnValue
+self finalStates do: [ :s |
+self assert: s retval isNil.
+s retval: returnValue
+]
 !
 startState: state
 self assert: (states includes: state).
 startState := state
+! !
+!PEGFsa methodsFor:'modifications - determinization'!
+determinize
+^ PEGFsaSequenceDeterminizator new determinize: self.
+!
+determinize: joinDictionary
+self error: 'deprecated'.
+self removeEpsilons.
+self removeUnreachableStates.
+self removeLowPriorityTransitions.
+self mergeTransitions.
+states := self topologicalOrder asOrderedCollection.
+states do: [ :state |
+state determinize: joinDictionary.
+].
+states	 := startState reachableStates.
+self removeUnreachableStates.
+self removeLowPriorityTransitions.
+self mergeTransitions.
+!
+determinizeChoice
+^ PEGFsaChoiceDeterminizator new determinize: self.
+!
+determinizeStandard
+^ PEGFsaDeterminizator new determinize: self.
+! !
+!PEGFsa methodsFor:'modifications - epsilons'!
+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
+].
+self assert: transition isEpsilon.
+self assert: transition priority = 0.
+(destination transitions) do: [ :t |
+source addTransition: (t copy)
+].
+source mergeInfo: destination into: source.
+destination isFinal ifTrue: [
+source final: true.
+source retval: destination retval.
+].
+source removeTransition: transition.
+!
+removeEpsilons
+"First, remove the negative values from epsilons"
+self removeNegativeEpsilons.
+states do: [ :state |
+self removeEpsilonsFor: state
+]
+!
+removeEpsilonsFor: state
+(self transitionsFor: state) copy do: [ :t |
+(t isEpsilon and: [ t destination isStub not ]) ifTrue: [
+self removeEpsilonTransition: t source: state
+]
+]
+!
+removeNegativeEpsilonTransition: transition source: state
+^ self removeNegativeEpsilonTransition: transition source: state openSet: IdentitySet new
+!
+removeNegativeEpsilonTransition: 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 removeNegativeEpsilonTransition: t source: destination openSet: openSet
+].
+"JK: Problem alert: if two different epsilons point to the same state,
+it will decreas the state priority two times!! I don't know how to handle
+this situation properly and I make sure during FSA generation that there
+are no two paths to one state (except for loops).
+"
+(self statesReachableFrom: destination) do: [ :s |
+s decreasePriorityBy: transition priority abs.
+s transitions do: [ :t | t decreasePriorityBy: transition priority abs  ]
+].
+transition priority: 0.
+!
+removeNegativeEpsilons
+"
+This will remove only negative values from epsilons, the epsilons itself will not
+be removed!!
+"
+states do: [ :state |
+self removeNegativeEpsilonsFor: state
+]
+!
+removeNegativeEpsilonsFor: state
+(self transitionsFor: state) copy do: [ :t |
+t isEpsilon ifTrue: [
+self removeNegativeEpsilonTransition: t source: state
+]
+]
 ! !
 !PEGFsa methodsFor:'printing'!
 asString
 !
 checkSanity
 self checkConsistency.
 self checkTransitionsIdentity.
+self checkTransitionsPriority.
 self checkFinalStatesPriorities.
 !
 checkTransitionsIdentity
 | bag set |
 set := self allTransitions: set.
 self assert: bag size == set size.
 !
+checkTransitionsPriority
+self finalStates do: [ :fs |
+fs isMultivalue ifFalse: [
+fs transitions allSatisfy: [ :t | fs priority >= t priority ]
+]
+]
+!
 isDeterministic
 self reachableStates do: [ :state |
 state transitionPairs do: [ :pair |
 ((pair first intersection: pair second) includes: true) ifTrue: [
 ^ false
 ! !
 !PEGFsa methodsFor:'transformations'!
 compact
-self fixFinalStatePriorities.
+self error: 'deprecated?'
-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 mergeTransitions.
-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
+| transitions |
 state hasPriority ifFalse: [ ^ self ].
 state isFinal ifFalse: [ ^ self ].
+"TODO JK: I can probably cut some transitions from multivalu as well"
-state transitions do: [ :t |
+state isMultivalue ifTrue: [ ^ self ].
+transitions := state transitions copy.
+transitions do: [ :t |
 (t priority < state priority) ifTrue: [
 state removeTransition: t
 ]
 ]
 !

changeset 515	b5316ef15274
parent 502	1e45d3c96ec5
child 516	3b81c9e53352
child 524	f6f68d32de73