Skip to content

Instantly share code, notes, and snippets.

@iriyak

iriyak/KILearningMOOC.st

Last active June 29, 2025 09:08
Show Gist options
  • Save iriyak/45cb37c810a169d9d37bd0fc0873404f to your computer and use it in GitHub Desktop.
Save iriyak/45cb37c810a169d9d37bd0fc0873404f to your computer and use it in GitHub Desktop.
Download ZIP
Raw
KILearningMOOC.st
Object subclass: #ClassCollectionThatMightApplyReification
instanceVariableNames: 'classMethodsEndingWithClass instanceMethodsEndingWithClass'
classVariableNames: ''
package: 'KILearningMOOC'!
!ClassCollectionThatMightApplyReification commentStamp: '<historical>' prior: 0!
I hold a class collection that I guess applies Reification pattern based on the use of a method selector that ends with "Class".
This is part of my learning note of [1.6] Reification and delegation - Advanced Object-Oriented Design MOOC.
Ref. https://www.youtube.com/watch?v=eVxnBjySbx8&list=PL2okA_2qDJ-k9qaQomNEoAo_sA2LsE2Y3&index=8!
!ClassCollectionThatMightApplyReification methodsFor: 'gt - views' stamp: 'GlamorousAuthor 6/29/2025 13:05'!
gtInstanceMethodsViewFor: aView
<gtView>
^ aView forward
title: 'InstanceMethods';
priority: 50;
object: [ self instanceMethodsEndingWithClass ];
view: #gtItemsFor:! !
!ClassCollectionThatMightApplyReification methodsFor: 'gt - views' stamp: 'GlamorousAuthor 6/29/2025 13:05'!
gtClassMethodsViewFor: aView
<gtView>
^ aView forward
title: 'ClassMethods';
priority: 45;
object: [ self classMethodsEndingWithClass ];
view: #gtItemsFor:! !
!ClassCollectionThatMightApplyReification methodsFor: 'gt - views' stamp: 'GlamorousAuthor 6/29/2025 17:50'!
gtOccurrencesOfClassMethodsViewFor: aView
<gtView>
^ aView forward
title: 'Occurrences (ClassMethods)';
priority: 45;
object: [ self classMethodsEndingWithClass ];
view: #gtOccurrencesFor:! !
!ClassCollectionThatMightApplyReification methodsFor: 'gt - views' stamp: 'GlamorousAuthor 6/29/2025 17:58'!
gtOccurrencesOfInstanceMethodsViewFor: aView
<gtView>
^ aView forward
title: 'Occurrences (InstanceMethods)';
priority: 55;
object: [ self instanceMethodsEndingWithClass ];
view: #gtOccurrencesFor:! !
!ClassCollectionThatMightApplyReification methodsFor: 'accessing' stamp: 'GlamorousAuthor 6/29/2025 13:04'!
instanceMethodsEndingWithClass
^ instanceMethodsEndingWithClass! !
!ClassCollectionThatMightApplyReification methodsFor: 'accessing' stamp: 'GlamorousAuthor 6/29/2025 13:04'!
classMethodsEndingWithClass
^ classMethodsEndingWithClass! !
!ClassCollectionThatMightApplyReification methodsFor: 'initalization' stamp: 'GlamorousAuthor 6/29/2025 14:55'!
initialize
super initialize.
classMethodsEndingWithClass := ClassMethodCollection endsWith: 'Class'.
instanceMethodsEndingWithClass := InstanceMethodCollection endsWith: 'Class'! !
Object subclass: #ClassMethodCollection
instanceVariableNames: 'elements selectors'
classVariableNames: ''
package: 'KILearningMOOC'!
!ClassMethodCollection methodsFor: 'initialization' stamp: 'GlamorousAuthor 6/29/2025 15:11'!
with: aSelector
elements := Smalltalk allClasses
flatCollect: [ :class | class class methodDict select: [ :method | method selector = aSelector ] ].
selectors := (elements collect: [ :method | method selector ]) asBag! !
!ClassMethodCollection methodsFor: 'initialization' stamp: 'GlamorousAuthor 6/29/2025 15:12'!
endsWith: aString
elements := Smalltalk allClasses
flatCollect: [ :class |
class class methodDict
select: [ :method | method selector asString endsWith: aString ] ].
selectors := (elements collect: [ :method | method selector ]) asBag! !
!ClassMethodCollection methodsFor: 'ui - building' stamp: 'GlamorousAuthor 6/29/2025 17:45'!
treeGraphOfClassMethodsFor: aSelector
| classes |
classes := self enumerateClassesthatImplement: aSelector from: elements.
^ self treeGraphFor: aSelector with: classes! !
!ClassMethodCollection methodsFor: 'ui - building' stamp: 'GlamorousAuthor 6/29/2025 17:45'!
treeGraphFor: aSelector with: classes
| mondrian stencilForNodes stencilForEdges superClasses |
mondrian := GtMondrian new.
stencilForNodes := self buildStencilForNodesFor: aSelector with: classes.
stencilForEdges := [ BlLineElement new
border: Color veryLightGray;
fromHead: (BlArrowheadSimpleArrow new border: Color veryLightGray);
zIndex: -1 ].
superClasses := classes flatCollect: [ :class | class allSuperclasses ].
mondrian nodes
stencil: stencilForNodes;
with: classes , superClasses.
mondrian edges
stencil: stencilForEdges;
connectToAll: #subclasses.
mondrian layout horizontalTree.
^ mondrian! !
!ClassMethodCollection methodsFor: 'ui - building' stamp: 'GlamorousAuthor 6/29/2025 17:46'!
buildStencilForNodesFor: aSelector with: classes
| superClasses |
superClasses := classes flatCollect: [ :class | class allSuperclasses ].
^ [ :class |
| element |
element := BrLabel new
text: class name;
background: Color lightOrange;
aptitude: BrGlamorousLabelAptitude new;
border: (BlBorder paint: Color veryLightGray);
when: BlClickEvent
do: [ :anEvent |
| compiledMethod |
anEvent consumed: true.
((superClasses includes: class) and: [ (classes includes: class) not ])
ifFalse: [ compiledMethod := class perform: #'>>' with: aSelector.
anEvent currentTarget phlow spawnObject: compiledMethod ] ];
when: BlMouseEnterEvent
do: [ :anEvent |
| graph |
graph := anEvent currentTarget graph.
graph connectedEdges
do: [ :inner | inner element border: (BlBorder paint: Color blue) ].
graph element border: (BlBorder paint: Color blue) ];
when: BlMouseLeaveEvent
do: [ :anEvent |
| graph |
graph := anEvent currentTarget graph.
graph connectedEdges
do: [ :inner | inner element border: (BlBorder paint: Color veryLightGray) ].
graph element border: (BlBorder paint: Color veryLightGray) ].
((superClasses includes: class) and: [ (classes includes: class) not ])
ifTrue: [ element background: Color lightYellow ].
element ]! !
!ClassMethodCollection methodsFor: 'accessing' stamp: 'GlamorousAuthor 6/29/2025 15:12'!
elements
^ elements! !
!ClassMethodCollection methodsFor: 'accessing' stamp: 'GlamorousAuthor 6/29/2025 15:13'!
selectors
^ selectors! !
!ClassMethodCollection methodsFor: 'acccessing' stamp: 'GlamorousAuthor 6/29/2025 17:46'!
enumerateClassesthatImplement: aSelector from: classes
^ (classes
select: [ :method | method selector = aSelector ]
thenCollect: [ :method | method methodClass ]) asSet! !
!ClassMethodCollection methodsFor: 'gt - views' stamp: 'GlamorousAuthor 6/29/2025 17:40'!
gtOccurrencesFor: aView
<gtView>
^ aView forward
title: 'Occurrences';
priority: 55;
object: [ self selectors ];
view: #gtOccurrencesFor:;
send: [ :assoc | self treeGraphOfClassMethodsFor: assoc value ]! !
!ClassMethodCollection methodsFor: 'gt - views' stamp: 'GlamorousAuthor 6/29/2025 14:38'!
gtItemsFor: aView
<gtView>
^ aView forward
title: 'Methods';
priority: 50;
object: [ self elements ];
view: #gtItemsFor:! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
ClassMethodCollection class
instanceVariableNames: ''!
!ClassMethodCollection class methodsFor: 'instance creation' stamp: 'GlamorousAuthor 6/29/2025 15:14'!
with: aSelector
^ self new with: aSelector! !
!ClassMethodCollection class methodsFor: 'instance creation' stamp: 'GlamorousAuthor 6/29/2025 15:14'!
endsWith: aString
^ self new endsWith: aString! !
Object subclass: #InstanceMethodCollection
instanceVariableNames: 'elements selectors'
classVariableNames: ''
package: 'KILearningMOOC'!
!InstanceMethodCollection methodsFor: 'initialization' stamp: 'GlamorousAuthor 6/29/2025 15:16'!
with: aSelector
elements := Smalltalk allClasses
flatCollect: [ :class | class methodDict select: [ :method | method selector = aSelector ] ].
selectors := (elements collect: [ :method | method selector ]) asBag! !
!InstanceMethodCollection methodsFor: 'initialization' stamp: 'GlamorousAuthor 6/29/2025 15:16'!
endsWith: aString
elements := Smalltalk allClasses
flatCollect: [ :class |
class methodDict
select: [ :method | method selector asString endsWith: aString ] ].
selectors := (elements collect: [ :method | method selector ]) asBag! !
!InstanceMethodCollection methodsFor: 'accessing' stamp: 'GlamorousAuthor 6/29/2025 15:12'!
elements
^ elements! !
!InstanceMethodCollection methodsFor: 'accessing' stamp: 'GlamorousAuthor 6/29/2025 15:12'!
selectors
^ selectors! !
!InstanceMethodCollection methodsFor: 'ui - building' stamp: 'GlamorousAuthor 6/29/2025 17:51'!
buildStencilForNodesFor: aSelector with: classes
| superClasses |
superClasses := classes flatCollect: [ :class | class allSuperclasses ].
^ [ :class |
| element |
element := BrLabel new
text: class name;
background: Color lightOrange;
aptitude: BrGlamorousLabelAptitude new;
border: (BlBorder paint: Color veryLightGray);
when: BlClickEvent
do: [ :anEvent |
| compiledMethod |
anEvent consumed: true.
((superClasses includes: class) and: [ (classes includes: class) not ])
ifFalse: [ compiledMethod := class perform: #'>>' with: aSelector.
anEvent currentTarget phlow spawnObject: compiledMethod ] ];
when: BlMouseEnterEvent
do: [ :anEvent |
| graph |
graph := anEvent currentTarget graph.
graph connectedEdges
do: [ :inner | inner element border: (BlBorder paint: Color blue) ].
graph element border: (BlBorder paint: Color blue) ];
when: BlMouseLeaveEvent
do: [ :anEvent |
| graph |
graph := anEvent currentTarget graph.
graph connectedEdges
do: [ :inner | inner element border: (BlBorder paint: Color veryLightGray) ].
graph element border: (BlBorder paint: Color veryLightGray) ].
((superClasses includes: class) and: [ (classes includes: class) not ])
ifTrue: [ element background: Color lightYellow ].
element ]! !
!InstanceMethodCollection methodsFor: 'ui - building' stamp: 'GlamorousAuthor 6/29/2025 17:52'!
treeGraphFor: aSelector with: classes
| mondrian stencilForNodes stencilForEdges superClasses |
mondrian := GtMondrian new.
stencilForNodes := self buildStencilForNodesFor: aSelector with: classes.
stencilForEdges := [ BlLineElement new
border: Color veryLightGray;
fromHead: (BlArrowheadSimpleArrow new border: Color veryLightGray);
zIndex: -1 ].
superClasses := classes flatCollect: [ :class | class allSuperclasses ].
mondrian nodes
stencil: stencilForNodes;
with: classes , superClasses.
mondrian edges
stencil: stencilForEdges;
connectToAll: #subclasses.
mondrian layout horizontalTree.
^ mondrian! !
!InstanceMethodCollection methodsFor: 'ui - building' stamp: 'GlamorousAuthor 6/29/2025 17:53'!
treeGraphOfInstanceMethodsFor: aSelector
| classes |
classes := self enumerateClassesthatImplement: aSelector from: elements.
^ self treeGraphFor: aSelector with: classes! !
!InstanceMethodCollection methodsFor: 'acccessing' stamp: 'GlamorousAuthor 6/29/2025 17:57'!
enumerateClassesthatImplement: aSelector from: classes
^ (classes
select: [ :method | method selector = aSelector ]
thenCollect: [ :method | method methodClass ]) asSet! !
!InstanceMethodCollection methodsFor: 'gt - views' stamp: 'GlamorousAuthor 6/29/2025 17:55'!
gtOccurrencesFor: aView
<gtView>
^ aView forward
title: 'Occurrences';
priority: 55;
object: [ self selectors ];
view: #gtOccurrencesFor:;
send: [ :assoc | self treeGraphOfInstanceMethodsFor: assoc value ]! !
!InstanceMethodCollection methodsFor: 'gt - views' stamp: 'GlamorousAuthor 6/29/2025 14:38'!
gtItemsFor: aView
<gtView>
^ aView forward
title: 'Methods';
priority: 50;
object: [ self elements ];
view: #gtItemsFor:! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
InstanceMethodCollection class
instanceVariableNames: ''!
!InstanceMethodCollection class methodsFor: 'instance creation' stamp: 'GlamorousAuthor 6/29/2025 15:16'!
with: aSelector
^ self new with: aSelector! !
!InstanceMethodCollection class methodsFor: 'instance creation' stamp: 'GlamorousAuthor 6/29/2025 15:15'!
endsWith: aString
^ self new endsWith: aString! !
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment