"{ 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

!

    (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.