[squeak-dev] The Inbox: Morphic-spd.459.mczcommits at source.squeak.org commits at source.squeak.orgFri Oct 1 17:01:39 UTC 2010
A new version of Morphic was added to project The Inbox: http://source.squeak.org/inbox/Morphic-spd.459.mcz ==================== Summary ==================== Name: Morphic-spd.459 Author: spd Time: 1 October 2010, 1:00:45.712 pm UUID: 1b989596-7d30-40b3-aadb-dde767cbd704 Ancestors: Morphic-ar.458 LineMorph class>>from:to:color:width: changed to return a LineMorph =============== Diff against Morphic-ar.458 =============== Item was removed: - ----- Method: BorderedMorph>>closestPointTo: (in category 'geometry') ----- - 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 at 6) - ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ]. - ]. - ^pt.! Item was removed: - ----- Method: BorderedMorph>>intersectionWithLineSegmentFromCenterTo: (in category 'geometry') ----- - 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 at 6) - ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ]. - ]. - ^pt.! Item was removed: - EllipseMorph subclass: #CircleMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Basic'! - - !CircleMorph commentStamp: '<historical>' prior: 0! - I am a specialization of EllipseMorph that knows enough to remain circular. - ! Item was removed: - ----- Method: CircleMorph class>>newPin (in category 'as yet unclassified') ----- - newPin - "Construct a pin for embedded attachment" - "CircleMorph newPin openInHand" - ^self new - removeAllMorphs; - extent: 18 at 18; - hResizing: #rigid; - vResizing: #rigid; - layoutPolicy: nil; - color: Color orange lighter; - borderColor: Color orange darker; - borderWidth: 2; - wantsConnectionWhenEmbedded: true; - name: 'Pin'! Item was removed: - ----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') ----- - supplementaryPartsDescriptions - "Extra items for parts bins" - - ^ {DescriptionForPartsBin - formalName: 'Circle1' - categoryList: #('Graphics') - documentation: 'A circular shape' - globalReceiverSymbol: #CircleMorph - nativitySelector: #newStandAlone. - - "DescriptionForPartsBin - formalName: 'Pin' - categoryList: #('Connectors') - documentation: 'An attachment point for Connectors that you can embed in another Morph.' - globalReceiverSymbol: #NCPinMorph - nativitySelector: #newPin." - }! Item was removed: - ----- Method: CircleMorph>>addFlexShellIfNecessary (in category 'rotate scale and flex') ----- - addFlexShellIfNecessary - "When scaling or rotating from a halo, I can do this without a flex shell" - - ^ self - ! Item was removed: - ----- Method: CircleMorph>>bounds: (in category 'geometry') ----- - bounds: aRectangle - | size | - size := aRectangle width min: aRectangle height. - super bounds: (Rectangle origin: aRectangle origin extent: size @ size).! Item was removed: - ----- Method: CircleMorph>>extent: (in category 'geometry') ----- - extent: aPoint - | size oldRotationCenter | - oldRotationCenter := self rotationCenter. - size := aPoint x min: aPoint y. - super extent: size @ size. - self rotationCenter: oldRotationCenter.! Item was removed: - ----- Method: CircleMorph>>heading: (in category 'geometry eToy') ----- - heading: newHeading - "Set the receiver's heading (in eToy terms). - Note that circles never use flex shells." - self rotationDegrees: newHeading.! Item was removed: - ----- Method: CircleMorph>>initialize (in category 'parts bin') ----- - initialize - super initialize. - self extent: 40 at 40; - color: Color green lighter; - yourself! Item was removed: - ----- Method: CircleMorph>>initializeToStandAlone (in category 'parts bin') ----- - initializeToStandAlone - ^super initializeToStandAlone - extent: 40 at 40; - color: Color green lighter; - yourself! Item was removed: - ----- Method: CircleMorph>>privateMoveBy: (in category 'rotate scale and flex') ----- - privateMoveBy: delta - self setProperty: #referencePosition toValue: self referencePosition + delta. - self setProperty: #originalCenter toValue: (self valueOfProperty: #originalCenter ifAbsent: [ self center ]) + delta. - super privateMoveBy: delta. - ! Item was removed: - ----- Method: CircleMorph>>referencePosition (in category 'geometry eToy') ----- - referencePosition - "Return the current reference position of the receiver" - ^ self valueOfProperty: #referencePosition ifAbsent: [ self center ] - ! Item was removed: - ----- Method: CircleMorph>>rotationCenter (in category 'geometry eToy') ----- - 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! Item was removed: - ----- Method: CircleMorph>>rotationCenter: (in category 'geometry eToy') ----- - 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 ]. - - ! Item was removed: - ----- Method: CircleMorph>>rotationDegrees (in category 'rotate scale and flex') ----- - rotationDegrees - - ^ self forwardDirection! Item was removed: - ----- Method: CircleMorph>>rotationDegrees: (in category 'rotate scale and flex') ----- - 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. - ! Item was removed: - ----- Method: CircleMorph>>setRotationCenterFrom: (in category 'menus') ----- - 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.! Item was removed: - ----- Method: CircleMorph>>transformedBy: (in category 'geometry') ----- - transformedBy: aTransform - aTransform isIdentity ifTrue:[^self]. - ^self center: (aTransform localPointToGlobal: self center). - ! Item was removed: - ----- Method: EllipseMorph>>bottomLeftCorner (in category 'geometry') ----- - bottomLeftCorner - ^self intersectionWithLineSegmentFromCenterTo: bounds bottomLeft - ! Item was removed: - ----- Method: EllipseMorph>>bottomRightCorner (in category 'geometry') ----- - bottomRightCorner - ^self intersectionWithLineSegmentFromCenterTo: bounds bottomRight - ! Item was removed: - ----- Method: EllipseMorph>>closestPointTo: (in category 'geometry') ----- - closestPointTo: aPoint - ^self intersectionWithLineSegmentFromCenterTo: aPoint! Item was removed: - ----- Method: EllipseMorph>>intersectionWithLineSegmentFromCenterTo: (in category 'geometry') ----- - 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. - ! Item was removed: - ----- Method: EllipseMorph>>topLeftCorner (in category 'geometry') ----- - topLeftCorner - ^self intersectionWithLineSegmentFromCenterTo: bounds topLeft - ! Item was removed: - ----- Method: EllipseMorph>>topRightCorner (in category 'geometry') ----- - topRightCorner - ^self intersectionWithLineSegmentFromCenterTo: bounds topRight - ! Item was removed: - ----- Method: HaloMorph>>doDup:with: (in category 'private') ----- - doDup: evt with: dupHandle - "Ask hand to duplicate my target." - - (target isKindOf: SelectionMorph) ifTrue: - [^ target doDup: evt fromHalo: self handle: dupHandle]. - - self obtainHaloForEvent: evt andRemoveAllHandlesBut: dupHandle. - self setTarget: (target duplicateMorph: evt). - evt hand grabMorph: target. - self step. "update position if necessary" - evt hand addMouseListener: self. "Listen for the drop"! Item was removed: - ----- Method: HandMorph>>position: (in category 'geometry') ----- - position: aPoint - "Overridden to align submorph origins to the grid if gridding is on." - | adjustedPosition delta box | - adjustedPosition := aPoint. - temporaryCursor ifNotNil: [adjustedPosition := adjustedPosition + temporaryCursorOffset]. - - "Copied from Morph to avoid owner layoutChanged" - "Change the position of this morph and and all of its submorphs." - delta := adjustedPosition - bounds topLeft. - (delta x = 0 and: [delta y = 0]) ifTrue: [^ self]. "Null change" - box := self fullBounds. - (delta dotProduct: delta) > 100 ifTrue:[ - "e.g., more than 10 pixels moved" - self invalidRect: box. - self invalidRect: (box translateBy: delta). - ] ifFalse:[ - self invalidRect: (box merge: (box translateBy: delta)). - ]. - self privateFullMoveBy: delta. - ! Item was removed: - ----- Method: HandMorph>>visible: (in category 'drawing') ----- - visible: aBoolean - self needsToBeDrawn ifFalse: [ ^self ]. - super visible: aBoolean! Item was changed: ----- Method: LineMorph class>>from:to:color:width: (in category 'instance creation') ----- from: startPoint to: endPoint color: lineColor width: lineWidth + ^ self vertices: {startPoint. endPoint} - ^ PolygonMorph vertices: {startPoint. endPoint} color: Color black borderWidth: lineWidth borderColor: lineColor! Item was removed: - ----- Method: Morph>>addMorphFrontFromWorldPosition: (in category 'submorphs-add/remove') ----- - addMorphFrontFromWorldPosition: aMorph - ^self addMorphFront: aMorph fromWorldPosition: aMorph positionInWorld.! Item was removed: - ----- Method: Morph>>allMorphsWithPlayersDo: (in category 'submorphs-add/remove') ----- - allMorphsWithPlayersDo: aTwoArgumentBlock - "Evaluate the given block for all morphs in this composite morph that have non-nil players. - Also evaluate the block for the receiver if it has a player." - - submorphs do: [:m | m allMorphsWithPlayersDo: aTwoArgumentBlock ]. - self playerRepresented ifNotNil: [ :p | aTwoArgumentBlock value: self value: p ]. - ! Item was removed: - ----- Method: Morph>>connections (in category 'accessing') ----- - connections - "Empty method in absence of connectors" - ^ #()! Item was removed: - ----- Method: Morph>>dismissMorph (in category 'meta-actions') ----- - dismissMorph - "This is called from an explicit halo destroy/delete action." - - | w | - w := self world ifNil:[^self]. - w abandonAllHalos; stopStepping: self. - self delete! Item was removed: - ----- Method: Morph>>dismissMorph: (in category 'meta-actions') ----- - dismissMorph: evt - self dismissMorph! Item was removed: - ----- Method: Morph>>dismissViaHalo (in category 'submorphs-add/remove') ----- - dismissViaHalo - "The user has clicked in the delete halo-handle. This provides a hook in case some concomitant action should be taken, or if the particular morph is not one which should be put in the trash can, for example." - - | cmd | - self setProperty: #lastPosition toValue: self positionInWorld. - self dismissMorph. - Preferences preserveTrash ifTrue: [ - Preferences slideDismissalsToTrash - ifTrue:[self slideToTrash: nil] - ifFalse:[TrashCanMorph moveToTrash: self]. - ]. - - cmd := Command new cmdWording: 'dismiss ' translated, self externalName. - cmd undoTarget: ActiveWorld selector: #reintroduceIntoWorld: argument: self. - cmd redoTarget: ActiveWorld selector: #onceAgainDismiss: argument: self. - ActiveWorld rememberCommand: cmd! Item was removed: - ----- Method: Morph>>embedInto: (in category 'meta-actions') ----- - embedInto: evt - "Embed the receiver into some other morph" - | target morphs | - morphs := self potentialEmbeddingTargets. - target := UIManager default - chooseFrom: (morphs collect:[:m| m knownName ifNil:[m class name asString]]) - values: self potentialEmbeddingTargets - title: ('Place ', self externalName, ' in...'). - target ifNil:[^self]. - target addMorphFront: self fromWorldPosition: self positionInWorld.! Item was added: + ----- Method: Morph>>filterViewerCategoryDictionary: (in category 'scripting') ----- + filterViewerCategoryDictionary: dict + "dict has keys of categories and values of priority. + You can re-order or remove categories here." + + self wantsConnectionVocabulary + ifFalse: [ dict removeKey: #'connections to me' ifAbsent: []. + dict removeKey: #connection ifAbsent: []]. + self wantsConnectorVocabulary + ifFalse: [ dict removeKey: #connector ifAbsent: [] ]. + self wantsEmbeddingsVocabulary + ifFalse: [dict removeKey: #embeddings ifAbsent: []]. + Preferences eToyFriendly + ifTrue: + [dict removeKey: #layout ifAbsent: []]. + (Preferences eToyFriendly or: [self isWorldMorph not]) ifTrue: + [dict removeKey: #preferences ifAbsent: []].! Item was removed: - ----- Method: Morph>>innocuousName (in category 'naming') ----- - innocuousName - "Choose an innocuous name for the receiver -- one that does not end in the word Morph" - - | className allKnownNames | - className := self defaultNameStemForInstances. - (className size > 5 and: [className endsWith: 'Morph']) - ifTrue: [className := className copyFrom: 1 to: className size - 5]. - className := className asString translated. - allKnownNames := self world ifNil: [OrderedCollection new] ifNotNil: [self world allKnownNames]. - ^ Utilities keyLike: className asString satisfying: - [:aName | (allKnownNames includes: aName) not]! Item was removed: - ----- Method: Morph>>intersects: (in category 'geometry') ----- - intersects: aRectangle - "Answer whether aRectangle, which is in World coordinates, intersects me." - - ^self fullBoundsInWorld intersects: aRectangle! Item was removed: - ----- Method: Morph>>isLineMorph (in category 'testing') ----- - isLineMorph - ^false! Item was removed: - ----- Method: Morph>>model (in category 'menus') ----- - model - ^ nil ! Item was removed: - ----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') ----- - overlapsShadowForm: itsShadow bounds: itsBounds - "Answer true if itsShadow and my shadow overlap at all" - | andForm overlapExtent | - overlapExtent := (itsBounds intersect: self fullBounds) extent. - overlapExtent > (0 @ 0) - ifFalse: [^ false]. - andForm := self shadowForm. - overlapExtent ~= self fullBounds extent - ifTrue: [andForm := andForm - contentsOfArea: (0 @ 0 extent: overlapExtent)]. - andForm := andForm - copyBits: (self fullBounds translateBy: itsShadow offset negated) - from: itsShadow - at: 0 @ 0 - clippingBox: (0 @ 0 extent: overlapExtent) - rule: Form and - fillColor: nil. - ^ andForm bits - anySatisfy: [:w | w ~= 0]! Item was removed: - ----- Method: Morph>>playerRepresented (in category 'accessing') ----- - playerRepresented - "Answer the player represented by the receiver. Morphs that serve as references to other morphs reimplement this; be default a morph represents its own player." - - ^ self player! Item was removed: - ----- Method: Morph>>removedMorph: (in category 'submorphs-add/remove') ----- - removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - ! Item was removed: - ----- Method: Morph>>renameTo: (in category 'testing') ----- - renameTo: aName - "Set Player name in costume. Update Viewers. Fix all tiles (old style). fix - References. New tiles: recompile, and recreate open scripts. If coming in - from disk, and have name conflict, References will already have new - name. " - - | aPresenter putInViewer aPasteUp renderer oldKey assoc classes oldName | - oldName := self knownName. - (renderer := self topRendererOrSelf) setNameTo: aName. - putInViewer := false. - ((aPresenter := self presenter) isNil or: [renderer player isNil]) - ifFalse: - [putInViewer := aPresenter currentlyViewing: renderer player. - putInViewer ifTrue: [renderer player viewerFlapTab hibernate]]. - "empty it temporarily" - (aPasteUp := self topPasteUp) - ifNotNil: [aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]]. - "Fix References dictionary. See restoreReferences to know why oldKey is - already aName, but oldName is the old name." - oldKey := References keyAtIdentityValue: renderer player ifAbsent: []. - oldKey ifNotNil: - [assoc := References associationAt: oldKey. - oldKey = aName - ifFalse: - ["normal rename" - - assoc key: (renderer player uniqueNameForReferenceFrom: aName). - References rehash]]. - putInViewer ifTrue: [aPresenter viewMorph: self]. - "recreate my viewer" - oldKey ifNil: [^aName]. - "Force strings in tiles to be remade with new name. New tiles only." - Preferences universalTiles ifFalse: [^aName]. - classes := (self systemNavigation allCallsOn: assoc) - collect: [:each | each classSymbol]. - classes asSet - do: [:clsName | (Smalltalk at: clsName) replaceSilently: oldName to: aName]. - "replace in text body of all methods. Can be wrong!!" - "Redo the tiles that are showing. This is also done in caller in - unhibernate. " - aPasteUp ifNotNil: - [aPasteUp allTileScriptingElements do: - [:mm | - "just ScriptEditorMorphs" - - nil. - (mm isScriptEditorMorph) - ifTrue: - [((mm playerScripted class compiledMethodAt: mm scriptName) - hasLiteral: assoc) - ifTrue: - [mm - hibernate; - unhibernate]]]]. - ^aName! Item was removed: - ----- Method: Morph>>slideToTrash: (in category 'dropping/grabbing') ----- - slideToTrash: evt - "Perhaps slide the receiver across the screen to a trash can and make it disappear into it. In any case, remove the receiver from the screen." - - | aForm trash startPoint endPoint morphToSlide | - ((self renderedMorph == Utilities scrapsBook) or: [self renderedMorph isKindOf: TrashCanMorph]) ifTrue: - [self dismissMorph. ^ self]. - Preferences slideDismissalsToTrash ifTrue: - [morphToSlide := self representativeNoTallerThan: 200 norWiderThan: 200 thumbnailHeight: 100. - aForm := morphToSlide imageForm offset: (0 at 0). - trash := ActiveWorld - findDeepSubmorphThat: - [:aMorph | (aMorph isKindOf: TrashCanMorph) and: - [aMorph topRendererOrSelf owner == ActiveWorld]] - ifAbsent: - [trash := TrashCanMorph new. - trash bottomLeft: ActiveWorld bottomLeft - (-10 at 10). - trash openInWorld. - trash]. - endPoint := trash fullBoundsInWorld center. - startPoint := self topRendererOrSelf fullBoundsInWorld center - (aForm extent // 2)]. - self dismissMorph. - ActiveWorld displayWorld. - Preferences slideDismissalsToTrash ifTrue: - [aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15]. - Utilities addToTrash: self! Item was removed: - ----- Method: Morph>>wantsConnectorVocabulary (in category 'connectors-scripting') ----- - wantsConnectorVocabulary - "Answer true if I want to show a 'connector' vocabulary" - ^false! Item was removed: - ----- Method: Morph>>wantsEmbeddingsVocabulary (in category 'accessing') ----- - wantsEmbeddingsVocabulary - "Empty method in absence of connectors" - ^ false! Item was removed: - ----- Method: PasteUpMorph>>deleteAllHalos (in category 'world state') ----- - deleteAllHalos - - self haloMorphs - do: [:each | (each target isKindOf: SelectionMorph) - ifTrue: [each target delete]]. - self hands - do: [:each | each removeHalo]! Item was removed: - ----- Method: PolygonMorph>>arrows (in category 'menu') ----- - arrows - ^arrows! Item was removed: - ----- Method: PolygonMorph>>arrowsContainPoint: (in category 'geometry') ----- - 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.! Item was removed: - ----- Method: PolygonMorph>>boundsSignatureHash (in category 'attachments') ----- - boundsSignatureHash - ^(vertices - (self positionInWorld)) hash - ! Item was removed: - ----- Method: PolygonMorph>>closestSegmentTo: (in category 'geometry') ----- - closestSegmentTo: aPoint - "Answer the starting index of my (big) segment nearest to aPoint" - | closestPoint minDist vertexIndex closestVertexIndex | - vertexIndex := 0. - closestVertexIndex := 0. - closestPoint := minDist := nil. - self lineSegmentsDo: - [:p1 :p2 | | dist curvePoint | - (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! Item was removed: - ----- Method: PolygonMorph>>dashedBorder (in category 'dashes') ----- - 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." - ! Item was removed: - ----- Method: PolygonMorph>>defaultAttachmentPointSpecs (in category 'attachments') ----- - defaultAttachmentPointSpecs - ^{ - { #firstVertex } . - { #midpoint } . - { #lastVertex } - }! Item was removed: - ----- Method: PolygonMorph>>drawArrowsOn: (in category 'drawing') ----- - drawArrowsOn: aCanvas - "Answer (possibly modified) endpoints for border drawing" - "ArrowForms are computed only upon demand" - | array | - - self hasArrows - ifFalse: [^ #() ]. - "Nothing to do" - - array := Array with: vertices first with: vertices last. - - "Prevent crashes for #raised or #inset borders" - borderColor isColor - ifFalse: [ ^array ]. - - (arrows == #forward or: [arrows == #both]) - ifTrue: [ array at: 2 put: (self - drawArrowOn: aCanvas - at: vertices last - from: self nextToLastPoint) ]. - - (arrows == #back or: [arrows == #both]) - ifTrue: [ array at: 1 put: (self - drawArrowOn: aCanvas - at: vertices first - from: self nextToFirstPoint) ]. - - ^array! Item was removed: - ----- Method: PolygonMorph>>endShapeColor: (in category 'attachments') ----- - endShapeColor: aColor - self borderColor: aColor. - self isClosed ifTrue: [ self color: aColor ].! Item was removed: - ----- Method: PolygonMorph>>endShapeWidth: (in category 'attachments') ----- - 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 at 0 ] - ]. - transform := MorphicTransform offset: 0 at 0 angle: self heading degreesToRadians scale: originalWidth / aWidth. - self setVertices: (originalVertices collect: [ :ea | - ((transform transform: ea) + self referencePosition) asIntegerPoint - ]). - self computeBounds.! Item was removed: - ----- Method: PolygonMorph>>firstVertex (in category 'attachments') ----- - firstVertex - ^vertices first! Item was removed: - ----- Method: PolygonMorph>>intersectionWithLineSegmentFromCenterTo: (in category 'geometry') ----- - intersectionWithLineSegmentFromCenterTo: aPoint - ^self closestPointTo: aPoint! Item was removed: - ----- Method: PolygonMorph>>intersectionsWith: (in category 'geometry') ----- - 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 - ! Item was removed: - ----- Method: PolygonMorph>>intersects: (in category 'geometry') ----- - intersects: aRectangle - "Answer whether any of my segments intersects aRectangle, which is in World coordinates." - | rect | - (super intersects: aRectangle) ifFalse: [ ^false ]. - rect := self bounds: aRectangle in: self world. - self - lineSegmentsDo: [:p1 :p2 | (rect intersectsLineFrom: p1 to: p2) - ifTrue: [^ true]]. - ^ false! Item was removed: - ----- Method: PolygonMorph>>isBordered (in category 'geometry') ----- - isBordered - ^false! Item was removed: - ----- Method: PolygonMorph>>isLineMorph (in category 'testing') ----- - isLineMorph - ^closed not! Item was removed: - ----- Method: PolygonMorph>>lastVertex (in category 'attachments') ----- - lastVertex - ^vertices last! Item was removed: - ----- Method: PolygonMorph>>lineBorderColor (in category 'geometry') ----- - lineBorderColor - ^self borderColor! Item was removed: - ----- Method: PolygonMorph>>lineBorderColor: (in category 'geometry') ----- - lineBorderColor: aColor - self borderColor: aColor! Item was removed: - ----- Method: PolygonMorph>>lineBorderWidth (in category 'geometry') ----- - lineBorderWidth - - ^self borderWidth! Item was removed: - ----- Method: PolygonMorph>>lineBorderWidth: (in category 'geometry') ----- - lineBorderWidth: anInteger - - self borderWidth: anInteger! Item was removed: - ----- Method: PolygonMorph>>lineColor (in category 'geometry') ----- - lineColor - ^self borderColor! Item was removed: - ----- Method: PolygonMorph>>lineColor: (in category 'geometry') ----- - lineColor: aColor - self borderColor: aColor! Item was removed: - ----- Method: PolygonMorph>>lineWidth (in category 'geometry') ----- - lineWidth - - ^self borderWidth! Item was removed: - ----- Method: PolygonMorph>>lineWidth: (in category 'geometry') ----- - lineWidth: anInteger - - self borderWidth: (anInteger rounded max: 1)! Item was removed: - ----- Method: PolygonMorph>>midpoint (in category 'attachments') ----- - midpoint - "Answer the midpoint along my segments" - | middle | - middle := self totalLength. - 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. - ]. - self error: 'can''t happen'! Item was removed: - ----- Method: PolygonMorph>>nextDuplicateVertexIndex (in category 'geometry') ----- - nextDuplicateVertexIndex - vertices - doWithIndex: [:vert :index | ((index between: 2 and: vertices size - 1) - and: [| epsilon v1 v2 | - v1 := vertices at: index - 1. - v2 := vertices at: index + 1. - epsilon := ((v1 x - v2 x) abs max: (v1 y - v2 y) abs) - // 32 max: 1. - vert - onLineFrom: v1 - to: v2 - within: epsilon]) - ifTrue: [^ index]]. - ^ 0! Item was removed: - ----- Method: PolygonMorph>>nudgeForLabel: (in category 'attachments') ----- - 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 at 0 ]. - flags := 0. - nudge := 0 at 0. - i := 1. - aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg | - rectSeg := LineSegment from: rp1 to: rp2. - self straightLineSegmentsDo: [ :lp1 :lp2 | | polySeg int | - 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 at 0 ]. - "2 adjacent sides only" - [ 9 ] -> [ 1 at 1 ]. - [ 3 ] -> [ -1 at 1 ]. - [ 12 ] -> [ 1 at -1 ]. - [ 6 ] -> [ -1 at -1 ]. - "2 opposite sides only" - [ 10 ] -> [ 0 at -1 ]. - [ 5 ] -> [ 1 at 0 ]. - "only 1 side" - [ 8 ] -> [ -1 at 0 ]. - [ 1 ] -> [ 0 at -1 ]. - [ 2 ] -> [ 1 at 0 ]. - [ 4 ] -> [ 0 at 1 ]. - "3 sides" - [ 11 ] -> [ 0 at 1 ]. - [ 13 ] -> [ 1 at 0 ]. - [ 14 ] -> [ 0 at -1 ]. - [ 7 ] -> [ -1 at 0 ]. - "all sides" - [ 15 ] -> [ 1 at -1 "move up and to the right" ]. - }. - ^nudge! Item was removed: - ----- Method: PolygonMorph>>reduceVertices (in category 'geometry') ----- - 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.! Item was removed: - ----- Method: PolygonMorph>>removeVertex: (in category 'dashes') ----- - 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 - ! Item was removed: - ----- Method: PolygonMorph>>straightLineSegmentsDo: (in category 'smoothing') ----- - straightLineSegmentsDo: endPointsBlock - "Emit a sequence of segment endpoints into endPointsBlock. - Work the same way regardless of whether I'm curved." - | beginPoint | - beginPoint := nil. - vertices do: - [:vert | beginPoint ifNotNil: - [endPointsBlock value: beginPoint - value: vert]. - beginPoint := vert]. - (closed or: [vertices size = 1]) - ifTrue: [endPointsBlock value: beginPoint - value: vertices first].! Item was removed: - ----- Method: PolygonMorph>>straighten (in category 'geometry') ----- - straighten - self setVertices: { vertices first . vertices last }! Item was removed: - ----- Method: PolygonMorph>>totalLength (in category 'attachments') ----- - totalLength - "Answer the full length of my segments. Can take a long time if I'm curved." - | length | - length := 0. - self lineSegmentsDo: [ :a :b | length := length + (a dist: b) ]. - ^length.! Item was removed: - ----- Method: PolygonMorph>>transformVerticesFrom:to: (in category 'private') ----- - 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. - ! Item was removed: - ----- Method: PolygonMorph>>vertexAt: (in category 'dashes') ----- - vertexAt: n - ^vertices at: (n min: vertices size).! Item was removed: - ----- Method: Presenter>>viewMorph: (in category 'stubs') ----- - viewMorph: aMorph - aMorph inspect. - ! Item was removed: - ----- Method: SelectionMorph>>addOrRemoveItems: (in category 'halo commands') ----- - addOrRemoveItems: handOrEvent - "Make a new selection extending the current one." - - | hand | - hand := (handOrEvent isMorphicEvent) - ifFalse: [handOrEvent] - ifTrue: [handOrEvent hand]. - hand - addMorphBack: ((self class - newBounds: (hand lastEvent cursorPoint extent: 16 @ 16)) - setOtherSelection: self). - ! Item was removed: - ----- Method: SketchMorph>>changePixelsOfColor:toColor: (in category 'menus') ----- - changePixelsOfColor: c toColor: newColor - - | r | - originalForm mapColor: c to: newColor. - r := originalForm rectangleEnclosingPixelsNotOfColor: Color transparent. - self form: (originalForm copy: r). - - ! Item was removed: - ----- Method: SketchMorph>>firstIntersectionWithLineFrom:to: (in category 'geometry') ----- - firstIntersectionWithLineFrom: start to: end - | intersections last | - intersections := self fullBounds extrapolatedIntersectionsWithLineFrom: start to: end. - intersections size = 1 ifTrue: [ ^intersections anyOne ]. - intersections isEmpty ifTrue: [ ^nil ]. - intersections := intersections asSortedCollection: [ :a :b | (start dist: a) < (start dist: b) ]. - last := intersections first rounded. - last pointsTo: intersections last rounded do: [ :pt | - (self rotatedForm isTransparentAt: (pt - bounds origin)) ifFalse: [ ^last ]. - last := pt. - ]. - ^intersections first rounded! Item was removed: - ----- Method: StringMorph>>minHeight (in category 'connectors-layout') ----- - minHeight - "answer the receiver's minHeight" - ^ self fontToUse height! Item was removed: - ----- Method: StringMorphEditor>>keyboardFocusChange: (in category 'event handling') ----- - keyboardFocusChange: aBoolean - | hadFocus | - owner ifNil: [ ^self ]. - hadFocus := owner hasFocus. - super keyboardFocusChange: aBoolean. - aBoolean ifFalse: - [hadFocus ifTrue: - [owner lostFocusWithoutAccepting; doneWithEdits]. - ^ self delete]! Item was removed: - ----- Method: TTSampleFontMorph class>>fontWithoutString: (in category 'connectors') ----- - fontWithoutString: aTTFontDescription - ^self new fontWithoutString: aTTFontDescription! Item was removed: - ----- Method: TTSampleFontMorph>>fontWithoutString: (in category 'connectors') ----- - fontWithoutString: aTTFontDescription - font := aTTFontDescription. - ! Item was removed: - ----- Method: TTSampleFontMorph>>glyphAt: (in category 'connectors') ----- - glyphAt: position - ^font at: (self glyphIndexAt: position).! Item was removed: - ----- Method: TTSampleFontMorph>>glyphIndexAt: (in category 'connectors') ----- - glyphIndexAt: position - | offset | - offset := (position adhereTo: (bounds insetBy: 1)) - bounds origin. - offset := (offset asFloatPoint / bounds extent) * 16. - offset := offset truncated. - ^offset y * 16 + offset x! Item was removed: - ----- Method: TTSampleFontMorph>>printOn: (in category 'connectors') ----- - printOn: aStream - aStream nextPutAll: 'TTSampleFont('; - nextPutAll: font familyName; - nextPut: $)! Item was removed: - ----- Method: TTSampleFontMorph>>selectGlyph (in category 'connectors') ----- - selectGlyph - | retval done | - "Modal glyph selector" - done := false. - self on: #mouseDown send: #selectGlyphBlock:event:from: to: self withValue: [ :glyph | retval := glyph. done := true. ]. - self on: #keyStroke send: #value to: [ done := true ]. - [ done ] whileFalse: [ self world doOneCycle ]. - self on: #mouseDown send: nil to: nil. - self on: #keyStroke send: nil to: nil. - ^retval! Item was removed: - ----- Method: TTSampleFontMorph>>selectGlyphAndSendTo: (in category 'connectors') ----- - selectGlyphAndSendTo: aBlock - self on: #mouseDown send: #selectGlyphBlock:event:from: to: self withValue: aBlock.! Item was removed: - ----- Method: TTSampleFontMorph>>selectGlyphBlock:event:from: (in category 'connectors') ----- - selectGlyphBlock: aBlock event: evt from: me - aBlock value: (self glyphAt: evt position). - ! Item was removed: - ----- Method: TTSampleStringMorph>>printOn: (in category 'printing') ----- - printOn: aStream - aStream nextPutAll: 'TTSampleString('; - nextPutAll: font familyName; - nextPut: $)! Item was removed: - ----- Method: TextMorph class>>boldAuthoringPrototype (in category 'connectorstext-parts bin') ----- - boldAuthoringPrototype - "TextMorph boldAuthoringPrototype openInHand" - | text | - text := Text string: 'Text' translated attributes: { TextEmphasis bold. }. - ^self new - contentsWrapped: text; - fontName: 'BitstreamVeraSans' pointSize: 24; - paragraph; - extent: 79 at 36; - margins: 4 at 0; - fit; - yourself - ! Item was removed: - ----- Method: TextMorph>>addCustomMenuItems:hand: (in category 'menu') ----- - addCustomMenuItems: aCustomMenu hand: aHandMorph - | outer | - super addCustomMenuItems: aCustomMenu hand: aHandMorph. - aCustomMenu add: 'text properties...' translated action: #changeTextColor. - aCustomMenu addUpdating: #autoFitString target: self action: #autoFitOnOff. - aCustomMenu addUpdating: #wrapString target: self action: #wrapOnOff. - aCustomMenu add: 'text margins...' translated action: #changeMargins:. - aCustomMenu add: 'add predecessor' translated action: #addPredecessor:. - aCustomMenu add: 'add successor' translated action: #addSuccessor:. - - outer := self owner. - outer ifNotNil: [ - outer isLineMorph ifTrue: - [container isNil - ifTrue: [aCustomMenu add: 'follow owner''s curve' translated action: #followCurve] - ifFalse: [aCustomMenu add: 'reverse direction' translated action: #reverseCurveDirection. - aCustomMenu add: 'set baseline' translated action: #setCurveBaseline:]] - ifFalse: - [self fillsOwner - ifFalse: [aCustomMenu add: 'fill owner''s shape' translated action: #fillingOnOff] - ifTrue: [aCustomMenu add: 'rectangular bounds' translated action: #fillingOnOff]. - self avoidsOcclusions - ifFalse: [aCustomMenu add: 'avoid occlusions' translated action: #occlusionsOnOff] - ifTrue: [aCustomMenu add: 'ignore occlusions' translated action: #occlusionsOnOff]]]. - aCustomMenu addLine. - aCustomMenu add: 'holder for characters' translated action: #holderForCharacters - ! Item was removed: - ----- Method: TextMorph>>avoidsOcclusions (in category 'containment') ----- - avoidsOcclusions - ^container notNil and: [ container avoidsOcclusions ] - ! Item was removed: - ----- Method: TextMorph>>fillingOnOff (in category 'containment') ----- - fillingOnOff - "Establish a container for this text, with opposite filling status" - self fillsOwner: (self fillsOwner not)! Item was removed: - ----- Method: TextMorph>>fillsOwner (in category 'containment') ----- - fillsOwner - "Answer true if I fill my owner's shape." - ^container notNil and: [container fillsOwner]! Item was removed: - ----- Method: TextMorph>>fillsOwner: (in category 'containment') ----- - fillsOwner: aBoolean - self fillsOwner == aBoolean - ifTrue: [^ self]. - self - setContainer: (aBoolean - ifTrue: [wrapFlag := true. - container - ifNil: [TextContainer new for: self minWidth: textStyle lineGrid * 2] - ifNotNil: [container fillsOwner: true]] - ifFalse: [self avoidsOcclusions - ifFalse: [ nil ] - ifTrue: [container fillsOwner: false]])! Item was removed: - ----- Method: TextMorph>>font: (in category 'accessing') ----- - font: aFont - | newTextStyle | - newTextStyle := aFont textStyle copy ifNil: [ TextStyle fontArray: { aFont } ]. - textStyle := newTextStyle. - text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOf: aFont)). - paragraph ifNotNil: [paragraph textStyle: newTextStyle]! Item was removed: - ----- Method: TextMorph>>fontName:pointSize: (in category 'accessing') ----- - fontName: fontName pointSize: fontSize - | newTextStyle | - newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy. - newTextStyle ifNil: [self error: 'font ', fontName, ' not found.']. - - textStyle := newTextStyle. - text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfPointSize: fontSize)). - paragraph ifNotNil: [paragraph textStyle: newTextStyle]! Item was removed: - ----- Method: TextMorph>>fontName:size: (in category 'accessing') ----- - fontName: fontName size: fontSize - | newTextStyle | - newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy. - textStyle := newTextStyle. - text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfSize: fontSize)). - paragraph ifNotNil: [paragraph textStyle: newTextStyle]! Item was removed: - ----- Method: TextMorph>>selectAll (in category 'accessing') ----- - selectAll - self editor selectFrom: 1 to: text size! Item was removed: - ----- Method: TextMorph>>selectFrom:to: (in category 'accessing') ----- - selectFrom: a to: b - self editor selectFrom: a to: b! Item was removed: - ----- Method: TextMorph>>selection (in category 'accessing') ----- - selection - ^editor ifNotNil: [ editor selection ]!
More information about the Squeak-dev mailing list |