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

    | priority |

"	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

!

retvals

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

!

states: whatever

    states := whatever

!

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 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 ]

!

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

!

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

!

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: 0>

    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:'ids'!

defaultName

    ^ #fsa

!

hasName

    ^ name isNil not

!

prefix

    ^ nil

!

suffix

    ^ nil

! !

!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 

    | 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 := PEGFsaCharacterTransition 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 := 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).