Kernel-Dag.st 3.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191
  1. Smalltalk createPackage: 'Kernel-Dag'!
  2. Object subclass: #AbstractDagVisitor
  3. instanceVariableNames: ''
  4. package: 'Kernel-Dag'!
  5. !AbstractDagVisitor commentStamp!
  6. I am base class of `DagNode` visitor.
  7. Concrete classes should implement `visitDagNode:`,
  8. they can reuse possible variants of implementation
  9. offered directly: `visitDagNodeVariantSimple:`
  10. and `visitDagNodeVariantRedux:`.!
  11. !AbstractDagVisitor methodsFor: 'evaluating'!
  12. value: anObject
  13. ^ self visit: anObject
  14. ! !
  15. !AbstractDagVisitor methodsFor: 'visiting'!
  16. visit: aNode
  17. ^ aNode acceptDagVisitor: self
  18. !
  19. visitAll: aCollection
  20. ^ aCollection collect: [ :each | self visit: each ]
  21. !
  22. visitAllChildren: aDagNode
  23. ^ self visitAll: aDagNode dagChildren
  24. !
  25. visitDagNode: aNode
  26. self subclassResponsibility
  27. !
  28. visitDagNodeVariantRedux: aNode
  29. "Immutable-guarded implementation of visitDagNode:.
  30. Visits all children and checks if there were changes.
  31. If not, returns aNode.
  32. If yes, returns copy of aNode with new children."
  33. | newChildren oldChildren |
  34. oldChildren := aNode dagChildren.
  35. newChildren := self visitAllChildren: aNode.
  36. oldChildren size = newChildren size ifTrue: [
  37. (1 to: oldChildren size) detect: [ :i |
  38. (oldChildren at: i) ~= (newChildren at: i)
  39. ] ifNone: [ "no change" ^ aNode ] ].
  40. ^ aNode copy dagChildren: newChildren; yourself
  41. !
  42. visitDagNodeVariantSimple: aNode
  43. "Simple implementation of visitDagNode:.
  44. Visits children, then returns aNode"
  45. self visitAllChildren: aNode.
  46. ^ aNode
  47. ! !
  48. AbstractDagVisitor subclass: #PathDagVisitor
  49. instanceVariableNames: 'path'
  50. package: 'Kernel-Dag'!
  51. !PathDagVisitor commentStamp!
  52. I am base class of `DagNode` visitor.
  53. I hold the path of ancestors up to actual node
  54. in `self path`.!
  55. !PathDagVisitor methodsFor: 'accessing'!
  56. path
  57. ^ path
  58. ! !
  59. !PathDagVisitor methodsFor: 'initialization'!
  60. initialize
  61. super initialize.
  62. path := #()
  63. ! !
  64. !PathDagVisitor methodsFor: 'visiting'!
  65. visit: aNode
  66. | oldPath result |
  67. result := aNode.
  68. oldPath := path.
  69. [
  70. path := path, {aNode}.
  71. result := super visit: aNode
  72. ] ensure: [ path := oldPath ].
  73. ^ result
  74. !
  75. visitDagNodeVariantRedux: aNode
  76. | newNode |
  77. newNode := super visitDagNodeVariantRedux: aNode.
  78. aNode == newNode ifFalse: [ path at: path size put: newNode ].
  79. ^ newNode
  80. ! !
  81. Object subclass: #DagNode
  82. instanceVariableNames: ''
  83. package: 'Kernel-Dag'!
  84. !DagNode commentStamp!
  85. I am the abstract root class of any directed acyclic graph.
  86. Concrete classes should implement `dagChildren` and `dagChildren:`
  87. to get / set direct successor nodes (aka child nodes / subnodes).!
  88. !DagNode methodsFor: 'accessing'!
  89. allDagChildren
  90. | allNodes |
  91. allNodes := self dagChildren asSet.
  92. self dagChildren do: [ :each |
  93. allNodes addAll: each allDagChildren ].
  94. ^ allNodes
  95. !
  96. dagChildren
  97. self subclassResponsibility
  98. !
  99. dagChildren: aCollection
  100. self subclassResponsibility
  101. ! !
  102. !DagNode methodsFor: 'testing'!
  103. isDagNode
  104. ^ true
  105. ! !
  106. !DagNode methodsFor: 'visiting'!
  107. acceptDagVisitor: aVisitor
  108. ^ aVisitor visitDagNode: self
  109. ! !
  110. DagNode subclass: #DagParentNode
  111. instanceVariableNames: 'nodes'
  112. package: 'Kernel-Dag'!
  113. !DagParentNode commentStamp!
  114. I am `DagNode` that stores a collection of its children,
  115. lazy initialized to empty array.
  116. I can `addDagChild:` to add a child.!
  117. !DagParentNode methodsFor: 'accessing'!
  118. addDagChild: aDagNode
  119. self dagChildren add: aDagNode
  120. !
  121. dagChildren
  122. ^ nodes ifNil: [ nodes := Array new ]
  123. !
  124. dagChildren: aCollection
  125. nodes := aCollection
  126. ! !
  127. DagNode subclass: #DagSink
  128. instanceVariableNames: 'nodes'
  129. package: 'Kernel-Dag'!
  130. !DagSink commentStamp!
  131. I am `DagNode` with no direct successors.
  132. Sending `dagChildren:` with empty collection is legal.!
  133. !DagSink methodsFor: 'accessing'!
  134. dagChildren
  135. ^ #()
  136. !
  137. dagChildren: aCollection
  138. aCollection ifNotEmpty: [ self error: 'A DagSink cannot have children.' ]
  139. ! !
  140. !Object methodsFor: '*Kernel-Dag'!
  141. isDagNode
  142. ^ false
  143. ! !