" DCI program: BB4aPlan "

" Exported from Squeak 7179-basic.76.image on: 18 December 2011 by: Trygve "

" Data perspective "

" Class BB4aActivity "

" Instances of this class represent the notion of an activity in a planning activity network.
Note that the successor and predecessor relations are not part of the activity; they are generated in a Context when needed.

See Controller>BB4aController for more details.

Instance variables:
    earlyStart (Integer) earliest start week for this activity.
    duration (Integer) in weeks
    name (String) activity name
    color (Color) simple representation of activity kind. "

Object subclass: #BB4aActivity
    instanceVariableNames: 'earlyStart duration name color'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB4aPlan-Data'

" BB4aActivity instance methods in category: access "

color
    ^color

displayName
    ^name , ' (' , duration printString , ')'

duration
    ^duration

earlyFinish
    ^earlyStart isNil
        ifTrue: [nil]
        ifFalse: [earlyStart + duration - 1]

earlyStart
    ^earlyStart

earlyStart: week
    earlyStart := week.

name
    ^name

" BB4aActivity instance methods in category: private "

initialize
    earlyStart := nil.
    duration := 0.
    name := 'Act' , self asOop printString.
    color := Color gray.

name: nam duration: dur color: col
    name := nam.
    duration := dur.
    color := col.

printOn: strm
    super printOn: strm.
    strm nextPutAll: ' (' , name , ')'.

" BB4aActivity class class methods in category: instance creation "

name: nam duration: dur color: col
    | act |
    act := self new.
    act name: nam duration: dur color: col.
    ^act

" Class BB4aDependency "

" Instances of this class represents a predecessor/successor relationship between activities.

See Controller>BB4aController for more details.

Instance variables:
    predecessor (Activity)
    successor (Activity) "

Object subclass: #BB4aDependency
    instanceVariableNames: 'predecessor successor'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB4aPlan-Data'

" BB4aDependency instance methods in category: access "

predecessor
    ^predecessor

successor
    ^successor

" BB4aDependency instance methods in category: private "

predecessor: pred successor: succ
    predecessor := pred.
    successor := succ.

printOn: strm
    super printOn: strm.
    strm nextPutAll: ' (' , predecessor name , '-->' , successor name , ')'.

" Class BB4aModel "

" The Model part of MVC. Represents an activity network.

See Controller>BB4aController for more details.

Instance variables:
    activities (Set of Activity)
    dependencies (Set of Dependency)
    activityRanks (Integer) A cache that is needed for certain computations.
        It has nothing to do with the Model as such
        and illustrates how behavior data get mixed into real domain Model data.
        (It is an instance variable in a Context in the BB4b example) "

Object subclass: #BB4aModel
    instanceVariableNames: 'activities dependencies activityRanks'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB4aPlan-Data'

" BB4aModel instance methods in category: access "

activityNamed: actNam
    | act |
    act := activities detect: [:a | a name = actNam] ifNone: [nil].
    act ifNil: [self error: 'Activity ' , actNam , ' does not exist.'. ^nil].
    ^act

allActivities
    ^activities

allDependencies
    ^dependencies

hasDependencyFrom: fromAct to: toAct
    | found |
    found := dependencies
        detect: [:dep | (dep predecessor = fromAct) and: [dep successor = toAct]]
        ifNone: [nil].
    ^found notNil

hasDependencyFromName: fromActName toName: toActName
    ^self
        hasDependencyFrom: (self activityNamed: fromActName)
        to: (self activityNamed: toActName)

predecessorsOf: succ
    | preds |
    preds := Set new.
    dependencies do: [:dep | dep successor == succ ifTrue: [preds add: dep predecessor]].
    ^preds

successorsOf: pred
    | succs |
    succs := Set new.
    dependencies do: [:dep | dep predecessor == pred ifTrue: [succs add: dep successor]].
    ^succs

" BB4aModel instance methods in category: data definition "

newActivityNamed: nam duration: dur color: col
    | act |
    act := BB4aActivity name: nam duration: dur color: col.
    activities add: act.
    self changed: #activities.
    ^act

newDependencyFrom: predNam to: succNam
    | pred succ |
    pred := self activityNamed: predNam.
    succ := self activityNamed: succNam.
    (self hasDependencyFrom: pred to: succ)
    ifFalse:
        [dependencies add:
            (BB4aDependency new
                predecessor: pred
                successor: succ).
        self changed: #model].

reset
    activities := Set new.
    dependencies := Set new.
    self changed: #activities.
    self changed: #dependencies.

" BB4aModel instance methods in category: for dependencyCtx "

computeRankedActivities
    | rankedActivities |
    rankedActivities :=OrderedCollection new. " rank -> activityCollection "
    activityRanks := Dictionary new. " activity -> rank "
    self allActivities do:
        [:act || rnk coll |
        rnk := self rankOf: act.
        activityRanks at: act put: rnk.
        coll := rankedActivities
            at: rnk
            ifAbsentPut: [SortedCollection sortBlock: [:x :y | x name < y name]].
        coll add: act].
    ^rankedActivities

rankOf: act
    " NOTE: A feature of the structure, not of an individual activity. "
    | rnk |
    ^activityRanks
        at: act
        ifAbsent:
            [rnk := 1.
            (self predecessorsOf: act) do: [:pred | rnk := rnk max: (self rankOf: pred) + 1].
        rnk]

" BB4aModel instance methods in category: for frontloadCTX "

frontActivity
    ^self allActivities
        detect:
            [:act |
            act earlyStart isNil
            and:
                [(self predecessorsOf: act) noneSatisfy: [:pred | pred earlyStart isNil]]]
        ifNone: [nil]

frontloadFrom: startWeek
    | frontAct |
    self allActivities do: [:act | act earlyStart: nil].
    [frontAct := self frontActivity. frontAct notNil]
    whileTrue:
        [frontAct earlyStart: startWeek.
        (self predecessorsOf: frontAct) do:
            [:pred |
            (pred earlyFinish > frontAct earlyStart)
                ifTrue: [frontAct earlyStart: pred earlyFinish + 1]].
        ].

" BB4aModel instance methods in category: private "

initialize
    activities := Set new.
    dependencies := Set new.

" BB4aModel instance methods in category: triggers "

frontloadNetworkFrom: startWeek
    self frontloadFrom: startWeek

" Controller perspective "

" Class BB4aController "

" This example is a refactoring of the BB4bPlan example. The difference is that the Context and Role methods have been merged into the relevant Data classes. The Context and Interaction perspectives are empty.

The point of this example is to illustrate how system behavior code gets mixed with other code when using conventional coding techniques.

This class is the C part of the original MVC paradigm:
    M is the Model that represents domain information
    V is a View that presents Model data to an end user and lets the user edit these data.
    C is a Controller that sets up and coordinates a number of Views. "

SystemWindow subclass: #BB4aController
    instanceVariableNames: 'dependencyView ganttView selectedActivity'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB4aPlan-Controller'

" BB4aController instance methods in category: overrides "

addMorph: aMorph fullFrame: aLayoutFrame
    " Suppresses crazy handling of panes in StandardSystemWindow. "
    | left right bottom top windowBorderWidth |
    windowBorderWidth _ self class borderWidth.
    left _ aLayoutFrame leftOffset ifNil: [0].
    right _ aLayoutFrame rightOffset ifNil: [0].
    bottom _ aLayoutFrame bottomOffset ifNil: [0].
    top _ aLayoutFrame topOffset ifNil: [0].
    aLayoutFrame rightFraction = 1 ifTrue: [aLayoutFrame rightOffset: right - windowBorderWidth].
    aLayoutFrame leftFraction = 0
        ifTrue: [aLayoutFrame leftOffset: left + windowBorderWidth]
        ifFalse: [aLayoutFrame leftOffset: left + ProportionalSplitterMorph splitterWidth].
    aLayoutFrame bottomFraction = 1 ifTrue: [aLayoutFrame bottomOffset: bottom - windowBorderWidth].
    aLayoutFrame topFraction = 0
        ifTrue: [aLayoutFrame topOffset: top]
        ifFalse: [aLayoutFrame topOffset: top + ProportionalSplitterMorph splitterWidth].
    (aMorph class name = #BrowserCommentTextMorph) ifTrue:
        [aLayoutFrame rightOffset: windowBorderWidth negated.
        aLayoutFrame leftOffset: windowBorderWidth.
        aLayoutFrame bottomOffset: windowBorderWidth negated.
        aLayoutFrame topOffset: (windowBorderWidth negated) + 4].
"    super addMorph: aMorph fullFrame: aLayoutFrame."
    aMorph layoutFrame: aLayoutFrame.
    aMorph hResizing: #spaceFill; vResizing: #spaceFill.
    self addMorph: aMorph.
    paneMorphs _ paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph).
"    aMorph adoptPaneColor: self paneColor."
"    aMorph borderWidth: 1; borderColor: Color lightGray; color: Color white."
    Preferences scrollBarsOnRight    "reorder panes so flop-out right-side scrollbar is visible"
        ifTrue: [self addMorphBack: aMorph].
    self addPaneSplitters.

open
    self buildDependencyView.
    self addMorph: dependencyView
        fullFrame: (LayoutFrame fractions: (0@0 corner: 1@0.4)).
    self buildGanttView.
    self addMorph: ganttView
        fullFrame: (LayoutFrame fractions: (0@0.4 corner: 1@1)).
    self openInWorld.
    model ifNotNil: [self changed: #model].

openInWorld: aWorld
    self bounds: (Rectangle originFromUser: 700@400).
    ^self openAsIsIn: aWorld

" BB4aController instance methods in category: private "

buildDependencyView
    (dependencyView := BB4aDependencyView new)
        color: Color lightGreen lighter;
        borderWidth: 2;
        borderColor: Color black;
        controller: self.

buildGanttView
    (ganttView := BB4aGanttView new)
        color: Color lightBlue lighter;
        borderWidth: 2;
        borderColor: Color black;
        controller: self.

" BB4aController instance methods in category: private-mouse "

handlesMouseDown: evt
    ^true

mouseDown: evt
    super mouseDown: evt.
    evt yellowButtonPressed
        ifTrue: [^self yellowButtonActivity: evt].

yellowButtonActivity: shiftKeyState
    | aMenu |
    aMenu := MenuMorph new defaultTarget: self.
    aMenu addTitle: self printString.
    aMenu addList: #(
        ('build demo network' #buildDemoNetwork)
        ('frontload from week 1' #frontloadDemo)
        ('reset demo' #resetDemo)
"        ('export diagram as GIF' #exportAsGIF 'Store this diagram as a GIF picture.' ) "
        ).
    aMenu popUpInWorld.

" BB4aController instance methods in category: selection "

clickAt: act
    selectedActivity := selectedActivity == act ifTrue: [nil] ifFalse: [act].
    self changed: #selection.

isSelected: act
    ^selectedActivity == act.

selectedActivity
    ^selectedActivity

selectedActivity: act
    selectedActivity := act.

" BB4aController instance methods in category: triggers "

buildDemoNetwork
    model ifNotNil:
        [dependencyView deleteContents.
        ganttView deleteContents.].
    model := BB4aModel new.
    model
        newActivityNamed: 'actA' duration: 2 color: Color yellow;
        newActivityNamed: 'actB' duration: 7 color: Color lightBlue;
        newActivityNamed: 'actC' duration: 3 color: Color lightMagenta;
        newActivityNamed: 'actD' duration: 2 color: Color lightGreen.
    model
        newDependencyFrom: 'actA' to: 'actC';
        newDependencyFrom: 'actB' to: 'actD';
        newDependencyFrom: 'actC' to: 'actD'.
    self changed: #model.

frontloadDemo
    model ifNil: [self inform: 'Define the model before frontloading. \Command ignored.' withCRs. ^self].
    model frontloadNetworkFrom: 1.
    self changed: #model.

resetDemo
    self model: nil.
    dependencyView deleteContents.
    ganttView deleteContents.

" BB4aController class class methods in category: class initialization "

initialize
    " BB4aController initialize. "
    "TheWorldMenu unregisterOpenCommand: 'BB4cPlan with role without context'."
    TheWorldMenu registerOpenCommand: {'BB4aPlan w/o role and context'. {BB4aController. #open}. 'Baby plan without role and context'}

" BB4aController class class methods in category: instance creation "

open
    (self labelled: 'BB4aPlan') open.

" View perspective "

" Class BB4aActivityView "

" This class is a V part of the original MVC paradigm:
    M is the Model that represents domain information
    V is a View that presents Model data to an end user and lets the user edit these data.
    C is a Controller that sets up and coordinates a number of Views.
This View presents a single network activity.

See Controller>BB4aController for more details. "

RectangleMorph subclass: #BB4aActivityView
    instanceVariableNames: 'controller activity nameMorph'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB4aPlan-View'

" BB4aActivityView instance methods in category: initialization "

controller: cnt activity: act
    controller := cnt.
    activity := act.
    self color: act color.
    nameMorph
        newContents: '' asText;     " To block any TextMorph optimization if name unchanged. "
        newContents: activity displayName asText allBold;
        updateFromParagraph.
    self update: nil.
    self invalidRect: self bounds.

initialize
    super initialize.
    self
        borderWidth: 2;
        borderColor: Color black;
        layoutPolicy: (TableLayout new);
        hResizing: #rigid;
        vResizing: #rigid;
        color: Color gray;
        extent: 75@50.
    nameMorph := TextMorph new
            hResizing: #shrinkWrap;
            contents: '';
            wrapFlag: false;
            centered;
            margins: 10;
            yourself.
    self addMorphBack: nameMorph.

" BB4aActivityView instance methods in category: private "

borderColor
    ^self isSelected
        ifTrue: [Color red]
        ifFalse: [Color black]

borderWidth
    ^self isSelected
        ifTrue: [5]
        ifFalse: [2]

isSelected
"    self traceRM: {activity name. controller isSelected: activity.}."
    ^controller isSelected: activity

printOn: strm
    super printOn: strm.
    strm nextPutAll: ' (' , nameMorph text asString , ')'.

update: aParameter
    | w |
    aParameter = #selection
    ifTrue:
        [self borderWidth: self borderWidth.
        self color: self color.
        self borderColor: self borderColor.
        self invalidRect: self bounds.
        (w := self world) ifNotNil: [w doOneCycle].
        
        
"    self traceRM: {activity name. self borderColor.}."
    
    ].

" BB4aActivityView instance methods in category: private-mouse "

click: evt
    controller clickAt: activity.

handlesMouseDown: evt
    ^true

mouseDown: evt
    evt yellowButtonPressed
        ifTrue: [^self yellowButtonActivity: evt].
    (evt redButtonPressed and: [self bounds containsPoint: evt cursorPoint])
        ifTrue: [evt hand waitForClicksOrDrag: self event: evt].

mouseDownPriority
    ^nameMorph mouseDownPriority + 1.

" Class BB4aDependencyView "

" This class is a V part of the original MVC paradigm:
    M is the Model that represents domain information
    V is a View that presents Model data to an end user and lets the user edit these data.
    C is a Controller that sets up and coordinates a number of Views.
This View presents a an activity network as a graph.

See Controller>BB4aController for more details. "

PasteUpMorph subclass: #BB4aDependencyView
    instanceVariableNames: 'controller activityViews lines rankedActivities maxRank maxRankSetSize'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB4aPlan-View'

" BB4aDependencyView instance methods in category: access "

activiyViewAt: act
    ^activityViews at: act

activiyViews
    ^activityViews values

addActivityViewFor: act
    | actView |
    actView := BB4aActivityView new controller: controller activity: act.
    activityViews at: act put: actView.
    self addMorph: actView.
    controller addDependent: actView.
    ^actView

addLineFrom: pt1 to: pt2
    | line |
    (line := PolygonMorph vertices: {pt1. pt2.} color: Color black borderWidth: 2 borderColor: Color black)
         makeOpen;
        sticky: true.
    lines add: line.
    self addMorph: line.

deleteContents
    activityViews values do: [:p | p delete].
    activityViews := Dictionary new.
    lines do: [:lin | lin delete].
    lines := OrderedCollection new.

" BB4aDependencyView instance methods in category: event handling "

handlesMouseDown: evt
    ^false

" BB4aDependencyView instance methods in category: initialization "

controller: cnt
    controller := cnt.
    controller addDependent: self.

initialize
    super initialize.
    activityViews := Dictionary new.
    lines := OrderedCollection new.

" BB4aDependencyView instance methods in category: role methods "

addActivityViews
    | gridX gridY x0 y0 actViewExtent xPos yPos actView |
    gridX := self bounds width // maxRank.
    gridY := self bounds height // maxRankSetSize.
    x0 := self bounds left + 10.
    y0 := self bounds top + 10.
    actViewExtent := 100 @ 40. "(gridX-50) @ (gridY-20)."
    1 to: rankedActivities size do:
        [:rank |
        xPos := x0 + (gridX * (rank-1)).
        yPos := y0.
        (rankedActivities at: rank) do:
            [:act |
            actView := self addActivityViewFor: act.
            actView bounds: ((xPos @ yPos) extent: actViewExtent).
            yPos := yPos + gridY.
            ] ].

addLines
    | fromView toView pt1 pt2 |
    controller model allDependencies do:
        [:dep |
        fromView := self activiyViewAt: dep predecessor.
        toView := self activiyViewAt: dep successor.
        pt1 := fromView right
                    @ ((fromView top + (fromView height // 2))).
        pt2 := toView left
                    @ ((toView top + (toView height // 2))).
        self addLineFrom: pt1 to: pt2.
        ]

resetView
    "---------------- Context responsibility start ------------------------"
    rankedActivities := controller model computeRankedActivities.
    maxRank := rankedActivities size.
    maxRankSetSize := 0.
    rankedActivities do: [:coll | maxRankSetSize := maxRankSetSize max: coll size].
    "---------------- Context responsibility end ------------------------"
    self deleteContents.
    self addActivityViews.
    self addLines.

" BB4aDependencyView instance methods in category: triggers "

refresh
    activityViews values do: [:v | v delete].
    activityViews := Dictionary new.
    self resetView.

update: aSymbol
    (aSymbol = #model and: [controller model notNil]) ifTrue: [self refresh].

" Class BB4aGanttView "

" This class is a V part of the original MVC paradigm:
    M is the Model that represents domain information
    V is a View that presents Model data to an end user and lets the user edit these data.
    C is a Controller that sets up and coordinates a number of Views.
This View presents the network activities along a time axis showing the time period of the execution of each activity.

See Controller>BB4aController for more details. "

PasteUpMorph subclass: #BB4aGanttView
    instanceVariableNames: 'controller activityViews lines annotations endTime startTime nameSortedActivities'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB4aPlan-View'

" BB4aGanttView instance methods in category: access "

addActivityViewFor: act
    | actView |
    actView := BB4aActivityView new controller: controller activity: act.
    activityViews at: act put: actView.
    self addMorph: actView.
    controller addDependent: actView.
    ^actView

addAnnotationFor: aString at: pt
    | annot |
    annot := StringMorph
                contents: aString
                font: ( ((TextStyle named: 'BitstreamVeraSans') fontAt: 3))
                emphasis: 1.
    annot
        color: Color lightGray;
        position: pt.
    annotations add: annot.
    self addMorphBack: annot.

addLineFrom: pt1 to: pt2
    | line |
    (line := PolygonMorph vertices: {pt1. pt2.} color: Color black borderWidth: 2 borderColor: Color black)
         makeOpen;
        sticky: true;
        color: Color lightGray;
        borderColor: Color lightGray.
    lines add: line.
    self addMorphBack: line.

deleteContents
    activityViews values do: [:view | view delete].
    activityViews := Dictionary new.
    lines do: [:lin | lin delete].
    lines := OrderedCollection new.
    annotations do: [:ann | ann delete].
    annotations := OrderedCollection new.

" BB4aGanttView instance methods in category: initialization "

controller: cnt
    controller := cnt.
    controller addDependent: self.

initialize
    super initialize.
    activityViews := Dictionary new.
    lines := OrderedCollection new.
    annotations := OrderedCollection new.

" BB4aGanttView instance methods in category: role methods "

addActivityViews
    | currY maxX maxY gridX gridY x0 width actView |
    startTime = endTime ifTrue: [^self. "Network not planned. "].
    maxX := self width - 20.
    maxY := self height - 20.
    gridX := maxX // (endTime - startTime + 1).
    gridY := maxY // (nameSortedActivities size + 1).
    currY := 10.
    nameSortedActivities do: [:act |
        x0 := act earlyStart - startTime * gridX + 10.
        width := (act earlyFinish - act earlyStart + 1) * gridX.
        actView := self addActivityViewFor: act.
        actView bounds: ((x0+self left) @ ((currY+self top) + 1) extent: width @ (gridY-2)).        
        currY := currY + gridY].

addLines
    | maxX maxY gridX gridY y1 y2 y0 |
    maxX := self width - 20.
    maxY := self height - 20.
    gridX := maxX // (endTime - startTime + 1).
    gridY := maxY // (nameSortedActivities size + 1).
    y0 := self top + 10.
    y1 := nameSortedActivities size * gridY + self top + 20.
    y2 := self bottom - 10.
    self addLineFrom: (self left + 10) @ y1 to: (self right - 10) @ y1.
    0 to: endTime - startTime + 1 do:
        [:week || x |
        x := week * gridX + self left + 10.
        self addLineFrom: x @ y0 to: x @ y2.
        self
            addAnnotationFor: (startTime + week) printString
            at: (gridX // 2 + x) @ (y1 + 10).
        ].

resetView
    "---------------- Context responsibility start ------------------------"
    endTime := nil.
    controller model allActivities do: [:act | endTime ifNil: [endTime := act earlyFinish] ifNotNil: [endTime := act earlyFinish max: endTime]].
    endTime := endTime ifNil: [0] ifNotNil: [endTime].
    startTime := nil.
    controller model allActivities do: [:act | startTime ifNil: [startTime := act earlyStart] ifNotNil: [startTime := act earlyStart min: startTime]].
    startTime := startTime ifNil: [0] ifNotNil: [startTime].
    nameSortedActivities := controller model allActivities asSortedCollection: [:x :y | x name < y name].
    "---------------- Context responsibility end ------------------------"
    self deleteContents.
    self addActivityViews.
    self addLines.

" BB4aGanttView instance methods in category: triggers "

refresh
    activityViews values do: [:v | v delete].
    activityViews := Dictionary new.
    self resetView.

update: aSymbol
    (aSymbol = #model and: [controller model notNil]) ifTrue: [self refresh].