DCIprogram: #MoveShape

Context subclass: #MoveShape
    instanceVariableNames: 'shapeName deltaPoint drawing'
    category: 'MoveShape-Context'

" System operation.
Consider a Draw progam such as the PowerPoint slide editor. A user can create and place different shapes such as ovals, polygons, lines and other shapes. A Connector is a special line that runs from one shape to another. The line will always connect the two shapes even if the shapes move. This program implements the shape:move: operation.

A NOTE ON THE IMPLEMENTATION
The code supports that a Role can be played by a Collection, in this case a collection of Connectors.
There is one Context class with one system operation:
    shape: aShape move: aPoint inData: drawing

"

instanceMethods: operations

shape: shape move: delta data: aDrawing
    shapeName := shape.
    deltaPoint := delta.
    drawing := aDrawing.
    self triggerInteractionFrom: #MOVINGSHAPE with: #move.

instanceMethods: role binding

DELTA
    ^deltaPoint

LINE
    " This role will be mapped at runtime during the enumeration of the LINECOLLECTION. "
    ^nil

LINECOLLECTION
    | connectorSet shape |
    connectorSet := Set new.
    shape := drawing at: shapeName.
    drawing do: [:value | ((value isKindOf: Connector) and: [value connects: shape])
                                ifTrue: [connectorSet add: value]].
    ^OrderedCollection newFrom: connectorSet

MOVINGSHAPE
    ^drawing at: shapeName

instanceMethods: role methods

move
    MOVINGSHAPE moveMe: DELTA.
    LINECOLLECTION shapeHasMoved.

instanceMethods: role methods

shapeHasMoved
    LINECOLLECTION with: #LINE do:
        [LINE shapeHasMoved].

instanceMethods: role methods

shapeHasMoved
    " Make Connector go between shape centers. "
    " Shape connectionPoints ignored for the time being. "
    " Left to do: Make Connectors into arrows connecting shape connectorPoints. "
    " Even later: Embed in a simple Draw program. (See BabyIDE) "
    | shapeStart shapeEnd |
    MOVINGSHAPE == LINE startShape
        ifTrue:
            [shapeStart := LINE endShape. shapeEnd := LINE startShape]
        ifFalse:
            [MOVINGSHAPE == LINE endShape
                ifTrue: [shapeStart := LINE startShape. shapeEnd := LINE endShape]
                ifFalse: [LINE error: 'This connector is not attached to MOVINGSHAPE']].
    LINE beginPoint: shapeStart center.
    LINE endPoint: shapeEnd center.

Object subclass: #Connector
    instanceVariableNames: 'startShape endShape line'
    category: 'MoveShape-Data'

" The line object in the Connector is not visible from outside the Connector.
No outside code can corrupt it. "

instanceMethods: initialize-release

startShape: start endShape: end
    startShape := start.
    endShape := end.
    (line := Line new) beginPoint: startShape center; endPoint: endShape center.

instanceMethods: attributes-read

beginPoint
    ^line beginPoint

endPoint
    ^line endPoint

startShape
    ^startShape

endShape
    ^endShape

connects: aShape
    ^(startShape == aShape) or: [endShape == aShape]

instanceMethods: attributes-write

beginPoint: aPoint
    line beginPoint: aPoint

endPoint: aPoint
    line endPoint: aPoint

pointAt: shape put: aPoint
"self halt: 'Not used'."
    startShape == shape
        ifTrue: [line beginPoint: aPoint rounded].
    endShape == shape
        ifTrue: [line endPoint: aPoint rounded].

instanceMethods: testing only

testLineStartPoint: start endPoint: end
    ^(line beginPoint = start) & (line endPoint = end)

Rectangle subclass: #RectangleShape
    instanceVariableNames: ''
    category: 'MoveShape-Data'

instanceMethods: attributes-read

connectionPoints
    ^{ self topLeft. self topCenter. self topRight. self rightCenter. self bottomRight. self bottomCenter. self bottomLeft. self leftCenter. }

instanceMethods: operations

moveMe: delta
    self setOrigin: self origin + delta corner: self corner + delta.

Object subclass: #Test
    instanceVariableNames: ''
    category: 'MoveShape-Test'

" See UseCase comment. "

instanceMethods: operations

test
    " Test new test. "
    "Set up test data. "
    | actA actB actC data actCmoved |
    actA := RectangleShape origin: 0@6 corner: 4@4.
    actB := RectangleShape origin: 0@2 corner: 4@0.
    actC := RectangleShape origin: 6@4 corner: 10@2.
    (data := IdentityDictionary new)
        at: #actA put: actA;
        at: #actB put: actB;
        at: #actC put: actC;
        at: #conAC put: (Connector new startShape: actA endShape: actC);
        at: #conBC put: (Connector new startShape: actB endShape: actC).
    " Check test Data. "
    self assert: [(
        (data at: #actA) = actA &
        (data at: #actB) = actB &
        (data at: #actC) = actC &
        ((data at: #conAC) testLineStartPoint: actA center endPoint: actC center) &
        ((data at: #conBC) testLineStartPoint: actB center endPoint: actC center)
        )
    ].
    " Move. "
    MoveShape new shape: #actC move: 6@3 data: data.
    " Check final Data. "
    actCmoved := RectangleShape origin: 12@7 corner: 16@5.
    self assert: [(
        (data at: #actA) = actA &
        (data at: #actB) = actB &
        (data at: #actC) = actCmoved &
        ((data at: #conAC) testLineStartPoint: actA center endPoint: actC center) &
        ((data at: #conBC) testLineStartPoint: actB center endPoint: actC center)
        ).
    ].
    self inform: 'MoveShape test successful.'.

classMethods: class initialization

initialize
    " Test initialize "
    " This magic makes ': Test move shape' appear as a choice "
    " in the background menu/'open' command. "
    TheWorldMenu unregisterOpenCommand: ': Test move shape'.
    TheWorldMenu
        registerOpenCommand:
            {': Test move shape, full code'. {Test. #run.}}.

classMethods: instance creation

run
    self basicNew initialize test