"blocks for readability"
findCreators := [ :class | | findConstructors creators |
findConstructors := [
:cclass | cclass methods select: [ :m | m kind = 'constructor'] ].
creators := Set new.
(findConstructors value: class) do: [
:method | method incomingInvocations do: [
:ii | creators add: ii sender parentType ]
].
creators. ].
newLine := Character cr asString.
camelWrap := [ :class |
rex := '([a-z])([A-Z])' asRegex.
rex copy: class name translatingMatchesUsing:
[ :each | (each at:1) asString, newLine, (each at:2) asString ]
].
classes := MooseModel root allModels first allClasses select: [
:c | c mooseName beginsWith: 'headfirst::designpatterns::factory::pizzaaf'].
thinArrow := RTDecoratedLine new
head: (RTFilledNarrowArrow asHead);
attachPoint: (RTBorderAttachPoint new);
width: 2.
"inheritanceArrow := RTDecoratedLine new
head: (RTEmptyNarrowArrow asHead);
attachPoint: (RTBorderAttachPoint new);
width: 2."
myClassShape := RTCompositeShape new
add: (RTBox new);
add: (RTLabel new text:camelWrap);
allOfSameSizeWithPadding.
b := RTMondrian new.
b shape shape: myClassShape;
borderColor: Color black;
fillColor: Color paleYellow;
textColor: Color black.
b nodes: classes.
b shape shape: thinArrow;
color: Color veryLightGray.
b edges moveBehind; connectFromAll: findCreators.
"b shape shape: inheritanceArrow;
color: Color green; withShorterDistanceAttachPoint.
b edges connectToAll: #directSuperclasses."
b layout dominanceTree verticalGap: 80; horizontalGap: 5.
b build.
b view @ RTZoomableView.
^ b