'From Squeak3.7alpha of ''11 September 2003'' [latest update: #5501] on 24 November 2003 at 7:42:43 pm'! EllipseMorph subclass: #CircleMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Connectors-Base'! Morph subclass: #HardnessSliderMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Skeleton-Morph'! EllipseMorph subclass: #MicMorph instanceVariableNames: 'mic isListening ' classVariableNames: '' poolDictionaries: '' category: 'Skeleton-Morph'! !MicMorph commentStamp: 'tak 11/16/2003 20:29' prior: 0! I am a simple tool for playing mic interface. Structure: mic SoundInputStream -- isListening Boolean -- true if in operation listning (etoy slot) -- Switch on when you use it. Off when to save project.! EllipseMorph subclass: #NCAttachmentPointAdjuster instanceVariableNames: 'originalSpec target ' classVariableNames: '' poolDictionaries: '' category: 'Connectors-Base'! Morph subclass: #NCConstraintMorph instanceVariableNames: 'constrained inputs lastTarget stepTime constraint dieWithInput ' classVariableNames: '' poolDictionaries: '' category: 'Connectors-Base'! Morph subclass: #NCFSMMorph instanceVariableNames: 'fsm ' classVariableNames: '' poolDictionaries: '' category: 'Connectors-Base'! NCFSMMorph subclass: #NCConnectorMorph instanceVariableNames: 'constraints line ' classVariableNames: 'DefaultFSM MinimumSelectionSlop ' poolDictionaries: '' category: 'Connectors-Base'! Object subclass: #NCFiniteStateMachine instanceVariableNames: 'transitions currentState stateActions newState missedEventSend logger lastEventArguments client ' classVariableNames: '' poolDictionaries: '' category: 'Connectors-FSM'! Morph subclass: #NCHighlightMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Connectors-Base'! NCConstraintMorph subclass: #NCLineEndConstraintMorph instanceVariableNames: 'firstVertex lineAttachmentPoint ' classVariableNames: '' poolDictionaries: '' category: 'Connectors-Base'! NCFiniteStateMachine subclass: #NCSharedFiniteStateMachine instanceVariableNames: 'prototype ' classVariableNames: '' poolDictionaries: '' category: 'Connectors-FSM'! PasteUpMorph subclass: #NCAttachmentPointAdjusterWindow instanceVariableNames: 'target joystick originalPosition ' classVariableNames: '' poolDictionaries: '' category: 'Connectors-Base'! NCConnectorMorph subclass: #SkeletonLineMorph instanceVariableNames: 'status ' classVariableNames: '' poolDictionaries: '' category: 'Skeleton-Morph'! !SkeletonLineMorph commentStamp: 'tak 11/23/2003 12:09' prior: 0! I am a Connector that is able to set / get length among any other morphs. SkeletonLineMorph example1! SkeletonLineMorph subclass: #SkeletonConstantLineMorph instanceVariableNames: 'rememberdLength delta hardness ' classVariableNames: '' poolDictionaries: '' category: 'Skeleton-Morph'! !SkeletonConstantLineMorph commentStamp: 'tak 11/23/2003 12:24' prior: 0! I keep a distance among any objects. SkeletonConstantLineMorph example1! TestCase subclass: #SkeletonLineMorphTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Skeleton-Morph'! PackageInfo subclass: #SkeletonMorphInfo instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Skeleton-Morph'! !SkeletonMorphInfo commentStamp: 'tak 11/17/2003 12:07' prior: 0! I am a package information of skeleton minimun set. .cs file for SqueakLand image, .cs file for 3.6 image, and .sar package is supported. This package includes - Basic set of Connectors 1.9 - SkeletonLine (Spring and Measure) - Hardness slider tool - Mic sensor - Transparency pen trail When packaging, Connectors 1.9 is required. - Make minimum change set SkeletonMorphInfo fileOutMinimumChangeSet -- workspace -- PartsBin initialize. self newSkeletonFlap openInWorld; setToPopOutOnDragOver: false. ! !Object methodsFor: 'evaluating' stamp: 'reThink 3/12/2001 18:14'! value ^self! ! !Object methodsFor: '*connectors-message handling' stamp: 'nk 4/11/2002 14:13'! perform: selector withEnoughArguments: anArray "Send the selector, aSymbol, to the receiver with arguments in argArray. Only use enough arguments for the arity of the selector; supply nils for missing ones." | numArgs args | numArgs _ selector numArgs. anArray size == numArgs ifTrue: [ ^self perform: selector withArguments: anArray asArray ]. args _ Array new: numArgs. args replaceFrom: 1 to: (anArray size min: args size) with: anArray startingAt: 1. ^ self perform: selector withArguments: args! ! !BlockContext methodsFor: '*connectors-evaluating' stamp: 'nk 3/11/2001 11:49'! valueWithEnoughArguments: anArray "call me with enough arguments from anArray" | args | (anArray size == self numArgs) ifTrue: [ ^self valueWithArguments: anArray ]. args _ Array new: self numArgs. args replaceFrom: 1 to: (anArray size min: args size) with: anArray startingAt: 1. ^ self valueWithArguments: args! ! !LineSegment methodsFor: '*connectors-intersection' stamp: 'nk 3/29/2002 22:30'! intersectionWith: anotherSegment "Copied from LineIntersections>>intersectFrom:to:with:to:" | det deltaPt alpha beta pt1Dir pt2Dir | pt1Dir _ end - start. pt2Dir _ anotherSegment end - anotherSegment start. det _ (pt1Dir x * pt2Dir y) - (pt1Dir y * pt2Dir x). deltaPt _ anotherSegment start - start. alpha _ (deltaPt x * pt2Dir y) - (deltaPt y * pt2Dir x). beta _ (deltaPt x * pt1Dir y) - (deltaPt y * pt1Dir x). det = 0 ifTrue:[^nil]. "no intersection" alpha * det < 0 ifTrue:[^nil]. beta * det < 0 ifTrue:[^nil]. det > 0 ifTrue:[(alpha > det or:[beta > det]) ifTrue:[^nil]] ifFalse:[(alpha < det or:[beta < det]) ifTrue:[^nil]]. "And compute intersection" ^start + (alpha * pt1Dir / (det@det))! ! !MessageSend methodsFor: '*connectors-evaluating' stamp: 'nk 3/11/2001 11:42'! valueWithEnoughArguments: anArray "call the selector with enough arguments from arguments and anArray" | args | args _ Array new: selector numArgs. args replaceFrom: 1 to: (arguments size min: args size) with: arguments startingAt: 1. args size > arguments size ifTrue: [ args replaceFrom: arguments size + 1 to: (arguments size + anArray size min: args size) with: anArray startingAt: 1. ]. ^ receiver perform: selector withArguments: args! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/11/2002 15:23'! addConnectedMorphsTo: aCollection "Add myself and all my connected Morphs (recursively) to aCollection" aCollection add: self. self connections do: [ :ea | ea ifNotNil: [ (aCollection includes: ea) ifFalse: [ ea addConnectedMorphsTo: aCollection. ] ] ]. self connectedMorphs do: [ :ea | ea ifNotNil: [ (aCollection includes: ea) ifFalse: [ ea addConnectedMorphsTo: aCollection. ] ] ]. ^aCollection! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 3/27/2001 12:01'! attachFrom: aConstraintMorph at: aPoint "If my property #movableAttachments is not set or is set to true, then make the constraintMorph attach to the nearest attachment point at any given instant. If the property #movableAttachments is set to false, then make the constraint attach permanently to the nearest attachment point." (self valueOfProperty: #movableAttachments ifAbsent: [ true ]) ifTrue: [ aConstraintMorph connectToNearestAttachmentPoint ] ifFalse: [ self attachFrom: aConstraintMorph atNearestSpecTo: aPoint ]! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 2/21/2002 18:38'! attachFrom: aConstraintMorph atNearestSpecTo: aPoint | spec | spec _ self attachmentPointSpecNearest: aPoint. aConstraintMorph connectToMorph: self usingSpec: spec.! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/15/2002 12:13'! attachmentPointAndSpecNearest: aPoint "aPoint is in my coordinate system. Answer an Array with a Point, and a Spec" | minDist minPoint minSpec dist point | minDist _ 1e6. self attachmentPointSpecs do: [:spec | point _ self perform: spec first withEnoughArguments: (spec allButFirst copyWith: aPoint). dist _ aPoint dist: point. dist < minDist ifTrue: [ minDist _ dist. minPoint _ point. minSpec _ spec. ] ]. ^Array with: minPoint with: minSpec.! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 9/29/2000 16:53'! attachmentPointNearest: aPoint ^ (self attachmentPointAndSpecNearest: aPoint) first! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 9/29/2000 16:53'! attachmentPointSpecNearest: aPoint ^ (self attachmentPointAndSpecNearest: aPoint) second! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/13/2002 10:12'! attachmentPointSpecs ^ self valueOfProperty: #attachmentPointSpecs ifAbsent: [ self defaultAttachmentPointSpecs ]! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 2/25/2001 17:00'! attachmentPointSpecs: aCollectionOrNil ^self setProperty: #attachmentPointSpecs toValue: aCollectionOrNil ! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/13/2002 10:10'! attachmentPoints ^ self attachmentPointSpecs collect: [:ea | (self perform: ea first withArguments: ea allButFirst) asIntegerPoint ]! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/14/2002 16:18'! connectionTarget ^self ! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 4/6/2001 07:31'! defaultAttachmentPointSpecs ^{ { #topLeftCorner } . { #topCenter } . { #topRightCorner } . { #leftCenter } . { #center } . { #rightCenter } . { #bottomLeftCorner } . { #bottomCenter } . { #bottomRightCorner } } ! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/15/2002 18:16'! disconnectAllConstraints self connectedConstraints do: [ :ea | ea inputs: (ea inputs copyWithout: self) ]! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/14/2002 16:05'! displayAttachmentPointsFor: aMorph "Show my attachment points as movable morphs. Upon calling setAttachmentPointsFromDisplayed, I will read their positions and (re) set my attachment points" | ams | ams _ self attachmentPointSpecs collect: [ :ea | NCAttachmentPointAdjuster new originalSpec: ea target: self ]. ams do: [ :ea | aMorph addMorphFront: ea ]. ! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/14/2002 16:44'! displayedAttachmentPoints ^self pasteUpMorph submorphs select: [ :ea | (ea isKindOf: NCAttachmentPointAdjuster) and: [ ea target == self ] ] ! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/30/2002 21:08'! endShapeColor: aColor self color: aColor! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/30/2002 21:05'! endShapeWidth: aWidth | originalWidth originalExtent where newExtent | where _ self referencePosition. originalWidth _ self valueOfProperty: #originalWidth ifAbsentPut: [ 2 ]. originalExtent _ self valueOfProperty: #originalExtent ifAbsentPut: [ self extent ]. newExtent _ (originalExtent * aWidth / originalWidth). self extent: newExtent. self referencePosition: where. ! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 6/13/2002 09:40'! isConnectable "Answer whether I will accept connections from ConnectorMorphs" ^true ! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 2/23/2001 14:37'! isConstrainedBy: aMorph "Answer true if aMorph or any of its submorphs are an input to any of my constraints" | herSubmorphs | herSubmorphs _ aMorph allMorphs. ^self constraints anySatisfy: [ :constraint | constraint hasAnyInputIn: herSubmorphs ] ! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 4/8/2001 08:18'! lineAttachmentOffset "Answer the relative offset from my rotation center at which a line is to attach if I am being used as a line end adornment" ^self valueOfProperty: #lineAttachmentOffset ifAbsent: [ 0@0 ].! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 4/8/2001 08:18'! lineAttachmentOffset: aPoint "Set the relative offset from my rotation center at which a line is to attach if I am being used as a line end adornment" ^self setProperty: #lineAttachmentOffset toValue: aPoint.! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 4/17/2001 15:35'! makerButtonImage "Answer a Form for use on a button" ^self imageForm! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 4/25/2001 21:35'! movableAttachments ^self valueOfProperty: #movableAttachments ifAbsent: [ true ]! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 3/27/2001 12:04'! movableAttachments: aBoolean "If aBoolean is true, then allow a connection to choose the nearest of my attachment points. If aBoolean if false, then the attachment point chosen at connection time will be permanent" aBoolean ifTrue: [ self removeProperty: #movableAttachments ] ifFalse: [ self setProperty: #movableAttachments toValue: false ]! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 4/2/2001 19:49'! preferredConnection ^self valueOfProperty: #preferredConnection ifAbsent: []! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 3/27/2001 12:53'! preferredConnection: anArrayOrSelector ^ self setProperty: #preferredConnection toValue: ((anArrayOrSelector isKindOf: Symbol) ifTrue: [{anArrayOrSelector}] ifFalse: [anArrayOrSelector])! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 4/5/2001 09:23'! preferredConnectionSelector | pref | pref _ self valueOfProperty: #preferredConnection ifAbsent: [ ^nil ]. ^pref first! ! !Morph methodsFor: '*connectors-connection' stamp: 'nk 9/15/2002 11:48'! wantsAttachmentFromEnd: endIndex ofConnector: aConnector "Answer true if I would like the given end of aConnector attaching to me." "aPoint is in world coordinates" ^(self == aConnector or: [ self isConnectable not or: [ (aConnector allMorphs includes: self) or: [ self isHighlight or: [ (self isConstrainedBy: aConnector) or: [ (Sensor shiftPressed not and: [ (self isFlexed ifFalse: [ owner ] ifTrue: [ owner owner ]) isPlayfieldLike not ]) or: [ self isPartsDonor or: [ (aConnector pasteUpMorph ~= World and: [ self pasteUpMorph ~~ aConnector pasteUpMorph ]) ]]]]]]]) not! ! !Morph methodsFor: '*connectors-change reporting' stamp: 'nk 6/26/2002 07:26'! addedOrRemovedSubmorph: aMorph "Report that the area occupied by this morph should be redrawn." "NOTE: this is subtly different from 'aMorph changed' in that it forces computation of aMorph fullBounds." "Used to be... self invalidRect: aMorph fullBounds from: aMorph" aMorph fullBounds. aMorph changed. aMorph noteNewOwner: self.! ! !Morph methodsFor: '*connectors-dropping/grabbing' stamp: 'nk 6/30/2002 13:08'! alignAttachmentPointsWithGridNear: aPoint "Try to align my AP nearest the grid with the prevailing grid." | tweak minDist tweaks best | self attachmentPointSpecs isEmpty ifTrue: [ ^self position: (self griddedPoint: self position) ]. minDist _ 1000. tweak _ 0@0. tweaks _ Bag new. best _ 0@0. self attachmentPoints do: [ :ap | | dist | dist _ ap dist: (self griddedPoint: ap). tweak _ (self griddedPoint: ap) - ap. dist < minDist ifTrue: [ best _ tweak ]. tweaks add: tweak. ]. tweaks sortedCounts first key > 1 ifTrue: [ tweak _ tweaks sortedCounts first value ] ifFalse: [ tweak _ best ]. self position: (self position + tweak) asIntegerPoint.! ! !Morph methodsFor: '*connectors-dropping/grabbing' stamp: 'nk 8/6/2002 12:59'! asButtonPrototype "I have been dropped on a NCMakerButton as a prototype. Return a duplicate of me ready to be used as a prototype" ^self duplicate fullBounds; isPartsDonor: true; stopSteppingSelfAndSubmorphs; suspendEventHandler; formerOwner: nil; formerPosition: nil; removeProperty: #undoGrabCommand; disconnectAllConstraints; yourself.! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 9/29/2000 15:55'! bottomCenter ^ bounds bottomCenter! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 4/6/2001 07:31'! bottomLeftCorner "Take rounded corners into account" ^self wantsRoundedCorners ifTrue: [ bounds bottomLeft + (2@-2) ] ifFalse: [ bounds bottomLeft ]! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 4/6/2001 07:30'! bottomRightCorner "Take rounded corners into account" ^self wantsRoundedCorners ifTrue: [ bounds bottomRight + (-2@-2) ] ifFalse: [ bounds bottomRight ]! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 4/25/2001 21:45'! centerX ^ bounds center x! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 4/25/2001 21:45'! centerY ^ bounds center y! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 6/27/2002 12:39'! closestOrthogonalPointTo: aPoint "first, find an intersection" | intersections | intersections _ OrderedCollection new. intersections addAll: (self bounds intersectionsWithLineFrom: (0@aPoint y) to: (Display width @ aPoint y)). intersections addAll: (self bounds intersectionsWithLineFrom: (aPoint x @ 0) to: (aPoint x @ Display height)). intersections isEmpty ifTrue: [ ^self closestPointTo: aPoint ]. ^intersections detectMin: [ :ea | ea dist: aPoint ] ! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 2/15/2001 15:52'! closestPointTo: aPoint ^self bounds pointNearestTo: aPoint! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 2/13/2001 18:17'! intersectionWithLineSegmentFromCenterTo: aPoint ^self bounds intersectionWithLineSegmentFromCenterTo: aPoint ! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 9/29/2000 15:55'! leftCenter ^ bounds leftCenter! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 3/8/2001 10:12'! pointAtOffset: aPoint ^bounds topLeft + ((aPoint x * bounds width) @ (aPoint y * bounds height))! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 9/29/2000 15:55'! rightCenter ^ bounds rightCenter! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 9/29/2000 15:55'! topCenter ^ bounds topCenter! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 4/6/2001 07:29'! topLeftCorner "Take rounded corners into account" ^self wantsRoundedCorners ifTrue: [ bounds topLeft + (2@2) ] ifFalse: [ bounds topLeft ]! ! !Morph methodsFor: '*connectors-geometry' stamp: 'nk 4/6/2001 07:30'! topRightCorner "Take rounded corners into account" ^self wantsRoundedCorners ifTrue: [ bounds topRight + (-2@2) ] ifFalse: [ bounds topRight ]! ! !Morph methodsFor: '*connectors-labels' stamp: 'nk 4/14/2002 08:51'! boundsSignatureHash "Answer a hash value that can be used to see if I've moved or been changed significantly" ^bounds hash ! ! !Morph methodsFor: '*connectors-labels' stamp: 'nk 6/22/2002 17:52'! deleteAllLabels "delete all labels from me and my submorphs" self allMorphsDo: [ :ea | ea deleteMorphs: ea labels ].! ! !Morph methodsFor: '*connectors-labels' stamp: 'nk 3/11/2002 21:22'! labels "Answer the NCLabelMorphs that are tied to me" ^ self connectedConstraints select: [ :ea | ea isLabelConstraint ] thenCollect: [ :ea | ea drawingElement ]! ! !Morph methodsFor: '*connectors-labels' stamp: 'nk 4/14/2002 10:26'! nudgeForLabel: labelBounds "Make label not overlap me. Answer an increment, or 0@0 if OK" | flags intersection | intersection _ labelBounds intersect: self bounds. intersection hasPositiveExtent ifFalse: [ ^0@0 ]. intersection = labelBounds ifTrue: [ ^0@-1 ]. flags _ 0. intersection top == self top ifTrue: [ flags _ flags + 1 ]. intersection right == self right ifTrue: [ flags _ flags + 2 ]. intersection bottom == self bottom ifTrue: [ flags _ flags + 4 ]. intersection left == self left ifTrue: [ flags _ flags + 8 ]. ^flags caseOf: { "no intersection" [ 0 ] -> [ 0@0 ]. "2 adjacent sides only" [ 9 ] -> [ 1@1 ]. [ 3 ] -> [ -1@1 ]. [ 12 ] -> [ 1@-1 ]. [ 6 ] -> [ -1@-1 ]. "2 opposite sides only" [ 10 ] -> [ 0@-1 ]. [ 5 ] -> [ 1@0 ]. "only 1 side" [ 8 ] -> [ -1@0 ]. [ 1 ] -> [ 0@-1 ]. [ 2 ] -> [ 1@0 ]. [ 4 ] -> [ 0@1 ]. "3 sides" [ 11 ] -> [ 0@1 ]. [ 13 ] -> [ 1@0 ]. [ 14 ] -> [ 0@-1 ]. [ 7 ] -> [ -1@0 ]. "all sides" [ 15 ] -> [ 1@-1 "move up and to the right" ]. }. ! ! !Morph methodsFor: '*connectors-labels' stamp: 'nk 4/14/2002 13:40'! relocateLabelFrom: aRectangle "Given a prospective label location, answer a new rectangle which doesn't overlap me" | newBounds nudge steps | newBounds _ aRectangle. steps _ aRectangle extent r truncated. [ (nudge _ self nudgeForLabel: newBounds) isZero or: [ steps < 0 ] ] whileFalse: [ newBounds _ newBounds translateBy: nudge. steps _ steps - 1 ]. steps < 0 ifTrue: [ ^aRectangle ]. ^ newBounds ! ! !Morph methodsFor: '*connectors-private' stamp: 'nk 3/11/2002 14:22'! connectConstraint: aConstraint | oldConstraints | oldConstraints _ self valueOfProperty: #connectedConstraints ifAbsentPut: [ WeakSet new ]. oldConstraints add: aConstraint.! ! !Morph methodsFor: '*connectors-private' stamp: 'nk 3/11/2002 14:48'! disconnectConstraint: aConstraint | oldConstraints | oldConstraints _ self valueOfProperty: #connectedConstraints ifAbsent: [ ^self ]. oldConstraints _ oldConstraints reject: [ :ea | ea == aConstraint or: [ ea isNil ]]. oldConstraints isEmpty ifTrue: [ self removeProperty: #connectedConstraints. ^self ]. self setProperty: #connectedConstraints toValue: oldConstraints.! ! !Morph methodsFor: '*connectors-private' stamp: 'nk 11/26/2002 11:24'! highlightForConnection: aBoolean | highlights | (self valueOfProperty: #isHighlight ifAbsent: [ false ]) ifTrue: [ ^self ]. highlights _ self valueOfProperty: #connectionHighlights ifAbsent: [ ]. self flag: #TODO. "use contrasting colors" aBoolean ifTrue: [ "self highlightForConnection: false." self setProperty: #highlightedForConnection toValue: aBoolean. highlights ifNil: [ | outerBorder aps pasteUp relativeFullBounds | pasteUp _ self pasteUpMorph. aps _ self attachmentPoints collect: [ :ea| self point: ea in: pasteUp ]. highlights _ OrderedCollection new: 4 + aps size. relativeFullBounds _ self bounds: self fullBounds in: pasteUp. outerBorder _ relativeFullBounds outsetBy: 3. highlights addAll: ({ (relativeFullBounds left @ outerBorder top) corner: (outerBorder right @ relativeFullBounds top) . (relativeFullBounds topRight) corner: (outerBorder bottomRight) . (outerBorder left @ relativeFullBounds bottom) corner: (relativeFullBounds right @ outerBorder bottom) . (outerBorder topLeft) corner: (relativeFullBounds bottomLeft) } collect: [ :rect | NCHighlightMorph new bounds: rect; color: (Color green alpha: 0.3); lock: true; yourself ]). highlights addAll: (aps collect: [ :ap | NCHighlightMorph new bounds: (Rectangle center: ap extent: 8@8); color: (Color blue alpha: 0.4); lock: true; yourself ]). "self pasteUpMorph addAllMorphs: highlights" highlights do: [ :ea | pasteUp addMorphFront: ea ]. self setProperty: #connectionHighlights toValue: highlights. ] ] ifFalse: [ highlights ifNotNil: [ self pasteUpMorph ifNotNilDo: [ :pu | pu deleteMorphs: highlights] ]. self removeProperty: #connectionHighlights. self removeProperty: #highlightedForConnection. self resetExtension ] ! ! !Morph methodsFor: '*connectors-private' stamp: 'nk 4/19/2002 11:11'! highlightedForConnection ^self valueOfProperty: #highlightedForConnection ifAbsent: [ false ] ! ! !Morph methodsFor: '*connectors-private' stamp: 'nk 11/26/2002 11:25'! isHighlight ^false! ! !Morph methodsFor: '*connectors-private' stamp: 'tk 12/11/2001 10:34'! privateAddMorph: aMorph atIndex: index | oldIndex myWorld itsWorld | ((index >= 1) and: [index <= (submorphs size + 1)]) ifFalse: [^ self error: 'index out of range']. myWorld _ self world. (aMorph owner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: ["aMorph's position changes within in the submorph chain" oldIndex < index ifTrue: ["moving aMorph to back" submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. submorphs at: index-1 put: aMorph] ifFalse: ["moving aMorph to front" oldIndex-1 to: index by: -1 do:[:i| submorphs at: i+1 put: (submorphs at: i)]. submorphs at: index put: aMorph]] ifFalse: ["adding a new morph" aMorph owner ifNotNil: [itsWorld _ aMorph world. itsWorld == myWorld ifFalse: [aMorph outOfWorld: itsWorld]. aMorph owner privateRemoveMorph: aMorph]. aMorph privateOwner: self. submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). itsWorld == myWorld ifFalse:[aMorph intoWorld: myWorld]]. self layoutChanged. myWorld ifNotNil: [self addedOrRemovedSubmorph: aMorph].! ! !Morph methodsFor: '*connectors-private' stamp: 'nk 6/30/2002 11:09'! setAttachmentPointsFromDisplayed "Read the positions of my displayed attachment points and (re) set my attachment points from them" | specs | specs _ self displayedAttachmentPoints collect: [ :a | a delete. a spec ]. self attachmentPointSpecs: specs. self preferredConnection: nil ! ! !Morph methodsFor: '*connectors-queries' stamp: 'nk 8/1/2002 12:56'! connectedConstraints "Answer the constraints that have me as an input" | retval | retval _ (self valueOfProperty: #connectedConstraints ifAbsent: [ ^EmptyArray ]) copy. retval _ retval reject: [ :ea | ea isNil ]. retval isEmpty ifTrue: [ self removeProperty: #connectedConstraints ]. ^retval! ! !Morph methodsFor: '*connectors-queries' stamp: 'nk 6/15/2002 18:13'! connectedMorphs "Answer all the morphs I am connected to (empty unless I'm a connector)" ^EmptyArray! ! !Morph methodsFor: '*connectors-queries' stamp: 'nk 3/11/2002 21:22'! connections "Answer the NCConnectorMorphs that are tied to me" ^ self connectedConstraints select: [ :ea | ea isLineConstraint ] thenCollect: [ :ea | ea drawingElement ]! ! !Morph methodsFor: '*connectors-queries' stamp: 'nk 6/15/2002 12:47'! connectionsAtAttachmentPoint: aPoint "Answer a collection of all the connections to the given point (if any)" | retval | retval _ Set new. self connections do: [ :connection | connection constraints do: [ :constraint | (constraint notNil and: [ self flag: #TODO. "coordinate transform" constraint lastTargetPoint asIntegerPoint = aPoint asIntegerPoint ]) ifTrue: [ retval add: connection ] ] ]. ^retval ! ! !Morph methodsFor: '*connectors-queries' stamp: 'nk 3/11/2002 14:13'! constraints "Answer a Set of all of my submorphs that are constraints" | retval | retval _ Set new. self allMorphsDo: [ :ea | ea isConstraint ifTrue: [ retval add: ea ] ]. ^retval! ! !Morph methodsFor: '*connectors-queries' stamp: 'nk 3/11/2002 21:58'! incomingConnections ^self connections select: [ :ea | ea endConnection == self ]! ! !Morph methodsFor: '*connectors-queries' stamp: 'nk 2/23/2001 13:42'! isConstraint ^false! ! !Morph methodsFor: '*connectors-queries' stamp: 'nk 3/11/2002 21:58'! outgoingConnections ^self connections select: [ :ea | ea startConnection == self ]! ! !Morph methodsFor: '*connectors-notifications' stamp: 'nk 7/12/2002 14:57'! connectedToBy: aConnector "notification upon connection by a NCConnectorMorph" ! ! !Morph methodsFor: '*connectors-notifications' stamp: 'nk 7/12/2002 14:56'! disconnectedFromBy: aConnector "notification upon disconnection by a NCConnectorMorph" ! ! !Morph methodsFor: '*connectors-submorphs-add/remove' stamp: 'nk 2/26/2001 23:50'! deleteMorphs: aCollection aCollection do: [ :ea | ea delete ]! ! !Morph methodsFor: '*connectors-submorphs-add/remove' stamp: 'nk 3/3/2001 11:35'! ensureMorph: front inFrontOf: back "Add a morph to the list of submorphs in front of the specified morph, but only if it isn't already in front. Assume that it is more common for newMorph to already be in front" | frontIndex | frontIndex _ 0. "front to back search" submorphs withIndexDo: [ :ea :i | ea == front ifTrue: [ frontIndex _ i ]. ea == back ifTrue: [ frontIndex = 0 ifFalse: [ ^self "already in front" ] ifTrue: [ ^self privateAddMorph: front atIndex: i ] ]. ]. ! ! !Morph methodsFor: '*connectors-structure' stamp: 'nk 12/12/2001 14:06'! noteNewOwner: aMorph "I have just been added as a submorph of aMorph"! ! !Morph methodsFor: '*skeleton-morph' stamp: 'tak 11/14/2003 17:41'! goalsStatus: aSymbol self flag: #TODO. "really need?" self assert: (#(#done #updating #error ) includes: aSymbol). ^ self setProperty: #goalStatus toValue: aSymbol! ! !BorderedMorph methodsFor: '*connectors-geometry' stamp: 'nk 4/5/2001 14:24'! closestPointTo: aPoint "account for round corners. Still has a couple of glitches at upper left and right corners" | pt | pt _ self bounds pointNearestTo: aPoint. self wantsRoundedCorners ifFalse: [ ^pt ]. self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in | (pt - out) abs < (6@6) ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ]. ]. ^pt.! ! !BorderedMorph methodsFor: '*connectors-geometry' stamp: 'nk 4/5/2001 14:23'! intersectionWithLineSegmentFromCenterTo: aPoint "account for round corners. Still has a couple of glitches at upper left and right corners" | pt | pt _ super intersectionWithLineSegmentFromCenterTo: aPoint. self wantsRoundedCorners ifFalse: [ ^pt ]. self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in | (pt - out) abs < (6@6) ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ]. ]. ^pt.! ! !BookMorph methodsFor: '*connectors-attachments-nk' stamp: 'nk 6/13/2002 09:33'! isConnectable "Answer whether I will accept connections from ConnectorMorphs" ^false! ! !EllipseMorph methodsFor: '*connectors-geometry' stamp: 'nk 2/27/2001 13:06'! bottomLeft ^self intersectionWithLineSegmentFromCenterTo: bounds bottomLeft ! ! !EllipseMorph methodsFor: '*connectors-geometry' stamp: 'nk 2/27/2001 13:06'! bottomRight ^self intersectionWithLineSegmentFromCenterTo: bounds bottomRight ! ! !EllipseMorph methodsFor: '*connectors-geometry' stamp: 'nk 2/15/2001 16:08'! closestPointTo: aPoint ^self intersectionWithLineSegmentFromCenterTo: aPoint! ! !EllipseMorph methodsFor: '*connectors-geometry' stamp: 'nk 2/13/2001 18:16'! intersectionWithLineSegmentFromCenterTo: aPoint | dx aSquared bSquared m mSquared xSquared x y dy | (self containsPoint: aPoint) ifTrue: [ ^aPoint ]. dx _ aPoint x - self center x. dy _ aPoint y - self center y. dx = 0 ifTrue: [ ^self bounds pointNearestTo: aPoint ]. m _ dy / dx. mSquared _ m squared. aSquared _ (self bounds width / 2) squared. bSquared _ (self bounds height / 2) squared. xSquared _ 1 / ((1 / aSquared) + (mSquared / bSquared)). x _ xSquared sqrt. dx < 0 ifTrue: [ x _ x negated ]. y _ m * x. ^ self center + (x @ y) asIntegerPoint. ! ! !EllipseMorph methodsFor: '*connectors-geometry' stamp: 'nk 2/27/2001 13:06'! topLeft ^self intersectionWithLineSegmentFromCenterTo: bounds topLeft ! ! !EllipseMorph methodsFor: '*connectors-geometry' stamp: 'nk 2/27/2001 13:06'! topRight ^self intersectionWithLineSegmentFromCenterTo: bounds topRight ! ! !CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 07:04'! addFlexShellIfNecessary "When scaling or rotating from a halo, I can do this without a flex shell" ^ self ! ! !CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 16:29'! privateMoveBy: delta self setProperty: #referencePosition toValue: self referencePosition + delta. self setProperty: #originalCenter toValue: (self valueOfProperty: #originalCenter ifAbsent: [ self center ]) + delta. super privateMoveBy: delta. ! ! !CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 07:28'! rotationDegrees ^ self forwardDirection! ! !CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 15:52'! rotationDegrees: degrees | ref newPos flex origAngle origCenter | ref _ self referencePosition. origAngle _ self valueOfProperty: #originalAngle ifAbsentPut: [ self heading ]. origCenter _ self valueOfProperty: #originalCenter ifAbsentPut: [ self center ]. flex _ (MorphicTransform offset: ref negated) withAngle: (degrees - origAngle) degreesToRadians. newPos _ (flex transform: origCenter) - flex offset. self position: (self position + newPos - self center) asIntegerPoint. self setProperty: #referencePosition toValue: ref. self setProperty: #originalAngle toValue: origAngle. self setProperty: #originalCenter toValue: origCenter. self forwardDirection: degrees. self changed. ! ! !CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 07:01'! bounds: aRectangle | size | size _ aRectangle width min: aRectangle height. super bounds: (Rectangle origin: aRectangle origin extent: size @ size).! ! !CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 16:39'! extent: aPoint | size oldRotationCenter | oldRotationCenter _ self rotationCenter. size _ aPoint x min: aPoint y. super extent: size @ size. self rotationCenter: oldRotationCenter.! ! !CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 08:49'! transformedBy: aTransform aTransform isIdentity ifTrue:[^self]. ^self center: (aTransform localPointToGlobal: self center). ! ! !CircleMorph methodsFor: 'connection' stamp: 'nk 7/1/2002 07:21'! endShapeColor: aColor self borderColor: aColor. self fillStyle isTransparent ifFalse: [ self color: aColor ].! ! !CircleMorph methodsFor: 'connection' stamp: 'nk 7/1/2002 16:08'! endShapeWidth: anInteger | oldLineAttachment oldRotationCenter | oldLineAttachment _ self lineAttachmentOffset. oldRotationCenter _ self rotationCenter. super endShapeWidth: anInteger. self lineAttachmentOffset: oldLineAttachment. self rotationCenter: oldRotationCenter. ! ! !CircleMorph methodsFor: 'geometry eToy' stamp: 'nk 7/1/2002 07:12'! heading: newHeading "Set the receiver's heading (in eToy terms). Note that circles never use flex shells." self rotationDegrees: newHeading.! ! !CircleMorph methodsFor: 'geometry eToy' stamp: 'nk 7/1/2002 07:31'! referencePosition "Return the current reference position of the receiver" ^ self valueOfProperty: #referencePosition ifAbsent: [ self center ] ! ! !CircleMorph methodsFor: 'geometry eToy' stamp: 'nk 7/1/2002 11:16'! rotationCenter "Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." | refPos | refPos _ self referencePosition. ^ (refPos - self bounds origin) / self bounds extent asFloatPoint! ! !CircleMorph methodsFor: 'geometry eToy' stamp: 'nk 7/1/2002 13:48'! rotationCenter: aPointOrNil "Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." | newRef box | aPointOrNil isNil ifTrue: [self removeProperty: #referencePosition. self removeProperty: #originalCenter. self removeProperty: #originalAngle. ] ifFalse: [ box _ self bounds. newRef _ box origin + (aPointOrNil * box extent). self setRotationCenterFrom: newRef ]. ! ! !CircleMorph methodsFor: 'parts bin' stamp: 'nk 7/1/2002 16:42'! initializeToStandAlone ^super initializeToStandAlone extent: 40@40; color: Color green lighter; yourself! ! !CircleMorph methodsFor: 'menus' stamp: 'nk 7/1/2002 11:30'! setRotationCenterFrom: aPoint "Called by halo rotation code. Circles store their referencePosition." self setProperty: #referencePosition toValue: aPoint. self setProperty: #originalCenter toValue: self center. self setProperty: #originalAngle toValue: self heading.! ! !CircleMorph class methodsFor: 'as yet unclassified' stamp: 'nk 7/1/2002 07:38'! descriptionForPartsBin ^ self partName: 'Circle' categories: #('Graphics' ' Basic 1 ') documentation: 'A circular shape'! ! !HardnessSliderMorph methodsFor: 'initialization' stamp: 'tak 11/22/2003 17:08'! initialize "HardnessSliderMorph new openInHand" | slider | super initialize. self layoutPolicy: TableLayout new; listDirection: #leftToRight; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 0. slider := SimpleSliderMorph new extent: 150 @ 10; color: (Color r: 0.742 g: 0.806 b: 1.0); sliderColor: Color gray; target: self; actionSelector: #hardness:; value: SkeletonConstantLineMorph defaultHardness. slider addMorph: ((UpdatingStringMorph on: self selector: #hardnessLabel) position: slider position; lock). self addMorph: slider! ! !HardnessSliderMorph methodsFor: 'accessing' stamp: 'tak 11/23/2003 17:45'! hardness ^ self pasteUpMorph ifNil: [SkeletonConstantLineMorph defaultHardness] ifNotNil: [self pasteUpMorph hardness ifNil: [SkeletonConstantLineMorph defaultHardness]]! ! !HardnessSliderMorph methodsFor: 'accessing' stamp: 'tak 11/17/2003 08:13'! hardness: aNumber ^ self pasteUpMorph ifNotNilDo: [:p | p hardness: aNumber]! ! !HardnessSliderMorph methodsFor: 'accessing' stamp: 'tak 11/17/2003 08:13'! hardnessLabel ^ 'hardness: ' , (self hardness roundTo: 0.01) asString! ! !MicMorph methodsFor: 'parts bin' stamp: 'tak 11/16/2003 20:58'! initializeToStandAlone super initializeToStandAlone. self extent: 32@32. self borderWidth: 10. self color: (Color r: 1.0 g: 0.2 b: 0.0). self borderColor: (TranslucentColor r: 1.0 g: 0.4 b: 0.0 alpha: 0.5).! ! !MicMorph methodsFor: 'initialization' stamp: 'tak 10/23/2003 00:40'! initialize super initialize. isListening _ false! ! !MicMorph methodsFor: 'accessing' stamp: 'tak 10/23/2003 00:36'! isListening ^ isListening! ! !MicMorph methodsFor: 'accessing' stamp: 'tak 10/23/2003 00:36'! isListening: aBoolean isListening _ aBoolean. isListening ifTrue: [self start] ifFalse: [self stop]! ! !MicMorph methodsFor: 'stepping and presenter' stamp: 'tak 10/23/2003 00:41'! step isListening ifTrue: [self tone. self volume]! ! !MicMorph methodsFor: 'stepping and presenter' stamp: 'tak 10/23/2003 19:52'! stepTime ^100! ! !MicMorph methodsFor: 'private' stamp: 'tak 10/23/2003 00:24'! start | m | m _ SoundInputStream new. m samplingRate: 22050. m startRecording. mic _ m! ! !MicMorph methodsFor: 'private' stamp: 'tak 10/23/2003 00:24'! stop " Send this message before to save project " mic stopRecording. ^ mic _ nil! ! !MicMorph methodsFor: 'private' stamp: 'tak 10/22/2003 23:55'! tone | m count buf | count _ 0. m _ mic. "skip to the most recent buffer" [m bufferCount > 2] whileTrue: [m nextBufferOrNil]. m bufferCount = 2 ifTrue: [buf _ m nextBufferOrNil , m nextBufferOrNil. buf inject: 0 into: [:prev :next | prev * next < 0 ifTrue: [count _ count + 1]. next]]. self y: count! ! !MicMorph methodsFor: 'private' stamp: 'tak 10/23/2003 00:49'! volume self x: mic meterLevel * 5! ! !MicMorph class methodsFor: 'scripting' stamp: 'tak 11/16/2003 20:41'! additionsToViewerCategories ^#(( mic ( (slot listening 'Set true when using, Set false when save this porject' Boolean readWrite Player getListning Player setListening:) ) )) ! ! !MicMorph class methodsFor: 'parts bin' stamp: 'tak 11/16/2003 20:51'! descriptionForPartsBin ^ self partName: 'Mic sensor' categories: #('Multimedia') documentation: 'A mic sensor'! ! !NCAttachmentPointAdjuster methodsFor: 'stepping and presenter' stamp: 'nk 6/30/2002 10:27'! aboutToBeGrabbedBy: aHand self center: aHand cursorPoint. ^super aboutToBeGrabbedBy: aHand! ! !NCAttachmentPointAdjuster methodsFor: 'stepping and presenter' stamp: 'nk 6/30/2002 11:33'! justDroppedInto: aMorph event: evt | griddedPos | ((aMorph ~~ target pasteUpMorph) or: [ (aMorph isKindOf: NCAttachmentPointAdjusterWindow) not ]) ifTrue: [ ^self delete ]. griddedPos _ self griddedPoint: evt position. self center ~= griddedPos ifTrue: [ self center: griddedPos ]. ! ! !NCAttachmentPointAdjuster methodsFor: 'initialization' stamp: 'nk 4/17/2002 22:47'! initialize super initialize. self extent: 8@8. self color: Color transparent. self borderColor: (Color red alpha: 0.5). ! ! !NCAttachmentPointAdjuster methodsFor: 'initialization' stamp: 'nk 6/14/2002 16:46'! originalPosition ^target localPointToGlobal: (target perform: originalSpec first withArguments: (originalSpec allButFirst) asArray). ! ! !NCAttachmentPointAdjuster methodsFor: 'initialization' stamp: 'nk 4/25/2001 21:38'! originalSpec: spec target: aMorph originalSpec _ spec. target _ aMorph. self center: self originalPosition! ! !NCAttachmentPointAdjuster methodsFor: 'initialization' stamp: 'nk 6/30/2002 12:28'! spec self center = self originalPosition ifTrue: [ ^originalSpec ]. target defaultAttachmentPointSpecs do: [ :spec | self center = (target perform: spec first withArguments: spec allButFirst) asIntegerPoint ifTrue: [ ^spec ]. ]. ^{ #pointAtOffset: . (((target globalPointToLocal: self center) - target position) / target extent) asFloatPoint }. ! ! !NCAttachmentPointAdjuster methodsFor: 'initialization' stamp: 'nk 4/25/2001 21:25'! target ^target! ! !NCAttachmentPointAdjuster methodsFor: 'visual properties' stamp: 'nk 4/25/2001 21:47'! nudgeHorizontally "If I am close to an important horizontal position, move myself there" #(top centerY bottom) do: [ :sym | | y | y _ target perform: sym. (self centerY - y) abs < 4 ifTrue: [ ^self center: (self centerX @ y) ] ]! ! !NCAttachmentPointAdjuster methodsFor: 'visual properties' stamp: 'nk 4/25/2001 21:47'! nudgeVertically "If I am close to an important vertical position, move myself there" #(left centerX right) do: [ :sym | | x | x _ target perform: sym. (self centerX - x) abs < 4 ifTrue: [ ^self center: (x @ self centerY) ] ]! ! !NCAttachmentPointAdjuster methodsFor: 'copying' stamp: 'nk 4/25/2001 21:50'! veryDeepFixupWith: aCopier super veryDeepFixupWith: aCopier. target _ aCopier references at: target ifAbsent: [ target ]. ! ! !NCAttachmentPointAdjuster methodsFor: 'copying' stamp: 'nk 4/25/2001 21:30'! veryDeepInner: aCopier super veryDeepInner: aCopier. target _ target. ! ! !NCAttachmentPointAdjuster class methodsFor: 'new morph menu' stamp: 'nk 6/15/2002 15:54'! includeInNewMorphMenu ^false! ! !NCConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 6/15/2002 13:23'! absolutePoint: p whileConnectedTo: m "This returns a point in my coordinate system, not m's" ^p! ! !NCConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 2/21/2002 18:37'! atSpec: s on: m ^m perform: s first withArguments: s allButFirst asArray.! ! !NCConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 2/15/2002 12:30'! centerOf: m ^m center! ! !NCConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 2/15/2002 12:31'! cursorPointOf: m ^m lastEvent position! ! !NCConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 6/15/2002 13:17'! nearestAttachmentPointOn: m ^m attachmentPointNearest: (self point: self center relativeTo: m)! ! !NCConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 6/15/2002 13:24'! nearestPointOn: m ^m closestPointTo: (self point: self center relativeTo: m)! ! !NCConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 6/15/2002 13:24'! nearestPointToCenterOf: m ^m intersectionWithLineSegmentFromCenterTo: (self point: self center relativeTo: m)! ! !NCConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 6/15/2002 13:53'! point: aPoint relativeTo: morph | world mtfm ctfm | world _ self world. ctfm _ self transformFrom: world. mtfm _ morph transformFrom: world. ^mtfm globalPointToLocal: (ctfm localPointToGlobal: aPoint)! ! !NCConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 2/15/2002 12:23'! positionRelative: relPoint to: m ^m topLeft + relPoint! ! !NCConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 2/21/2002 18:22'! vertexNumbered: ix of: m ^m vertexAt: ix! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 4/8/2001 13:30'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine; add: 'attach to...' action: #attachToSelectedMorph:; add: 'display attachments' action: #displayInputs; addLine; add: 'add arbitrary shape...' target: self selector: #addSelectedMorph:. self class preMadeShapeNames isEmpty ifFalse: [ aCustomMenu add: 'add pre-made shape...' subMenu: self selectShapeMenu ]. aCustomMenu add: 'delete shape...' target: self selector: #deleteSelectedMorph:; addLine. #( connectToCenter connectToNearestAttachmentPoint connectToNearestPoint connectToNearestPointToCenter "connectToAbsolutePoint:" connectToRelativePoint: noConnectionPreference ) do: [ :sel | aCustomMenu addUpdating: #connectionWordingFor: target: self selector: #choosePreferredConnection: argumentList: { sel }. ]. self dieWithInput ifFalse: [ aCustomMenu addUpdating: #connectionWordingFor: target: self selector: #choosePreferredConnection: argumentList: #( connectToNothing ). ]. ! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 4/7/2001 22:24'! addSelectedMorph: anEvent "Allow the user to select a new submorph and add it to me" | hand handle | hand _ anEvent hand. handle _ NewHandleMorph new followHand: hand forEachPointDo: [ :newPoint | ] lastPointDo: [ :newPoint | | targets choice | targets _ (self world morphsAt: newPoint) copyWithoutAll: { self . handle }. targets _ targets reject: [ :ea | ea isPlayfieldLike ]. targets isEmpty ifFalse: [ "choice _ targets size = 1 ifTrue: [ 1 ] ifFalse: [ (PopUpMenu labelArray: (targets collect: [ :ea | ea name ])) startUpWithCaption: 'Select Morph' ]. choice > 0 ifTrue: [ self addShape: (targets at: choice) ]" self addShape: targets first. self layoutChanged; changed. ]. ]. anEvent hand attachMorph: handle. handle startStepping.! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 6/20/2002 13:31'! addYellowButtonMenuItemsTo: aMenu event: evt | event | event _ (evt isKindOf: UserInputEvent) ifTrue: [ evt ] ifFalse: [ ActiveEvent ]. aMenu defaultTarget: self; addStayUpItem; add: 'resize' target: self selector: #resizeMorph: argument: event; add: 'attach to...' target: self selector: #attachToSelectedMorph:; add: 'properties...' target: self selector: #openAPropertySheet; add: 'display attachments' target: self selector: #displayInputs; addLine; add: 'add arbitrary shape...' target: self selector: #addSelectedMorph:. self class preMadeShapeNames isEmpty ifFalse: [ aMenu add: 'add pre-made shape...' subMenu: self selectShapeMenu ]. aMenu addWithLabel: 'delete shape...' enablement: #hasSubmorphs action: #deleteSelectedMorph:; addLine. self connectionsInMenu do: [ :sel | aMenu addUpdating: #connectionWordingFor: target: self selector: #choosePreferredConnection: argumentList: { sel }. ]. self dieWithInput ifFalse: [ aMenu addUpdating: #connectionWordingFor: target: self selector: #choosePreferredConnection: argumentList: #( connectToNothing ). ]. ! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 4/7/2001 17:50'! attachToSelectedMorph: anEvent "Allow the user to select a new input" | handle targets highlights | highlights _ self highlightInputs. handle _ NewHandleMorph new followHand: anEvent hand forEachPointDo: [ :newPoint | ] lastPointDo: [ :newPoint | | localPoint choice | localPoint _ self globalPointToLocal: newPoint. highlights do: [ :ea | ea delete ]. targets _ self connectionTargetsAt: localPoint. targets _ targets copyWithout: handle. targets isEmpty ifTrue: [ self connectToAbsolutePoint: localPoint ] ifFalse: [ choice _ targets size = 1 ifTrue: [ 1 ] ifFalse: [ (PopUpMenu labelArray: (targets collect: [ :ea | ea name ])) startUpWithCaption: 'Select Morph' ]. choice > 0 ifTrue: [ self attachUnobnoxiouslyTo: (targets at: choice) at: localPoint ] ]. ]. anEvent hand attachMorph: handle. handle startStepping.! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 4/5/2001 17:19'! choosePreferredConnection: sel "To be called from a menu choice (thus the user interaction). Sel should take 0 or 1 argument, or be nil" "if nil, forget my preference, and change my constraintBlock" ((sel == #noConnectionPreference) or: [ sel isNil ]) ifTrue: [ self preferredConnection: nil. self input ifNil: [ ^self ]. ^self attachTo: self input at: self center ]. (sel numArgs = 1) ifTrue: [ self selectPointWith: (self currentHand) thenDo: [ :pt | self anchorPreferredConnection: sel at: pt ]. ] ifFalse: [ self preferredConnection: { sel }. self perform: sel ].! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 4/5/2001 17:26'! connectionWordingFor: sel "sel is the desired menu choice" | str selector | selector _ self preferredConnection ifNotNilDo: [ :pc | pc first ]. (sel == #connectToNothing) ifTrue: [ ^(selector == #connectToNothing) ifTrue: [ 'connect to nothing' ] ifFalse: [ 'connect to nothing' ] ]. (sel == #noConnectionPreference) ifTrue: [ ^selector ifNil: [ 'no connection preference' ] ifNotNil: [ 'no connection preference' ] ]. str _ (sel = selector) ifTrue: [ '' ] ifFalse: [ '' ]. str _ str, (sel splitOnCapBoundaries). ^str! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 6/20/2002 13:31'! connectionsInMenu "Answer a collection of the connection types that should appear in my menu" ^#( connectToCenter connectToNearestAttachmentPoint connectToNearestPoint connectToNearestPointToCenter connectToRelativePoint: noConnectionPreference )! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 4/8/2001 12:22'! deleteSelectedMorph: anEvent "Allow the user to delete one of my submorphs, if any." | choice | submorphs isEmpty ifTrue: [ ^self ]. submorphs size = 1 ifTrue: [ ^self deleteShape: submorphs first ]. choice _ (PopUpMenu labelArray: (submorphs collect: [ :ea | ea externalName ])) startUpWithCaption: 'Select Morph'. choice > 0 ifTrue: [ self deleteShape: (submorphs at: choice) ].! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 4/18/2001 11:05'! deleteShape: aMorph aMorph delete. self forceRedraw. self step.! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 2/26/2001 23:53'! displayInputs | highlights | highlights _ self highlightInputs. self addAlarm: #deleteMorphs: with: highlights after: 2000! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 3/2/2001 18:33'! selectPointWith: aHand thenDo: aBlock "Allow the user to select a point, then pass the point to aBlock. aBlock might never get called, if the handle gets deleted." | handle | handle _ NewHandleMorph new followHand: aHand forEachPointDo: [ :newPoint | ] lastPointDo: aBlock. aHand attachMorph: handle. handle startStepping.! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 7/12/2002 18:50'! selectShapeMenu | menu | menu _ MenuMorph new layoutPolicy: TableLayout new. self class preMadeShapeNames do: [ :ea | | morph text ix mm sm | morph _ self class perform: ea. ix _ ea findString: 'Shape' startingAt: 1. ix _ ix = 0 ifTrue: [ ea size ] ifFalse: [ ix - 1 ]. text _ (ea copyFrom: 1 to: ix) splitOnCapBoundaries. (mm _ MenuItemMorph new) layoutPolicy: TableLayout new; listDirection: #leftToRight; layoutInset: 3@3; wrapCentering: #topLeft; hResizing: #spaceFill; vResizing: #shrinkWrap; contents: ' '; target: self; selector: #addShape: ; arguments: { morph }. "The SketchMorph here is because my PolygonMorphs were getting stretched." sm _ SketchMorph withForm: morph imageForm. mm addMorphBack: sm. sm heading: -90. mm addMorphBack: AlignmentMorph newVariableTransparentSpacer. mm addMorphBack: ((StringMorph contents: text) font: Preferences standardMenuFont). menu addMorphBack: mm. ]. ^menu! ! !NCConstraintMorph methodsFor: 'menus' stamp: 'nk 4/28/2002 09:34'! yellowButtonActivity: evt | aMenu event | event _ (evt isKindOf: UserInputEvent) ifTrue: [ evt ] ifFalse: [ ActiveEvent ]. aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: self externalName. self addYellowButtonMenuItemsTo: aMenu event: event. aMenu popUpInWorld: World ! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 6/18/2002 11:48'! addShape: aMorph | newMorph | aMorph ifNil: [ ^self ]. newMorph _ aMorph duplicate center: self center. newMorph endShapeColor: self endShapeColor. self addMorphFront: newMorph. self forceRedraw. ^newMorph! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 6/17/2002 16:28'! applyConstraint: aPoint self center ~= aPoint ifTrue: [ self isFlexed ifTrue: [ owner center: (self point: aPoint in: self pasteUpMorph) ] ifFalse: [ self center: aPoint ] ]! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 6/17/2002 16:32'! connectionTargetsAt: localPoint ^(self pasteUpMorph rootMorphsAt: (self point: localPoint in: self pasteUpMorph)) reject: [ :ea | ea isHighlight ]. ! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 4/17/2001 15:23'! constrained "Answer the morph that I constrain, or self if none" ^constrained ifNil: [ self ]! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 2/13/2001 14:04'! constrained: anObject constrained _ anObject! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 2/23/2002 13:18'! constraint: aBlockOrMessageSend "aBlock is passed self and all of my inputs (some of which could be nil). It should return a Point" constraint := (aBlockOrMessageSend isKindOf: BlockContext) ifTrue: [self error: 'BlockContexts aren''t used anymore'] ifFalse: [aBlockOrMessageSend]. aBlockOrMessageSend ifNotNil: [self startStepping]! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 4/8/2001 16:18'! defaultTargetPoint ^self center! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 2/26/2001 22:26'! firstInput | ips | ips _ self inputs. ^ips isEmpty ifTrue: [ ] ifFalse: [ ips first ] ! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 2/23/2001 14:35'! hasAnyInputIn: aCollection ^inputs includesAnyOf: aCollection! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 6/13/2002 09:42'! hasAnyInputs ^inputs notNil and: [inputs anySatisfy: [:ea | ea ~~ nil ]] ! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 2/23/2001 13:44'! hasInput: anObject ^inputs includes: anObject! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 2/15/2002 12:42'! input ^inputs at: 1 ifAbsent: []! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 2/23/2001 16:20'! input: anObject self inputs: { anObject }! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 2/15/2002 12:42'! inputs ^inputs reject: [:ea | ea isNil]! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 3/11/2002 14:12'! inputs: aCollection "aCollection consists of objects that I derive my target from" inputs do: [ :ea | ea ifNotNil: [ ea disconnectConstraint: self ]]. inputs := WeakArray withAll: aCollection. inputs do: [ :ea | ea ifNotNil: [ ea connectConstraint: self ]]. self startStepping! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 3/31/2002 10:39'! needsToApplyConstraintGivenNewTarget: newTarget "newTarget has just been returned by 'self target'. Do I have to apply the constraint? If I return true, applyConstraint: will be called." ^lastTarget ~= newTarget! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 4/8/2001 11:15'! target ^self targetPoint! ! !NCConstraintMorph methodsFor: 'constraints' stamp: 'nk 6/15/2002 13:13'! targetPoint | pt | (constraint isNil or: [self hasAnyInputs not]) ifTrue: [^self defaultTargetPoint]. "call target block" pt := constraint valueWithEnoughArguments: (Array withAll: inputs). "transform point" pt _ (self input isMorph ifTrue: [self globalPointToLocal: (self input localPointToGlobal: pt)] ifFalse: [self globalPointToLocal: pt]) asIntegerPoint. ^ "self griddedPoint:" pt ! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 6/12/2002 08:10'! anchorPreferredConnection: sel at: aPoint "this is called at the end of the user selection of a relative or absolute preferred connection point" | target targets | targets _ (self pasteUpMorph rootMorphsAt: aPoint) reject: [ :ea | (ea isKindOf: HandleMorph) or: [ ea == owner or: [ ea == self or: [ (self allMorphs includes: ea) or: [ (ea isConstrainedBy: self) ] ] ] ] ]. target _ targets isEmpty ifTrue: [ self pasteUpMorph ] ifFalse: [ targets first ]. ^self anchorPreferredConnection: sel to: target at: aPoint! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 6/15/2002 12:57'! anchorPreferredConnection: sel to: target at: aPoint "this is called at the end of the user selection of a relative or absolute preferred connection point. Answer my new preferredConnection." | relPoint pref | relPoint _ aPoint - (self globalPointToLocal: (target localPointToGlobal: (target topLeft))). self input: target. self preferredConnection: (pref _ { sel . relPoint }). self perform: sel with: relPoint. ^pref ! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 2/22/2002 17:58'! connectTo: m atVertexNumber: ix self constraint: (MessageSend receiver: self selector: #vertexNumbered:of: argument: ix) ! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 2/22/2002 17:58'! connectToAbsolutePoint: aPoint self constraint: (MessageSend receiver: self selector: #absolutePoint:whileConnectedTo: argument: aPoint)! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 2/22/2002 17:59'! connectToCenter self constraint: (MessageSend receiver: self selector: #centerOf:) ! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 2/22/2002 17:59'! connectToCursorPoint self constraint: (MessageSend receiver: self selector: #cursorPointOf:) ! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 9/15/2002 14:22'! connectToMorph: m usingSpec: s self input: m. self constraint: (MessageSend receiver: self selector: #atSpec:on: argument: s) "self constraint: (MessageSend receiver: m selector: s first arguments: s allButFirst)"! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 2/22/2002 17:59'! connectToNearestAttachmentPoint self constraint: (MessageSend receiver: self selector: #nearestAttachmentPointOn:) ! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 2/22/2002 17:59'! connectToNearestPoint self constraint: (MessageSend receiver: self selector: #nearestPointOn:)! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 2/22/2002 17:59'! connectToNearestPointToCenter self constraint: (MessageSend receiver: self selector: #nearestPointToCenterOf:)! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 2/22/2002 17:59'! connectToNothing self input: nil. self constraint: nil.! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 2/22/2002 17:59'! connectToRelativePoint: relPoint self constraint: (MessageSend receiver: self selector: #positionRelative:to: argument: relPoint). ! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 6/22/2002 17:55'! connectUsingSpec: s self constraint: (MessageSend receiver: self selector: #atSpec:on: argument: s) ! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 3/3/2001 15:20'! reAnchorPreferredConnectionAt: aPoint "Answer my preferredConnection, if any" | pref | (pref _ self preferredConnection) ifNil: [ ^nil ]. pref first numArgs = 0 ifTrue: [ ^pref ]. ^self anchorPreferredConnection: pref first at: aPoint. ! ! !NCConstraintMorph methodsFor: 'connection' stamp: 'nk 3/3/2001 15:19'! reAnchorPreferredConnectionTo: aMorph at: aPoint "Answer my preferredConnection, if any" | pref | (pref _ self preferredConnection) ifNil: [ ^nil ]. pref first numArgs = 0 ifTrue: [ ^pref ]. ^self anchorPreferredConnection: pref first to: aMorph at: aPoint.! ! !NCConstraintMorph methodsFor: 'attachments-nk' stamp: 'nk 6/16/2002 07:58'! attachTo: aMorph at: aPoint "aPoint is in my coordinate system" "Precedence of preferences: 1. My preference 2. aMorph's preference 3. aMorph's default " | pref | self stopStepping. aMorph == self ifTrue: [ ^self ]. "ignore these" self input: aMorph. pref _ self reAnchorPreferredConnectionTo: aMorph at: aPoint. (pref isNil or: [ pref first == #noConnectionPreference ]) ifTrue: [ pref _ aMorph preferredConnection. pref ifNotNil: [ self perform: pref first withArguments: pref allButFirst ] ifNil: [ aMorph attachFrom: self at: (aMorph globalPointToLocal: (self localPointToGlobal: aPoint)) ] ] ifFalse: [ self perform: pref first withArguments: pref allButFirst ]. self startStepping. ! ! !NCConstraintMorph methodsFor: 'attachments-nk' stamp: 'nk 2/27/2001 08:46'! attachUnobnoxiouslyTo: aMorph at: aPoint self attachTo: aMorph at: aPoint.! ! !NCConstraintMorph methodsFor: 'attachments-nk' stamp: 'nk 4/18/2001 11:45'! endShapeColor ^self valueOfProperty: #endShapeColor ifAbsent: [ owner ifNotNil: [ owner color ] ifNil: [ Color black ] ].! ! !NCConstraintMorph methodsFor: 'attachments-nk' stamp: 'nk 4/18/2001 11:45'! endShapeColor: aColor self submorphsDo: [ :ea | ea allMorphsDo: [ :sm | sm endShapeColor: aColor ] ]. self setProperty: #endShapeColor toValue: aColor.! ! !NCConstraintMorph methodsFor: 'attachments-nk' stamp: 'nk 6/18/2002 10:41'! endShapeWidth: aWidth self submorphsDo: [ :ea | ea allMorphsDo: [ :sm | sm endShapeWidth: aWidth ] ]. self computeLineAttachmentPoint. self forceRedraw.! ! !NCConstraintMorph methodsFor: 'attachments-nk' stamp: 'nk 2/23/2001 13:42'! isConstraint ^true! ! !NCConstraintMorph methodsFor: 'accessing' stamp: 'nk 11/26/2002 11:26'! beAdjacent ^false! ! !NCConstraintMorph methodsFor: 'accessing' stamp: 'nk 2/23/2002 13:18'! constraint ^constraint! ! !NCConstraintMorph methodsFor: 'accessing' stamp: 'nk 4/18/2002 18:02'! dieWithInput ^dieWithInput! ! !NCConstraintMorph methodsFor: 'accessing' stamp: 'nk 4/18/2002 18:01'! dieWithInput: aBoolean "If aBoolean is true, make sure that I delete myself when my input goes away" dieWithInput _ aBoolean! ! !NCConstraintMorph methodsFor: 'object fileIn' stamp: 'nk 4/19/2002 10:07'! convertToCurrentVersion self convertToMessageSend. dieWithInput ifNil: [ dieWithInput _ (self valueOfProperty: #dieWithInput ifAbsent: [ false ]). self removeProperty: #dieWithInput. ]. ! ! !NCConstraintMorph methodsFor: 'object fileIn' stamp: 'nk 4/19/2002 10:12'! convertToCurrentVersion: varDict refStream: smartRefStrm "I renamed targetBlock to constraint to catch these conversions." varDict at: 'targetBlock' ifPresent: [:b | constraint := b ]. self convertToCurrentVersion. ^super convertToCurrentVersion: varDict refStream: smartRefStrm ! ! !NCConstraintMorph methodsFor: 'object fileIn' stamp: 'nk 10/21/2002 10:07'! convertToMessageSend "If I have an old-style (i.e. BlockContext) constraintBlock, convert it if possible to a MessageSend that does the same thing" | pc | (constraint isKindOf: MessageSend) ifTrue: [^self]. "already converted" self input == self ifTrue: [inputs := inputs allButFirst]. (constraint isNil or: [inputs isEmpty or: [self input isNil]]) ifTrue: [self connectToNothing. ^self]. pc := self preferredConnection. pc ifNil: [self attachTo: self input at: self center] ifNotNil: [self perform: pc first withArguments: pc allButFirst]! ! !NCConstraintMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 2/23/2002 13:18'! delete constrained := nil. constraint := nil. super delete! ! !NCConstraintMorph methodsFor: 'testing' stamp: 'nk 3/11/2002 21:16'! drawingElement "Answer the drawing element that I constrain, typically either a Connector or a label" ^owner! ! !NCConstraintMorph methodsFor: 'testing' stamp: 'nk 2/27/2001 13:02'! isLabelConstraint ^false! ! !NCConstraintMorph methodsFor: 'testing' stamp: 'nk 2/27/2001 13:01'! isLineConstraint ^false! ! !NCConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 6/17/2002 17:07'! ensureInFront "Make sure that I am in front of my input." | meInWorld input inputInWorld pu | ((input _ self input) isNil) ifTrue: [ ^self ]. inputInWorld _ input isFlexed ifTrue: [ input owner ] ifFalse: [ input ]. meInWorld _ self isFlexed ifTrue: [ owner ] ifFalse: [ self ]. (meInWorld boundsInWorld intersects: (inputInWorld boundsInWorld)) ifFalse: [ ^self ]. ((pu _ meInWorld pasteUpMorph) isNil or: [ pu ~= inputInWorld pasteUpMorph ]) ifTrue: [ ^self ]. pu ensureMorph: meInWorld inFrontOf: inputInWorld. ! ! !NCConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 6/17/2002 20:29'! forceRedraw self changed; layoutChanged. lastTarget _ 0@0.! ! !NCConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 3/2/2001 16:17'! incrementStepTime stepTime _ (stepTime + 1) min: self maximumStepTime! ! !NCConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 3/2/2001 16:20'! maximumStepTime ^200! ! !NCConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 3/2/2001 15:47'! minimumStepTime ^20! ! !NCConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 3/31/2002 10:38'! step | newTarget | self hasAnyInputs ifFalse: [constraint ifNotNil: [constraint := nil. self changed]. self dieWithInput ifTrue: [^self delete]]. newTarget := self target. (self needsToApplyConstraintGivenNewTarget: newTarget) ifTrue: [self applyConstraint: newTarget. lastTarget := newTarget. stepTime := self minimumStepTime] ifFalse: [self incrementStepTime]! ! !NCConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 3/2/2001 15:47'! stepTime ^stepTime! ! !NCConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 3/2/2001 15:46'! stepTime: mSecsPerStep stepTime _ mSecsPerStep truncated. ! ! !NCConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 2/23/2002 13:18'! wantsSteps ^constraint notNil! ! !NCConstraintMorph methodsFor: 'WiW support' stamp: 'nk 4/5/2001 17:56'! fixMorphicLayer (super morphicLayerNumber) ~= (self morphicLayerNumber) ifTrue: [ | oldOwner | (oldOwner _ owner) ifNotNil: [ owner _ nil. oldOwner privateRemoveMorph: self. oldOwner addMorphInLayer: self. ] ]. ! ! !NCConstraintMorph methodsFor: 'WiW support' stamp: 'nk 4/5/2001 17:54'! morphicLayerNumber "Try to keep me above my input" ^(self input notNil and: [ self input ~~ self and: [ self input isMorph ]]) ifTrue: [ self input morphicLayerNumber - 1 ] ifFalse: [ super morphicLayerNumber ] ! ! !NCConstraintMorph methodsFor: 'drawing' stamp: 'nk 4/5/2001 17:40'! forcedInvisible ^super visible not! ! !NCConstraintMorph methodsFor: 'drawing' stamp: 'nk 6/17/2002 16:19'! highlightInputs | highlights | highlights _ self inputs collect: [ :ea | (Morph new) bounds: ea fullBounds; color: ((Color red) alpha: 0.3); lock ]. highlights _ OrderedCollection withAll: highlights. highlights add: ( (EllipseMorph new) extent: 12@12; center: (self point: self targetPoint in: self pasteUpMorph); color: ((Color green) alpha: 0.6); lock). highlights do: [ :ea | self pasteUpMorph addMorphFront: ea ]. ^highlights ! ! !NCConstraintMorph methodsFor: 'drawing' stamp: 'nk 2/23/2002 13:18'! visible self forcedInvisible ifTrue: [^false]. ^constraint isNil or: [constrained isNil or: [self hasAnyInputs not]]! ! !NCConstraintMorph methodsFor: 'event handling' stamp: 'nk 2/26/2001 19:04'! handlesMouseDown: anEvent anEvent yellowButtonPressed ifTrue: [ ^true ]. ^super handlesMouseDown: anEvent! ! !NCConstraintMorph methodsFor: 'event handling' stamp: 'nk 2/26/2001 19:07'! mouseDown: evt evt yellowButtonPressed "First check for option (menu) click" ifTrue: [^ self yellowButtonActivity: evt ]. super mouseDown: evt! ! !NCConstraintMorph methodsFor: 'halos and balloon help' stamp: 'nk 4/5/2001 17:51'! hasHalo | halo haloTarget | super hasHalo ifTrue: [ ^true ]. halo _ self currentHand halo. halo ifNil: [ ^false ]. haloTarget _ halo target. haloTarget == self ifTrue: [ ^true ]. self allMorphsDo: [ :ea | haloTarget == ea ifTrue: [ ^true ] ]. ^false! ! !NCConstraintMorph methodsFor: 'initialization' stamp: 'nk 4/18/2002 18:08'! initialize super initialize. inputs _ EmptyArray. dieWithInput _ false. self stepTime: self minimumStepTime; color: Color red; extent: 10@10; connectToNearestAttachmentPoint. ! ! !NCConstraintMorph methodsFor: 'naming' stamp: 'nk 4/14/2002 15:58'! innocuousName | name | name _ super innocuousName. ^name copyFrom: 3 to: name size. "Get rid of NC" ! ! !NCConstraintMorph methodsFor: 'structure' stamp: 'nk 6/16/2002 20:26'! pasteUpMorph "Answer the closest containing morph that is a PasteUp morph. If none, answer the world." self allOwnersDo: [:m | (m isPlayfieldLike) ifTrue: [^ m]]. ^ ActiveWorld! ! !NCConstraintMorph methodsFor: 'copying' stamp: 'nk 5/1/2001 18:20'! veryDeepFixupWith: aDeepCopier super veryDeepFixupWith: aDeepCopier. constrained _ aDeepCopier references at: constrained ifAbsent: [ ]. inputs _ inputs collect: [ :ea | ea ifNotNil: [ aDeepCopier references at: ea ifAbsent: [ ea ] ] ]. ! ! !NCConstraintMorph methodsFor: 'copying' stamp: 'nk 4/18/2002 18:15'! veryDeepInner: aDeepCopier super veryDeepInner: aDeepCopier. constrained := constrained. inputs := inputs copy. "this lets you stay attached" constraint := constraint veryDeepCopyWith: aDeepCopier. "lastTarget _ nil." stepTime := stepTime. dieWithInput _ dieWithInput.! ! !NCConstraintMorph class methodsFor: 'fileIn/Out' stamp: 'nk 4/18/2002 22:52'! classVersion "This version has the Message Sends and additional instance variables" ^2 ! ! !NCConstraintMorph class methodsFor: 'instance creation' stamp: 'nk 2/26/2001 21:30'! includeInNewMorphMenu ^false! ! !NCConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 4/8/2001 12:29'! preMadeShapeNames "Answer a collection of pre-made shape names for a menu" "NCConstraintMorph preMadeShapeNames" ^#( )! ! !NCFSMMorph methodsFor: 'debug and other' stamp: 'nk 3/6/2001 13:54'! buildDebugMenu: aHand | menu | menu _ super buildDebugMenu: aHand. menu addLine. menu add: 'monitor FSM' target: self selector: #monitorFSM. fsm canLog ifFalse: [ menu add: 'log FSM to transcript' target: fsm selector: #logToTranscript. ] ifTrue: [ fsm isLogging ifFalse: [ menu add: 'trace events' target: self selector: #traceEvents ] ifTrue: [ menu add: 'stop tracing events' target: self selector: #stopTracingEvents ] ]. ^menu! ! !NCFSMMorph methodsFor: 'debug and other' stamp: 'nk 2/14/2001 14:45'! fsm ^fsm! ! !NCFSMMorph methodsFor: 'debug and other' stamp: 'nk 2/23/2001 19:12'! monitorFSM | s | s _ UpdatingStringMorph on: fsm selector: #currentState. s openInWorld: self world.! ! !NCFSMMorph methodsFor: 'debug and other' stamp: 'nk 2/23/2001 19:07'! stopTracingEvents fsm logging: false.! ! !NCFSMMorph methodsFor: 'debug and other' stamp: 'nk 2/23/2001 19:07'! traceEvents fsm logging: true.! ! !NCFSMMorph methodsFor: 'accessing' stamp: 'nk 3/12/2001 10:26'! fsm: aNCFiniteStateMachine fsm _ aNCFiniteStateMachine. fsm ifNotNil: [ fsm whenMissedEventPerform: (MessageSend receiver: self selector: #missedEvent:args:) ]! ! !NCFSMMorph methodsFor: 'events-processing' stamp: 'nk 10/8/2001 13:44'! handleEvent: anEvent anEvent wasHandled ifTrue: [^self]. "not interested" (self rejectsEvent: anEvent) ifTrue: [ ^self ]. anEvent wasHandled: true. fsm trigger: anEvent type with: anEvent! ! !NCFSMMorph methodsFor: 'events-processing' stamp: 'nk 3/11/2001 14:39'! ignore: argument ^self! ! !NCFSMMorph methodsFor: 'events-processing' stamp: 'nk 6/23/2002 19:42'! rejectsEvent: anEvent ^self isLocked or: [ (fsm willRespondTo: anEvent type) not ]! ! !NCFSMMorph methodsFor: 'events-processing' stamp: 'nk 2/14/2001 15:59'! unhandleEvent: anEvent anEvent wasHandled: false.! ! !NCFSMMorph methodsFor: 'event handling' stamp: 'nk 2/14/2001 22:02'! handlesMouseDown: anEvent ^anEvent wasHandled not and: [ fsm willRespondToAnyOf: #(mouseDown mouseUp mouseMove) ]! ! !NCFSMMorph methodsFor: 'event handling' stamp: 'nk 6/19/2002 09:22'! missedEvent: eventName args: args fsm isLogging ifTrue: [ ^self ]. "{ self . ' (' . fsm currentState . ') missed event ' . eventName . ' args=' . args } do: [ :ea | Transcript nextPutAll: ea asString ]. Transcript cr; flush"! ! !NCFSMMorph methodsFor: 'initialization' stamp: 'nk 3/14/2001 14:07'! initialize super initialize. self fsm: self class stateMachineClass new.! ! !NCConnectorMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 2/17/2001 21:07'! abandon fsm initialize. constraints _ line _ fsm _ nil. super abandon! ! !NCConnectorMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 3/11/2001 21:12'! addHandles self setProperty: #showingHandles toValue: true. self ensureHandles.! ! !NCConnectorMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 8/1/2002 13:12'! delete self deleteAllLabels. self detach. super delete.! ! !NCConnectorMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 2/15/2002 13:52'! ensureHandles | handles lastHandle | self showingHandles ifFalse: [ ^self ]. lastHandle _ 0. handles _ Array new: submorphs size. submorphs do: [ :ea | ea valueOfProperty: #connectorHandle ifPresentDo: [ :ix | handles at: ix put: ea. lastHandle _ lastHandle max: ix. ] ]. "Make missing handles" (lastHandle + 1 max: 2) to: line vertices size - 1 do: [ :ix | self addMorphFront: (NCConstraintMorph new color: (Color blue orColorUnlike: self borderColor); input: self; extent: 8@8; connectTo: self atVertexNumber: ix; setProperty: #connectorHandle toValue: ix). ]. "Remove extra handles" line vertices size to: lastHandle do: [ :ix | (handles at: ix) delete. ]. ! ! !NCConnectorMorph methodsFor: 'submorphs-add/remove' stamp: 'hpt 2/6/2003 11:58'! fixDegenerateLine "If I have two vertices and they're in the same place, more or less, and both are connected to the same object, then add a couple more vertices and space them so I can be grabbed" | v p1 p2 p transform | (line vertices size = 2 and: [self sourceMorph == self destinationMorph and: [self sourceMorph notNil]]) ifFalse: [^ self]. (self firstVertex dist: self lastVertex) < 4 ifFalse: [^ self]. v _ self firstVertex - self sourceMorph center. p _ self sourceMorph intersectionWithLineSegmentFromCenterTo: self sourceMorph center + (200 * v). p1 _ (Point r: 40 degrees: v degrees + 30) + p. p2 _ (Point r: 40 degrees: v degrees - 30) + p. "p1 and p2 are in SourceMorph coordinate system" transform := owner transformFromWorld composedWithLocal: (self sourceMorph transformFromWorld inverseTransformation). p1 := transform globalPointToLocal: p1. p2 := transform globalPointToLocal: p2. line setVertices: {line firstVertex. p1. p2. line lastVertex}! ! !NCConnectorMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 3/11/2001 20:51'! removeHandles self deleteSubmorphsWithProperty: #connectorHandle. self removeProperty: #showingHandles! ! !NCConnectorMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 3/11/2001 20:56'! showingHandles ^self valueOfProperty: #showingHandles ifAbsent: [ false ]! ! !NCConnectorMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 3/11/2001 23:23'! toggleHandles self showingHandles ifTrue: [ self removeHandles ] ifFalse: [ self addHandles ]! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 8/1/2002 12:39'! addBasicArrowMenuItemsTo: aMenu event: evt aMenu addLine. aMenu addWithLabel: '---' enablement: [self arrows ~~ #none] action: #makeNoArrows. aMenu addWithLabel: '-->' enablement: [self arrows ~~ #forward] action: #makeForwardArrow. aMenu addWithLabel: '<--' enablement: [self arrows ~~ #back] action: #makeBackArrow. aMenu addWithLabel: '<->' enablement: [self arrows ~~ #both] action: #makeBothArrows. owner ifNotNil: [ aMenu add: 'customize arrows' action: #customizeArrows:. ]. (line hasProperty: #arrowSpec) ifTrue: [aMenu add: 'standard arrows' action: #standardArrows]. ! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 7/31/2002 14:58'! addBasicMenuItemsTo: aMenu event: evt owner ifNotNil: [ aMenu add: 'delete' action: #delete; addLine. aMenu add: 'add label' action: #addLabel:; addLine. ]. aMenu add: 'line color...' target: self selector: #changeBorderColor:; add: 'line width...' target: self selector: #changeBorderWidth:; addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles; addUpdating: #orthogonalityPhrase target: self action: #toggleOrthogonality; addUpdating: #makeSegmentedOrSmoothLinePhrase action: #toggleSmoothing. aMenu addWithLabel: 'straighten' enablement: [self vertices size > 2 ] action: #straighten. aMenu add: 'custom dashed line' action: #specifyDashedLine; addUpdating: #makeDashedOrSolidLinePhrase action: #toggleDashedLine. ! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 4/18/2002 17:24'! addCustomMenuItems: aMenu hand: aHandMorph "Use my line's menu additions" super addCustomMenuItems: aMenu hand: aHandMorph. aMenu addLine. aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles. aMenu addUpdating: #orthogonalityPhrase target: self action: #toggleOrthogonality. self vertices size > 2 ifTrue: [ line isCurve ifTrue: [aMenu add: 'make segmented line' action: #toggleSmoothing] ifFalse: [aMenu add: 'make smooth line' action: #toggleSmoothing]. aMenu add: 'straighten' target: self selector: #straighten. ]. aMenu add: 'custom dashed line' action: #specifyDashedLine. line dashedBorder ifNil: [ aMenu add: 'make dashed line' target: self selector: #dashedLine: argument: true ] ifNotNil: [ aMenu add: 'make solid line' target: self selector: #dashedLine: argument: false ]. aMenu addLine. aMenu addWithLabel: '---' enablement: [self arrows ~~ #none] action: #makeNoArrows. aMenu addWithLabel: '-->' enablement: [self arrows ~~ #forward] action: #makeForwardArrow. aMenu addWithLabel: '<--' enablement: [self arrows ~~ #back] action: #makeBackArrow. aMenu addWithLabel: '<->' enablement: [self arrows ~~ #both] action: #makeBothArrows. aMenu add: 'customize arrows' action: #customizeArrows:. (line hasProperty: #arrowSpec) ifTrue: [aMenu add: 'standard arrows' action: #standardArrows]. aMenu addLine; add: 'add label' action: #addLabel:. ! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 8/1/2002 12:39'! addYellowButtonMenuItemsTo: aMenu event: evt aMenu defaultTarget: self; addStayUpItem. self addBasicMenuItemsTo: aMenu event: evt. self addBasicArrowMenuItemsTo: aMenu event: evt. ^aMenu! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 4/18/2001 11:51'! changeBorderColor: evt | aHand | aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand]. self changeColorTarget: self selector: #borderColor: originalColor: self borderColor hand: aHand! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 11/14/2002 12:34'! changeBorderWidth: evt "Copied from BorderedMorph" | newWidth | (owner notNil and: [self visible]) ifTrue: [^self changeBorderWidthInteractively: evt]. newWidth := FillInTheBlank request: 'New line width?' initialAnswer: self borderWidth asString. newWidth isEmpty ifTrue: [ ^self ]. newWidth := newWidth asNumber. self borderWidth: newWidth! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 4/17/2001 07:24'! changeBorderWidthInteractively: evt "Copied from BorderedMorph" | handle origin aHand newWidth oldWidth | aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand]. origin _ aHand position. oldWidth _ self borderWidth. handle _ HandleMorph new forEachPointDo: [:newPoint | handle removeAllMorphs. handle addMorph: (LineMorph from: origin to: newPoint color: Color black width: 1). newWidth _ (newPoint - origin) r asInteger // 5. self borderWidth: (newWidth max: 1)] lastPointDo: [:newPoint | handle deleteBalloon. self halo doIfNotNil: [:halo | halo addHandles]. self rememberCommand: (Command new cmdWording: 'border change'; undoTarget: self selector: #borderWidth: argument: oldWidth; redoTarget: self selector: #borderWidth: argument: newWidth)]. aHand attachMorph: handle. handle setProperty: #helpAtCenter toValue: true. handle showBalloon: 'Move cursor farther from this point to increase border width. Click when done.' hand: evt hand. handle startStepping! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 3/11/2001 21:17'! handlesShowingPhrase ^ self showingHandles ifTrue: ['hide handles'] ifFalse: ['show handles']! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 4/2/2001 20:42'! makeDashedOrSolidLinePhrase ^line dashedBorder ifNil: [ 'make dashed line' ] ifNotNil: [ 'make solid line' ]. ! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 4/2/2001 20:43'! makeSegmentedOrSmoothLinePhrase ^line isCurve ifTrue: [ 'make segmented line' ] ifFalse: [ 'make smooth line' ].! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 4/18/2002 17:23'! orthogonalityPhrase ^ self isOrthogonal ifTrue: ['stop being orthogonal'] ifFalse: ['be orthogonal'] ! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 3/11/2001 21:18'! showOrHideHandles self showingHandles ifTrue: [self removeHandles] ifFalse: [self addHandles]! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 4/2/2001 20:52'! toggleDashedLine self dashedLine: line dashedBorder isNil.! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 4/18/2002 17:24'! toggleOrthogonality ^ self beOrthogonal: self isOrthogonal not ! ! !NCConnectorMorph methodsFor: 'menus' stamp: 'nk 6/15/2002 14:14'! toggleSmoothing line toggleSmoothing ! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 6/11/2002 16:09'! addConnectedConnectorsTo: aCollection "Add myself and all my connected connectors (recursively) to aCollection" aCollection add: self. self connections do: [ :ea | (ea notNil and: [ ea isConnector ]) ifTrue: [ (aCollection includes: ea) ifFalse: [ ea addConnectedConnectorsTo: aCollection. ] ] ]. self connectedMorphs do: [ :ea | (ea notNil and: [ ea isConnector ]) ifTrue: [ (aCollection includes: ea) ifFalse: [ ea addConnectedConnectorsTo: aCollection. ] ] ]. ^aCollection ! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 3/11/2002 22:04'! connectedMorphs "Answer a 2 element Array with my connections. Either or both could be nil" ^(constraints collect: [ :ea | ea input ])! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 2/17/2001 21:07'! constraints ^constraints! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 3/3/2001 17:54'! destinationMorph "Answer the morph connected to my first vertex, if any" ^constraints last input! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 3/11/2002 21:29'! endConnection "Answer my ending connection or nil" ^constraints second input! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 6/22/2002 17:58'! endConstraint "Answer my ending constraint" ^constraints second ! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 6/11/2002 16:11'! network "Answer a set of myself plus all of the connectors that are either connected directly to me or that I'm connected to (recursively)" | retval | retval _ Set new. self addConnectedConnectorsTo: retval. ^retval ! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 3/3/2001 17:54'! sourceMorph "Answer the morph connected to my first vertex, if any" ^constraints first input! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 3/11/2002 21:29'! startConnection "Answer my beginning connection or nil" ^constraints first input! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 6/22/2002 17:58'! startConstraint "Answer my beginning constraint" ^constraints first ! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 6/11/2002 16:13'! subNet "Answer a set of myself plus all of the connectors that are either connected directly to me or that I'm connected to (recursively)" | retval | retval _ Set new. self addConnectedConnectorsTo: retval. ^retval ! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 6/11/2002 16:13'! subnet "Answer a set of myself plus all of the connectors that are either connected directly to me or that I'm connected to (recursively)" | retval | retval _ Set new. self addConnectedConnectorsTo: retval. ^retval ! ! !NCConnectorMorph methodsFor: 'connectors-queries' stamp: 'nk 4/5/2001 09:35'! validConnections "Answer an Array with all of my valid connections. This will be from 0 to 2 long." | f s | f _ constraints at: 1. s _ constraints at: 2. ^f input ifNotNil: [ s input ifNotNil: [ { f input . s input } ] ifNil: [ { f input } ] ] ifNil: [ constraints second input ifNotNil: [ { s input } ] ifNil: [ { } ] ]! ! !NCConnectorMorph methodsFor: 'drop shadows' stamp: 'nk 4/7/2001 17:04'! addDropShadow line hasDropShadow ifTrue: [ ^self setProperty: #keepDropShadow toValue: true ]. line addDropShadow; shadowOffset: 3@4; shadowColor: Color gray. constraints do: [ :ea | ea addDropShadow ]! ! !NCConnectorMorph methodsFor: 'drop shadows' stamp: 'nk 3/12/2001 22:09'! changeShadowColor line changeShadowColor! ! !NCConnectorMorph methodsFor: 'drop shadows' stamp: 'nk 3/14/2001 10:12'! hasDropShadow ^line notNil and: [ line hasDropShadow ]! ! !NCConnectorMorph methodsFor: 'drop shadows' stamp: 'nk 3/12/2001 22:12'! hasDropShadow: aBoolean ^line hasDropShadow: aBoolean! ! !NCConnectorMorph methodsFor: 'drop shadows' stamp: 'nk 4/7/2001 17:04'! removeDropShadow (self valueOfProperty: #keepDropShadow ifAbsent: [ false ]) ifTrue: [ ^self removeProperty: #keepDropShadow ]. line removeDropShadow; removeProperty: #shadowOffset; removeProperty: #shadowColor. constraints do: [ :ea | ea removeDropShadow ].! ! !NCConnectorMorph methodsFor: 'drop shadows' stamp: 'nk 3/12/2001 22:10'! setShadowOffset: evt line setShadowOffset: evt! ! !NCConnectorMorph methodsFor: 'drop shadows' stamp: 'nk 3/5/2002 12:38'! shadowColor ^line shadowColor! ! !NCConnectorMorph methodsFor: 'drop shadows' stamp: 'nk 3/12/2001 22:09'! shadowColor: aColor line shadowColor: aColor! ! !NCConnectorMorph methodsFor: 'drop shadows' stamp: 'nk 3/12/2001 22:10'! shadowOffset ^line shadowOffset! ! !NCConnectorMorph methodsFor: 'drop shadows' stamp: 'nk 3/12/2001 22:10'! shadowOffset: pt line shadowOffset: pt! ! !NCConnectorMorph methodsFor: 'rotate scale and flex' stamp: 'nk 2/26/2001 15:24'! addFlexShell "Behave like a line" ^self! ! !NCConnectorMorph methodsFor: 'rotate scale and flex' stamp: 'nk 8/16/2002 13:53'! transformedBy: aTransform "Since I don't really add a flex shell, just behave like a PolygonMorph" line transformedBy: aTransform. "constraints do: [ :ea | ea transformedBy: aTransform ]." ^self.! ! !NCConnectorMorph methodsFor: 'labeling' stamp: 'nk 8/2/2002 07:42'! addLabel: anEvent | label | label _ self labelClass new string: ' ' minWidth: 20. label align: label center with: anEvent position; attachUnobnoxiouslyTo: self at: anEvent position; dieWithInput: true; selectAll. self pasteUpMorph addMorph: label. anEvent hand newKeyboardFocus: label label. ^label! ! !NCConnectorMorph methodsFor: 'labeling' stamp: 'nk 4/14/2002 15:28'! addLabel: text at: aPoint | label | label _ (self labelClass new string: text). label attachTo: self at: aPoint; align: label center with: aPoint; dieWithInput: true. self pasteUpMorph addMorph: label. ^label! ! !NCConnectorMorph methodsFor: 'labeling' stamp: 'nk 4/14/2002 15:28'! addLabel: text near: aPoint | label | label _ (self labelClass new string: text). label color: self color; align: label center with: aPoint; attachUnobnoxiouslyTo: self at: aPoint; dieWithInput: true. self pasteUpMorph addMorph: label. ^label! ! !NCConnectorMorph methodsFor: 'labeling' stamp: 'nk 2/22/2002 15:55'! addShapes: anArray constraints with: anArray do: [ :end :shape | end addShape: shape; step ].! ! !NCConnectorMorph methodsFor: 'labeling' stamp: 'nk 4/14/2002 15:28'! addUnwrappedLabel: text at: aPoint | label | label _ (self labelClass new string: text wrap: false). label attachTo: self at: aPoint; align: label center with: aPoint; dieWithInput: true. self pasteUpMorph addMorph: label. ^label! ! !NCConnectorMorph methodsFor: 'labeling' stamp: 'nk 6/17/2002 09:55'! setCorrectOwnerForConnections: connections | numberOfConnections owners1 owners2 n innermostOwner | numberOfConnections _ connections size. numberOfConnections = 0 ifTrue: [ ^self ]. "Make sure that I am owned by the innermost of my connections' common owners" innermostOwner _ connections first pasteUpMorph. (numberOfConnections = 2 and: [ connections second pasteUpMorph ~~ innermostOwner ]) ifTrue: [ owners1 _ connections first allOwners select: [ :ea | ea isPlayfieldLike ]. owners2 _ connections second allOwners select: [ :ea | ea isPlayfieldLike ] . owners1 size + (owners2 size) == 3 ifTrue: [ innermostOwner _ owners1 last ] ifFalse: [ n _ (owners1 size min: owners2 size) - 1. (owners1 size to: owners1 size - n by: -1) with: (owners2 size to: owners2 size - n by: -1) do: [ :i1 :i2 | | o1 o2 | o1 _ (owners1 at: i1). o2 _ (owners2 at: i2). (o1 == o2 and: [ o1 isPlayfieldLike ]) ifTrue: [ innermostOwner _ o1 ] ]. ]. ]. innermostOwner ifNotNil: [ self owner == innermostOwner ifFalse: [ ^self jumpToOwner: innermostOwner. ] ]. connections do: [ :conn | | hisOwner | hisOwner _ conn orOwnerSuchThat: [ :ea | ea owner == owner ]. hisOwner ifNotNil: [ (line bounds intersects: (hisOwner bounds insetBy: 1)) ifTrue: [ owner ensureMorph: self inFrontOf: hisOwner ] ] ] ! ! !NCConnectorMorph methodsFor: 'visual properties' stamp: 'nk 4/3/2001 16:58'! arrowSpec: aPoint "The standard arrow is equivalent to arrowSpec: 5@4." line arrowSpec: aPoint! ! !NCConnectorMorph methodsFor: 'visual properties' stamp: 'nk 11/26/2002 11:26'! beAdjacent ^false! ! !NCConnectorMorph methodsFor: 'visual properties' stamp: 'nk 4/18/2001 11:36'! borderColor: aColor constraints do: [ :ea | ea endShapeColor: aColor ]. ^line ifNotNil: [ line borderColor: aColor ] ifNil: [ super borderColor: aColor ]! ! !NCConnectorMorph methodsFor: 'visual properties' stamp: 'nk 2/27/2001 12:51'! dashedLine: aBoolean line dashedBorder: (aBoolean ifTrue: [ { line borderWidth * 4 . line borderWidth * 3 . Color transparent } ] ifFalse: [ nil ])! ! !NCConnectorMorph methodsFor: 'visual properties' stamp: 'nk 2/26/2001 20:06'! doesBevels ^false! ! !NCConnectorMorph methodsFor: 'visual properties' stamp: 'nk 2/12/2001 08:10'! fillStyle: aFillStyle ^line ifNotNil: [ line fillStyle: aFillStyle ] ifNil: [ super fillStyle: aFillStyle ]! ! !NCConnectorMorph methodsFor: 'visual properties' stamp: 'nk 4/5/2001 15:04'! straighten line removeHandles; straighten. self ensureHandles. constraints do: [ :ea | ea step ]. self fixDegenerateLine.! ! !NCConnectorMorph methodsFor: 'dropping/grabbing' stamp: 'nk 8/6/2002 12:57'! asButtonPrototype ^super asButtonPrototype initializeFSM; detach! ! !NCConnectorMorph methodsFor: 'dropping/grabbing' stamp: 'nk 4/15/2002 11:40'! rejectDropMorphEvent: evt "Make sure that I restore the cursor" self isWiring ifTrue: [ ActiveHand showTemporaryCursor: nil ]. super rejectDropMorphEvent: evt. ! ! !NCConnectorMorph methodsFor: 'geometry' stamp: 'nk 3/12/2002 09:56'! asVector "Answer a Point representing me as a vector. Ignore intermediate vertices" ^line vertices last - line vertices first! ! !NCConnectorMorph methodsFor: 'geometry' stamp: 'nk 3/12/2002 09:59'! asVectorFrom: aMorph "Answer a Point representing me as a vector. Ignore intermediate vertices" ^ aMorph == self startConnection ifTrue: [line vertices last - line vertices first] ifFalse: [line vertices first - line vertices last]! ! !NCConnectorMorph methodsFor: 'geometry' stamp: 'nk 4/7/2001 14:10'! bounds ^line ifNotNil: [ ((line bounds outsetBy: self selectionSlop) quickMerge: (constraints first bounds)) quickMerge: (constraints second bounds) ] ifNil: [ super bounds ]! ! !NCConnectorMorph methodsFor: 'geometry' stamp: 'nk 6/27/2002 12:39'! closestOrthogonalPointTo: aPoint "first, find an intersection" | intersections | intersections _ OrderedCollection new. intersections addAll: (self line intersectionsWith: (0@0 corner: aPoint)). intersections addAll: (self line intersectionsWith: (aPoint corner: Display extent)). intersections isEmpty ifTrue: [ ^self closestPointTo: aPoint ]. ^intersections detectMin: [ :ea | ea dist: aPoint ] ! ! !NCConnectorMorph methodsFor: 'geometry' stamp: 'nk 2/27/2001 07:46'! closestPointTo: aPoint ^line closestPointTo: aPoint! ! !NCConnectorMorph methodsFor: 'geometry' stamp: 'nk 2/21/2001 16:26'! extent: aPoint super extent: aPoint. bounds _ self submorphBounds! ! !NCConnectorMorph methodsFor: 'geometry' stamp: 'nk 3/3/2001 19:24'! intersectionWithLineSegmentFromCenterTo: aPoint ^line closestPointTo: aPoint! ! !NCConnectorMorph methodsFor: 'geometry' stamp: 'nk 4/15/2002 15:12'! position: aPoint bounds _ self submorphBounds. super position: aPoint. ! ! !NCConnectorMorph methodsFor: 'geometry' stamp: 'nk 4/3/2002 14:21'! realBounds ^line ifNotNil: [ | world | world _ self world. (((line boundsIn: world) outsetBy: self selectionSlop) quickMerge: (constraints first boundsIn: world)) quickMerge: (constraints second boundsIn: world) ] ifNil: [ super bounds ]! ! !NCConnectorMorph methodsFor: 'geometry' stamp: 'nk 4/18/2002 16:40'! reduceVertices line vertices size > 2 ifTrue: [ line reduceVertices ]. constraints do: [ :ea | ea step ]. self ensureHandles ! ! !NCConnectorMorph methodsFor: 'attachments-nk' stamp: 'nk 6/20/2002 13:34'! attachFrom: aConstraintMorph at: aPoint (constraints includes: aConstraintMorph) ifTrue: [ self error: 'can''t happen' ]. "I don't want my labels to wander" (aConstraintMorph isLabelConstraint) ifTrue: [ ^self attachFrom: aConstraintMorph atNearestSpecTo: aPoint ]. (aConstraintMorph isLineConstraint) ifTrue: [ aConstraintMorph connectToNearestPoint ] ifFalse: [ super attachFrom: aConstraintMorph at: aPoint ] ! ! !NCConnectorMorph methodsFor: 'attachments-nk' stamp: 'nk 4/11/2002 14:28'! defaultAttachmentPointSpecs "Where would labels attach to me? (note that I normally let Connectors slide along my length)" ^{ { #firstVertex } . { #midpoint } . { #lastVertex } } ! ! !NCConnectorMorph methodsFor: 'attachments-nk' stamp: 'nk 6/27/2002 21:19'! imageForm "Make my constraints transparent and then make the image." | oldColors image | oldColors _ constraints collect: [ :ea | ea fillStyle ]. constraints do: [ :ea | ea fillStyle: Color transparent; computeLineAttachmentPoint; forceRedraw ]. image _ super imageForm. constraints with: oldColors do: [ :constraint :ccolor | constraint fillStyle: ccolor ]. ^image! ! !NCConnectorMorph methodsFor: 'orthogonality' stamp: 'nk 4/18/2002 16:11'! beOrthogonal: aBoolean aBoolean ifTrue: [ self setProperty: #orthogonal toValue: true] ifFalse: [ self removeProperty: #orthogonal ] ! ! !NCConnectorMorph methodsFor: 'orthogonality' stamp: 'nk 4/18/2002 16:12'! isOrthogonal ^self valueOfProperty: #orthogonal ifAbsent: [ false ] ! ! !NCConnectorMorph methodsFor: 'orthogonality' stamp: 'nk 6/11/2002 17:40'! orthogonalizeVertex: index | rect newPoint oldVertices | oldVertices _ line vertices. (index <= 1 or: [ index >= line vertices size ]) ifTrue: [ ^self error: 'bad vertex index' ]. rect _ (oldVertices at: index - 1) corner: (oldVertices at: index + 1). newPoint _ { rect bottomLeft . rect topRight } detectMin: [ :pt | pt dist: (oldVertices at: index) ]. (oldVertices at: index) ~= newPoint ifTrue: [ line setVertices: (oldVertices copyReplaceFrom: index to: index with: { self griddedPoint: newPoint } ) ] ! ! !NCConnectorMorph methodsFor: 'accessing' stamp: 'nk 2/21/2001 09:07'! borderWidth ^line ifNotNil: [ line borderWidth ] ifNil: [ 0 ]! ! !NCConnectorMorph methodsFor: 'accessing' stamp: 'nk 6/17/2002 09:27'! borderWidth: anInteger constraints do: [ :ea | ea endShapeWidth: anInteger ]. line ifNotNil: [ line borderWidth: anInteger ] ifNil: [ super borderWidth: anInteger ]. ! ! !NCConnectorMorph methodsFor: 'accessing' stamp: 'nk 3/27/2002 16:44'! color ^line ifNotNil: [ line fillStyle ] ifNil: [ super color]! ! !NCConnectorMorph methodsFor: 'accessing' stamp: 'nk 3/27/2002 16:44'! color: aColor constraints do: [ :ea | ea endShapeColor: aColor ]. ^line ifNotNil: [ line fillStyle: aColor ] ifNil: [ super color: aColor ]! ! !NCConnectorMorph methodsFor: 'accessing' stamp: 'nk 2/25/2001 17:24'! firstVertex ^line firstVertex! ! !NCConnectorMorph methodsFor: 'accessing' stamp: 'nk 2/25/2001 17:24'! lastVertex ^line lastVertex! ! !NCConnectorMorph methodsFor: 'accessing' stamp: 'nk 2/17/2001 12:32'! line ^line! ! !NCConnectorMorph methodsFor: 'accessing' stamp: 'nk 2/25/2001 17:24'! midpoint ^line midpoint! ! !NCConnectorMorph methodsFor: 'accessing' stamp: 'nk 6/17/2002 09:28'! selectionSlop "Answer the distance from the line centerline that I will accept as a valid selection point" "This is set class-wide; the accessor is on the instance side so that subclasses can override on a per-instance basis" ^MinimumSelectionSlop! ! !NCConnectorMorph methodsFor: 'accessing' stamp: 'nk 6/15/2002 14:13'! vertexAt: index ^line vertexAt: index ! ! !NCConnectorMorph methodsFor: 'connectors-labels' stamp: 'nk 4/14/2002 09:45'! boundsSignatureHash | hash | hash _ line boundsSignatureHash. self validConnections do: [ :ea | hash _ (hash + ea boundsSignatureHash + ea owner identityHash) hashMultiply ]. ^hash ! ! !NCConnectorMorph methodsFor: 'connectors-labels' stamp: 'nk 4/14/2002 15:44'! labelClass ^Preferences useSmartLabels ifTrue: [ NCSmartLabelMorph ] ifFalse: [ NCLabelMorph ] ! ! !NCConnectorMorph methodsFor: 'connectors-labels' stamp: 'nk 4/14/2002 15:50'! nudgeForLabel: labelBounds "First, clear my connected morphs, then clear my line" | nudge | "self labels do: [ :ea | nudge _ ea nudgeForLabel: labelBounds. nudge isZero ifFalse: [ ^nudge ] ]." self validConnections do: [ :ea | nudge _ ea nudgeForLabel: labelBounds. nudge isZero ifFalse: [ ^nudge ]. ]. ^line nudgeForLabel: labelBounds ! ! !NCConnectorMorph methodsFor: 'connectors-labels' stamp: 'nk 4/14/2002 10:39'! relocateLabelFrom: aRectangle "Given a prospective label location, answer a new rectangle which doesn't overlap me" | newBounds | newBounds _ aRectangle. self validConnections do: [ :ea | newBounds _ ea relocateLabelFrom: newBounds. ]. newBounds _ line relocateLabelFrom: newBounds. ^ newBounds ! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 3/11/2001 10:33'! connectFinishTo: aMorph | old | old _ constraints last input. constraints last input: aMorph. fsm trigger: #connectEndTo with: aMorph. ^old ! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 3/11/2001 10:33'! connectStartTo: aMorph | old | old _ constraints first input. constraints first input: aMorph. fsm trigger: #connectEndTo with: aMorph. ^old ! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 2/17/2001 21:14'! connectToNearestAttachmentPoint "Connect both ends to wherever the target Morphs prefer" constraints do: [ :ea | ea connectToNearestAttachmentPoint ]! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 6/20/2002 12:59'! connectToNearestOrthogonalPoint "Connect both ends to the nearest point orthogonally, or the nearest point if none" constraints do: [ :ea | ea connectToNearestOrthogonalPoint ] ! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 2/17/2001 21:14'! connectToNearestPoint constraints do: [ :ea | ea connectToNearestPoint ]! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 2/27/2001 07:41'! connectToNearestPointToCenter constraints do: [ :ea | ea connectToNearestPointToCenter ]! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 8/1/2002 13:11'! detach constraints do: [ :const | const input: nil ] ! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 7/26/2002 16:07'! detachFrom: aMorph constraints do: [ :const | (const input == aMorph) ifTrue: [ const input: nil ] ].! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 4/16/2002 15:06'! insertVertexNextTo: constraint at: position "insert another vertex, before first or after last" | newVertices | newVertices _ OrderedCollection new: line vertices size + 1. constraint == constraints first ifTrue: [ newVertices add: position; addAll: line vertices. ] ifFalse: [ newVertices addAll: line vertices; add: position ]. line setVertices: newVertices asArray. self changed.! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 3/27/2001 13:00'! preferredEndConnection: anArrayOrSelector constraints do: [ :ea | ea preferredConnection: anArrayOrSelector ]! ! !NCConnectorMorph methodsFor: 'connection' stamp: 'nk 7/26/2002 15:46'! wantsToAttachEnd: index toMorph: aMorph "Answer true if I want my end with index 'index' (1 or 2) to attach to the given Morph." ^true! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 7/26/2002 15:45'! connectionTargetsAt: localPoint for: constraint "Answer a collection of prospective connection targets. Search up to the first playfield." | targets globalPoint index firstPlayfield | index _ constraints indexOf: constraint. globalPoint _ (constraint transformFrom: self world) localPointToGlobal: localPoint. targets _ self world morphsAt: globalPoint. firstPlayfield _ targets detect: [ :ea | ea isPlayfieldLike ] ifNone: [ ]. targets _ targets copyUpTo: firstPlayfield. targets _ targets select: [ :ea | (ea wantsAttachmentFromEnd: index ofConnector: self) and: [ self wantsToAttachEnd: index toMorph: ea ] ]. "The following logic is to avoid connecting to other NCConnectors when there is something else there to connect to" ^targets asSortedCollection: [ :a :b | (a isKindOf: self class) ifTrue: [ false ] ifFalse: [ a owner isPlayfieldLike ] ]! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/5/2001 10:48'! connectionsChanged "The number of my connections has changed. This is a hook for subclasses" ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/5/2001 09:35'! determineConnectionState | connections | "Look at my connections and branch to the appropriate state" connections _ self validConnections. connections size == 0 ifTrue: [ fsm newState: #disconnected ]. connections size == 1 ifTrue: [ fsm newState: #oneEndConnected ]. connections size == 2 ifTrue: [ connections first == connections second ifTrue: [ fsm newState: #fixingDegenerateLine ] ifFalse: [ fsm newState: #connected ] ]. ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 3/11/2001 21:08'! enterConnected self reduceVertices ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 6/16/2002 12:08'! enterDraggingEnd | constraint evt args | args _ fsm lastEventArguments. constraint _ args first. evt _ args second. self stopStepping. (self isWiring not and: [ evt shiftPressed and: [ constraint hasAnyInputs not ] ]) ifTrue: [ self insertVertexNextTo: constraint at: (self griddedPoint: evt position) ]. self isWiring: false. owner isWorldMorph ifFalse: [ self jumpToWorld ]. self addDropShadow. "make end follow hand" constraint input: evt hand; connectToCursorPoint. evt hand newMouseFocus: self. self startMonitoringEnd: constraint. self setProperty: #startDraggingTime toValue: evt timeStamp! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 6/26/2002 09:56'! enterDraggingMorph | constraintMorph | fullBounds _ nil. self stopSteppingSelector: #stepAt:. constraints do: [ :ea | ea stopSteppingSelector: #stepAt: ]. constraintMorph _ constraints detect: [ :ea | ea hasAnyInputs not ] ifNone: [ ^self ]. (self valueOfProperty: #justDuplicated ifAbsent: [ false ]) ifTrue: [ self removeProperty: #justDuplicated ]. self startMonitoringEnd: constraintMorph. ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 6/16/2002 12:08'! enterDraggingSegment "lastEventArguments has anEvent . anEvent position . vertexIndex" | args | args _ fsm lastEventArguments. self stopStepping. self setProperty: #draggingSegmentStart toValue: (self localPointToGlobal: args first position). owner isWorldMorph ifFalse: [ self jumpToWorld ]. self addDropShadow. args first hand newMouseFocus: self. self setProperty: #draggingSegmentIndex toValue: args third. self setProperty: #draggingSegmentVertices toValue: line vertices copy. "constraints do: [ :ea | ea stopStepping ]."! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 6/16/2002 12:08'! enterDraggingVertex "lastArgs are anEvent . vertex . vertexIndex" | args | args _ fsm lastEventArguments. self stopStepping. owner isWorldMorph ifFalse: [ self jumpToWorld. self step. ]. self addDropShadow. args first hand newMouseFocus: self. self setProperty: #draggingVertexStart toValue: args first position. self setProperty: #draggingVertexIndex toValue: args third! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 3/11/2001 16:31'! enterFixingDegenerateLine constraints first step. constraints second step. self fixDegenerateLine. self changed; layoutChanged. ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 9/15/2002 11:41'! enterHandlingDrop | potentialConnections nextConnection hand | self removeDropShadow. self stopMonitoringEnd. Cursor normal show. self startStepping. "First, detach any ends that were following the hand." constraints do: [ :ea | ea input ifNotNilDo: [ :m | m isHandMorph ifTrue: [ hand _ m. ea connectToNothing ] ]. ea removeDropShadow ]. "Then find which ends we should potentially try to connect" potentialConnections _ constraints select: [ :ea | ea input isNil ]. (self isWiring and: [ potentialConnections size = 2 ]) ifTrue: [ nextConnection _ potentialConnections second. potentialConnections _ potentialConnections copyFrom: 1 to: 1 ]. potentialConnections do: [ :constraint | | localPoint targets | localPoint _ self griddedPoint: constraint targetPoint. targets _ self connectionTargetsAt: localPoint for: constraint. targets notEmpty ifTrue: [ Sensor shiftPressed ifFalse: [ constraint attachTo: targets first at: localPoint ] ifTrue: [ constraint attachTo: targets last at: localPoint ] ] ifFalse: [ constraint connectToNothing; forceRedraw ]. ]. self changed; layoutChanged. (self isWiring and: [ nextConnection notNil ]) ifTrue: [ | evt label pos | hand ifNil: [ hand _ self currentHand ]. evt _ hand lastEvent. pos _ self griddedPoint: (self globalPointToLocal: evt position). potentialConnections first lastTargetPoint: pos. nextConnection center: pos. self visible: true. label _ self valueOfProperty: #wiringLabel. label ifNotNil: [ self removeProperty: #wiringLabel. label visible: true. ]. Cursor normal show. self setProperty: #triggeredWireFinish toValue: pos. fsm trigger: #wireFinish withArguments: { nextConnection . evt }. ] ifFalse: [ self determineConnectionState ]. self reduceVertices. ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 6/14/2002 12:01'! exitDraggingSegment | evt vertices segIndex | self removeDropShadow. evt _ fsm lastEventArguments first. vertices _ line vertices copy. segIndex _ self valueOfProperty: #draggingSegmentIndex. self isOrthogonal ifTrue: [ self orthogonalizeVertex: segIndex. self orthogonalizeVertex: segIndex + 1 ] ifFalse: [ vertices at: segIndex put: (self griddedPoint: (vertices at: segIndex) ). vertices at: segIndex + 1 put: (self griddedPoint: (vertices at: segIndex + 1 )). line setVertices: vertices. ]. evt hand releaseMouseFocus: self. self removeProperty: #draggingSegmentIndex. self removeProperty: #draggingSegmentVertices. self removeProperty: #draggingSegmentStart. constraints do: [ :ea | ea startStepping ]. self startStepping. ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/18/2002 16:08'! exitDraggingVertex | evt ix | self removeDropShadow. evt _ fsm lastEventArguments first. ix _ self valueOfProperty: #draggingVertexIndex. self isOrthogonal ifTrue: [ self orthogonalizeVertex: ix ] ifFalse: [ line setVertices: (line vertices copyReplaceFrom: ix to: ix with: { self griddedPoint: evt position } ) ]. (evt shiftPressed and: [ ((evt position) dist: (self valueOfProperty: #draggingVertexStart)) < self selectionSlop ]) ifTrue: [ self toggleHandles ]. evt hand releaseMouseFocus: self. self removeProperty: #draggingVertexIndex. self removeProperty: #draggingVertexStart. self startStepping. ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/7/2001 13:10'! findEndNear: localPoint "Answer a constraint near localPoint, or nil. If more than one near, prefer disconnected one." | possible margin | possible _ constraints detect: [ :ea | ea bounds containsPoint: localPoint ] ifNone: []. possible ifNotNil: [ ^possible ]. margin _ 20 min: ((constraints first position dist: constraints second position) / 3). possible _ SortedCollection sortBlock: [ :a :b | a input isNil ]. constraints with: (line arrowsContainPoint: localPoint) do: [ :constraint :flag | (flag or: [ (localPoint dist: constraint center) < margin ]) ifTrue: [ possible add: constraint ] ]. ^possible at: 1 ifAbsent: [ ]! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 9/15/2002 11:54'! monitorDestinationForEnd: aConstraint "self startStepping: #monitorDestinationForEnd: at: Time millisecondClockValue arguments: { constraint } stepTime: 200" | targets | targets _ self connectionTargetsAt: self world currentHand cursorPoint for: aConstraint. targets isEmpty ifFalse: [ targets _ { (Sensor shiftPressed ifTrue: [ targets last ] ifFalse: [ targets first ]) } ]. (targets isEmpty ifTrue: [ Cursor crossHair ] ifFalse: [ Cursor webLink ]) show. self valueOfProperty: #highlightedTargets ifPresentDo: [ :ht | ht do: [ :ea | (targets includes: ea) ifFalse: [ ea highlightForConnection: false ] ]]. targets do: [ :ea | ea highlightedForConnection ifFalse: [ ea highlightForConnection: true ]]. self setProperty: #highlightedTargets toValue: targets.! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/18/2002 17:43'! mouseDownInConnected: anEvent | constraint vertex vertexIndex pos | pos _ "self griddedPoint:" anEvent position. constraint _ self findEndNear: pos. constraint ifNotNil: [ ^fsm trigger: #mouseDownNearEnd withArguments: { constraint . anEvent } ]. line vertices withIndexDo: [ :ea :ix | (ea dist: pos) < (line isCurve ifTrue: [ 40 ] ifFalse: [ 20 ]) ifTrue: [ vertex _ ea. vertexIndex _ ix ] ]. vertex ifNotNil: [ (vertexIndex > 1 and: [ vertexIndex < line vertices size ]) ifTrue: [ ^fsm trigger: #mouseDownOnVertex withArguments: { anEvent . vertex . vertexIndex } ] ]. vertexIndex _ line closestSegmentTo: pos. (anEvent shiftPressed or: [ vertexIndex = 1 or: [ vertexIndex = (line vertices size - 1) ] ]) ifTrue: [ line setVertices: (line vertices copyReplaceFrom: vertexIndex + 1 to: vertexIndex with: (Array with: pos)). self ensureHandles. ^(self isOrthogonal and: [ line vertices size > 3 ]) ifTrue: [ fsm trigger: #mouseDownOnSegment withArguments: { anEvent . pos . vertexIndex = 1 ifTrue: [ 2 ] ifFalse: [ line vertices size - 2 ] } ] ifFalse: [ fsm trigger: #mouseDownOnVertex withArguments: { anEvent . pos . vertexIndex + 1 } ] ]. fsm trigger: #mouseDownOnSegment withArguments: { anEvent . pos . vertexIndex } ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 3/11/2001 20:35'! mouseDownInDisconnected: anEvent | constraint | constraint _ self findEndNear: anEvent position. constraint ifNil: [ self straighten. anEvent hand grabMorph: self. "will generate ownerChangedToHand event" ] ifNotNil: [ fsm trigger: #mouseDownNearEnd withArguments: { constraint . anEvent } ]. ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/5/2001 15:05'! mouseDownInOneEndConnected: anEvent | constraint | constraint _ self findEndNear: anEvent position. constraint ifNotNil: [ constraint connectToNothing. ^fsm trigger: #mouseDownNearEnd withArguments: { constraint . anEvent } ]. constraint _ constraints detect: [ :ea | ea input isNil ]. constraint ifNil: [ self error: 'can''t happen' ] ifNotNil: [ constraint center: anEvent position. fsm trigger: #mouseDownNearEnd withArguments: { constraint . anEvent } ]. ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 3/11/2001 19:23'! mouseMoveInDraggingSegment: anEvent | vertices delta segIndex | vertices _ (self valueOfProperty: #draggingSegmentVertices) copy. delta _ anEvent position - (self valueOfProperty: #draggingSegmentStart). segIndex _ self valueOfProperty: #draggingSegmentIndex. vertices at: segIndex put: (vertices at: segIndex) + delta. vertices at: segIndex + 1 put: (vertices at: segIndex + 1) + delta. line setVertices: vertices.! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/16/2002 15:09'! mouseMoveInDraggingVertex: anEvent | ix | ix _ self valueOfProperty: #draggingVertexIndex. line setVertices: (line vertices copyReplaceFrom: ix to: ix with: { anEvent position } ) ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/16/2002 22:42'! mouseUpInDraggingEnd: anEvent | started pt dist | started _ self valueOfProperty: #startDraggingTime ifAbsent: [ 0 ]. anEvent timeStamp - started < HandMorph doubleClickTime ifTrue: [ ^self ]. self removeProperty: #startDraggingTime. pt _ self valueOfProperty: #triggeredWireFinish ifAbsent: [ 0@0 ]. dist _ anEvent position dist: pt. dist > 10 ifTrue: [ self removeProperty: #triggeredWireFinish. anEvent hand releaseMouseFocus: self. fsm newState: #handlingDrop ]! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 6/16/2002 09:12'! pasteUpChanged: newPasteUp constraints do: [ :ea | ea forceRedraw ] ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/19/2002 13:20'! startMonitoringEnd: constraint self startStepping: #monitorDestinationForEnd: at: Time millisecondClockValue arguments: { constraint } stepTime: 100 ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/19/2002 12:04'! stopMonitoringEnd self stopSteppingSelector: #monitorDestinationForEnd:. self valueOfProperty: #highlightedTargets ifPresentDo: [ :targets | targets do: [ :ea | ea highlightForConnection: false ]. self removeProperty: #highlightedTargets ]. ! ! !NCConnectorMorph methodsFor: 'event handling' stamp: 'nk 4/5/2001 19:10'! yellowButtonDown: evt onEnd: aConstraintOrNil | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: self externalName. self addYellowButtonMenuItemsTo: aMenu event: evt. aConstraintOrNil ifNotNil: [ | subMenu | subMenu _ MenuMorph new defaultTarget: aConstraintOrNil. aMenu addLine. aMenu add: 'end...' subMenu: subMenu. aConstraintOrNil addYellowButtonMenuItemsTo: subMenu event: evt. #('delete' 'resize' 'properties...' ) do: [:ea | (subMenu itemWithWording: ea) ifNotNilDo: [:item | item target = aConstraintOrNil ifTrue: [item delete]]] ]. aMenu popUpInWorld: World! ! !NCConnectorMorph methodsFor: 'geometry testing' stamp: 'nk 3/28/2002 09:31'! containsPoint: aPoint "first, bounds test (simple)" (super containsPoint: aPoint) ifFalse: [^false]. constraints do: [:ea | (ea containsPoint: aPoint) ifTrue: [^true]]. line ifNil: [^true]. line lineSegmentsDo: [:p1 :p2 | (aPoint onLineFrom: p1 to: p2 within: (self selectionSlop + (line borderWidth // 2)) asFloat) ifTrue: [^true]]. ^line arrowForms anySatisfy: [:f | (f pixelValueAt: aPoint - f offset) > 0 ]. ! ! !NCConnectorMorph methodsFor: 'error handling' stamp: 'nk 6/19/2002 09:21'! doesNotUnderstand: aMessage "As much as possible, delegate all behavior to my line" ^(line respondsTo: aMessage selector) ifTrue: [ "Transcript nextPutAll: self class name; nextPutAll: ' DNU '; nextPutAll: aMessage selector; cr. " line perform: aMessage selector withArguments: aMessage arguments. ] ifFalse: [ super doesNotUnderstand: aMessage ]! ! !NCConnectorMorph methodsFor: 'meta-actions' stamp: 'nk 4/15/2002 16:20'! duplicate | newMorph | newMorph _ super duplicate. newMorph setProperty: #justDuplicated toValue: true. ^newMorph! ! !NCConnectorMorph methodsFor: 'meta-actions' stamp: 'nk 4/5/2002 12:32'! duplicateMorph: evt | newMorph | newMorph _ super duplicateMorph: evt. newMorph setProperty: #justDuplicated toValue: true. ^newMorph! ! !NCConnectorMorph methodsFor: 'initialization' stamp: 'nk 3/11/2001 22:26'! fromMorph: startMorph toMorph: endMorph color: lineColor width: lineWidth constraints with: { startMorph . endMorph } do: [ :c :i | c inputs: { i } ]. line borderColor: lineColor; borderWidth: lineWidth. fsm trigger: #createdConnected. ! ! !NCConnectorMorph methodsFor: 'initialization' stamp: 'nk 4/17/2001 07:48'! initialize super initialize. self initializeFSM. super color: Color transparent. line _ PolygonMorph vertices: { 0@0 . 50@0 } color: Color black borderWidth: 2 borderColor: Color black. constraints _ Array new: 2. constraints at: 1 put: ((NCLineEndConstraintMorph new line: line firstVertex: true otherMorph: nil) connectToNearestPoint; center: 0@0; lastTargetPoint: 0@0; yourself). constraints at: 2 put: ((NCLineEndConstraintMorph new line: line firstVertex: false otherMorph: nil) connectToNearestPoint; center: line vertices second; lastTargetPoint: line vertices second; yourself). self addAllMorphs: constraints. self addMorphBack: line. ! ! !NCConnectorMorph methodsFor: 'initialization' stamp: 'nk 3/14/2001 14:32'! initializeFSM "All mouse or keyboard events have a single arg: the event" fsm copyFromPrototype: DefaultFSM; client: self; trigger: #initialized. "but what if we're not in #initial?" ! ! !NCConnectorMorph methodsFor: 'initialization' stamp: 'nk 3/14/2001 15:01'! reinitializeFSM | newFSM | newFSM _ self class stateMachineClass new. newFSM copyFromPrototype: DefaultFSM; copyStateFrom: fsm. newFSM client: self. fsm _ newFSM! ! !NCConnectorMorph methodsFor: 'testing' stamp: 'nk 3/12/2002 09:27'! isConnector ^true! ! !NCConnectorMorph methodsFor: 'wiring' stamp: 'nk 3/18/2001 14:05'! isWiring ^self valueOfProperty: #wiring ifAbsent: [ false ]! ! !NCConnectorMorph methodsFor: 'wiring' stamp: 'nk 3/18/2001 14:06'! isWiring: aBoolean aBoolean ifTrue: [ self setProperty: #wiring toValue: true ] ifFalse: [ self removeProperty: #wiring ]! ! !NCConnectorMorph methodsFor: 'wiring' stamp: 'nk 6/17/2002 10:56'! startWiring "NCConnectorMorph new startWiring" self isWiring: true. self visible: false. World currentHand attachMorph: self. self position: self position + World currentHand cursorPoint - constraints first center. Cursor crossHair show. ! ! !NCConnectorMorph methodsFor: 'wiring' stamp: 'nk 8/1/2002 20:34'! startWiringFrom: aMorph "NCConnectorMorph new startWiringFrom: (Morph new openInWorld)" | hand | hand _ World currentHand. self isWiring: true. constraints first position: hand position; input: aMorph. constraints second position: hand lastEvent cursorPoint. self openInWorld. fsm trigger: #wireFrom withArguments: { constraints last . hand lastEvent }. ! ! !NCConnectorMorph methodsFor: 'wiring' stamp: 'nk 3/27/2002 21:41'! startWiringLabeled self startWiringLabeled: 'label'! ! !NCConnectorMorph methodsFor: 'wiring' stamp: 'nk 6/17/2002 11:01'! startWiringLabeled: labelString | label | label _ (self addUnwrappedLabel: labelString at: self midpoint) visible: false. label offset: 0@10. label textWrap: true. self setProperty: #wiringLabel toValue: label. self startWiring.! ! !NCConnectorMorph methodsFor: 'wiring' stamp: 'nk 6/17/2002 10:57'! startWiringVisibly "NCConnectorMorph new startWiringVisibly" self startWiring. self visible: true. ! ! !NCConnectorMorph methodsFor: 'structure' stamp: 'nk 6/17/2002 12:36'! jumpToOwner: newOwner | transform | transform _ owner transformFromWorld composedWithLocal: newOwner transformFromWorld inverseTransformation. self transformedBy: transform. newOwner addMorphFront: self. ! ! !NCConnectorMorph methodsFor: 'structure' stamp: 'nk 6/17/2002 09:58'! jumpToWorld "Change from my owner to the World, but maintain my original global position." self jumpToOwner: World! ! !NCConnectorMorph methodsFor: 'structure' stamp: 'nk 12/4/2002 14:15'! noteNewOwner: aMorph super noteNewOwner: aMorph. aMorph isHandMorph ifTrue: [ fsm trigger: #ownerChangedToHand with: aMorph ] ifFalse: [ aMorph isPlayfieldLike ifTrue: [ fsm trigger: #ownerChangedToPasteUp with: aMorph] ifFalse: [ fsm trigger: #ownerChanged with: aMorph ] ] ! ! !NCConnectorMorph methodsFor: 'structure' stamp: 'nk 3/22/2002 12:20'! pasteUpMorph "Answer the closest containing morph that is a PasteUp morph. If none, answer the world." self allOwnersDo: [:m | (m isPlayfieldLike) ifTrue: [^ m]]. ^ ActiveWorld! ! !NCConnectorMorph methodsFor: 'layout' stamp: 'nk 2/26/2001 10:10'! layoutChanged bounds _ self submorphBounds. super layoutChanged. ! ! !NCConnectorMorph methodsFor: 'debug and other' stamp: 'nk 3/7/2001 21:02'! logFSMToTranscript fsm logToTranscript! ! !NCConnectorMorph methodsFor: 'halos and balloon help' stamp: 'nk 4/11/2002 09:48'! okayToResizeEasily "Answer whether it is appropriate for a sizing handle to be shown for the receiver" ^ false! ! !NCConnectorMorph methodsFor: 'halos and balloon help' stamp: 'nk 4/11/2002 09:44'! okayToRotateEasily "Answer whether it is appropriate for a rotation handle to be shown for the receiver" ^ false! ! !NCConnectorMorph methodsFor: 'events-processing' stamp: 'nk 6/19/2002 09:22'! processEvent: anEvent using: anIgnoredDispatcher "NOTE: anEvent has already been transformed to my coordinate system. This processes control-clicks, blue-button clicks, and yellow-button clicks without using the FSM." (self containsPoint: anEvent position) ifFalse: [ ^#rejected ]. (anEvent type == #mouseDown) ifTrue: [ anEvent wasHandled: true. anEvent blueButtonChanged ifTrue: [ ^self blueButtonDown: anEvent ]. anEvent controlKeyPressed ifTrue: [ ^self invokeMetaMenu: anEvent ]. anEvent yellowButtonPressed ifTrue: [ ^self yellowButtonDown: anEvent onEnd: (self findEndNear: anEvent position) ]. self isPartsDonor ifTrue: [ anEvent wasHandled: false. ^#rejected ]. ]. (anEvent type == #keystroke) ifTrue: [ anEvent keyValue == 27 ifTrue: [ anEvent wasHandled: true. ^self yellowButtonDown: anEvent onEnd: (self findEndNear: anEvent position) ] ]. (self rejectsEvent: anEvent) ifTrue: [ "(#(mouseOver mouseMove) includes: anEvent type ) ifFalse: [ Transcript print: self; nextPutAll: ' ('; print: fsm currentState; nextPutAll: ') rejected '; print: anEvent; cr ]." ^#rejected ]. self comeToFront. anEvent wasHandled: true. fsm trigger: anEvent type with: anEvent. ! ! !NCConnectorMorph methodsFor: 'stepping and presenter' stamp: 'nk 6/11/2002 15:19'! step | numberOfConnections connections | owner ifNil: [ ^self ]. "don't bother doing anything if unowned" connections _ self validConnections. numberOfConnections _ connections size. owner isHandMorph ifFalse: [ self setCorrectOwnerForConnections: connections ]. (numberOfConnections == 1 and: [ fsm currentState == #connected ]) ifTrue: [ ^fsm trigger: #endGone ]. numberOfConnections == 0 ifTrue: [ fsm currentState == #connected ifTrue: [ ^fsm trigger: #bothEndsGone ]. fsm currentState == #oneEndConnected ifTrue: [ ^fsm trigger: #endGone ] ]. (numberOfConnections == 2 and: [ self isOrthogonal not ]) ifTrue: [ self fixDegenerateLine ]. self isOrthogonal ifTrue: [ | numberOfVertices | numberOfVertices _ line vertices size. (numberOfConnections > 0 and: [ numberOfVertices > 2 ]) ifTrue: [ self orthogonalizeVertex: 2 ]. (numberOfConnections > 1 and: [ numberOfVertices > 3 ]) ifTrue: [ self orthogonalizeVertex: line vertices size - 1 ]. self reduceVertices. ] ! ! !NCConnectorMorph methodsFor: 'stepping and presenter' stamp: 'nk 2/20/2001 16:00'! stepTime ^100! ! !NCConnectorMorph methodsFor: '*skeleton' stamp: 'tak 10/3/2003 16:12'! lineEndChanged ^self changed: #PlayerChanged! ! !NCFSMMorph class methodsFor: 'instance creation' stamp: 'nk 2/26/2001 21:30'! includeInNewMorphMenu ^false! ! !NCFSMMorph class methodsFor: 'instance creation' stamp: 'nk 3/14/2001 14:07'! stateMachineClass ^NCFiniteStateMachine! ! !NCConnectorMorph class methodsFor: 'class variables' stamp: 'nk 3/14/2001 15:11'! defaultFSM ^DefaultFSM! ! !NCConnectorMorph class methodsFor: 'examples' stamp: 'nk 2/13/2001 18:49'! example1 "NCConnectorMorph example1" | e l r | e _ EllipseMorph new position: 600@100; openInWorld. r _ RectangleMorph new position: 500@150; openInWorld. l _ self fromMorph: e toMorph: r color: Color blue width: 2. l makeBothArrows; connectToNearestPoint. World addMorph: l. ^l ! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 3/3/2001 16:51'! fromMorph: startMorph toMorph: endMorph ^self new fromMorph: startMorph toMorph: endMorph color: Color black width: 2 ! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 2/11/2001 19:14'! fromMorph: startMorph toMorph: endMorph color: lineColor width: lineWidth ^self new fromMorph: startMorph toMorph: endMorph color: lineColor width: lineWidth ! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 2/26/2001 21:30'! includeInNewMorphMenu ^true! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 4/3/2001 17:06'! newAssociation "Answer a new one of me ready for use in a class diagram" "NCConnectorMorph newAssociation openInHand" ^self new name: 'Association'! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 4/18/2001 10:26'! newDirectionalAssociation "Answer a new one of me with an arrow at the 'to' end ready for use in a class diagram" "NCConnectorMorph newDirectionalAssociation openInHand" ^self new name: 'Association'; addShapes: { nil . NCLineEndConstraintMorph openArrowheadShape }. ! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 6/25/2002 18:20'! newGeneralizationRelationship "Answer a new one of me ready for use in a class diagram" "NCConnectorMorph newGeneralizationRelationship openInHand" ^self new addShapes: { nil . NCLineEndConstraintMorph closedArrowheadShape }; name: 'Generalization'! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 4/3/2001 17:07'! newImplementationRelationship "Answer a new one of me ready for use in a class diagram" "NCConnectorMorph newImplementationRelationship openInHand" ^self newGeneralizationRelationship dashedLine: true; name: 'Implements'! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 6/27/2002 10:48'! newNoteConnector "Answer a new one of me ready for use in a class diagram" "NCConnectorMorph newNoteConnector openInHand" ^self new dashedLine: true; borderWidth: 1; name: 'Note Connector'; connectToNearestPointToCenter.! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 3/27/2001 12:55'! newStateTransition "Answer a new one of me ready for use in a state diagram" "NCConnectorMorph newStateTransition openInHand" ^self new makeForwardArrow; name: 'Transition'! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 2/24/2002 11:25'! startWiringVia: selector label: aString | newMe | newMe _ self perform: selector. newMe name: aString. newMe startWiring.! ! !NCConnectorMorph class methodsFor: 'instance creation' stamp: 'nk 3/14/2001 14:08'! stateMachineClass ^NCSharedFiniteStateMachine ! ! !NCConnectorMorph class methodsFor: 'class initialization' stamp: 'nk 6/17/2002 09:15'! initialize "NCConnectorMorph initialize" DefaultFSM ifNil: [ DefaultFSM _ NCFiniteStateMachine new ]. self initializeFSM: DefaultFSM. Preferences addPreference: #useSmartLabels categories: #(connectors) default: true balloonHelp: 'if true, use labels that try to position themselves'. MinimumSelectionSlop _ 4 ! ! !NCConnectorMorph class methodsFor: 'class initialization' stamp: 'nk 8/6/2002 12:27'! initializeFSM: fsm "NCConnectorMorph initialize" "All mouse or keyboard events have a single arg: the event" ^fsm initialize; when: #initialized inState: #initial changeStateTo: #unOwned; when: #ownerChangedToPasteUp inState: #unOwned changeStateTo: #disconnected; when: #ownerChangedToHand inState: #unOwned changeStateTo: #draggingMorph; when: #createdConnected inState: #unOwned sendToClient: #determineConnectionState; when: #connectEndTo inState: #unOwned sendToClient: #determineConnectionState; whenEnteringState: #disconnected sendToClient: #connectionsChanged; when: #mouseDown inState: #disconnected sendToClient: #mouseDownInDisconnected: ; when: #ownerChangedToHand inState: #disconnected changeStateTo: #draggingMorph; when: #mouseDownNearEnd inState: #disconnected changeStateTo: #draggingEnd; when: #connectEndTo inState: #disconnected changeStateTo: #oneEndConnected; when: #wireFrom inState: #disconnected changeStateTo: #draggingEnd; when: #ownerChangedToPasteUp inState: #disconnected sendToClient: #pasteUpChanged: ; whenEnteringState: #draggingMorph sendToClient: #enterDraggingMorph; when: #ownerChangedToPasteUp inState: #draggingMorph changeStateTo: #handlingDrop; whenEnteringState: #handlingDrop sendToClient: #enterHandlingDrop; when: #mouseUp inState: #handlingDrop sendToClient: #ignore: ; when: #wireFinish inState: #handlingDrop changeStateTo: #draggingEnd; whenEnteringState: #draggingEnd sendToClient: #enterDraggingEnd; when: #mouseUp inState: #draggingEnd sendToClient: #mouseUpInDraggingEnd: ; "when: #mouseUp inState: #draggingEnd changeStateTo: #handlingDrop ;" when: #mouseDown inState: #draggingEnd sendToClient: #mouseUpInDraggingEnd: ; "when: #mouseDown inState: #draggingEnd changeStateTo: #handlingDrop ;" when: #ownerChangedToPasteUp inState: #draggingEnd sendToClient: #pasteUpChanged: ; whenEnteringState: #oneEndConnected sendToClient: #connectionsChanged; when: #mouseDown inState: #oneEndConnected sendToClient: #mouseDownInOneEndConnected: ; when: #mouseDownNearEnd inState: #oneEndConnected changeStateTo: #draggingEnd; when: #connectEndTo inState: #oneEndConnected changeStateTo: #connected; when: #endGone inState: #oneEndConnected changeStateTo: #disconnected; when: #ownerChangedToHand inState: #oneEndConnected changeStateTo: #draggingMorph; when: #ownerChangedToPasteUp inState: #oneEndConnected sendToClient: #pasteUpChanged: ; whenEnteringState: #connected sendToClient: #enterConnected; whenEnteringState: #connected sendToClient: #connectionsChanged; when: #mouseDown inState: #connected sendToClient: #mouseDownInConnected: ; when: #mouseDownNearEnd inState: #connected changeStateTo: #draggingEnd; when: #mouseDownOnSegment inState: #connected changeStateTo: #draggingSegment; when: #mouseDownOnVertex inState: #connected changeStateTo: #draggingVertex; when: #endGone inState: #connected changeStateTo: #oneEndConnected; when: #bothEndsGone inState: #connected changeStateTo: #disconnected; when: #ownerChangedToHand inState: #connected changeStateTo: #draggingMorph; when: #ownerChangedToPasteUp inState: #connected sendToClient: #pasteUpChanged: ; whenEnteringState: #fixingDegenerateLine sendToClient: #enterFixingDegenerateLine; afterEnteringState: #fixingDegenerateLine changeStateTo: #connected; whenEnteringState: #draggingSegment sendToClient: #enterDraggingSegment; when: #mouseMove inState: #draggingSegment sendToClient: #mouseMoveInDraggingSegment: ; when: #mouseUp inState: #draggingSegment changeStateTo: #connected; when: #ownerChangedToPasteUp inState: #draggingSegment sendToClient: #pasteUpChanged:; whenExitingState: #draggingSegment sendToClient: #exitDraggingSegment; whenEnteringState: #draggingVertex sendToClient: #enterDraggingVertex; when: #mouseMove inState: #draggingVertex sendToClient: #mouseMoveInDraggingVertex: ; when: #mouseUp inState: #draggingVertex changeStateTo: #connected; whenExitingState: #draggingVertex sendToClient: #exitDraggingVertex; yourself ! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 2/12/2001 16:19'! afterEnteringState: aState changeStateTo: aNewState self whenEnteringState: aState send: #newState: to: self with: aNewState! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 3/14/2001 20:21'! whenEnteringState: aState perform: aMessageSend ((stateActions at: aState ifAbsentPut: [ IdentityDictionary new ]) at: #entry ifAbsentPut: [ OrderedCollection new ]) add: aMessageSend! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 3/11/2001 08:01'! whenEnteringState: aState send: aSelector to: anObject self whenEnteringState: aState perform: (MessageSend receiver: anObject selector: aSelector)! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 2/12/2001 15:32'! whenEnteringState: aState send: aSelector to: anObject with: anArgument self whenEnteringState: aState perform: (MessageSend receiver: anObject selector: aSelector argument: anArgument)! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 2/12/2001 15:33'! whenEnteringState: aState send: aSelector to: anObject withArguments: anArray self whenEnteringState: aState perform: (MessageSend receiver: anObject selector: aSelector arguments: anArray)! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 3/14/2001 14:03'! whenEnteringState: aState sendToClient: aSelector self whenEnteringState: aState perform: (MessageSend receiver: self selector: aSelector)! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 2/15/2001 10:33'! whenExitingState: aState perform: aMessageSend ((stateActions at: aState ifAbsentPut: [ IdentityDictionary new ]) at: #exit ifAbsentPut: [ OrderedCollection new ]) add: aMessageSend! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 3/11/2001 08:01'! whenExitingState: aState send: aSelector to: anObject self whenExitingState: aState perform: (MessageSend receiver: anObject selector: aSelector)! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 2/12/2001 15:34'! whenExitingState: aState send: aSelector to: anObject with: anArgument self whenExitingState: aState perform: (MessageSend receiver: anObject selector: aSelector argument: anArgument)! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 2/12/2001 15:34'! whenExitingState: aState send: aSelector to: anObject withArguments: anArray self whenExitingState: aState perform: (MessageSend receiver: anObject selector: aSelector arguments: anArray)! ! !NCFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 3/14/2001 14:03'! whenExitingState: aState sendToClient: aSelector self whenExitingState: aState perform: (MessageSend receiver: self selector: aSelector)! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 2/23/2001 19:24'! canLog ^logger notNil and: [ logger canLog ]! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 2/23/2001 19:21'! isLogging ^logger notNil and: [ logger isLogging ]! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 2/23/2001 19:21'! logChangeFrom: oldState to: state logger ifNotNil: [ logger logChangeFrom: oldState to: state ]! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 2/23/2001 19:21'! logInitialize logger ifNotNil: [ logger logInitialize ]! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 3/11/2001 11:57'! logMessageSend: aMessageSend withArguments: args logger ifNotNil: [ logger logMessageSend: aMessageSend withArguments: args ]! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 2/23/2001 19:21'! logMissedEvent: event withArguments: args logger ifNotNil: [ logger logMissedEvent: event withArguments: args ]! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 2/23/2001 19:22'! logReset logger ifNotNil: [ logger logReset ]! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 4/10/2001 22:21'! logTo: stream self logger: ((NCFSMStreamLogger on: stream) fsm: self). self logging: true.! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 3/29/2002 21:51'! logToTranscript self logTo: (Smalltalk at: #Transcript)! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 2/23/2001 19:22'! logTrigger: eventSymbol withArguments: args logger ifNotNil: [ logger logTrigger: eventSymbol withArguments: args ]! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 3/14/2001 14:57'! logger ^logger! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 2/23/2001 19:23'! logger: aLogger logger _ aLogger! ! !NCFiniteStateMachine methodsFor: 'logging' stamp: 'nk 2/23/2001 19:22'! logging: aBoolean logger ifNotNil: [ logger logging: aBoolean ] ! ! !NCFiniteStateMachine methodsFor: 'accessing' stamp: 'nk 3/12/2001 11:44'! client ^client! ! !NCFiniteStateMachine methodsFor: 'accessing' stamp: 'nk 3/12/2001 11:44'! client: anObject client _ anObject! ! !NCFiniteStateMachine methodsFor: 'accessing' stamp: 'nk 2/12/2001 15:17'! currentState ^currentState! ! !NCFiniteStateMachine methodsFor: 'accessing' stamp: 'nk 3/4/2001 10:02'! eventActionsDo: aBlock "Evaluate aBlock with all of my registered event actions. Arguments are: * state name * event name * message send " transitions keysAndValuesDo: [ :state :dict | dict keysAndValuesDo: [ :event :msgSends | msgSends do: [ :msgSend | aBlock value: state value: event value: msgSend ] ] ].! ! !NCFiniteStateMachine methodsFor: 'accessing' stamp: 'nk 3/11/2001 08:33'! lastEventArguments ^lastEventArguments! ! !NCFiniteStateMachine methodsFor: 'accessing' stamp: 'nk 3/4/2001 10:08'! missedEventAction ^missedEventSend! ! !NCFiniteStateMachine methodsFor: 'accessing' stamp: 'nk 3/14/2001 19:27'! receiverFor: aMessageSend ^(aMessageSend receiver == self and: [ aMessageSend selector ~= #newState: ]) ifTrue: [ client ] ifFalse: [ aMessageSend receiver ].! ! !NCFiniteStateMachine methodsFor: 'accessing' stamp: 'nk 3/14/2001 20:21'! stateActionsDo: aBlock "Evaluate aBlock with all of my registered state actions. Arguments are: * state name * event name (entry or exit) * message send " stateActions keysAndValuesDo: [ :state :dict | #( entry exit ) do: [ :event | | msgSends | msgSends _ dict at: event ifAbsent: [ #() ]. msgSends do: [ :msgSend | aBlock value: state value: event value: msgSend ] ] ]! ! !NCFiniteStateMachine methodsFor: 'accessing' stamp: 'nk 3/3/2001 16:28'! states "May miss the end states if no actions" ^(transitions keys) addAll: stateActions keys; yourself! ! !NCFiniteStateMachine methodsFor: 'copying' stamp: 'nk 4/19/2002 10:11'! copyStateFrom: anFSM currentState _ anFSM currentState. newState _ anFSM newState. lastEventArguments _ anFSM lastEventArguments. client _ anFSM client. logger _ anFSM logger. missedEventSend _ anFSM missedEventSend! ! !NCFiniteStateMachine methodsFor: 'copying' stamp: 'nk 3/14/2001 15:40'! veryDeepFixupWith: deepCopier "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals." client _ deepCopier references at: client ifAbsent: [ client ].! ! !NCFiniteStateMachine methodsFor: 'copying' stamp: 'nk 4/30/2001 17:56'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." transitions _ transitions veryDeepCopyWith: deepCopier. currentState _ currentState. stateActions _ stateActions veryDeepCopyWith: deepCopier. newState _ currentState. missedEventSend _ missedEventSend veryDeepCopyWith: deepCopier. logger _ logger veryDeepCopyWith: deepCopier. lastEventArguments _ nil. client _ client.! ! !NCFiniteStateMachine methodsFor: 'private-accessing' stamp: 'nk 4/30/2001 17:56'! currentState: aSymbol aSymbol == currentState ifTrue: [ ^self ]. self exitState: currentState. self logChangeFrom: currentState to: aSymbol. currentState _ aSymbol. self enterState: currentState. "could change newState" newState == currentState ifFalse: [ self currentState: newState ]. "call recursively until we're in the right state" ! ! !NCFiniteStateMachine methodsFor: 'private-accessing' stamp: 'nk 3/12/2001 11:51'! missedEventSend ^missedEventSend! ! !NCFiniteStateMachine methodsFor: 'private-accessing' stamp: 'nk 4/19/2002 10:11'! newState ^newState! ! !NCFiniteStateMachine methodsFor: 'private-accessing' stamp: 'nk 3/12/2001 11:38'! stateActionSpecs ^stateActions! ! !NCFiniteStateMachine methodsFor: 'private-accessing' stamp: 'nk 3/12/2001 11:38'! transitionSpecs ^transitions! ! !NCFiniteStateMachine methodsFor: 'private' stamp: 'nk 3/14/2001 20:21'! enterState: aState ((stateActions at: aState ifAbsent: [ ^self ]) at: #entry ifAbsent: [ ^self ]) do: [ :ea | self performMessageSend: ea withArguments: { } ]! ! !NCFiniteStateMachine methodsFor: 'private' stamp: 'nk 3/12/2001 13:33'! exitState: aState ((stateActions at: aState ifAbsent: [ ^self ]) at: #exit ifAbsent: [ ^self ]) do: [ :ea | self performMessageSend: ea withArguments: { } ]! ! !NCFiniteStateMachine methodsFor: 'private' stamp: 'nk 3/11/2001 10:37'! missedEvent: anEventSymbol "An event came in that we couldn't respond to." self logMissedEvent: anEventSymbol withArguments: #(). missedEventSend ifNotNil: [ missedEventSend valueWithArguments: { anEventSymbol . nil } ] ! ! !NCFiniteStateMachine methodsFor: 'private' stamp: 'nk 2/20/2001 17:20'! missedEvent: anEventSymbol withArguments: args "An event came in that we couldn't respond to." self logMissedEvent: anEventSymbol withArguments: args. missedEventSend ifNotNil: [ missedEventSend valueWithArguments: { anEventSymbol . args } ]! ! !NCFiniteStateMachine methodsFor: 'events' stamp: 'nk 4/5/2001 11:09'! forceCurrentStateFromNewState newState == currentState ifFalse: [ self currentState: newState ]! ! !NCFiniteStateMachine methodsFor: 'events' stamp: 'nk 2/12/2001 16:30'! removeEventsTriggeredFor: anObject "Remove all the events triggered by the receiver which would have been sent to anObject in any state." self states do: [ :ea | self removeEventsTriggeredFor: anObject inState: ea ]! ! !NCFiniteStateMachine methodsFor: 'events' stamp: 'nk 3/12/2001 13:33'! trigger: anEventSymbol "Evaluate all message sends registered for anEventSymbol in my current state" lastEventArguments _ #(). self logTrigger: anEventSymbol withArguments: lastEventArguments. ((transitions at: currentState ifAbsent: [^ self missedEvent: anEventSymbol ]) at: anEventSymbol ifAbsent: [^ self missedEvent: anEventSymbol ]) do: [ :each | self performMessageSend: each withArguments: { } ]. newState == currentState ifFalse: [ self currentState: newState ]! ! !NCFiniteStateMachine methodsFor: 'events' stamp: 'nk 3/27/2002 14:32'! trigger: anEventSymbol with: anObject "Evaluate all message sends registered for anEventSymbol in my current state and pass anObject to the registered actions." ^self trigger: anEventSymbol withArguments: (Array with: anObject) ! ! !NCFiniteStateMachine methodsFor: 'events' stamp: 'nk 3/12/2001 13:33'! trigger: anEventSymbol withArguments: anArray "Evaluate all message sends registered for anEventSymbol in my current state and pass anArray to the registered actions." lastEventArguments _ anArray. self logTrigger: anEventSymbol withArguments: anArray. ((transitions at: currentState ifAbsent: [^ self missedEvent: anEventSymbol withArguments: anArray ]) at: anEventSymbol ifAbsent: [^ self missedEvent: anEventSymbol withArguments: anArray ]) do: [ :each | self performMessageSend: each withArguments: anArray ]. newState == currentState ifFalse: [ self currentState: newState ]! ! !NCFiniteStateMachine methodsFor: 'events' stamp: 'nk 2/14/2001 14:19'! willRespondTo: anEventSymbol "Answer whether I will respond to anEventSymbol in my current state" ^(transitions at: currentState ifAbsent: [^ false ]) includesKey: anEventSymbol.! ! !NCFiniteStateMachine methodsFor: 'events' stamp: 'nk 2/14/2001 14:24'! willRespondToAnyOf: someEventSymbols "Answer whether I will respond to any of someEventSymbols in my current state" ^(transitions at: currentState ifAbsent: [^ false ]) keys includesAnyOf: someEventSymbols.! ! !NCFiniteStateMachine methodsFor: 'initialization' stamp: 'nk 2/23/2001 19:39'! initialize currentState _ newState _ #initial. transitions _ IdentityDictionary new. stateActions _ IdentityDictionary new. transitions at: currentState put: IdentityDictionary new. stateActions at: currentState put: IdentityDictionary new. self logInitialize.! ! !NCFiniteStateMachine methodsFor: 'initialization' stamp: 'nk 2/20/2001 17:25'! reset currentState _ newState _ #initial. self logReset.! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 2/12/2001 16:10'! newState: aStateSymbol "To be invoked only from transition actions or state actions" newState _ aStateSymbol! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 3/12/2001 11:48'! removeEventsTriggeredFor: anObject inState: aState "Remove all the events triggered by the receiver which would have been sent to anObject in the given state." | events | events _ transitions at: aState ifAbsent: [ ^self ]. events copy keysAndValuesDo: [:evtSym :msgSendSet | | newSet | newSet _ msgSendSet reject: [:each | each receiver == anObject and: [ (anObject == self and: [ each selector == #newState: ]) not ] ]. msgSendSet size = newSet size ifFalse: [newSet isEmpty ifTrue: [ events removeKey: evtSym] ifFalse: [ events at: evtSym put: newSet]]].! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 3/12/2001 11:32'! removeEventsTriggeredForClientInState: aState self removeEventsTriggeredFor: self inState: aState! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 3/12/2001 11:32'! when: anEventSymbol clientSendEventInState: aState self when: anEventSymbol inState: aState send: anEventSymbol to: self! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 2/12/2001 16:17'! when: anEventSymbol inState: aState changeStateTo: aNewStateSymbol self when: anEventSymbol inState: aState send: #newState: to: self with: aNewStateSymbol. ! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 2/15/2001 10:32'! when: anEventSymbol inState: aState perform: aMessageSend ((transitions at: aState ifAbsentPut: [ IdentityDictionary new ]) at: anEventSymbol ifAbsentPut: [ OrderedCollection new ]) add: aMessageSend! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 2/12/2001 15:06'! when: anEventSymbol inState: aState send: aSelector to: anObject self when: anEventSymbol inState: aState perform: (MessageSend receiver: anObject selector: aSelector)! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 2/12/2001 15:06'! when: anEventSymbol inState: aState send: aSelector to: anObject with: anArgument self when: anEventSymbol inState: aState perform: (MessageSend receiver: anObject selector: aSelector argument: anArgument)! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 2/12/2001 15:07'! when: anEventSymbol inState: aState send: aSelector to: anObject withArguments: anArray self when: anEventSymbol inState: aState perform: (MessageSend receiver: anObject selector: aSelector arguments: anArray)! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 2/12/2001 15:08'! when: anEventSymbol inState: aState sendTo: anObject self when: anEventSymbol inState: aState send: anEventSymbol to: anObject! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 3/12/2001 11:30'! when: anEventSymbol inState: aState sendToClient: aSelector self when: anEventSymbol inState: aState send: aSelector to: self! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 3/12/2001 11:42'! when: anEventSymbol inState: aState sendToClient: aSelector with: anArgument self when: anEventSymbol inState: aState perform: (MessageSend receiver: self selector: aSelector argument: anArgument)! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 3/12/2001 11:42'! when: anEventSymbol inState: aState sendToClient: aSelector withArguments: anArray self when: anEventSymbol inState: aState perform: (MessageSend receiver: self selector: aSelector arguments: anArray)! ! !NCFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 2/12/2001 17:30'! whenMissedEventPerform: aMessageSendOrNil missedEventSend _ aMessageSendOrNil! ! !NCFiniteStateMachine methodsFor: 'objects from disk' stamp: 'nk 8/6/2002 06:43'! objectForDataStream: refStrm "If I am the default NCConnectorMorph prototype, write out a DiskProxy instead" lastEventArguments _ nil. (Smalltalk hasClassNamed: #NCConnectorMorph) ifTrue: [(Smalltalk classNamed: #NCConnectorMorph) defaultFSM == self ifTrue: [| dp | dp _ DiskProxy global: #NCConnectorMorph selector: #defaultFSM args: {}. refStrm replace: self with: dp. ^ dp]]! ! !NCFiniteStateMachine methodsFor: 'message handling' stamp: 'nk 3/12/2001 13:32'! performMessageSend: aMessageSend withArguments: args "Map sends to me (other than newState:) into sends to my client" ^(aMessageSend receiver == self and: [ aMessageSend selector ~= #newState: ]) ifTrue: [ | ms | ms _ (aMessageSend copy) receiver: client. self logMessageSend: ms withArguments: args. ms valueWithEnoughArguments: args ] ifFalse: [ self logMessageSend: aMessageSend withArguments: args. aMessageSend valueWithEnoughArguments: args ]! ! !NCFiniteStateMachine methodsFor: 'printing' stamp: 'nk 2/20/2001 16:13'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' state: '; nextPutAll: currentState printString! ! !NCFiniteStateMachine methodsFor: 'printing' stamp: 'nk 2/12/2001 17:23'! printVerboseOn: aStream aStream nextPutAll: 'CurrentState: '; nextPutAll: currentState printString; cr; nextPutAll: 'Transitions:'; cr. transitions keysAndValuesDo: [ :state :dict | aStream nextPutAll: 'In State '; nextPutAll: state printString; cr. dict keysAndValuesDo: [ :event :msgSends | msgSends do: [ :msgSend | aStream nextPutAll: 'On Event '; nextPutAll: event printString; nextPutAll: ' send '; nextPutAll: msgSend selector printString; nextPutAll: ' to '; nextPutAll: msgSend receiver printString; nextPutAll: ' with args '; nextPutAll: msgSend arguments printString; cr. ] ] ]. aStream nextPutAll: 'Actions:'; cr. stateActions keysAndValuesDo: [ :state :dict | dict keysAndValuesDo: [ :event :msgSends | aStream nextPutAll: 'State '; nextPutAll: state printString; space; nextPutAll: event; cr. msgSends do: [ :msgSend | aStream nextPutAll: event; tab; nextPutAll: msgSend selector printString; nextPutAll: ' to '; nextPutAll: msgSend receiver printString; nextPutAll: ' with args '; nextPutAll: msgSend arguments printString; cr. ] ] ] ! ! !NCFiniteStateMachine class methodsFor: 'instance creation' stamp: 'nk 10/28/2002 13:41'! new ^super new initialize! ! !NCHighlightMorph methodsFor: 'adjacency layout' stamp: 'nk 11/26/2002 11:23'! beAdjacent ^false! ! !NCHighlightMorph methodsFor: 'classification' stamp: 'nk 11/26/2002 11:23'! isHighlight ^true! ! !NCHighlightMorph methodsFor: 'WiW support' stamp: 'nk 11/26/2002 11:24'! morphicLayerNumber ^10! ! !NCLineEndConstraintMorph methodsFor: 'drop shadows' stamp: 'nk 4/7/2001 18:40'! addDropShadow self visible ifFalse: [ ^self ]. submorphs do: [ :sm | sm allMorphsDo: [ :ea | ea addDropShadow; shadowOffset: 3@4; shadowColor: Color gray ] ]. super visible ifTrue: [ super addDropShadow ]! ! !NCLineEndConstraintMorph methodsFor: 'drop shadows' stamp: 'nk 6/17/2002 22:13'! okayToRotateEasily "Answer whether it is appropriate for a rotation handle to be shown for the receiver" ^ false! ! !NCLineEndConstraintMorph methodsFor: 'drop shadows' stamp: 'nk 4/7/2001 18:41'! removeDropShadow self visible ifFalse: [ ^self ]. submorphs do: [ :sm | sm allMorphsDo: [ :ea | ea removeDropShadow ] ]. super removeDropShadow. self fixColor.! ! !NCLineEndConstraintMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 7/1/2002 14:08'! addJunctionDotShape self submorphs isEmpty ifTrue: [ self addShape: self class junctionDotShape. self connectToNearestOrthogonalPoint. self preferredConnection: #(#connectToNearestOrthogonalPoint) ].! ! !NCLineEndConstraintMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 7/1/2002 14:10'! deleteAllShapes self submorphs isEmpty ifFalse: [ self submorphs do: [ :ea | self deleteShape: ea ]. self preferredConnection: nil ] ! ! !NCLineEndConstraintMorph methodsFor: 'constraints' stamp: 'nk 6/26/2002 09:48'! addShape: aMorph | newMorph | aMorph ifNil: [ ^self ]. newMorph _ super addShape: aMorph. newMorph endShapeWidth: owner borderWidth. newMorph heading: self heading. newMorph referencePosition: self lastTargetPoint. self computeLineAttachmentPoint. self applyConstraint: lastTarget. self layoutChanged.! ! !NCLineEndConstraintMorph methodsFor: 'constraints' stamp: 'nk 6/25/2002 18:03'! computeLineAttachmentPoint ^lineAttachmentPoint _ (submorphs isEmpty ifTrue: [ 0@0 ] ifFalse: [ (submorphs collect: [ :ea | ea lineAttachmentOffset * ea extent ]) min ]) rounded ! ! !NCLineEndConstraintMorph methodsFor: 'constraints' stamp: 'nk 4/7/2001 17:49'! connectionTargetsAt: localPoint ^owner connectionTargetsAt: localPoint for: self! ! !NCLineEndConstraintMorph methodsFor: 'constraints' stamp: 'nk 4/15/2001 15:58'! constrainedVertex constrained ifNil: [ ^0@0 ]. ^constrained vertices at: self vertexIndex! ! !NCLineEndConstraintMorph methodsFor: 'constraints' stamp: 'nk 4/8/2001 16:30'! defaultTargetPoint ^self lastTargetPoint! ! !NCLineEndConstraintMorph methodsFor: 'constraints' stamp: 'nk 7/12/2002 14:54'! inputs: aCollection inputs do: [:ea | (ea notNil and: [ ea isHandMorph not]) ifTrue: [ea disconnectedFromBy: self owner]]. super inputs: aCollection. inputs do: [:ea | (ea notNil and: [ ea isHandMorph not]) ifTrue: [ea connectedToBy: self owner]] ! ! !NCLineEndConstraintMorph methodsFor: 'constraints' stamp: 'nk 2/22/2002 15:47'! lastTargetAngle: angle lastTarget _ lastTarget ifNil: [ { self constrainedVertex . angle } ] ifNotNil: [ { lastTarget first . angle } ]. ^lastTarget! ! !NCLineEndConstraintMorph methodsFor: 'constraints' stamp: 'nk 4/18/2001 12:47'! lastTargetPoint: aPoint lastTarget _ lastTarget ifNil: [ { aPoint . 0 } ] ifNotNil: [ { aPoint . lastTarget second } ]. ^lastTarget! ! !NCLineEndConstraintMorph methodsFor: 'constraints' stamp: 'nk 4/16/2002 15:11'! target "Answer an Array with my target point and angle" | pt | pt _ "self griddedPoint:" self targetPoint. ^{ pt . (self nextVertex - pt) degrees }! ! !NCLineEndConstraintMorph methodsFor: 'connection' stamp: 'nk 6/20/2002 13:22'! connectToNearestOrthogonalPoint self constraint: (MessageSend receiver: self selector: #nearestOrthogonalPointOn:)! ! !NCLineEndConstraintMorph methodsFor: 'connection' stamp: 'nk 4/5/2001 09:24'! preferredConnection: pref super preferredConnection: pref. self changed.! ! !NCLineEndConstraintMorph methodsFor: 'menus' stamp: 'nk 6/20/2002 13:37'! connectionsInMenu | retval | retval _ OrderedCollection withAll: super connectionsInMenu. retval add: #connectToNearestOrthogonalPoint afterIndex: retval size - 1. ^retval! ! !NCLineEndConstraintMorph methodsFor: 'menus' stamp: 'nk 2/22/2002 15:08'! deleteShape: aMorph super deleteShape: aMorph. self computeLineAttachmentPoint. self forceRedraw.! ! !NCLineEndConstraintMorph methodsFor: 'object fileIn' stamp: 'nk 4/19/2002 10:06'! convertToCurrentVersion lineAttachmentPoint ifNil: [ lineAttachmentPoint _ (self valueOfProperty: #lineAttachmentPoint ifAbsent: [ 0@0 ]). self removeProperty: #lineAttachmentPoint. ]. super convertToCurrentVersion.! ! !NCLineEndConstraintMorph methodsFor: 'object fileIn' stamp: 'nk 4/18/2002 21:57'! convertToCurrentVersion: varDict refStream: smartRefStrm lineAttachmentPoint ifNil: [ lineAttachmentPoint _ (self valueOfProperty: #lineAttachmentPoint ifAbsent: [ 0@0 ]). self removeProperty: #lineAttachmentPoint. ]. ^super convertToCurrentVersion: varDict refStream: smartRefStrm ! ! !NCLineEndConstraintMorph methodsFor: 'drawing' stamp: 'nk 4/18/2001 10:10'! drawOn: aCanvas self submorphsDo: [ :ea | ea drawOn: aCanvas ]. self hasAnyInputs ifFalse: [ aCanvas fillRectangle: ((Rectangle center: self lastTargetPoint extent: 10@10) intersect: self bounds) fillStyle: self fillStyle. ]! ! !NCLineEndConstraintMorph methodsFor: 'drawing' stamp: 'nk 4/18/2001 10:09'! visible self forcedInvisible ifTrue: [ ^false ]. submorphs isEmpty ifFalse: [ ^true ]. ^self preferredConnectionSelector ~~ #connectToNothing! ! !NCLineEndConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 3/5/2001 16:17'! ensureInFront "Make sure that I my line is in front of my input." | input world | constrained ifNil: [ ^self ]. (input _ self input) ifNil: [ ^self ]. (owner isNil or: [ (owner owner) ~~ (world _ input pasteUpMorph) ]) ifTrue: [ ^self ]. (constrained bounds intersects: (input bounds)) ifFalse: [ ^self ]. world ensureMorph: owner inFrontOf: input root.! ! !NCLineEndConstraintMorph methodsFor: 'stepping and presenter' stamp: 'nk 6/17/2002 20:32'! forceRedraw self lastTargetAngle: (lastTarget second + 1e-6). self changed. owner changed! ! !NCLineEndConstraintMorph methodsFor: 'layout' stamp: 'nk 4/8/2001 14:29'! fixColor submorphs isEmpty ifFalse: [ self color: (Color r: 1.0 g: 0 b: 0 alpha: 0.2 )]. super visible ifTrue: [ self color: Color red ]. ! ! !NCLineEndConstraintMorph methodsFor: 'layout' stamp: 'nk 4/8/2001 15:36'! layoutChanged self fixColor. submorphs isEmpty ifTrue: [ self privateBounds: (Rectangle center: self targetPoint extent: 10@10) ]. super layoutChanged. ! ! !NCLineEndConstraintMorph methodsFor: 'event handling' stamp: 'nk 2/26/2001 19:28'! handlesMouseDown: evt ^false! ! !NCLineEndConstraintMorph methodsFor: 'initialization' stamp: 'nk 4/18/2002 18:08'! initialize super initialize. lineAttachmentPoint _ 0@0. ! ! !NCLineEndConstraintMorph methodsFor: 'initialization' stamp: 'nk 4/18/2002 18:09'! line: l firstVertex: b otherMorph: m self constrained: l; inputs: { m }. firstVertex _ b. ! ! !NCLineEndConstraintMorph methodsFor: 'testing' stamp: 'nk 2/27/2001 13:02'! isLineConstraint ^true! ! !NCLineEndConstraintMorph methodsFor: 'accessing' stamp: 'nk 4/15/2001 14:32'! lastTargetPoint ^lastTarget ifNil: [ self constrainedVertex ] ifNotNil: [ lastTarget first ]! ! !NCLineEndConstraintMorph methodsFor: 'accessing' stamp: 'nk 4/18/2002 17:59'! lineAttachmentPoint ^lineAttachmentPoint! ! !NCLineEndConstraintMorph methodsFor: 'accessing' stamp: 'nk 4/18/2002 17:59'! lineAttachmentPoint: aPointOrNil lineAttachmentPoint _ aPointOrNil! ! !NCLineEndConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 6/15/2002 13:16'! nearestAttachmentPointOn: m ^m attachmentPointNearest: (self nextVertexRelativeTo: m) ! ! !NCLineEndConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 6/27/2002 12:35'! nearestOrthogonalPointOn: m ^m closestOrthogonalPointTo: (self nextVertexRelativeTo: m) ! ! !NCLineEndConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 2/15/2002 12:37'! nearestPointOn: m ^m closestPointTo: (self nextVertexRelativeTo: m)! ! !NCLineEndConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 2/15/2002 12:38'! nearestPointToCenterOf: m ^m intersectionWithLineSegmentFromCenterTo: (self nextVertexRelativeTo: m).! ! !NCLineEndConstraintMorph methodsFor: 'connection-callbacks' stamp: 'nk 6/12/2002 07:47'! nextVertexRelativeTo: m ^self point: self nextVertex relativeTo: m! ! !NCLineEndConstraintMorph methodsFor: 'private' stamp: 'nk 2/13/2001 18:27'! nextVertex "Answer the point at the next vertex toward the other end of the line" ^firstVertex ifTrue: [ constrained nextToFirstPoint ] ifFalse: [ constrained nextToLastPoint ]! ! !NCLineEndConstraintMorph methodsFor: 'private' stamp: 'nk 4/8/2001 16:49'! privateMoveBy: delta super privateMoveBy: delta. self lastTargetPoint: self lastTargetPoint + delta ! ! !NCLineEndConstraintMorph methodsFor: 'private' stamp: 'nk 2/13/2001 18:26'! vertexIndex "Answer the index of the end of the line that I'm constraining" ^firstVertex ifTrue: [ 1 ] ifFalse: [ constrained vertices size ]! ! !NCLineEndConstraintMorph methodsFor: 'halos and balloon help' stamp: 'nk 6/17/2002 22:17'! okayToBrownDragEasily "Answer whether it is appropriate for a drag handle to be shown for the receiver" ^ self hasAnyInputs not! ! !NCLineEndConstraintMorph methodsFor: '*skeleton-morph' stamp: 'tak 11/23/2003 17:41'! attacheePosition: aPoint "Set position of the attachee or my center" | delta target newPosition | delta := aPoint - self center. target := self input ifNil: [self forceRedraw; yourself] ifNotNil: [self input topRendererOrSelf ifNil: [self]]. newPosition := target position + delta. (target pasteUpMorph bounds containsRect: (newPosition extent: target extent)) ifTrue: [target position: newPosition]! ! !NCLineEndConstraintMorph methodsFor: '*skeleton-morph' stamp: 'tak 11/21/2003 18:01'! lightness "larger number is lighter weight, 0 .. most heavy" self input ifNil: [^ 1]. self input owner == ActiveHand ifTrue: [^ 2]. ^ self input isLocked ifTrue: [0] ifFalse: [3]! ! !NCLineEndConstraintMorph methodsFor: '*skeleton' stamp: 'tak 10/3/2003 20:50'! applyConstraint: anArray "anArray consists of { targetPoint . angle }" | newTargetPoint newPoint oldPoint angle | newTargetPoint _ anArray first. angle _ anArray second + 90.0. newPoint _ newTargetPoint. "Now compute actual line start" lineAttachmentPoint isZero ifFalse: [ newPoint _ newPoint + (lineAttachmentPoint rotateBy: angle negated degreesToRadians about: 0@0). newPoint _ newPoint rounded. ]. oldPoint _ constrained vertexAt: self vertexIndex. newPoint ~= oldPoint ifTrue: [ constrained verticesAt: self vertexIndex put: newPoint ]. (owner respondsTo: #lineEndChanged) ifTrue: [ owner lineEndChanged ]. submorphs isEmpty ifTrue: [ ^self center: newPoint ]. submorphs do: [ :ea | ea heading: angle. ea referencePosition: newTargetPoint. ]. bounds _ self submorphBounds. self layoutChanged.! ! !NCLineEndConstraintMorph methodsFor: '*skeleton' stamp: 'tak 10/2/2003 00:08'! isTargetHanded ^ self input owner == ActiveHand! ! !NCLineEndConstraintMorph methodsFor: '*skeleton' stamp: 'tak 10/2/2003 00:08'! isTargetLocked self input ifNil: [^ true]. ^ self input isLocked! ! !NCLineEndConstraintMorph class methodsFor: 'fileIn/Out' stamp: 'nk 4/18/2002 22:52'! classVersion "This version has the Message Sends and additional instance variables" ^2 ! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 7/28/2002 20:06'! closedArrowheadShape "NCLineEndConstraintMorph closedArrowheadShape openInHand" ^(self filledArrowheadShape) makeOpen; borderWidth: 2; name: 'closed arrowhead'; lineAttachmentOffset: 0@-1! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 6/25/2002 18:14'! crowsFootShape "NCLineEndConstraintMorph crowsFootShape openInHand" ^(PolygonMorph vertices: { 0@15 . 7@0. 14@15 } color: Color black borderWidth: 2 borderColor: Color black) makeOpen; setProperty: #referencePosition toValue: 7@16; lineAttachmentOffset: -0.01@0; vResizing: #rigid; hResizing: #rigid; name: 'crows foot' ! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 6/25/2002 17:41'! doubleArrowheadShape "NCLineEndConstraintMorph doubleArrowheadShape openInHand" ^(PolygonMorph vertices: { 0@0 . 7@9 . 14@0 . 7@9 . 7@15 . 0@6 . 7@15 . 14@6 } color: Color black borderWidth: 2 borderColor: Color black) makeOpen; setProperty: #referencePosition toValue: 7@15; lineAttachmentOffset: (0@(-8/15)) asFloatPoint; name: 'double arrowhead'! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 6/25/2002 17:28'! filledArrowheadShape "NCLineEndConstraintMorph filledArrowheadShape openInHand" ^(PolygonMorph vertices: { 0@0 . 7@17 . 14@0 . 0@0 } color: Color black borderWidth: 0 borderColor: Color black) setProperty: #referencePosition toValue: 7@17; vResizing: #rigid; hResizing: #rigid; name: 'filled arrowhead'! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 7/1/2002 16:03'! filledCircleShape "NCLineEndConstraintMorph filledCircleShape openInHand" ^ CircleMorph new borderWidth: 0; color: Color black; extent: 12@12; setProperty: #originalExtent toValue: 12@12; setProperty: #originalWidth toValue: 2; rotationCenter: 0.5@1.0; lineAttachmentOffset: 0@-1; name: 'filled circle'! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 6/25/2002 18:06'! filledDiamondShape "NCLineEndConstraintMorph filledDiamondShape openInHand" ^(PolygonMorph vertices: { 6@0 . 12@11 . 6@22 . 0@12 . 6@0 } color: Color black borderWidth: 0 borderColor: Color black) setProperty: #referencePosition toValue: 6@22; lineAttachmentOffset: -0.01@-0.95; name: 'filled diamond'! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 7/1/2002 16:22'! junctionDotShape "NCLineEndConstraintMorph junctionDotShape openInHand" ^ CircleMorph new borderWidth: 0; color: Color black; extent: 8@8; setProperty: #originalExtent toValue: 8@8; setProperty: #originalWidth toValue: 2; rotationCenter: 0.5@0.5; lineAttachmentOffset: 0@0; name: 'junction dot'! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 6/25/2002 17:20'! openArrowheadShape "NCLineEndConstraintMorph openArrowheadShape openInHand" "NCConnectorMorph newDirectionalAssociation openInHand" ^(PolygonMorph vertices: { 0@0 . 6@15 . 12@0 } color: Color black borderWidth: 2 borderColor: Color black) makeOpen; setProperty: #referencePosition toValue: 6@15; vResizing: #rigid; hResizing: #rigid; name: 'open arrowhead'! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 7/1/2002 07:19'! openCircleShape "NCLineEndConstraintMorph openCircleShape openInHand" ^self filledCircleShape borderWidth: 2; color: Color transparent; name: 'open circle'! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 4/8/2001 12:21'! openDiamondShape "NCLineEndConstraintMorph openDiamondShape openInHand" ^self filledDiamondShape makeOpen; borderWidth: 2; name: 'open diamond'! ! !NCLineEndConstraintMorph class methodsFor: 'line end shapes' stamp: 'nk 4/17/2002 13:29'! preMadeShapeNames "Answer a collection of pre-made shape names for a menu" "NCLineEndConstraintMorph preMadeShapeNames" ^#( filledCircleShape openCircleShape junctionDotShape openDiamondShape filledDiamondShape openArrowheadShape closedArrowheadShape filledArrowheadShape doubleArrowheadShape crowsFootShape ) ! ! !NCLineEndConstraintMorph class methodsFor: 'conversion' stamp: 'nk 6/26/2002 09:51'! updateOldShapes26June2002 "NCLineEndConstraintMorph updateOldShapes26June2002" "Change all pre-defined shapes to the better ones" self allSubInstancesDo: [ :lec | lec submorphsDo: [ :att | (att isKindOf: PolygonMorph) ifTrue: [ | new | new _ att knownName caseOf: { [ 'closed arrowhead' ] -> [ #closedArrowheadShape ]. [ 'crows foot' ] -> [ #crowsFootShape ]. [ 'double arrowhead' ] -> [ #doubleArrowheadShape ]. [ 'filled arrowhead' ] -> [ #filledArrowheadShape ]. [ 'filled circle' ] -> [ #filledCircleShape ]. [ 'filled diamond' ] -> [ #filledDiamondShape ]. [ 'junction dot' ] -> [ #junctionDotShape ]. [ 'open arrowhead' ] -> [ #openArrowheadShape ]. } otherwise: [ nil ]. new ifNotNil: [ | newEnd | newEnd _ self perform: new. lec deleteShape: att. lec addShape: newEnd. ] ] ] ]. NCMakerButton allSubInstancesDo: [ :ea | ea updateImage ] ! ! !NCSharedFiniteStateMachine methodsFor: 'initialization' stamp: 'nk 3/12/2001 11:53'! copyFromPrototype: anFSM transitions _ anFSM transitionSpecs. stateActions _ anFSM stateActionSpecs. prototype _ anFSM. currentState _ newState _ #initial. lastEventArguments _ nil. anFSM missedEventSend ifNotNilDo: [ :send | missedEventSend _ send copy. ((missedEventSend receiver == anFSM client) or: [ missedEventSend receiver == anFSM ]) ifTrue: [ missedEventSend receiver: self ] ].! ! !NCSharedFiniteStateMachine methodsFor: 'initialization' stamp: 'nk 4/18/2002 22:26'! initialize currentState ifNil: [ currentState _ #initial ]. newState ifNil: [ newState _ #initial ]. self logInitialize.! ! !NCSharedFiniteStateMachine methodsFor: 'message handling' stamp: 'nk 3/14/2001 13:25'! performMessageSend: aMessageSend withArguments: args "Map sends to me or my prototype (other than newState:) into sends to my client" ^(aMessageSend receiver == prototype or: [ aMessageSend receiver == self ]) ifTrue: [ | ms | ms _ (aMessageSend copy) receiver: ((aMessageSend selector == #newState:) ifTrue: [ self ] ifFalse: [ client ]). self logMessageSend: ms withArguments: args. ms valueWithEnoughArguments: args ] ifFalse: [ self logMessageSend: aMessageSend withArguments: args. aMessageSend valueWithEnoughArguments: args ]! ! !NCSharedFiniteStateMachine methodsFor: 'accessing' stamp: 'nk 3/14/2001 19:28'! receiverFor: aMessageSend ^ ((aMessageSend receiver == self or: [ aMessageSend receiver == prototype ]) and: [aMessageSend selector ~= #newState:]) ifTrue: [client] ifFalse: [aMessageSend receiver]! ! !NCSharedFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 3/14/2001 13:27'! removeEventsTriggeredFor: anObject inState: aState self shouldNotImplement! ! !NCSharedFiniteStateMachine methodsFor: 'transitions' stamp: 'nk 3/14/2001 13:28'! when: anEventSymbol inState: aState perform: aMessageSend self shouldNotImplement! ! !NCSharedFiniteStateMachine methodsFor: 'copying' stamp: 'nk 3/14/2001 15:45'! veryDeepFixupWith: deepCopier "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals." super veryDeepFixupWith: deepCopier. prototype _ deepCopier references at: prototype ifAbsent: [ prototype ]. ! ! !NCSharedFiniteStateMachine methodsFor: 'copying' stamp: 'nk 3/14/2001 15:45'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." | oldTransitions oldStateActions | oldTransitions _ transitions. transitions _ nil. oldStateActions _ stateActions. stateActions _ nil. super veryDeepInner: deepCopier. transitions _ oldTransitions. stateActions _ oldStateActions. prototype _ prototype. ! ! !NCSharedFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 3/14/2001 13:29'! whenEnteringState: aState perform: aMessageSend self shouldNotImplement! ! !NCSharedFiniteStateMachine methodsFor: 'state actions' stamp: 'nk 3/14/2001 13:29'! whenExitingState: aState perform: aMessageSend self shouldNotImplement! ! !PasteUpMorph methodsFor: '*connectors-misc' stamp: 'nk 6/13/2002 09:34'! isConnectable "Answer whether I will accept connections from ConnectorMorphs" ^false! ! !PasteUpMorph methodsFor: '*skeleton-morph' stamp: 'tak 9/30/2003 01:45'! createOrResizeTrailsForm "If necessary, create a new turtleTrailsForm or resize the existing one to fill my bounds. On return, turtleTrailsForm exists and is the correct size." | newForm | turtleTrailsForm ifNil: ["create new TrailsForm if needed" turtleTrailsForm _ Form extent: self extent depth: 32. turtleTrailsForm fillColor: self color. turtlePen _ nil]. turtleTrailsForm extent = self extent ifFalse: ["resize TrailsForm if my size has changed" newForm _ Form extent: self extent depth: 32. newForm fillColor: self color. newForm copy: self bounds from: turtleTrailsForm to: 0@0 rule: Form paint. turtleTrailsForm _ newForm. turtlePen _ nil]. "Recreate Pen for this form" turtlePen ifNil: [turtlePen _ Pen newOnForm: turtleTrailsForm. turtlePen combinationRule: Form blend].! ! !PasteUpMorph methodsFor: '*skeleton-morph' stamp: 'tak 11/16/2003 22:41'! hardness ^ self valueOfProperty: #SkeletonHardness! ! !PasteUpMorph methodsFor: '*skeleton-morph' stamp: 'tak 11/16/2003 22:41'! hardness: aNumber ^ self setProperty: #SkeletonHardness toValue: aNumber! ! !NCAttachmentPointAdjusterWindow methodsFor: 'dropping/grabbing' stamp: 'nk 6/30/2002 12:01'! acceptDroppingMorph: aMorph event: evt "this is followed by aMorph justDroppedInto: self event: evt" (aMorph isKindOf: HandleMorph) ifTrue: [ ^self ]. super acceptDroppingMorph: aMorph event: evt. (aMorph isKindOf: NCAttachmentPointAdjuster) ifTrue: [ ^self ]. target _ aMorph. self initializeOriginalPositionFor: aMorph. joystick moveHandleToCenter. ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'dropping/grabbing' stamp: 'nk 6/20/2002 09:15'! initializeOriginalPositionFor: aMorph aMorph displayedAttachmentPoints do: [ :ea | ea delete ]. aMorph alignAttachmentPointsWithGridNear: aMorph position. originalPosition _ aMorph position - self position. aMorph connectionTarget displayAttachmentPointsFor: self. ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'dropping/grabbing' stamp: 'nk 6/30/2002 13:20'! wantsDroppedMorph: aMorph event: evt | retval | retval _ owner notNil and: [(super wantsDroppedMorph: aMorph event: evt) and: [target isNil or: [(aMorph isKindOf: NCAttachmentPointAdjuster) or: [(aMorph isKindOf: NCAttachmentPointAdjuster) ]]]]. ^retval ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 09:44'! addAttacher target ifNil: [ ^self ]. (NCAttachmentPointAdjuster new initialize originalSpec: { #center } target: target) openInHand! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 11:49'! addAttacherButton ^SimpleButtonMorph new target: self; actionSelector: #addAttacher; label: 'Add'; actWhen: #buttonDown; cornerStyle: #square; color: Color gray lighter; borderWidth: 3; borderColor: #raised; vResizing: #spaceFill; yourself. ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 12:46'! addDefaultAttachers target ifNil: [ ^self ]. target attachmentPointSpecs: nil. self initializeOriginalPositionFor: target. ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 12:51'! attachersString target ifNil: [ ^'--' ]. ^target attachmentPointSpecs isEmpty ifTrue: [ 'Default' ] ifFalse: [ 'None' ] ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 4/27/2001 09:44'! attachmentModeButton ^self standardButton actionSelector: #toggleAttachmentMode; wordingSelector: #attachmentModeString! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 12:51'! attachmentModeString target ifNil: [ ^'--' ]. ^target movableAttachments ifTrue: [ 'Make non-movable' ] ifFalse: [ 'Make movable' ] ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 12:25'! deleteAttachers target ifNil: [ ^self ]. target attachmentPointSpecs: #(). self initializeOriginalPositionFor: target. ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 12:45'! deleteAttachersButton ^self standardButton actionSelector: #toggleAttachers; wordingSelector: #attachersString ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 4/27/2001 10:00'! gridButton ^self standardButton actionSelector: #toggleGridding; wordingSelector: #griddingOnOffString! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 11:51'! griddingOnOffString ^ (self griddingOn ifTrue: ['Turn grid off'] ifFalse: ['Turn grid on']) ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 11:49'! makeButtons | aligner | aligner _ AlignmentMorph newRow. aligner color: Color white; vResizing: #spaceFill; cellInset: 4@4; hResizing: #spaceFill; addMorphBack: self gridButton; addMorphBack: AlignmentMorph newVariableTransparentSpacer; addMorphBack: self addAttacherButton; addMorphBack: AlignmentMorph newVariableTransparentSpacer; addMorphBack: self deleteAttachersButton; addMorphBack: AlignmentMorph newVariableTransparentSpacer; addMorphBack: self attachmentModeButton; addMorphBack: AlignmentMorph newVariableTransparentSpacer; addMorphBack: (joystick _ JoystickMorph new extent: 40@40; toggleAutoCenter; moveHandleToCenter). ^aligner. ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 4/16/2002 14:58'! standardButton "self standardButton actionSelector: #toggleAttachmentMode; wordingSelector: #attachmentModeString" ^UpdatingSimpleButtonMorph new target: self; actWhen: #buttonDown; cornerStyle: #square; color: Color gray lighter; borderWidth: 3; borderColor: #raised; vResizing: #spaceFill; yourself. ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 12:48'! toggleAttachers target ifNil: [ ^self ]. target attachmentPointSpecs isEmpty ifTrue: [ self addDefaultAttachers ] ifFalse: [ self deleteAttachers ] ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 4/27/2001 09:22'! toggleAttachmentMode target ifNil: [ ^self ]. target movableAttachments: target movableAttachments not.! ! !NCAttachmentPointAdjusterWindow methodsFor: 'buttons' stamp: 'nk 6/30/2002 13:11'! toggleGridding self griddingOnOff; gridVisibleOnOff. target ifNil: [ ^self ]. self initializeOriginalPositionFor: target. ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'private' stamp: 'nk 6/30/2002 12:42'! addedOrRemovedSubmorph: aMorph super addedOrRemovedSubmorph: aMorph. aMorph == target ifFalse: [ ^self ]. target := nil. aMorph connectionTarget setAttachmentPointsFromDisplayed. self changed. ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'private' stamp: 'nk 4/17/2002 22:34'! joystickOffset | xShift yShift | xShift _ joystick leftRight * (self gridModulus x / 3.125). yShift _ joystick upDown * (self gridModulus y / 3.125) negated. ^xShift @ yShift ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'gridding' stamp: 'nk 6/19/2002 21:06'! gridSpec "shift this so that when it's added to my position, we end up in sync" ^self valueOfProperty: #gridSpec ifAbsent: [ | pu offset | pu _ self pasteUpMorph ifNil: [ ^super gridSpec ]. pu gridSpec. ]! ! !NCAttachmentPointAdjusterWindow methodsFor: 'initialization' stamp: 'nk 4/27/2001 09:07'! initialize super initialize. self color: Color white; borderWidth: 2; borderColor: Color black; extent: 200@200! ! !NCAttachmentPointAdjusterWindow methodsFor: 'stepping' stamp: 'nk 6/30/2002 12:40'! step target ifNil: [ ^self ]. self wantsSteps ifFalse: [ ^self ]. target position: (self position + originalPosition + (self joystickOffset / 2)) asIntegerPoint ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'stepping' stamp: 'nk 4/17/2002 22:45'! stepTime ^20 ! ! !NCAttachmentPointAdjusterWindow methodsFor: 'stepping' stamp: 'nk 6/30/2002 12:37'! wantsSteps ^World currentHand submorphs isEmpty or: [ (World currentHand submorphs first isKindOf: SelectionMorph) not ] ! ! !NCAttachmentPointAdjusterWindow class methodsFor: 'opening' stamp: 'nk 6/30/2002 13:17'! adjusterWindow "Answer a SystemWindow set up as an adjuster panel" "NCAttachmentPointAdjusterWindow adjusterWindow openInHand" | window adjuster buttonHeight buttons | window _ SystemWindow new. adjuster _ self new. buttons _ adjuster makeButtons. buttonHeight _ buttons submorphs last height + 8. window addMorph: buttons fullFrame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@buttonHeight)). window addMorph: adjuster fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@buttonHeight corner: 0@0)). window setLabel: 'Attachment Point Adjuster'; model: adjuster; extent: 400@280. ^window ! ! !NCAttachmentPointAdjusterWindow class methodsFor: 'opening' stamp: 'nk 12/7/2001 11:54'! newStandAlone ^self adjusterWindow! ! !Pen methodsFor: '*skeleton-morph' stamp: 'tak 11/23/2003 17:15'! squareNib: widthInteger "Makes this pen draw with a square nib of the given width." self sourceForm: (Form extent: widthInteger @ widthInteger) fillBlack. combinationRule ifNil: [self combinationRule: Form over "a bit faster than paint mode"]! ! !Player methodsFor: '*skeleton-morph' stamp: 'tak 11/23/2003 22:44'! getHardness ^self costume hardness * 100! ! !Player methodsFor: '*skeleton-morph' stamp: 'tak 11/16/2003 20:45'! getLength "Answer the length of the object" | aLength cost | (self costume isKindOf: SkeletonLineMorph) ifTrue: [^ self costume length]. ((cost _ self costume) isKindOf: PolygonMorph) "annoying special case" ifTrue: [^ cost unrotatedLength]. aLength _ cost renderedMorph height. "facing upward when unrotated" cost isRenderer ifTrue: [aLength _ aLength * cost scaleFactor]. ^ aLength! ! !Player methodsFor: '*skeleton-morph' stamp: 'tak 10/23/2003 00:37'! getListning ^self costume isListening! ! !Player methodsFor: '*skeleton-morph' stamp: 'tak 11/21/2003 16:11'! getWidth "Answer the width of the object" | aWidth cost | ((cost _ self costume) isKindOf: PolygonMorph) "annoying special case" ifTrue: [^ cost unrotatedWidth]. ((cost _ self costume) isKindOf: SkeletonLineMorph) ifTrue: [^ cost width]. aWidth _ cost renderedMorph width. "facing upward when unrotated" cost isRenderer ifTrue: [aWidth _ aWidth * cost scaleFactor]. ^ aWidth! ! !Player methodsFor: '*skeleton-morph' stamp: 'tak 11/23/2003 22:44'! setHardness: aNumber self costume hardness: aNumber / 100! ! !Player methodsFor: '*skeleton-morph' stamp: 'tak 11/16/2003 20:45'! setLength: aLength "Set the length of the receiver." | cost lengthToUse | (self costume isKindOf: SkeletonLineMorph) ifTrue: [^ self costume length: aLength]. ((cost _ self costume) isKindOf: PolygonMorph) ifTrue: [^ cost unrotatedLength: aLength]. lengthToUse _ cost isRenderer ifTrue: [aLength / cost scaleFactor] ifFalse: [aLength]. cost renderedMorph height: lengthToUse! ! !Player methodsFor: '*skeleton-morph' stamp: 'tak 10/23/2003 00:38'! setListening: aBoolean self costume isListening: aBoolean! ! !Player methodsFor: '*skeleton-morph' stamp: 'tak 11/21/2003 16:12'! setWidth: aWidth "Set the width" | cost widthToUse | ((cost _ self costume) isKindOf: PolygonMorph) ifTrue: [^ cost unrotatedWidth: aWidth]. ((cost _ self costume) isKindOf: SkeletonLineMorph) ifTrue: [^ cost width: aWidth]. widthToUse _ cost isRenderer ifTrue: [aWidth / cost scaleFactor] ifFalse: [aWidth]. cost renderedMorph width: widthToUse! ! !Point methodsFor: '*skeleton-morph' stamp: 'tak 11/22/2003 16:18'! direction: freePoint distance: distance "Ask Point by extention of self - freePoint with distance. (100@100 direction: 400@100 distance: 100) = (200@100)" ^ self = freePoint ifTrue: [self] ifFalse: [self + (freePoint - self * distance / (freePoint - self) r)]! ! !PolygonMorph methodsFor: '*connectors-geometry testing' stamp: 'nk 2/15/2001 09:09'! arrowsContainPoint: aPoint "Answer an Array of two Booleans that indicate whether the given point is inside either arrow" | retval f | retval _ { false . false }. (super containsPoint: aPoint) ifFalse: [^ retval ]. (closed or: [arrows == #none or: [vertices size < 2]]) ifTrue: [^ retval]. (arrows == #forward or: [arrows == #both]) ifTrue: [ "arrowForms first has end form" f _ self arrowForms first. retval at: 2 put: ((f pixelValueAt: aPoint - f offset) > 0) ]. (arrows == #back or: [arrows == #both]) ifTrue: [ "arrowForms last has start form" f _ self arrowForms last. retval at: 1 put: ((f pixelValueAt: aPoint - f offset) > 0) ]. ^retval.! ! !PolygonMorph methodsFor: '*connectors-geometry testing' stamp: 'nk 3/6/2001 21:58'! intersects: aRectangle "Answer whether any of my segments intersects aRectangle" (bounds intersects: aRectangle) ifFalse: [ ^false ]. self lineSegmentsDo: [:p1 :p2 | (aRectangle intersectsLineFrom: p1 to: p2) ifTrue: [^ true]]. ^ false! ! !PolygonMorph methodsFor: '*connectors-attachments-nk' stamp: 'nk 4/14/2002 08:52'! boundsSignatureHash ^vertices hash ! ! !PolygonMorph methodsFor: '*connectors-attachments-nk' stamp: 'nk 2/25/2001 17:21'! defaultAttachmentPointSpecs ^{ { #firstVertex } . { #midpoint } . { #lastVertex } }! ! !PolygonMorph methodsFor: '*connectors-attachments-nk' stamp: 'nk 4/18/2001 11:43'! endShapeColor: aColor self borderColor: aColor. self isClosed ifTrue: [ self color: aColor ].! ! !PolygonMorph methodsFor: '*connectors-attachments-nk' stamp: 'nk 6/18/2002 10:48'! endShapeWidth: aWidth | originalWidth originalVertices transform | originalWidth _ self valueOfProperty: #originalWidth ifAbsentPut: [ self borderWidth isZero ifFalse: [ self borderWidth ] ifTrue: [ 2 ] ]. self borderWidth: aWidth. originalVertices _ self valueOfProperty: #originalVertices ifAbsentPut: [ self vertices collect: [ :ea | (ea - (self referencePosition)) rotateBy: self heading degreesToRadians about: 0@0 ] ]. transform _ MorphicTransform offset: 0 angle: self heading degreesToRadians scale: originalWidth / aWidth. self setVertices: (originalVertices collect: [ :ea | ((transform transform: ea) + self referencePosition) asIntegerPoint ]). self computeBounds.! ! !PolygonMorph methodsFor: '*connectors-attachments-nk' stamp: 'nk 2/25/2001 17:19'! firstVertex ^vertices first! ! !PolygonMorph methodsFor: '*connectors-attachments-nk' stamp: 'nk 2/25/2001 17:19'! lastVertex ^vertices last! ! !PolygonMorph methodsFor: '*connectors-attachments-nk' stamp: 'nk 3/3/2001 19:12'! midpoint "Answer the midpoint along my segments" | middle | middle _ 0. self lineSegmentsDo: [ :a :b | middle _ middle + (a dist: b) ]. middle < 2 ifTrue: [ ^ self center ]. middle _ middle / 2. self lineSegmentsDo: [ :a :b | | dist | dist _ (a dist: b). middle < dist ifTrue: [ ^(a + ((b - a) * (middle / dist))) asIntegerPoint ]. middle _ middle - dist. ]! ! !PolygonMorph methodsFor: '*connectors-attachments-nk' stamp: 'nk 4/23/2002 15:49'! nudgeForLabel: aRectangle "Try to move the label off me. Prefer labels on the top and right." | i flags nudge | (self bounds intersects: aRectangle) ifFalse: [^ 0@0 ]. flags _ 0. nudge _ 0@0. i _ 1. aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg int | rectSeg _ LineSegment from: rp1 to: rp2. self straightLineSegmentsDo: [ :lp1 :lp2 | | polySeg | polySeg _ LineSegment from: lp1 to: lp2. int _ polySeg intersectionWith: rectSeg. int ifNotNil: [ flags _ flags bitOr: i ]. ]. i _ i * 2. ]. "Now flags has bitflags for which sides" nudge _ flags caseOf: { "no intersection" [ 0 ] -> [ 0@0 ]. "2 adjacent sides only" [ 9 ] -> [ 1@1 ]. [ 3 ] -> [ -1@1 ]. [ 12 ] -> [ 1@-1 ]. [ 6 ] -> [ -1@-1 ]. "2 opposite sides only" [ 10 ] -> [ 0@-1 ]. [ 5 ] -> [ 1@0 ]. "only 1 side" [ 8 ] -> [ -1@0 ]. [ 1 ] -> [ 0@-1 ]. [ 2 ] -> [ 1@0 ]. [ 4 ] -> [ 0@1 ]. "3 sides" [ 11 ] -> [ 0@1 ]. [ 13 ] -> [ 1@0 ]. [ 14 ] -> [ 0@-1 ]. [ 7 ] -> [ -1@0 ]. "all sides" [ 15 ] -> [ 1@-1 "move up and to the right" ]. }. ^nudge! ! !PolygonMorph methodsFor: '*connectors-geometry' stamp: 'nk 3/11/2001 19:08'! closestSegmentTo: aPoint "Answer the starting index of my (big) segment nearest to aPoint" | curvePoint closestPoint dist minDist vertexIndex closestVertexIndex | vertexIndex _ 0. closestVertexIndex _ 0. closestPoint _ minDist _ nil. self lineSegmentsDo: [:p1 :p2 | (p1 = (self vertices at: vertexIndex + 1)) ifTrue: [ vertexIndex _ vertexIndex + 1 ]. curvePoint _ aPoint nearestPointOnLineFrom: p1 to: p2. dist _ curvePoint dist: aPoint. (closestPoint == nil or: [dist < minDist]) ifTrue: [closestPoint _ curvePoint. minDist _ dist. closestVertexIndex _ vertexIndex. ]]. ^ closestVertexIndex! ! !PolygonMorph methodsFor: '*connectors-geometry' stamp: 'nk 2/15/2001 15:45'! intersectionWithLineSegmentFromCenterTo: aPoint ^self closestPointTo: aPoint! ! !PolygonMorph methodsFor: '*connectors-geometry' stamp: 'nk 3/30/2002 12:29'! intersectionsWith: aRectangle "Answer a Set of points where the given Rectangle intersects with me. Ignores arrowForms." | retval | retval _ IdentitySet new: 4. (self bounds intersects: aRectangle) ifFalse: [^ retval]. self lineSegmentsDo: [ :lp1 :lp2 | | polySeg | polySeg _ LineSegment from: lp1 to: lp2. aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg int | rectSeg _ LineSegment from: rp1 to: rp2. int _ polySeg intersectionWith: rectSeg. int ifNotNil: [ retval add: int ]. ]. ]. ^retval ! ! !PolygonMorph methodsFor: '*connectors-geometry' stamp: 'nk 4/18/2002 16:56'! nextDuplicateVertexIndex vertices doWithIndex: [ :vert :index | ((index between: 2 and: vertices size - 1) and: [vert onLineFrom: (vertices at: index - 1) to: (vertices at: index + 1) within: 4]) ifTrue: [ ^index ]. ]. ^0! ! !PolygonMorph methodsFor: '*connectors-geometry' stamp: 'nk 4/18/2002 16:58'! reduceVertices "Reduces the vertices size, when 3 vertices are on the same line with a little epsilon. Based on code by Steffen Mueller" | dup | [ (dup _ self nextDuplicateVertexIndex) > 0 ] whileTrue: [ self setVertices: (vertices copyWithoutIndex: dup) ]. ^vertices size.! ! !PolygonMorph methodsFor: '*connectors-geometry' stamp: 'nk 3/6/2001 16:36'! straighten self setVertices: { vertices first . vertices last }! ! !PolygonMorph methodsFor: '*connectors-dashes' stamp: 'nk 2/27/2001 12:11'! dashedBorder ^borderDashSpec "A dash spec is a 3- or 5-element array with { length of normal border color. length of alternate border color. alternate border color. starting offset. amount to add to offset at each step } Starting offset is usually = 0, but changing it moves the dashes along the curve." ! ! !PolygonMorph methodsFor: '*connectors-dashes' stamp: 'nk 4/5/2001 16:02'! removeVertex: aVert "Make sure that I am not left with less than two vertices" | newVertices | vertices size < 2 ifTrue: [ ^self ]. newVertices _ vertices copyWithout: aVert. newVertices size caseOf: { [1] -> [ newVertices _ { newVertices first . newVertices first } ]. [0] -> [ newVertices _ { aVert . aVert } ] } otherwise: []. self setVertices: newVertices ! ! !PolygonMorph methodsFor: '*connectors-dashes' stamp: 'nk 2/25/2001 17:05'! vertexAt: n ^vertices at: (n min: vertices size).! ! !PolygonMorph methodsFor: '*connectors-private' stamp: 'nk 3/27/2001 21:23'! transformVerticesFrom: oldOwner to: newOwner | oldTransform newTransform world newVertices | world _ self world. oldTransform _ oldOwner ifNil: [ IdentityTransform new ] ifNotNil: [ oldOwner transformFrom: world ]. newTransform _ newOwner ifNil: [ IdentityTransform new ] ifNotNil: [ newOwner transformFrom: world ]. newVertices _ vertices collect: [ :ea | newTransform globalPointToLocal: (oldTransform localPointToGlobal: ea) ]. self setVertices: newVertices. ! ! !Rectangle methodsFor: '*connectors-geometry' stamp: 'nk 3/29/2002 22:51'! intersectionWithLineSegmentFromCenterTo: aPoint "Answer the point, if any, along my border that intersects the line segment between my center and aPoint. Return aPoint if aPoint is inside me or is on my border, else a computed point somewhere along my border." | seg | (self containsPoint: aPoint) ifTrue: [^ aPoint]. "Answer the set of intersections, if any" seg _ LineSegment from: self center to: aPoint. self lineSegmentsDo: [ :p1 :p2 | | side int | side _ LineSegment from: p1 to: p2. int _ side intersectionWith: seg. int ifNotNil: [ ^int ]. ]. self error: 'no intersection found'! ! !Rectangle methodsFor: '*connectors-geometry' stamp: 'nk 3/29/2002 22:56'! intersectionsWithLineFrom: start to: end "Answer the set of intersections, if any" | retval l i | retval _ IdentitySet new: 4. l _ LineSegment from: start to: end. self lineSegmentsDo: [ :p1 :p2 | | s | s _ LineSegment from: p1 to: p2. i _ s intersectionWith: l. i ifNotNil: [ retval add: i ]. ]. ^retval! ! !Rectangle methodsFor: '*connectors-rectangle functions' stamp: 'nk 3/29/2002 22:34'! lineSegmentsDo: aBlock "Evaluate aBlock with the receiver's line segments" | p | aBlock value: origin value: (p _ self topRight). aBlock value: p value: corner. aBlock value: corner value: (p _ self bottomLeft). aBlock value: p value: origin.! ! !Rectangle methodsFor: '*skeleton-morph' stamp: 'tak 11/22/2003 21:07'! diagonal: length "Answer Rectangle of same ratio and specific diagonal ((100@100 corner: 400@100) diagonal: 100) = ((200@100) corner: (300@100))" | p1 p2 direction delta | p1 := self origin. p2 := self corner. direction := p2 - p1. ^ direction = (0 @ 0) ifTrue: [self] ifFalse: [delta := direction - (direction * length / direction r) / 2. p1 + delta corner: p2 - delta]! ! !SimpleButtonMorph methodsFor: '*connectors-labels' stamp: 'nk 12/4/2002 13:20'! beLabeled: aBoolean "nothing to do here"! ! !SkeletonLineMorph methodsFor: 'geometry' stamp: 'tak 11/21/2003 16:32'! length self flag: #TODO. "not only integer" ^ self privateLength! ! !SkeletonLineMorph methodsFor: 'geometry' stamp: 'tak 10/3/2003 10:37'! length: aNumber self privateLength: aNumber! ! !SkeletonLineMorph methodsFor: 'geometry' stamp: 'tak 11/21/2003 17:09'! privateLength "Ask actual length" ^ self asVector r rounded! ! !SkeletonLineMorph methodsFor: 'geometry' stamp: 'tak 11/22/2003 23:21'! privateLength: aNumber "Set the length to me and move related morphs. In this context, the length is a length of a PolygonMorph. But it uses a length among NSConstraintMorphs for implementation. NSConstraintMorph's conter = a vertex of PolygonMorph" | start end | start := self startConstraint. end := self endConstraint. aNumber <= 0 ifTrue: [^ self]. "Too heavy to move it" (start lightness = 0 and: [end lightness = 0]) ifTrue: [^ self]. "Same lightness then both move" start lightness = end lightness ifTrue: [| rect | rect := (start center corner: end center) diagonal: aNumber. start attacheePosition: rect origin. end attacheePosition: rect corner. ^ self]. ^ start lightness < end lightness ifTrue: [^ end attacheePosition: (start center direction: end center distance: aNumber)] ifFalse: [start attacheePosition: (end center direction: start center distance: aNumber)]! ! !SkeletonLineMorph methodsFor: 'geometry' stamp: 'tak 11/21/2003 16:10'! width ^ line borderWidth! ! !SkeletonLineMorph methodsFor: 'geometry' stamp: 'tak 11/21/2003 16:10'! width: aNumber ^ line borderWidth: aNumber! ! !SkeletonLineMorph methodsFor: 'connection' stamp: 'tak 10/1/2003 14:38'! choosePreferredConnection: sel constraints do: [:ea | ea choosePreferredConnection: sel]! ! !SkeletonLineMorph methodsFor: 'connection' stamp: 'tak 10/1/2003 14:38'! connectToCenter constraints do: [:ea | ea connectToCenter]! ! !SkeletonLineMorph methodsFor: 'parts bin' stamp: 'tak 11/23/2003 14:06'! initializeToStandAlone super initializeToStandAlone. self line setVertices: {0 @ 0. 71 @ 71}. self constraints first center: self line vertices first. self constraints second center: self line vertices second. self color: (TranslucentColor r: 0.1 g: 0.55 b: 0.0 alpha: 0.15). self line dashedBorder: {10. 10. Color transparent}. self borderWidth: 3. self choosePreferredConnection: #connectToCenter; connectToCenter; yourself! ! !SkeletonLineMorph methodsFor: 'accessing' stamp: 'tak 10/3/2003 02:13'! goalsStatus: aSymbol super goalsStatus: aSymbol. constraints do: [:each | each goalsStatus: aSymbol]! ! !SkeletonLineMorph methodsFor: 'miscellaneous' stamp: 'tak 11/24/2003 19:41'! setExtentFromHalo: newExtent | center safeExtent oldExtent | self startConstraint lightness = self endConstraint lightness ifTrue: [center := self referencePosition. safeExtent := newExtent max: 10 @ 10. oldExtent := self asVector abs. {self constraints first. self constraints second} do: [:m | m attacheePosition: m center - center * (safeExtent asFloatPoint / (oldExtent max: 1 @ 1)) + center]] ifFalse: [self length: newExtent r; step "step is to apply new length for SkeletonConstaintLineMorph"]! ! !SkeletonConstantLineMorph methodsFor: 'accessing' stamp: 'tak 11/23/2003 22:42'! applyedHardness self hardness ifNil: [self hardness: 1.0]. ^ self hardness * (self pasteUpMorph ifNil: [SkeletonConstantLineMorph defaultHardness] ifNotNil: [self pasteUpMorph hardness ifNil: [SkeletonConstantLineMorph defaultHardness]])! ! !SkeletonConstantLineMorph methodsFor: 'accessing' stamp: 'tak 11/23/2003 22:40'! hardness ^ hardness ! ! !SkeletonConstantLineMorph methodsFor: 'accessing' stamp: 'tak 11/23/2003 22:38'! hardness: aNumber hardness _ aNumber! ! !SkeletonConstantLineMorph methodsFor: 'accessing' stamp: 'tak 10/3/2003 10:40'! length ^ rememberdLength! ! !SkeletonConstantLineMorph methodsFor: 'accessing' stamp: 'tak 10/3/2003 14:57'! length: aNumber "Transcript show: self externalName; show: aNumber; cr." rememberdLength = aNumber ifTrue: [^self]. self changed: #PlayerChanged. rememberdLength _ aNumber. self goalsStatus: #updating! ! !SkeletonConstantLineMorph methodsFor: 'initialization' stamp: 'tak 11/23/2003 12:02'! initialize super initialize. self length: self privateLength. delta _ 0.! ! !SkeletonConstantLineMorph methodsFor: 'stepping and presenter' stamp: 'tak 10/3/2003 16:13'! lineEndChanged "do nothing" ! ! !SkeletonConstantLineMorph methodsFor: 'stepping and presenter' stamp: 'tak 11/23/2003 22:40'! step (delta _ rememberdLength - self privateLength) abs < 0.4 ifTrue: [self goalsStatus: #done] ifFalse: [self goalsStatus: #updating. self privateLength: self privateLength + (delta * self applyedHardness)]! ! !SkeletonConstantLineMorph methodsFor: 'stepping and presenter' stamp: 'tak 10/28/2003 18:59'! stepTime delta abs < 10 ifTrue: [^ 300]. ^ 50! ! !SkeletonConstantLineMorph methodsFor: 'parts bin' stamp: 'tak 11/23/2003 12:04'! initializeToStandAlone super initializeToStandAlone. self dashedBorder: nil. self color: (TranslucentColor r: 0.0 g: 0.0 b: 1.0 alpha: 0.15). self length: self privateLength! ! !SkeletonConstantLineMorph methodsFor: 'miscellaneous' stamp: 'tak 11/22/2003 23:40'! setExtentFromHalo: newExtent super setExtentFromHalo: newExtent. self length: self privateLength! ! !SkeletonLineMorph class methodsFor: 'examples' stamp: 'tak 11/23/2003 12:23'! example1 "self example1" | line | line := self newStandAlone. line connectStartTo: (StarMorph new color: Color blue; position: 100 @ 100; openInWorld). line connectFinishTo: (StarMorph new color: Color blue; position: 300 @ 100; openInWorld). line choosePreferredConnection: #connectToCenter; connectToCenter. World addMorph: line! ! !SkeletonLineMorph class methodsFor: 'parts bin' stamp: 'tak 11/16/2003 21:30'! supplementaryPartsDescriptions ^ SkeletonMorphInfo quadsDefiningSuppliesFlap collect: [:quads | DescriptionForPartsBin formalName: quads third asSymbol categoryList: #('Skeleton' ) documentation: quads fourth globalReceiverSymbol: quads first nativitySelector: quads second]! ! !SkeletonLineMorph class methodsFor: 'scripting' stamp: 'tak 11/19/2003 16:12'! additionsToViewerCategories ^ #((geometry ( (slot length 'The length' Number readWrite Player getLength Player setLength:) ))) ! ! !SkeletonConstantLineMorph class methodsFor: 'accessing' stamp: 'tak 11/22/2003 17:08'! defaultHardness ^0.4 ! ! !SkeletonConstantLineMorph class methodsFor: 'scripting' stamp: 'tak 11/23/2003 22:35'! additionsToViewerCategories ^#(( constraint ( (slot hardness 'hardness' Number readWrite Player getHardness Player setHardness:) ) )) ! ! !SkeletonLineMorphTest methodsFor: 'tests' stamp: 'tak 11/22/2003 17:43'! testConstantLength | a b line world hardness | "Currently, hardness is belong to world or class default, and this test may be failed if world hardness is modified." hardness _ SkeletonConstantLineMorph defaultHardness. self assert: hardness = 0.4. "For detecting running over, a world is needed" world _ PasteUpMorph new extent: 1000 @ 1000. a _ Morph new position: 100 @ 100. b _ Morph new position: 400 @ 100. line _ SkeletonConstantLineMorph fromMorph: a toMorph: b. line choosePreferredConnection: #connectToCenter; connectToCenter. world addMorph: a; addMorph: b; addMorph: line. line length: 200. line step. "(150 - 100) * 0.4 + 100 = 120" "0.4 is length" self assert: a position = (120 @ 100). self assert: b position = (380 @ 100). a position: 100 @ 100; lock. b position: 100 @ 400. line length: 200. self assert: a position = (100 @ 100) ! ! !SkeletonLineMorphTest methodsFor: 'tests' stamp: 'tak 11/22/2003 23:38'! testHeloExtent | line world | "For detecting running over, a world is needed" line _ SkeletonLineMorph new. world _ PasteUpMorph new extent: 1000 @ 1000. world addMorph: line. line constraints first center: 100 @ 100; step. line constraints second center: 400 @ 400; step. line setExtentFromHalo: 100@100. self assert: line constraints first center = (200 @ 200). self assert: line constraints second center = (300 @ 300). ! ! !SkeletonLineMorphTest methodsFor: 'tests' stamp: 'tak 11/22/2003 23:07'! testLine | line world | "For detecting running over, a world is needed" line _ SkeletonLineMorph new. world _ PasteUpMorph new extent: 1000 @ 1000. world addMorph: line. line constraints first center: 100 @ 100; step. line constraints second center: 400 @ 100; step. self assert: line length = 300. line length: 200. line constraints first step. line constraints second step. self assert: line constraints first center = (150 @ 100). self assert: line constraints second center = (350 @ 100). self assert: line length = 200. ! ! !SkeletonLineMorphTest methodsFor: 'tests' stamp: 'tak 11/22/2003 18:03'! testLineAttached | line world a b | "For detecting running over, a world is needed" a _ Morph new position: 100 @ 100. b _ Morph new position: 400 @ 100. line _ SkeletonLineMorph fromMorph: a toMorph: b. line choosePreferredConnection: #connectToCenter; connectToCenter. world _ PasteUpMorph new extent: 1000 @ 1000. world addMorph: a; addMorph: b; addMorph: line. a position: 100 @ 100. b position: 400 @ 100. self assert: line length = 300. line length: 200. line constraints first step. line constraints second step. self assert: a position = (150 @ 100). self assert: b position = (350 @ 100). self assert: line length = 200. ! ! !SkeletonLineMorphTest methodsFor: 'tests' stamp: 'tak 11/22/2003 18:04'! testLineLocked | line world a b | "For detecting running over, a world is needed" a _ Morph new position: 100 @ 100. b _ Morph new position: 400 @ 100. line _ SkeletonLineMorph fromMorph: a toMorph: b. line choosePreferredConnection: #connectToCenter; connectToCenter. world _ PasteUpMorph new extent: 1000 @ 1000. world addMorph: a; addMorph: b; addMorph: line. a position: 100 @ 100. a lock. b position: 400 @ 100. self assert: line length = 300. line length: 200. line constraints first step. line constraints second step. self assert: a position = (100 @ 100). self assert: b position = (300 @ 100). self assert: line length = 200. ! ! !SkeletonLineMorphTest methodsFor: 'tests' stamp: 'tak 11/16/2003 10:14'! testPartsBin | desc | desc _ SkeletonConstantLineMorph supplementaryPartsDescriptions. self assert: desc first globalReceiverSymbol = #SkeletonConstantLineMorph. ! ! !SkeletonMorphInfo methodsFor: 'introspection' stamp: 'tak 11/15/2003 20:54'! postscriptText ^ ' SkeletonMorphInfo installSuppliesFlap.'! ! !SkeletonMorphInfo class methodsFor: 'parts bin' stamp: 'tak 11/15/2003 22:36'! point "self point openInHand" ^ EllipseMorph new extent: 24 @ 24; color: (Color r: 0.0 g: 0.8 b: 0.7); borderColor: (TranslucentColor r: 0.0 g: 0.8 b: 0.7 alpha: 0.4) yourself! ! !SkeletonMorphInfo class methodsFor: 'fileIn/Out' stamp: 'tak 11/14/2003 16:59'! addClass: aClass toChangeset: aChangeSet aChangeSet addClass: aClass. aChangeSet commentClass: aClass. aClass selectors do: [:aSymbol | aChangeSet adoptSelector: aSymbol forClass: aClass]. aClass class selectors do: [:aSymbol | aChangeSet adoptSelector: aSymbol forClass: aClass class]. ^ aChangeSet! ! !SkeletonMorphInfo class methodsFor: 'fileIn/Out' stamp: 'tak 11/14/2003 16:55'! addPackage: aPackageInfo toChangeset: aChangeSet "self addPackage: self default toChangeset: ChangeSet new" aPackageInfo classes do: [:aClass | self addClass: aClass toChangeset: aChangeSet]. aPackageInfo extensionMethods do: [:method | aChangeSet adoptSelector: method methodSymbol forClass: method actualClass]. ^ aChangeSet! ! !SkeletonMorphInfo class methodsFor: 'fileIn/Out' stamp: 'tak 11/16/2003 00:20'! fileOutMinimumChangeSet "This change set supports SqueakLand image" "self fileOutMinimumChangeSet" | set | (ChangeSorter changeSetNamed: 'Skeleton-Morph-Minimum') ifNotNilDo: [:cs | ChangeSorter removeChangeSet: cs]. set := ChangeSorter basicNewChangeSet: 'Skeleton-Morph-Minimum'. self requiredClasses do: [:aClass | self addClass: aClass toChangeset: set]. self requiredPackages do: [:aPackageInfo | self addPackage: aPackageInfo toChangeset: set]. self requiredMethods do: [:method | set adoptSelector: method methodSymbol forClass: method actualClass]. self unusedMethods do: [:method | set removeSelectorChanges: method methodSymbol class: method actualClass]. set postscriptString: self default postscriptText. set fileOut! ! !SkeletonMorphInfo class methodsFor: 'fileIn/Out' stamp: 'tak 11/16/2003 20:07'! requiredClasses ^ {NCConnectorMorph. NCFSMMorph. NCFiniteStateMachine. NCSharedFiniteStateMachine. NCLineEndConstraintMorph. NCConstraintMorph. NCHighlightMorph. NCAttachmentPointAdjusterWindow. NCAttachmentPointAdjuster. CircleMorph}! ! !SkeletonMorphInfo class methodsFor: 'fileIn/Out' stamp: 'tak 11/14/2003 19:53'! requiredMethods ^ {MethodReference class: Object selector: #value}! ! !SkeletonMorphInfo class methodsFor: 'fileIn/Out' stamp: 'tak 11/20/2003 20:01'! requiredPackages ^ {self default. PackageInfo named: 'Connectors-Attachments'. PackageInfo named: 'Connectors-Evaluating'. PackageInfo named: 'Connectors-Change reporting'. PackageInfo named: 'Connectors-Connection'. PackageInfo named: 'Connectors-Converting'. PackageInfo named: 'Connectors-Dropping/grabbing'. PackageInfo named: 'Connectors-Intersection'. PackageInfo named: 'Connectors-Message handling'. PackageInfo named: 'Connectors-Notifications'. PackageInfo named: 'Connectors-Private'. PackageInfo named: 'Connectors-Rectangle functions'. PackageInfo named: 'Connectors-Geometry'. PackageInfo named: 'Connectors-Geometry testing'. PackageInfo named: 'Connectors-Dashes'. PackageInfo named: 'Connectors-Queries'. PackageInfo named: 'Connectors-Misc'. PackageInfo named: 'Connectors-Labels'. PackageInfo named: 'Connectors-Submorphs'. PackageInfo named: 'Connectors-Structure'. } ! ! !SkeletonMorphInfo class methodsFor: 'fileIn/Out' stamp: 'tak 11/16/2003 00:29'! unusedMethods ^ { MethodReference class: NCConnectorMorph class selector: #supplementaryPartsDescriptions. MethodReference class: NCAttachmentPointAdjusterWindow class selector: #descriptionForPartsBin. }! ! !SkeletonMorphInfo class methodsFor: 'predefined flaps' stamp: 'tak 11/19/2003 20:59'! installSuppliesFlap "Install objects for Skeleton to Supplies flap self installSuppliesFlap" (Flaps respondsTo: #registerQuad:forFlapNamed:) ifTrue: [self quadsDefiningSuppliesFlap do: [:quad | Flaps registerQuad: quad forFlapNamed: 'Supplies']. Flaps replaceGlobalFlapwithID: 'Supplies'] ifFalse: [self installSuppliesFlapForSqueakLandImage]. Project current setNaturalLanguageTo: Project current naturalLanguage. ! ! !SkeletonMorphInfo class methodsFor: 'predefined flaps' stamp: 'tak 11/15/2003 21:00'! installSuppliesFlapForSqueakLandImage | newQuads | newQuads := Flaps quadsDefiningPlugInSuppliesFlap , self quadsDefiningSuppliesFlap. Flaps class compileInobtrusively: 'quadsDefiningPlugInSuppliesFlap ^ ' , newQuads asArray storeString classified: 'predefined flaps'. Flaps disableGlobalFlaps: false. Flaps addAndEnableEToyFlaps. Smalltalk isMorphic ifTrue: [ActiveWorld enableGlobalFlaps]! ! !SkeletonMorphInfo class methodsFor: 'predefined flaps' stamp: 'tak 11/14/2003 17:33'! newSkeletonFlap "self newSkeletonFlap openInWorld; setToPopOutOnDragOver: false." | aFlapTab aStrip | aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight from: self quadsDefiningSkeletonFlap. aFlapTab _ FlapTab new referent: aStrip beSticky. aFlapTab setName: 'Skeleton' edge: #bottom color: Color green muchLighter. aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. aStrip beFlap: true. aStrip extent: (self currentWorld width @ 78). aStrip color: (Color green muchLighter alpha: 0.8). ^ aFlapTab ! ! !SkeletonMorphInfo class methodsFor: 'predefined flaps' stamp: 'tak 11/17/2003 08:28'! quadsDefiningSkeletonFlap "see Flaps>>newConnectorsFlap." ^ #( (SkeletonConstantLineMorph newStandAlone 'line' 'A line') (SkeletonLineMorph newStandAlone 'weak line' 'A line') (TextMorph skeletonsPrototype 'text' 'A basic bordered text') (HardnessSliderMorph newStandAlone 'hardness slider' 'A wire hardness slider') (SkeletonMorphInfo circle 'point' 'point') )! ! !SkeletonMorphInfo class methodsFor: 'predefined flaps' stamp: 'tak 11/17/2003 08:34'! quadsDefiningSuppliesFlap "Answer a list of quads which define the additional object for skeleton" ^ #( (SkeletonConstantLineMorph newStandAlone 'Spring' 'A spring to connect any morphs') (SkeletonLineMorph newStandAlone 'Measure' 'A measure') (HardnessSliderMorph newStandAlone 'Hardness slider' 'A wire hardness slider') (SkeletonMorphInfo point 'Point' 'point') (NCAttachmentPointAdjusterWindow newStandAlone 'AP Adjuster' 'This lets you adjust the attachment points on a dropped Morph') )! ! !SkeletonMorphInfo class methodsFor: 'predefined flaps' stamp: 'tak 11/15/2003 19:30'! uninstallSuppliesFlap "self uninstallSuppliesFlap" self quadsDefiningSuppliesFlap do: [:quad | Flaps unregisterQuadsWithReceiver: (Smalltalk at: quad first)]. Flaps replaceGlobalFlapwithID: 'Supplies'. ! ! !SketchMorph methodsFor: '*connectors-geometry' stamp: 'nk 12/12/2001 14:07'! extent: newExtent "Change my scale to fit myself into the given extent. Avoid extents where X or Y is zero." (newExtent y = 0 or: [ newExtent x = 0 ]) ifTrue: [ ^self ]. self extent = newExtent ifTrue:[^self]. scalePoint _ newExtent asFloatPoint / originalForm extent. self layoutChanged. ! ! !SmartRefStream methodsFor: '*skeleton-morph-compatibility' stamp: 'tak 10/21/2003 21:47'! goalConstantLineMorphbosfcefclsrd0 ^ SkeletonConstantLineMorph! ! !SmartRefStream methodsFor: '*skeleton-morph-compatibility' stamp: 'tak 10/24/2003 01:14'! goalLineMorphTestt0 ^ SkeletonLineMorph! ! !SmartRefStream methodsFor: '*skeleton-morph-compatibility' stamp: 'tak 10/21/2003 21:30'! goalLineMorphbosfcefcls0 ^ SkeletonLineMorph! ! !StarMorph methodsFor: '*skeleton-morph' stamp: 'tak 10/1/2003 13:20'! stepTime ^ 10! ! !String methodsFor: '*connectors-converting' stamp: 'nk 3/27/2001 12:28'! splitOnCapBoundaries | stream prev | stream _ WriteStream on: (self species new: self size * 2). prev _ self at: 1. self do: [ :c | (c = $:) ifTrue: [ stream nextPutAll: '...' ] ifFalse: [ ((c isUppercase) and: [ c isLowercase ~= prev isLowercase ]) ifTrue: [ stream space; nextPut: c asLowercase ] ifFalse: [ stream nextPut: c ]. ]. prev _ c. ]. ^stream contents! ! !TextMorph class methodsFor: '*skeleton-morph' stamp: 'tak 11/14/2003 17:35'! skeletonsPrototype " self skeletonsPrototype openInHand " | t | t _ self new. t autoFit: true; extent: 150 @ 30. t borderWidth: 3; margins: 4 @ 0. t fontName: #ComicSansMS size: 36; textColor: Color black; backgroundColor: Color white. t addDropShadow. t shadowColor: Color gray. t contents: 'abcd'. t wrapFlag: true. "updating extent ???" "Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window" t paragraph. ^ t! ! !TransformationMorph methodsFor: '*connectors-connection' stamp: 'nk 6/14/2002 16:18'! connectionTarget ^submorphs at: 1 ifAbsent: [ self ]! ! !TransformationMorph methodsFor: '*connectors-private' stamp: 'nk 6/13/2002 09:34'! isConnectable "Answer whether I will accept connections from ConnectorMorphs" ^false! ! !TransformationMorph methodsFor: '*connectors-private' stamp: 'nk 6/17/2002 20:56'! lineAttachmentOffset ^(submorphs at: 1 ifAbsent: [ ^0@0 ]) lineAttachmentOffset! ! NCConnectorMorph initialize! SkeletonMorphInfo installSuppliesFlap.!