Class {
	#name : 'PEGFsa',
	#superclass : 'Object',
	#instVars : [
		'states',
		'startState',
		'name',
		'distances',
		'priorities'
	],
	#category : 'PetitCompiler-FSA'
}

{ #category : 'instance creation' }
PEGFsa class >> new [
	"return an initialized instance"

	^ self basicNew initialize.
]

{ #category : 'comparing' }
PEGFsa >> = anotherFsa [
	"
		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 ].
	(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
]

{ #category : 'modifications' }
PEGFsa >> addState: state [
	self assert: (states includes: state) not.
	states add: state
]

{ #category : 'modifications' }
PEGFsa >> addTransitionFrom: fromState to: toState [ 
	| transition |
	self assert: (states includes: fromState).
	self assert: (states includes: toState).
	
	transition := PEGFsaEpsilonTransition new 
		destination: toState;
		priority: 0;
		yourself.
		
	fromState addTransition: transition.
]

{ #category : 'modifications' }
PEGFsa >> addTransitionFrom: fromState to: toState on: character [
	self addTransitionFrom: fromState to: toState on: character priority: 0
]

{ #category : 'modifications' }
PEGFsa >> addTransitionFrom: fromState to: toState on: character priority: priority [
	| transition |
	transition := PEGFsaCharacterTransition new 
		addCharacter: character;
		destination: toState;
		priority: priority;
		yourself.
		
	fromState addTransition: transition
]

{ #category : 'modifications' }
PEGFsa >> addTransitionFrom: fromState to: toState onCharacterSet: characterSet [
	self addTransitionFrom: fromState to: toState onCharacterSet: characterSet priority: 0
]

{ #category : 'modifications' }
PEGFsa >> addTransitionFrom: fromState to: toState onCharacterSet: characterSet priority: priority [
	| transition |
	transition := PEGFsaCharacterTransition new 
		characterSet: characterSet;
		destination: toState;
		priority: priority;
		yourself.

	fromState addTransition: transition
]

{ #category : 'modifications' }
PEGFsa >> addTransitionFrom: fromState to: toState onPredicate: block priority: priority [
	| transition |
	transition := PEGFsaPredicateTransition new 
		predicate: block;
		destination: toState;
		priority: priority;
		yourself.
		
	fromState addTransition: transition
]

{ #category : 'modifications' }
PEGFsa >> 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 := PEGFsaEpsilonTransition new 
		destination: toState;
		priority: priority;
		yourself.
		
	fromState addTransition: transition.
]

{ #category : 'modifications' }
PEGFsa >> adopt: fsa [
	states addAll: fsa reachableStates.
]

{ #category : 'accessing' }
PEGFsa >> allTransitions [
	^ self allTransitions: IdentitySet new
]

{ #category : 'accessing' }
PEGFsa >> allTransitions: collection [
	self states do: [ :s | collection addAll: s transitions  ].
	^ collection
]

{ #category : 'printing' }
PEGFsa >> 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.
]

{ #category : 'analysis' }
PEGFsa >> backTransitions [
	|  transitionSet |
	transitionSet := IdentitySet new.
	self computeDistances.
	
	self backTransitionsFrom: startState openSet: IdentitySet new transitionSet: transitionSet.
	^ transitionSet
]

{ #category : 'analysis' }
PEGFsa >> 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
	]
]

{ #category : 'testing' }
PEGFsa >> canHavePPCId [
	^ true
]

{ #category : 'testing' }
PEGFsa >> checkConsistency [
	self assert: (states includes: startState).
	
	states do: [ :s | s transitions do: [ :t |
		self assert: (states includes: t destination).
	] ].
	^ true
]

{ #category : 'testing' }
PEGFsa >> checkFinalStatesPriorities [
	self assert: (self finalStates allSatisfy: #hasPriority)
]

{ #category : 'testing' }
PEGFsa >> checkSanity [
	self checkConsistency.
	self checkTransitionsIdentity.
	self checkTransitionsPriority.
	self checkFinalStatesPriorities.
]

{ #category : 'testing' }
PEGFsa >> checkTransitionsIdentity [
	| bag set |
	bag := IdentityBag new.
	set := IdentitySet new.
	bag := self allTransitions: bag.
	set := self allTransitions: set.	
	
	self assert: bag size == set size.
]

{ #category : 'testing' }
PEGFsa >> checkTransitionsPriority [
	self finalStates do: [ :fs |
		fs isMultivalue ifFalse: [ 
			fs transitions allSatisfy: [ :t | fs priority >= t priority ]
		]
	]
]

{ #category : 'transformations' }
PEGFsa >> compact [
	self error: 'deprecated?'
]

{ #category : 'analysis' }
PEGFsa >> 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
]

{ #category : 'modifications' }
PEGFsa >> decreasePriority [
	^ self decreasePriorityBy: 1
]

{ #category : 'modifications' }
PEGFsa >> decreasePriorityBy: value [
	self states select: [ :s | s hasPriority ] thenDo: [ :s |
		s decreasePriorityBy: value.
	].

	self allTransitions do: [ :t |
		t decreasePriorityBy: value
	]
]

{ #category : 'ids' }
PEGFsa >> defaultName [
	^ #fsa
]

{ #category : 'modifications - determinization' }
PEGFsa >> determinize [
	^ PEGFsaSequenceDeterminizator new determinize: self.

]

{ #category : 'modifications - determinization' }
PEGFsa >> 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.
	

]

{ #category : 'modifications - determinization' }
PEGFsa >> determinizeChoice [
	^ PEGFsaChoiceDeterminizator new determinize: self.

]

{ #category : 'modifications - determinization' }
PEGFsa >> determinizeStandard [
	^ PEGFsaDeterminizator new determinize: self.

]

{ #category : 'analysis' }
PEGFsa >> epsilonDestinationsFrom: state [
	| openSet |
	openSet := IdentitySet new.
	self epsilonDestinationsFrom: state openSet: openSet.
	^ openSet
]

{ #category : 'analysis' }
PEGFsa >> 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
	]
	
]

{ #category : 'modifications' }
PEGFsa >> finalState: state [
	self assert: state isFinal not.
	state final: true.
	state priority: 0.
]

{ #category : 'analysis' }
PEGFsa >> finalStates [
	^ self states select: [ :s | s isFinal ]
]

{ #category : 'modifications' }
PEGFsa >> fixFinalStatePriorities [
	self finalStates do: [ :s |
		s hasPriority ifFalse: [ s priority: 0 ]
	]
]

{ #category : '*PetitCompiler-GUI' }
PEGFsa >> gtGraphViewIn: composite [
	<gtInspectorPresentationOrder: 0>
	composite roassal2
		title: 'Graph'; 
		initializeView: [ RTMondrian new ];
		painting: [ :view |
			self viewGraphOn: view.	
		].
]

{ #category : '*PetitCompiler-GUI' }
PEGFsa >> gtStringViewIn: composite [
	<gtInspectorPresentationOrder: 40>

	composite text
			title: 'Textual Representation';
			display: [ :fsa | fsa asString  ]
]

{ #category : 'analysis' }
PEGFsa >> 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
]

{ #category : 'ids' }
PEGFsa >> hasName [
	^ name isNil not
]

{ #category : 'analysis' }
PEGFsa >> hasNoRetvals [
	^ self finalStates isEmpty


]

{ #category : 'comparing' }
PEGFsa >> hash [
	^ states hash bitXor: (startState hash bitXor: name hash)
]

{ #category : 'initialization' }
PEGFsa >> initialize [
	states := IdentitySet new.
]

{ #category : 'analysis' }
PEGFsa >> is: state furtherThan: anotherState [

	^ (distances at: state) >= (distances at: anotherState)
]

{ #category : 'analysis' }
PEGFsa >> isBackTransition: t [
	^ self backTransitions includes: t
]

{ #category : 'testing' }
PEGFsa >> isDeterministic [
	self reachableStates do: [ :state |
		state transitionPairs do: [ :pair | 
			((pair first intersection: pair second) includes: true) ifTrue: [ 					
				^ false
			] 
		]
	].
	^ true
]

{ #category : 'comparing' }
PEGFsa >> 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 ].
"	

]

{ #category : 'testing' }
PEGFsa >> isReachableState: state [
	^ self reachableStates includes: state
]

{ #category : 'testing' }
PEGFsa >> isStartState: state [
	^ startState == state
]

{ #category : 'testing' }
PEGFsa >> isWithoutEpsilons [
	self reachableStates do: [ :state | 
		state transitions do: [ :t | 
			t isEpsilon ifTrue: [ ^ false ]
		]
	].
	^ true
]

{ #category : 'analysis' }
PEGFsa >> isWithoutPriorities [
	^ self states allSatisfy: [ :s | 
		s hasPriority not or: [ 
			s stateInfos allSatisfy: [ :i | i priority == 0 ]
		] 
	].
]

{ #category : 'transformations' }
PEGFsa >> mergeTransitions [
	|  |
	self reachableStates do: [ :state |
		state mergeTransitions.
	]

]

{ #category : 'modifications' }
PEGFsa >> minimize [
	^ PEGFsaMinimizator new minimize: self
]

{ #category : 'accessing' }
PEGFsa >> name [
	^ name 
]

{ #category : 'accessing' }
PEGFsa >> name: anObject [
	
	name := anObject
]

{ #category : 'analysis' }
PEGFsa >> nonFinalStates [
	^ self states reject: [ :s | s isFinal ]
]

{ #category : 'copying' }
PEGFsa >> postCopy [
	| map |
	super postCopy.
	
	map := IdentityDictionary new.
	states do: [ :s |
		map at: s put: s copy.
	].
	
	states := map values asIdentitySet.
	startState isNil ifFalse: [ 
		startState := map at: startState.
	].
	
	states do: [ :s |
		s transitions do: [:t |
			t destination: (map at: t destination)
		]
	]
]

{ #category : 'ids' }
PEGFsa >> prefix [
	^ 'scan'
]

{ #category : 'analysis' }
PEGFsa >> reachableStates [
	^ self statesReachableFrom: startState
]

{ #category : 'modifications - epsilons' }
PEGFsa >> removeEpsilonTransition: transition source: state [
	^ self removeEpsilonTransition: transition source: state openSet: IdentitySet new
]

{ #category : 'modifications - epsilons' }
PEGFsa >> 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.
]

{ #category : 'modifications - epsilons' }
PEGFsa >> removeEpsilons [
	"First, remove the negative values from epsilons"
	self removeNegativeEpsilons.
	
	states do: [ :state |
		self removeEpsilonsFor: state
	]
]

{ #category : 'modifications - epsilons' }
PEGFsa >> removeEpsilonsFor: state [
	(self transitionsFor: state) copy do: [ :t |
		(t isEpsilon and: [ t destination isStub not ]) ifTrue: [ 
			self removeEpsilonTransition: t source: state
		]
	]
]

{ #category : 'modifications' }
PEGFsa >> removeFinals [
	self finalStates do: [ :s |
		s final: false
	]
]

{ #category : 'transformations' }
PEGFsa >> removeLowPriorityTransitions [
	states do: [ :state |
		self removeLowPriorityTransitionsFor: state
	]
]

{ #category : 'transformations' }
PEGFsa >> removeLowPriorityTransitionsFor: state [
	| transitions |
	state hasPriority ifFalse: [ ^ self ].
	state isFinal ifFalse: [ ^ self ].
	"TODO JK: I can probably cut some transitions from multivalu as well"
	state isMultivalue ifTrue: [ ^ self ].

	transitions := state transitions copy.
	transitions do: [ :t |
		(t priority < state priority) ifTrue: [ 
			state removeTransition: t
		]
	]
]

{ #category : 'modifications - epsilons' }
PEGFsa >> removeNegativeEpsilonTransition: transition source: state [
	^ self removeNegativeEpsilonTransition: transition source: state openSet: IdentitySet new
]

{ #category : 'modifications - epsilons' }
PEGFsa >> 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.

]

{ #category : 'modifications - epsilons' }
PEGFsa >> removeNegativeEpsilons [
	"
		This will remove only negative values from epsilons, the epsilons itself will not
		be removed!
	"
	states do: [ :state |
		self removeNegativeEpsilonsFor: state
	]
]

{ #category : 'modifications - epsilons' }
PEGFsa >> removeNegativeEpsilonsFor: state [
	(self transitionsFor: state) copy do: [ :t |
		t isEpsilon ifTrue: [ 
			self removeNegativeEpsilonTransition: t source: state
		]
	]
]

{ #category : 'modifications' }
PEGFsa >> removePriorities [
	self states select: [ :s| s hasPriority ] thenDo: [ :s |
		s priority: 0
	].

	self allTransitions do: [ :t |
		t priority: 0
	]
]

{ #category : 'modifications' }
PEGFsa >> removeState: state [
	self assert: (states includes: state).
	states remove: state.
]

{ #category : 'transformations' }
PEGFsa >> 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 ]
]

{ #category : 'modifications' }
PEGFsa >> replace: state with: anotherState [
	| transitions  |
	self assert: (state isKindOf: PEGFsaState).
	self assert: (anotherState isKindOf: PEGFsaState).
	
	transitions := self allTransitions.

	transitions do: [ :t |
		(t destination == state) ifTrue: [ 
			t destination: anotherState.
		]
	].

	state == startState ifTrue: [ startState := anotherState ].
	states remove: state.
	states add: anotherState.
]

{ #category : 'modifications' }
PEGFsa >> retval: returnValue [
	self finalStates do: [ :s |
		self assert: s retval isNil.
		s retval: returnValue
	]
]

{ #category : 'accessing' }
PEGFsa >> retvals [
	^ (self finalStates flatCollect: [ :e | e retvals collect: #value ]) asIdentitySet
]

{ #category : 'accessing' }
PEGFsa >> startState [
	self assert: (states includes: startState).
	^ startState
]

{ #category : 'modifications' }
PEGFsa >> startState: state [
	self assert: (states includes: state).
	
	startState := state
]

{ #category : 'accessing' }
PEGFsa >> stateNamed: stateName [
	^ states detect: [ :e | e name = stateName ]
]

{ #category : 'analysis' }
PEGFsa >> statePairs [
	|  pairs ordered |
	pairs := OrderedCollection new.
	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))
 		]
	].

	self assert: (pairs allSatisfy: [ :e | e class == PEGFsaPair ]).
	^ pairs
]

{ #category : 'accessing' }
PEGFsa >> states [
	^ states
]

{ #category : 'accessing' }
PEGFsa >> states: whatever [
	states := whatever
]

{ #category : 'analysis' }
PEGFsa >> statesReachableFrom: state [
	| openSet |
	self assert: state isNil not.
	
	openSet := IdentitySet new.
	self statesReachableFrom: state openSet: openSet.
	^ openSet
]

{ #category : 'analysis' }
PEGFsa >> 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
	]
	

]

{ #category : 'ids' }
PEGFsa >> suffix [
	^ nil
]

{ #category : 'analysis' }
PEGFsa >> topologicalOrder [
	| collection |
	collection := OrderedCollection new.
	
	self statesReachableFrom: startState openSet: collection.
	^ collection
]

{ #category : 'accessing' }
PEGFsa >> transitionFrom: from to: to [
	^ from transitions detect: [ :t | t destination = to ]
]

{ #category : 'accessing' }
PEGFsa >> transitionsFor: state [
	self assert: (states includes: state).
	^ state transitions
]

{ #category : '*PetitCompiler-GUI' }
PEGFsa >> 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
]