'From Squeak3.5 of ''11 April 2003'' [latest update: #5180] on 17 June 2003 at 12:26:38 pm'! Object subclass: #Beeper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !Beeper commentStamp: 'nb 6/17/2003 12:25'! My job is to provide simple audible feedback. The sound you get can be changed by invoking my class-side method #setDefault: with any object that implements the #play message. Use Beeper beep to play the current beep, Beeper beepPrimitive to play the primitive beep. Note that #play is introduced to propose a common interface between AbstractSound and Beeper. This way we can have more enhanced beepers as illustrated by the following example: SampleSound class>>initialize "SampledSound initialize" IncrementFractionBits _ 16. IncrementScaleFactor _ 2 raisedTo: IncrementFractionBits. ScaledIndexOverflow _ 2 raisedTo: 29. "handle overflow before needing LargePositiveIntegers" self useCoffeeCupClink. SoundLibrary ifNil: [SoundLibrary _ Dictionary new]. Beeper setDefault: (self new setSamples: self coffeeCupClink samplingRate: 12000)). Then Beeper beep will play the coffeeCup sound. ! Beeper class instanceVariableNames: 'default '! !Beeper methodsFor: 'play interface'! play self beep! ! !Beeper methodsFor: 'beeping'! beepPrimitive "Beep in the absence of sound support" self class beepPrimitive! beep self beepPrimitive! ! !Beeper class methodsFor: 'customize'! setDefault: aPlayableEntity "aBeepingEntity should implement the message #play." default := aPlayableEntity! clearDefault "Set the primitive beep as the default beep." default := nil! default "When the default is not defined, it is myself." default isNil ifTrue: [default := self newDefault ]. ^ default! newDefault "Subclasses may override me to provide a default beep." ^ self new! ! !Beeper class methodsFor: 'beeping'! beepPrimitive "Beep in the absence of sound support" self primitiveFailed! beep "The preferred way of producing an audible feedback" Preferences soundsEnabled ifTrue: [self default play] ! ! !Beeper class methodsFor: 'play interface'! play self beep! ! !NewWorldWindow methodsFor: 'color'! setWindowColor: incomingColor | existingColor aColor | incomingColor ifNil: [^ self]. "it happens" aColor _ incomingColor asNontranslucentColor. (aColor = ColorPickerMorph perniciousBorderColor or: [aColor = Color black]) ifTrue: [^ self]. existingColor _ self paneColorToUse. existingColor ifNil: [^ Beeper beep]. self setStripeColorsFrom: aColor ! ! !Object methodsFor: 'objects from disk'! saveOnFile "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. Does not file out the class of the object. tk 6/26/97 13:48" | aFileName fileStream | aFileName _ self class name asFileName. "do better?" aFileName _ FillInTheBlank request: 'File name?' initialAnswer: aFileName. aFileName size == 0 ifTrue: [^ Beeper beep]. fileStream _ FileStream newFileNamed: aFileName. fileStream fileOutClass: nil andObject: self.! ! !Object methodsFor: 'deprecated'! playSoundNamed: soundName "Play the sound with the given name. Do nothing if this image lacks sound playing facilities." self deprecatedExplanation: 'Use SampledSound>>playSoundNamed: instead.'. Smalltalk at: #SampledSound ifPresent: [:sampledSound | sampledSound playSoundNamed: soundName asString]. ! beepPrimitive "Beep in the absence of sound support" self deprecatedExplanation: 'Use Beeper>>beep or Beeper>>beepPrimitive instead of 1 beep.'. Beeper beepPrimitive! beep "If sound system is present use it, otherwise do whatever we can." | classOrNil | self deprecatedExplanation: 'Use Beeper>>beep or Beeper>>beepPrimitive instead of 1 beep.'. classOrNil := self class environment at: #SampledSound ifAbsent: [nil]. classOrNil ifNil: [self primitiveBeep] ifNotNil: [classOrNil beep] ! beep: soundName "Make the given sound, unless the making of sound is disabled in Preferences." self deprecatedExplanation: 'Use SampledSound>>playSoundNamed: instead.'. Preferences soundsEnabled ifTrue: [self playSoundNamed: soundName] ! ! !MorphThumbnail methodsFor: 'as yet unclassified'! revealOriginal ((owner isKindOf: PasteUpMorph) and: [owner alwaysShowThumbnail]) ifTrue: [^ Beeper beep]. morphRepresented owner == nil ifTrue: [^ owner replaceSubmorph: self by: morphRepresented]. self beep.! ! !InternalThreadNavigationMorph methodsFor: 'as yet unclassified'! triggerActionFromPianoRoll | proj | WorldState addDeferredUIMessage: [ (self currentIndex >= listOfPages size) ifTrue: [Beeper beep] ifFalse: [ currentIndex _ self currentIndex + 1. proj _ Project named: ((listOfPages at: currentIndex) at: 1). proj world setProperty: #letTheMusicPlay toValue: true. proj enter. ]. ]! skipOverNext | target | (target _ self currentIndex + 2) > listOfPages size ifTrue: [^Beeper beep]. currentIndex _ target. self loadPageWithProgress. ! ! !ParagraphEditor methodsFor: 'menu messages'! changeStyle "Let user change styles for the current text pane Moved from experimentalCommand to its own method " | aList reply style | aList _ StrikeFont familyNames remove: 'DefaultTextStyle' ifAbsent: []; asOrderedCollection. aList addFirst: 'DefaultTextStyle'. reply _ (SelectionMenu labelList: aList lines: #(1) selections: aList) startUp. reply ~~ nil ifTrue: [(style _ TextStyle named: reply) ifNil: [Beeper beep. ^ true]. paragraph textStyle: style copy. paragraph composeAll. self recomputeSelection. self mvcRedisplay]. ^ true! ! !FileStream class methodsFor: 'file reader services'! fileIn: fullName "File in the entire contents of the file specified by the name provided" | fn ff | fullName ifNil: [^ Beeper beep]. ff _ self readOnlyFileNamed: (fn _ GZipReadStream uncompressedFileName: fullName). ((FileDirectory extensionFor: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml]. ff fileIn! ! !SampledSound class methodsFor: 'class initialization'! initialize "SampledSound initialize" IncrementFractionBits _ 16. IncrementScaleFactor _ 2 raisedTo: IncrementFractionBits. ScaledIndexOverflow _ 2 raisedTo: 29. "handle overflow before needing LargePositiveIntegers" self useCoffeeCupClink. SoundLibrary ifNil: [SoundLibrary _ Dictionary new]. Beeper setDefault: (self new setSamples: self coffeeCupClink samplingRate: 12000). ! ! !Browser methodsFor: 'class list'! recent "Let the user select from a list of recently visited classes. 11/96 stp. 12/96 di: use class name, not classes themselves. : dont fall into debugger in empty case" | className class recentList | recentList _ RecentClasses select: [:n | Smalltalk includesKey: n]. recentList size == 0 ifTrue: [^ Beeper beep]. className := (SelectionMenu selections: recentList) startUp. className == nil ifTrue: [^ self]. class := Smalltalk at: className. self selectCategoryForClass: class. self classListIndex: (self classList indexOf: class name)! ! !StringHolder methodsFor: 'message list menu'! makeIsolatedCodePane | msgName | (msgName _ self selectedMessageName) ifNil: [^ Beeper beep]. MethodHolder makeIsolatedCodePaneForClass: self selectedClassOrMetaClass selector: msgName! revertToPreviousVersion "Revert to the previous version of the current method" | aClass aSelector changeRecords | self okToChange ifFalse: [^ self]. aClass _ self selectedClassOrMetaClass. aClass ifNil: [^ self changed: #flash]. aSelector _ self selectedMessageName. changeRecords _ aClass changeRecordsAt: aSelector. (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [self changed: #flash. ^ Beeper beep]. changeRecords second fileIn. self contentsChanged ! ! !Debugger methodsFor: 'context stack menu'! peelToFirst "Peel the stack back to the second occurance of the currently selected message. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning. Also frees a lot of space!!" | upperGuy meth second | contextStackIndex = 0 ifTrue: [^ Beeper beep]. "self okToChange ifFalse: [^ self]." upperGuy _ contextStack at: contextStackIndex. meth _ upperGuy method. contextStackIndex+1 to: contextStack size do: [:ind | (contextStack at: ind) method == meth ifTrue: [ second _ upperGuy. upperGuy _ contextStack at: ind]]. second ifNil: [second _ upperGuy]. self resetContext: second. interruptedProcess popTo: self selectedContext.! ! !ThreadNavigationMorph methodsFor: 'as yet unclassified'! previousPage self currentIndex <= 1 ifTrue: [^Beeper beep]. currentIndex _ self currentIndex - 1. self loadPageWithProgress.! firstPage listOfPages isEmpty ifTrue: [^Beeper beep]. currentIndex _ 1. self loadPageWithProgress.! lastPage listOfPages isEmpty ifTrue: [^Beeper beep]. currentIndex _ listOfPages size. self loadPageWithProgress.! nextPage self currentIndex >= listOfPages size ifTrue: [^Beeper beep]. currentIndex _ self currentIndex + 1. self loadPageWithProgress.! ! !ClassDescription methodsFor: 'deprecated'! browseClassVarRefs "Put up a menu offering all class variable names; if the user chooses one, open up a message-list browser on all methods that refer to the selected class variable" | lines labelStream vars allVars index owningClasses | self deprecatedExplanation: 'Method Deprecated: Use SystemNavigation>>browseClassVarRefs: instead'. lines _ OrderedCollection new. allVars _ OrderedCollection new. owningClasses _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). self withAllSuperclasses reverseDo: [:class | vars _ class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var. owningClasses add: class]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index _ (PopUpMenu labels: labelStream contents lines: lines) startUp. index = 0 ifTrue: [^ self]. self environment browseAllCallsOn: ((owningClasses at: index) classPool associationAt: (allVars at: index))! ! !ClassDescription methodsFor: 'instance variables'! chooseClassVarName "Present the user with a list of class variable names and answer the one selected, or nil if none" | lines labelStream vars allVars index | lines _ OrderedCollection new. allVars _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). self withAllSuperclasses reverseDo: [:class | vars _ class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index _ (PopUpMenu labels: labelStream contents lines: lines) startUp. index = 0 ifTrue: [^ nil]. ^ allVars at: index! ! !CRDictionaryBrowser methodsFor: 'view hooks'! changeCharRequestRequestor: aPluggableCollectionMorph "A view calls this method when the currently displayed character changes" ^ ((self subPaneOf: aPluggableCollectionMorph) isKindOf: CRAddFeatureMorph) ifTrue: [Beeper beep. false] ifFalse: [true]! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified'! backgroundWorldDisplay | f | self flag: #bob. "really need a better way to do this" "World displayWorldSafely." "ugliness to try to track down a possible error" [World displayWorld] ifError: [ :a :b | stageCompleted _ 999. f _ FileDirectory default fileNamed: 'bob.errors'. f nextPutAll: a printString,' ',b printString; cr; cr. f nextPutAll: 'worlds equal ',(formerWorld == World) printString; cr; cr. f nextPutAll: thisContext longStack; cr; cr. f nextPutAll: formerProcess suspendedContext longStack; cr; cr. f close. Beeper beep. ]. ! ! !ComplexProgressIndicator class methodsFor: 'as yet unclassified'! historyReport " ComplexProgressIndicator historyReport " | answer data | History ifNil: [^Beeper beep]. answer _ String streamContents: [ :strm | (History keys asSortedCollection: [ :a :b | a asString <= b asString]) do: [ :k | strm nextPutAll: k printString; cr. data _ History at: k. (data keys asSortedCollection: [ :a :b | a asString <= b asString]) do: [ :dataKey | strm tab; nextPutAll: dataKey printString,' ', (data at: dataKey) asArray printString; cr. ]. strm cr. ]. ]. StringHolder new contents: answer contents; openLabel: 'Progress History'! ! !SketchMorph methodsFor: 'e-toy support'! acquirePlayerSimilarTo: aSketchMorphsPlayer "Retrofit into the receiver a player derived from the existing scripted player of a different morph. Works only between SketchMorphs. Maddeningly complicated by potential for transformations or native sketch-morph scaling in donor or receiver or both" | myName myTop itsTop newTop newSketch | myTop _ self topRendererOrSelf. aSketchMorphsPlayer belongsToUniClass ifFalse: [^ Beeper beep]. itsTop _ aSketchMorphsPlayer costume. (itsTop renderedMorph isKindOf: SketchMorph) ifFalse: [^ self beep]. newTop _ itsTop veryDeepCopy. "May be a sketch or a tranformation" myName _ myTop externalName. "Snag before the replacement is added to the world, because otherwise that could affect this" newSketch _ newTop renderedMorph. newSketch form: self form. newSketch scalePoint: self scalePoint. newSketch bounds: self bounds. myTop owner addMorph: newTop after: myTop. newTop heading ~= myTop heading ifTrue: "avoids annoying round-off error in what follows" [newTop player setHeading: myTop heading]. (newTop isFlexMorph and: [myTop == self]) ifTrue: [newTop removeFlexShell]. newTop _ newSketch topRendererOrSelf. newTop bounds: self bounds. (newTop isFlexMorph and:[myTop isFlexMorph]) ifTrue:[ "Note: This completely dumps the above #bounds: information. We need to recompute the bounds based on the transform." newTop transform: myTop transform copy. newTop computeBounds]. newTop setNameTo: myName. newTop player class bringScriptsUpToDate. myTop delete! ! !ButtonProperties class methodsFor: 'as yet unclassified'! test3 | m | (m _ self ellipticalButtonWithText: 'Hello world') openInWorld. m ensuredButtonProperties target: Beeper; actionSelector: #beep; delayBetweenFirings: 1000.! ! !CRGestureProcessor methodsFor: 'private'! preprocessGesture: aCRGesture "Preprocess the recognized gesture. Return true if it should not be passed to the target morph, false otherwise" "Check for alert and reject" aCRGesture isReject ifTrue: [^ true]. aCRGesture isAlert ifTrue: [Beeper beep]. "Store mouse buttons if special mouse action gesture" (self updateMouseActionButton: aCRGesture) ifTrue: [^ true]. aCRGesture isCommand ifFalse: [^ false]. "Update capsLock state" aCRGesture normalizedChar = #capsLock ifTrue: [capsLockPressed _ capsLockPressed not. ^ true]. "Stop recognizing all gesture exclusively for one morph. NOTE: The exclusive recognition mode is never turned on in this preprocessing method (it has to be done in HandMorph). But it is terminated here for safety reasons" (self isFocused and: [aCRGesture normalizedChar = #switchFocus or: [aCRGesture normalizedChar = #switchRecognizeAll]]) ifTrue: [self disableFocus. ^ true]. "Inspect the last gesture" (aCRGesture normalizedChar = #inspectLastGesture) ifTrue: [self inspectLastGesture. ^ true]. ^ false.! ! !Utilities class methodsFor: 'recent method submissions'! revertLastMethodSubmission | changeRecords lastSubmission theClass theSelector | "If the most recent method submission was a method change, revert that change, and if it was a submission of a brand-new method, remove that method." RecentSubmissions isEmptyOrNil ifTrue: [^ Beeper beep]. lastSubmission _ RecentSubmissions last. theClass _ lastSubmission actualClass ifNil: [^ Beeper beep]. theSelector _ lastSubmission methodSymbol. changeRecords _ theClass changeRecordsAt: theSelector. changeRecords isEmptyOrNil ifTrue: [^ Beeper beep]. changeRecords size == 1 ifTrue: ["method has no prior version, so reverting in this case means removing" theClass removeSelector: theSelector] ifFalse: [changeRecords second fileIn]. "Utilities revertLastMethodSubmission"! ! !Utilities class methodsFor: 'graphical support'! grabScreenAndSaveOnDisk "Utilities grabScreenAndSaveOnDisk" | form fileName | form _ Form fromUser. form bits size = 0 ifTrue: [^ Beeper beep]. fileName _ FileDirectory default nextNameFor: 'Squeak' extension: 'gif'. Utilities informUser: 'Writing ' , fileName during: [GIFReadWriter putForm: form onFileNamed: fileName].! ! !IRCConnection methodsFor: 'naval mode'! ircMessageRecieved: aMessage | sender newLine | Beeper beep. sender _ aMessage sender ifNil: [ 'me' ]. (sender includes: $!!) ifTrue: [ sender _ sender copyFrom: 1 to: (sender indexOf: $!!)-1 ]. newLine _ (Text string: sender emphasis: (Array with: TextEmphasis bold)), ': ', aMessage text, String cr. self addToConsole: newLine.! ! !SketchEditorMorph methodsFor: 'start & finish'! undo: evt "revert to a previous state. " | temp poly | self flag: #bob. "what is undo in multihand environment?" undoBuffer ifNil: [^ Beeper beep]. "nothing to go back to" (poly _ self valueOfProperty: #polygon) ifNotNil: [poly delete. self setProperty: #polygon toValue: nil. ^ self]. temp _ paintingForm. paintingForm _ undoBuffer. undoBuffer _ temp. "can get back to what you had by undoing again" (self get: #paintingFormPen for: evt) setDestForm: paintingForm. formCanvas _ paintingForm getCanvas. "used for lines, ovals, etc." formCanvas _ formCanvas copyOrigin: self topLeft negated clipRect: (0@0 extent: bounds extent). self render: bounds.! ! !ChangeList class methodsFor: 'fileIn/Out'! browseChangesFile: fullName "Browse the selected file in fileIn format." fullName ifNotNil: [ChangeList browseStream: (FileStream oldFileNamed: fullName)] ifNil: [Beeper beep]! ! !ChangeList class methodsFor: 'public access'! browseRecentLogOnPath: fullName "figure out where the last snapshot or quit was, then browse the recent entries." fullName ifNotNil: [self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)] ifNil: [Beeper beep] ! ! !SystemWindow methodsFor: 'menu'! setWindowColor: incomingColor | existingColor aColor | incomingColor ifNil: [^ self]. "it happens" aColor _ incomingColor asNontranslucentColor. (aColor = ColorPickerMorph perniciousBorderColor or: [aColor = Color black]) ifTrue: [^ self]. existingColor _ self paneColorToUse. existingColor ifNil: [^ Beeper beep]. Preferences alternativeWindowLook ifFalse:[ (self allMorphs copyWithout: self) do:[:aMorph | ((aMorph isKindOf: PluggableButtonMorph) and: [aMorph offColor = existingColor]) ifTrue: [aMorph onColor: aColor darker offColor: aColor]. aMorph color = existingColor ifTrue: [aMorph color: aColor]]]. self paneColor: aColor. self setStripeColorsFrom: aColor. self changed.! takeOutOfWindow "Take the receiver's pane morph out the window and place it, naked, where once the window was" | aMorph | paneMorphs size == 1 ifFalse: [^ Beeper beep]. aMorph _ paneMorphs first. owner addMorphFront: aMorph. self delete! ! !ViewerEntry methodsFor: 'contents'! contents: c notifying: k "later, spruce this up so that it can accept input such as new method source" | info | (info _ self userSlotInformation) ifNotNil: [info documentation: c. ^ true]. Beeper beep. ^ false! ! !IRCDirectMessagesObserver methodsFor: 'as yet unclassified'! sendMessage: aString "send a message to the user we are talking to" | newLine | talkingTo ifNil: [ Beeper beep. ^self ]. connection privmsgFrom: nil to: talkingTo text: aString. newLine _ (Text string: 'me' attribute: TextEmphasis bold), ': ', aString, String cr. self addToChatText: newLine. ^true! ! !Viewer methodsFor: 'commands'! nextCostume | aList aPlayer itsCurrent anIndex newIndex | aList _ (aPlayer _ scriptedPlayer) availableCostumesForArrows. aList isEmptyOrNil ifTrue: [^ Beeper beep]. itsCurrent _ aPlayer costume renderedMorph. anIndex _ aList indexOf: itsCurrent ifAbsent: [nil]. newIndex _ anIndex ifNil: [1] ifNotNil: [anIndex + 1]. newIndex > aList size ifTrue: [newIndex _ 1]. aPlayer renderedCostume: (aList at: newIndex). self presenter ifNotNil: [self presenter updateViewer: self]! previousCostume | aList aPlayer itsCurrent anIndex newIndex | aList _ (aPlayer _ scriptedPlayer) availableCostumesForArrows. aList isEmptyOrNil ifTrue: [^ Beeper beep]. itsCurrent _ aPlayer costume renderedMorph. anIndex _ aList indexOf: itsCurrent ifAbsent: [nil]. newIndex _ anIndex ifNil: [aList size] ifNotNil: [anIndex - 1]. newIndex < 1 ifTrue: [newIndex _ aList size]. aPlayer renderedCostume: (aList at: newIndex). self presenter ifNotNil: [self presenter updateViewer: self]! ! !UniclassScript methodsFor: 'versions'! revertScriptVersionFrom: anEditor "Let user choose which prior tile version to revert to, and revert to it" | aMenu chosenStampAndTileList | formerScriptingTiles isEmptyOrNil ifTrue: [^ Beeper beep]. formerScriptingTiles size == 1 ifTrue: [chosenStampAndTileList _ formerScriptingTiles first] ifFalse: [aMenu _ SelectionMenu labelList: (formerScriptingTiles collect: [:e | e first]) selections: formerScriptingTiles. chosenStampAndTileList _ aMenu startUp]. chosenStampAndTileList ifNotNil: [anEditor reinsertSavedTiles: chosenStampAndTileList second. isTextuallyCoded _ false]! ! !ProjectNavigationMorph methodsFor: 'the actions'! publishStyle: aSymbol forgetURL: aBoolean withRename: renameBoolean | w saveOwner primaryServer rename | w _ self world ifNil: [^Beeper beep]. w setProperty: #SuperSwikiPublishOptions toValue: aSymbol. primaryServer _ w project primaryServerIfNil: [nil]. rename _ ((primaryServer notNil and: [primaryServer acceptsUploads]) not) or: [renameBoolean]. w setProperty: #SuperSwikiRename toValue: rename. saveOwner _ owner. self delete. w project storeOnServerShowProgressOn: self forgetURL: aBoolean | rename. saveOwner addMorphFront: self.! soundUpEvt: a morph: b soundSlider ifNotNil: [soundSlider delete]. soundSlider _ nil. Beeper beepPrimitive! nextProject Project advanceToNextProject. Beeper beep.! getNewerVersionIfAvailable (self world ifNil: [^Beeper beep]) project loadFromServer: true. ! previousProject Project returnToPreviousProject. CurrentProjectRefactoring exitCurrentProject. "go to parent if no previous" Beeper beep.! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut'! fileIntoNewChangeSet | p ff | (p _ self selectedPackage) ifNil: [^ Beeper beep]. ff _ StandardFileStream readOnlyFileNamed: p fullPackageName. ChangeSorter newChangesFromStream: ff named: p packageName! ! !FileContentsBrowser class methodsFor: 'instance creation'! browseFile: aFilename "Open a file contents browser on a file of the given name" aFilename ifNil: [^ Beeper beep]. self browseFiles: (Array with: aFilename)! ! !SystemNavigation methodsFor: 'browse'! browseClassVarRefs: aClass "Put up a menu offering all class variable names; if the user chooses one, open up a message-list browser on all methods that refer to the selected class variable" | lines labelStream vars allVars index owningClasses | lines _ OrderedCollection new. allVars _ OrderedCollection new. owningClasses _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). aClass withAllSuperclasses reverseDo: [:class | vars _ class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var. owningClasses add: class]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index _ (PopUpMenu labels: labelStream contents lines: lines) startUp. index = 0 ifTrue: [^ self]. self browseAllCallsOn: ((owningClasses at: index) classPool associationAt: (allVars at: index))! ! !CRRecognizer class methodsFor: 'class initialization'! loadCRDictionary: fullName | morph | Smalltalk isMorphic ifFalse: [Beeper beep. ^ self inform: 'Only available within morphic']. morph _ CRDictionary instanceBrowser newMorphWithFileNamed: fullName. (CRDictionary instanceBrowser isOpenInWorld: World) ifTrue: [morph delete] ifFalse: [morph openInWorld].! loadCRDisplayProperties: fullName | morph | Smalltalk isMorphic ifFalse: [Beeper beep. ^ self inform: 'Only available within morphic']. morph _ CRDisplayProperties instanceBrowser newMorphWithFileNamed: fullName. (CRDisplayProperties instanceBrowser isOpenInWorld: World) ifTrue: [morph delete] ifFalse: [morph openInWorld].! ! !FileList methodsFor: 'obsolete methods'! loadCRDictionary | morph | self error: 'should not be used keep for temporary documentation'. Smalltalk isMorphic ifFalse: [Beeper beep. ^ self inform: 'Only available within morphic']. morph _ CRDictionary instanceBrowser newMorphWithFileNamed: self fullName. (CRDictionary instanceBrowser isOpenInWorld: World) ifTrue: [morph delete] ifFalse: [morph openInWorld].! loadCRDisplayProperties | morph | self error: 'should not be used keep for temporary documentation'. Smalltalk isMorphic ifFalse: [Beeper beep. ^ self inform: 'Only available within morphic']. self flag: #ViolateNonReferenceToOtherClasses. "Genie related" morph _ CRDisplayProperties instanceBrowser newMorphWithFileNamed: self fullName. (CRDisplayProperties instanceBrowser isOpenInWorld: World) ifTrue: [morph delete] ifFalse: [morph openInWorld].! ! !FileList methodsFor: 'file list menu'! browseRecentChanges "Browse the selected file's recently logged changes" fileName ifNil: [Beeper beep] ifNotNil: [ChangeList browseRecentLogOn: (directory readOnlyFileNamed: fileName)]! ! !EToyProjectHistoryMorph methodsFor: 'as yet unclassified'! mouseUp: evt in: aMorph | tuple project url | (aMorph boundsInWorld containsPoint: evt cursorPoint) ifFalse: [^self]. tuple _ aMorph valueOfProperty: #projectParametersTuple ifAbsent: [^Beeper beep]. project _ tuple fourth first. (project notNil and: [project world notNil]) ifTrue: [self closeMyFlapIfAny. ^project enter]. url _ tuple third. url isEmptyOrNil ifTrue: [^Beeper beep]. self closeMyFlapIfAny. ProjectLoading thumbnailFromUrl: url. "--- newTuple _ { aProject name. aProject thumbnail. aProject url. WeakArray with: aProject. }. ---"! ! !CodeHolder methodsFor: 'commands'! copyUpOrCopyDown "Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing. Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established." | aClass aSelector allClasses implementors aMenu aColor | Smalltalk isMorphic ifFalse: [^ self inform: 'Sorry, for the moment you have to be in Morphic to use this feature.']. ((aClass _ self selectedClassOrMetaClass) isNil or: [(aSelector _ self selectedMessageName) == nil]) ifTrue: [^ Beeper beep]. allClasses _ Utilities hierarchyOfClassesSurrounding: aClass. implementors _ Utilities hierarchyOfImplementorsOf: aSelector forClass: aClass. aMenu _ MenuMorph new defaultTarget: self. aMenu title: aClass name, '.', aSelector, ' Choose where to insert a copy of this method (blue = current, black = available, red = other implementors'. allClasses do: [:cl | aColor _ cl == aClass ifTrue: [#blue] ifFalse: [(implementors includes: cl) ifTrue: [#red] ifFalse: [#black]]. (aColor == #red) ifFalse: [aMenu add: cl name selector: #spawnToClass: argument: cl] ifTrue: [aMenu add: cl name selector: #spawnToCollidingClass: argument: cl]. aMenu lastItem color: (Color colorFrom: aColor)]. aMenu popUpInWorld! removeClass "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | message className classToRemove result | self okToChange ifFalse: [^ false]. classToRemove _ self selectedClassOrMetaClass ifNil: [Beeper beep. ^ false]. classToRemove _ classToRemove theNonMetaClass. className _ classToRemove name. message _ 'Are you certain that you want to REMOVE the class ', className, ' from the system?'. (result _ self confirm: message) ifTrue: [classToRemove subclasses size > 0 ifTrue: [(self confirm: 'class has subclasses: ' , message) ifFalse: [^ false]]. classToRemove removeFromSystem. self changed: #classList. true]. ^ result! ! !ObjectPropertiesMorph methodsFor: 'panes'! borderPrototype: aBorderStyle help: helpString | selector proto | selector _ BorderedMorph new. selector borderWidth: 0. selector color: Color transparent. proto _ Morph new extent: 16@16. proto color: Color transparent. proto borderStyle: aBorderStyle. selector extent: proto extent + 4. selector addMorphCentered: proto. (myTarget canDrawBorder: aBorderStyle) ifTrue:[ selector setBalloonText: helpString. selector on: #mouseDown send: #toggleBorderStyle:with:from: to: self withValue: proto. (myTarget borderStyle species == aBorderStyle species and:[ myTarget borderStyle style == aBorderStyle style]) ifTrue:[selector borderWidth: 1]. ] ifFalse:[ selector setBalloonText: 'This border style cannot be used here'. selector on: #mouseDown send: #beep to: Beeper. selector addMorphCentered: ((Morph new) color: (Color black alpha: 0.5); extent: selector extent). ]. ^selector! ! !StringSocket class methodsFor: 'as yet unclassified'! showRatesSeen " StringSocket showRatesSeen " | answer | MaxRatesSeen ifNil: [^Beeper beep]. answer _ WriteStream on: String new. MaxRatesSeen keys asSortedCollection do: [ :key | answer nextPutAll: key printString,' ',((MaxRatesSeen at: key) // 10000) printString; cr ]. StringHolder new contents: answer contents; openLabel: 'send rates at 10 second intervals'.! ! !Project methodsFor: 'file in/out'! storeSomeSegment "Try all projects to see if any is ready to go out. Send at most three of them. Previous one has to wait for a garbage collection before it can go out." | cnt pList start proj gain | cnt _ 0. gain _ 0. pList _ Project allProjects. start _ pList size atRandom. "start in a random place" start to: pList size + start do: [:ii | proj _ pList atWrap: ii. proj storeSegment ifTrue: ["Yes, did send its morphs to the disk" gain _ gain + (proj projectParameters at: #segmentSize ifAbsent: [0]). "a guess" Beeper beep. (cnt _ cnt + 1) >= 2 ifTrue: [^ gain]]]. self beep. ^ gain! storeToMakeRoom "Write out enough projects to fulfill the space goals. Include the size of the project about to come in." | params memoryEnd goalFree cnt gain proj skip tried | GoalFreePercent ifNil: [GoalFreePercent _ 33]. GoalNotMoreThan ifNil: [GoalNotMoreThan _ 20000000]. params _ Smalltalk getVMParameters. memoryEnd _ params at: 3. " youngSpaceEnd _ params at: 2. free _ memoryEnd - youngSpaceEnd. " goalFree _ GoalFreePercent asFloat / 100.0 * memoryEnd. goalFree _ goalFree min: GoalNotMoreThan. world isInMemory ifFalse: ["enough room to bring it in" goalFree _ goalFree + (self projectParameters at: #segmentSize ifAbsent: [0])]. cnt _ 30. gain _ Smalltalk garbageCollectMost. "skip a random number of projects that are in memory" proj _ self. skip _ 6 atRandom. [proj _ proj nextInstance ifNil: [Project someInstance]. proj world isInMemory ifTrue: [skip _ skip - 1]. skip > 0] whileTrue. cnt _ 0. tried _ 0. [gain > goalFree] whileFalse: [ proj _ proj nextInstance ifNil: [Project someInstance]. proj storeSegment ifTrue: ["Yes, did send its morphs to the disk" gain _ gain + (proj projectParameters at: #segmentSize ifAbsent: [20000]). "a guess" Beeper beep. (cnt _ cnt + 1) > 5 ifTrue: [^ self]]. "put out 5 at most" (tried _ tried + 1) > 23 ifTrue: [^ self]]. "don't get stuck in a loop"! storeSegmentNoFile "For testing. Make an ImageSegment. Keep the outPointers in memory. Also useful if you want to enumerate the objects in the segment afterwards (allObjectsDo:)" | is str | (World == world) ifTrue: [^ self]. " inform: 'Can''t send the current world out'." world isInMemory ifFalse: [^ self]. "already done" world isMorph ifFalse: [ self projectParameters at: #isMVC put: true. ^ self]. "Only Morphic projects for now" world ifNil: [^ self]. world presenter ifNil: [^ self]. "Do this on project enter" World flapTabs do: [:ft | ft referent adaptToWorld: World]. "Hack to keep the Menu flap from pointing at my project" "Preferences setPreference: #useGlobalFlaps toValue: false." "Utilities globalFlapTabsIfAny do: [:aFlapTab | Utilities removeFlapTab: aFlapTab keepInList: false]. Utilities clobberFlapTabList. " "project world deleteAllFlapArtifacts." "self currentWorld deleteAllFlapArtifacts. " Utilities emptyScrapsBook. World checkCurrentHandForObjectToPaste2. is _ ImageSegment new copyFromRootsLocalFileFor: (Array with: world presenter with: world) "world, and all Players" sizeHint: 0. is segment size < 800 ifTrue: ["debugging" Transcript show: self name, ' did not get enough objects'; cr. ^ Beeper beep]. false ifTrue: [ str _ String streamContents: [:strm | strm nextPutAll: 'Only a tiny part of the project got into the segment'. strm nextPutAll: '\These are pointed to from the outside:' withCRs. is outPointers do: [:out | (out class == Presenter) | (out class == ScriptEditorMorph) ifTrue: [ strm cr. out printOn: strm. self systemNavigation browseAllObjectReferencesTo: out except: (Array with: is outPointers) ifNone: [:obj | ]]. (is arrayOfRoots includes: out class) ifTrue: [strm cr. out printOn: strm. self systemNavigation browseAllObjectReferencesTo: out except: (Array with: is outPointers) ifNone: [:obj | ]]]]. self inform: str. ^ is inspect]. is extract. "is instVarAt: 2 put: is segment clone." "different memory" ! ! !Project class methodsFor: 'squeaklet on server'! enterIfThereOrFind: aProjectName | newProject | newProject _ Project named: aProjectName. newProject ifNotNil: [^newProject enter]. ComplexProgressIndicator new targetMorph: nil; historyCategory: 'project loading'; withProgressDo: [ [ newProject _ CurrentProject fromMyServerLoad: aProjectName ] on: ProjectViewOpenNotification do: [ :ex | ex resume: false] "we probably don't want a project view morph in this case" ]. newProject ifNotNil: [^newProject enter]. Beeper beep.! ! !TextPropertiesMorph methodsFor: 'as yet unclassified'! changeStyle | aList reply style | aList _ StrikeFont familyNames remove: 'DefaultTextStyle' ifAbsent: []; asOrderedCollection. aList addFirst: 'DefaultTextStyle'. reply _ (SelectionMenu labelList: aList lines: #(1) selections: aList) startUp. reply ifNil: [^self]. (style _ TextStyle named: reply) ifNil: [Beeper beep. ^ true]. self applyToWholeText ifTrue: [self activeEditor selectAll]. self activeEditor changeStyleTo: style copy. self activeTextMorph updateFromParagraph.! ! !FileList2 methodsFor: 'as yet unclassified'! okHit ok _ true. currentDirectorySelected ifNil: [Beeper beep] ifNotNil: [modalView delete]! ! !StackMorph methodsFor: 'background'! addCardsFromClipboardDataForInstanceVariables: slotNames "Using the current background, paste data from the (textual) clipboard to create new records. No senders, but can be usefully called manually for selectively bringing in data in oddball format." | clip | (clip _ Clipboard clipboardText) isEmptyOrNil ifTrue: [^ Beeper beep]. self addCardsFromString: clip slotNames: slotNames! addCardsFromFile: fileStream "Using the current background, take tab delimited data from the file to create new records." | aString | (aString _ fileStream contentsOfEntireFile) isEmptyOrNil ifTrue: [^ Beeper beep]. self addCardsFromString: aString! addCardsFromAFile "Using the current background, create new cards by reading in data from a fileThe data are in each record are expected to be tab-delimited, and to occur in the same order as the instance variables of the current-background's cards " | aFileStream | (aFileStream _ FileList2 modalFileSelector) ifNil: [^ Beeper beep]. self addCardsFromString: aFileStream contentsOfEntireFile. aFileStream close! addCardsFromClipboardData "Using the current background, paste data from the (textual) clipboard to create new records. The data are in each record are expected to be tab-delimited, and to occur in the same order as the instance variables of the current-background's cards " | clip | (clip _ Clipboard clipboardText) isEmptyOrNil ifTrue: [^ Beeper beep]. self addCardsFromString: clip! ! !StackMorph methodsFor: 'card access'! deleteCard: aCard "Delete the current card from the stack." self privateCards size = 1 ifTrue: [^ Beeper beep]. (aCard == self currentCard) ifTrue: [^ self deleteCard]. self privateCards remove: aCard ifAbsent: []! deleteCard "Delete the current card from the stack" | aCard | aCard _ self currentCard. self privateCards size = 1 ifTrue: [^ Beeper beep]. (self confirm: 'Really delete this card and all of its data?') ifTrue: [self goToNextCardInStack. self privateCards remove: aCard].! goToFirstCardInBackground "Install the initial card in the current background as the current card in the stack" | kind | kind _ currentPage player class baseUniclass. self goToCard: (self privateCards detect: [:aCard | aCard isKindOf: kind] ifNone: [^ Beeper beep])! deleteAllCardsExceptThisOne "Delete all cards except the current one" self privateCards size <= 1 ifTrue: [^ Beeper beep]. (self confirm: 'Really delete ', self privateCards size asString, ' card(s) and all of their data?') ifTrue: [self privateCards: (OrderedCollection with: self currentCard)].! goToLastCardInBackground "Install the final card in the current background as the current card" | kind | kind _ currentPage player class baseUniclass. self goToCard: (self privateCards reversed detect: [:aCard | aCard isKindOf: kind] ifNone: [^ Beeper beep])! ! !Morph methodsFor: 'player commands'! playSoundNamed: soundName "Play the sound with the given name. Do nothing if this image lacks sound playing facilities." Preferences soundsEnabled ifTrue: [ Smalltalk at: #SampledSound ifPresent: [:sampledSound | sampledSound playSoundNamed: soundName asString]].! beep: soundName self playSoundNamed: soundName ! ! !Morph methodsFor: 'menus'! setArrowheads "Let the user edit the size of arrowheads for this object" | aParameter result | aParameter _ self renderedMorph valueOfProperty: #arrowSpec ifAbsent: [Preferences parameterAt: #arrowSpec ifAbsent: [5 @ 4]]. result _ Utilities obtainArrowheadFor: 'Head size for arrowheads: ' defaultValue: aParameter asString. result ifNotNil: [self renderedMorph setProperty: #arrowSpec toValue: result] ifNil: [Beeper beep]! printPSToFileNamed: aString "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag | fileName _ aString asFileName. fileName _ FillInTheBlank request: 'File name? (".eps" will be added to end)' initialAnswer: fileName. fileName size == 0 ifTrue: [^ Beeper beep]. (fileName endsWith: '.eps') ifFalse: [fileName _ fileName,'.eps']. rotateFlag _ ((PopUpMenu labels: 'portrait (tall) landscape (wide)') startUpWithCaption: 'Choose orientation...') = 2. (FileStream newFileNamed: fileName) nextPutAll: ( PostscriptCanvas defaultCanvasType morphAsPostscript: self rotated: rotateFlag ); close. ! ! !Morph methodsFor: 'card in a stack'! newCard "Create a new card for the receiver and return it" | aNewInstance | self isStackBackground ifFalse: [^ Beeper beep]. "bulletproof against deconstruction" aNewInstance _ self player class baseUniclass new. ^ aNewInstance! reassessBackgroundShape "A change has been made which may affect the instance structure of the Card uniclass that holds the instance state, which can also be thought of as the 'card data'." | takenNames uniqueName requestedName variableDocks docks sepDataMorphs sorted existing name1 name2 | "Caution: still to be done: the mechanism so that when a new instance variable is added, it gets initialized in all subinstances of the receiver's player, which are the cards of this shape. One needs to take into account here the instance variable names coming in; those that are unchanged should keep their values, but those that have newly arrived should obtain their default values from the morphs on whose behalf they are being maintained in the model" self isStackBackground ifFalse: [^ Beeper beep]. "bulletproof against deconstruction" Cursor wait showWhile: [variableDocks _ OrderedCollection new. "This will be stored in the uniclass's class-side inst var #variableDocks" takenNames _ OrderedCollection new. sepDataMorphs _ OrderedCollection new. "fields, holders of per-card data" self submorphs do: [:aMorph | aMorph renderedMorph holdsSeparateDataForEachInstance ifTrue: [sepDataMorphs add: aMorph renderedMorph] ifFalse: ["look for buried fields, inside a frame" aMorph renderedMorph isShared ifTrue: [ aMorph allMorphs do: [:mm | mm renderedMorph holdsSeparateDataForEachInstance ifTrue: [ sepDataMorphs add: mm renderedMorph]]]]]. sorted _ (SortedCollection new) sortBlock: [:a :b | (a valueOfProperty: #cardInstance) ~~ nil]. "puts existing ones first" sorted addAll: sepDataMorphs. sorted do: [:aMorph | docks _ aMorph variableDocks. "Each morph can request multiple variables. This complicates matters somewhat but creates a generality for Fabrk-like uses. Each spec is an instance of VariableDock, and it provides a point of departure for the negotiation between the PasteUp and its constitutent morphs" docks do: [:aVariableDock | uniqueName _ self player uniqueInstanceVariableNameLike: (requestedName _ aVariableDock variableName) excluding: takenNames. uniqueName ~= requestedName ifTrue: [aVariableDock variableName: uniqueName. aMorph noteNegotiatedName: uniqueName for: requestedName]. takenNames add: uniqueName]. variableDocks addAll: docks]. existing _ self player class instVarNames. variableDocks _ (variableDocks asSortedCollection: [:dock1 :dock2 | name1 _ dock1 variableName. name2 _ dock2 variableName. (existing indexOf: name1 ifAbsent: [0]) < (existing indexOf: name2 ifAbsent: [variableDocks size])]) asOrderedCollection. self player class setNewInstVarNames: (variableDocks collect: [:info | info variableName asString]). "NB: sets up accessors, and removes obsolete ones" self player class newVariableDocks: variableDocks]! insertAsStackBackground "I am not yet in a stack. Find a Stack that my reference point (center) overlaps, and insert me as a new background." | aMorph | self isStackBackground ifTrue: [^ Beeper beep]. "already in a stack. Must clear flags when remove." " self potentialEmbeddingTargets do: [:mm | No, force user to choose a stack. (mm respondsTo: #insertAsBackground:resize:) ifTrue: [ ^ mm insertAsBackground: self resize: false]]. " "None found, ask user" self inform: 'Please click on a Stack'. Sensor waitNoButton. aMorph _ self world chooseClickTarget. aMorph ifNil: [^ self]. (aMorph ownerThatIsA: StackMorph) insertAsBackground: self resize: false.! ! !Morph methodsFor: 'fileIn/out'! saveOnFile "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." | aFileName fileStream ok | aFileName _ ('my ', self class name) asFileName. "do better?" aFileName _ FillInTheBlank request: 'File name? (".morph" will be added to end)' initialAnswer: aFileName. aFileName size == 0 ifTrue: [^ Beeper beep]. self allMorphsDo: [:m | m prepareToBeSaved]. ok _ aFileName endsWith: '.morph'. "don't double them" ok _ ok | (aFileName endsWith: '.sp'). ok ifFalse: [aFileName _ aFileName,'.morph']. fileStream _ FileStream newFileNamed: aFileName. fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"! ! !Morph methodsFor: 'e-toy support'! definePath | points lastPoint aForm offset currentPoint dwell ownerPosition | points _ OrderedCollection new: 70. lastPoint _ nil. aForm _ self imageForm. offset _ aForm extent // 2. ownerPosition _ owner position. Cursor move show. Sensor waitButton. [Sensor anyButtonPressed and: [points size < 100]] whileTrue: [currentPoint _ Sensor cursorPoint. dwell _ 0. currentPoint = lastPoint ifTrue: [dwell _ dwell + 1. ((dwell \\ 1000) = 0) ifTrue: [Beeper beep]] ifFalse: [self position: (currentPoint - offset). self world displayWorld. (Delay forMilliseconds: 20) wait. points add: currentPoint. lastPoint _ currentPoint]]. points size > 1 ifFalse: [self inform: 'no path obtained'] ifTrue: [points size = 100 ifTrue: [self playSoundNamed: 'croak']. Transcript cr; show: 'path defined with ', points size printString, ' points'. self renderedMorph setProperty: #pathPoints toValue: (points collect: [:p | p - ownerPosition])]. Cursor normal show ! followPath | pathPoints offset | (pathPoints _ self renderedMorph valueOfProperty: #pathPoints) ifNil: [^ Beeper beep]. offset _ owner position - (self extent // 2). pathPoints do: [:aPoint | self position: aPoint + offset. self world displayWorld. (Delay forMilliseconds: 20) wait]! ! !Morph methodsFor: 'events-processing'! handleUnknownEvent: anEvent "An event of an unknown type was sent to the receiver. What shall we do?!!" Beeper beep. anEvent printString displayAt: 0@0. anEvent wasHandled: true.! ! !Morph methodsFor: 'meta-actions'! makeMultipleSiblings: evt "Make multiple siblings, first prompting the user for how many" | result | result _ FillInTheBlank request: 'how many siblings do you want?' initialAnswer: '2'. result isEmptyOrNil ifTrue: [^ self]. result first isDigit ifFalse: [^ Beeper beep]. self topRendererOrSelf makeSiblings: result asInteger.! ! !Morph methodsFor: 'undo'! undoMove: cmd redo: redo owner: formerOwner bounds: formerBounds predecessor: formerPredecessor "Handle undo and redo of move commands in morphic" self owner ifNil: [^ Beeper beep]. redo ifFalse: ["undo sets up the redo state first" cmd redoTarget: self selector: #undoMove:redo:owner:bounds:predecessor: arguments: {cmd. true. owner. bounds. (owner morphPreceding: self)}]. formerOwner ifNotNil: [formerPredecessor ifNil: [formerOwner addMorphFront: self] ifNotNil: [formerOwner addMorph: self after: formerPredecessor]]. self bounds: formerBounds. (self isKindOf: SystemWindow) ifTrue: [self activate]! ! !CanvasEncoder class methodsFor: 'as yet unclassified'! showStats " CanvasEncoder showStats " | answer bucket | SentTypesAndSizes ifNil: [^Beeper beep]. answer _ WriteStream on: String new. SentTypesAndSizes keys asSortedCollection do: [ :each | bucket _ SentTypesAndSizes at: each. answer nextPutAll: each printString,' ', bucket first printString,' ', bucket second asStringWithCommas,' ', (self nameForCode: each); cr. ]. StringHolder new contents: answer contents; openLabel: 'send/receive stats'. ! explainTestVars " CanvasEncoder explainTestVars " | answer total oneBillion data putter nReps | SimpleCounters ifNil: [^ Beeper beep]. total _ 0. oneBillion _ 1000 * 1000 * 1000. answer _ String streamContents: [ :strm | data _ SimpleCounters copy. putter _ [ :msg :index :nSec | nReps _ data at: index. total _ total + (nSec * nReps). strm nextPutAll: nReps asStringWithCommas,' * ',nSec printString,' ', (nSec * nReps / oneBillion roundTo: 0.01) printString,' secs for ',msg; cr ]. putter value: 'string socket' value: 1 value: 8000. putter value: 'rectangles' value: 2 value: 40000. putter value: 'points' value: 3 value: 18000. putter value: 'colors' value: 4 value: 8000. ]. StringHolder new contents: answer; openLabel: 'put integer times'. ! ! !EToyTextNodeWrapper methodsFor: 'as yet unclassified'! addSibling parentWrapper ifNil: [^Beeper beep]. parentWrapper addNewChildAfter: item.! delete parentWrapper ifNil: [^Beeper beep]. parentWrapper withoutListWrapper removeChild: item withoutListWrapper. ! ! !Preferences class methodsFor: 'misc'! setArrowheads "Let the user edit the size of arrowheads" | aParameter result | aParameter _ self parameterAt: #arrowSpec ifAbsent: [5 @ 4]. result _ Utilities obtainArrowheadFor: 'Default size of arrowheads on pen trails ' defaultValue: aParameter asString. result ifNotNil: [self setParameter: #arrowSpec to: result] ifNil: [Beeper beep]! ! !Preferences class methodsFor: 'preferences panel'! openPreferencesControlPanel "Open a preferences panel" "Preferences openPreferencesControlPanel" Smalltalk verifyMorphicAvailability ifFalse: [^ Beeper beep]. ^ self openFactoredPanel! ! !Preferences class methodsFor: 'personalization'! disableProgrammerFacilities "Warning: do not call this lightly!! It disables all access to menus, debuggers, halos. There is no guaranteed return from this, which is to say, you cannot necessarily reenable these things once they are disabled -- you can only use whatever the UI of the current project affords, and you cannot even snapshot -- you can only quit. You can completely reverse the work of this method by calling the dual Preferences method enableProgrammerFacilities, provided you have left yourself leeway to bring about a call to that method. To set up a system that will come up in such a state, you have to request the snapshot in the same breath as you disable the programmer facilities. To do this, put the following line into the 'do' menu and then evaluate it from that 'do' menu: Preferences disableProgrammerFacilities. You will be prompted for a new image name under which to save the resulting image." Beeper beep. (self confirm: 'CAUTION!!!! This is a drastic step!! Do you really want to do this?') ifFalse: [self beep. ^ self inform: 'whew!!']. self disable: #cmdDotEnabled. "No user-interrupt-into-debugger" self compileHardCodedPref: #cmdGesturesEnabled enable: false. "No halos, etc." self compileHardCodedPref: #cmdKeysInText enable: false. "No user commands invokable via cmd-key combos in text editor" self enable: #noviceMode. "No control-menu" self disable: #warnIfNoSourcesFile. self disable: #warnIfNoChangesFile. Smalltalk saveAs! ! !PasteUpMorph methodsFor: 'world menu'! findWindow: evt "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." | menu expanded collapsed nakedMorphs | menu _ MenuMorph new. expanded _ SystemWindow windowsIn: self satisfying: [:w | w isCollapsed not]. collapsed _ SystemWindow windowsIn: self satisfying: [:w | w isCollapsed]. nakedMorphs _ self submorphsSatisfying: [:m | ((m isKindOf: SystemWindow) not and: [(m isKindOf: StickySketchMorph) not]) and: [(m isFlapTab) not]]. (expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty)) ifTrue: [^ Beeper beep]. (expanded asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: [:w | menu add: w label target: w action: #activateAndForceLabelToShow. w model canDiscardEdits ifFalse: [menu lastItem color: Color red]]. (expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty)) ifFalse: [menu addLine]. (collapsed asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: [:w | menu add: w label target: w action: #collapseOrExpand. w model canDiscardEdits ifFalse: [menu lastItem color: Color red]]. nakedMorphs isEmpty ifFalse: [menu addLine]. (nakedMorphs asSortedCollection: [:w1 :w2 | w1 nameForFindWindowFeature caseInsensitiveLessOrEqual: w2 nameForFindWindowFeature]) do: [:w | menu add: w nameForFindWindowFeature target: w action: #comeToFrontAndAddHalo]. menu addTitle: 'find window'. menu popUpEvent: evt in: self.! ! !PasteUpMorph methodsFor: 'menu & halo'! saveOnFile "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." | aFileName fileStream ok | self flag: #bob0302. self isWorldMorph ifTrue: [^self project saveAs]. aFileName _ ('my ', self class name) asFileName. "do better?" aFileName _ FillInTheBlank request: 'File name? (".project" will be added to end)' initialAnswer: aFileName. aFileName size == 0 ifTrue: [^ Beeper beep]. self allMorphsDo: [:m | m prepareToBeSaved]. ok _ aFileName endsWith: '.project'. "don't double them" ok _ ok | (aFileName endsWith: '.sp'). ok ifFalse: [aFileName _ aFileName,'.project']. fileStream _ FileStream newFileNamed: aFileName. fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"! ! !PasteUpMorph methodsFor: 'dropping/grabbing'! acceptDroppingMorph: dropped event: evt "The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied" | mm tfm aMorph | aMorph _ self morphToDropFrom: dropped. self isWorldMorph ifTrue:["Add the given morph to this world and start stepping it if it wants to be." self addMorphFront: aMorph. (aMorph fullBounds intersects: self viewBox) ifFalse: [Beeper beep. aMorph position: self bounds center]] ifFalse:[super acceptDroppingMorph: aMorph event: evt]. aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]]. aMorph allMorphsDo: "Establish any penDown morphs in new world" [:m | m player ifNotNil: [m player getPenDown ifTrue: [((mm _ m player costume) notNil and: [(tfm _ mm owner transformFrom: self) notNil]) ifTrue: [self noteNewLocation: (tfm localPointToGlobal: mm referencePosition) forPlayer: m player]]]]. self isPartsBin ifTrue: [aMorph isPartsDonor: true. aMorph stopSteppingSelfAndSubmorphs. aMorph suspendEventHandler] ifFalse: [self world startSteppingSubmorphsOf: aMorph]. self presenter morph: aMorph droppedIntoPasteUpMorph: self. self showingListView ifTrue: [self sortSubmorphsBy: (self valueOfProperty: #sortOrder). self currentWorld abandonAllHalos]! ! !PasteUpMorph methodsFor: 'world state'! standardPlayerHit self playSoundNamed: 'peaks'. ! previousPage "backstop for smartprev-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the button was not embedded in a book, so we can do nothing useful" Beeper beep! nextPage "backstop for smart next-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the 'next' button was not embedded in a book, so we can do nothing useful" Beeper beep! ! !UserScript methodsFor: 'versions'! revertScriptVersionFrom: anEditor "Let user choose which prior tile version to revert to, and revert to it" | aMenu result | formerScriptEditors isEmptyOrNil ifTrue: [^ Beeper beep]. formerScriptEditors size == 1 ifTrue: [result _ formerScriptEditors first] ifFalse: [aMenu _ SelectionMenu labelList: (formerScriptEditors collect: [:e | e timeStamp]) selections: formerScriptEditors. result _ aMenu startUp]. result ifNotNil: [self revertScriptVersionFrom: anEditor installing: result]! ! !UpdatingBooleanStringMorph methodsFor: 'as yet unclassified'! mouseUp: evt (bounds containsPoint: evt cursorPoint) ifTrue: [self contentsClipped: (target perform: getSelector) not asString. self informTarget] ifFalse: [Beeper beep]. self color: Color black! ! !CRDisplayPropertiesMorph methodsFor: 'updating'! accept "This is triggered if a user accepts the settings. It writes the current settings to the model." "Instances without a name are treated as deleted" tempProperties name isEmptyOrNil ifTrue: [self modelIsActive ifTrue: [Beeper beep. self inform: 'Active instance needs a name'. ^ self] ifFalse: [(self confirm: 'Properties without a name are deleted. Ok to continue?') ifFalse: [^ self]]]. model set: tempProperties. self isActive ifTrue: [model activate]. model changed. self setOldValues.! ! !Inspector methodsFor: 'menu commands'! inspectElement | sel selSize countString count | "Create and schedule an Inspector on an element of the receiver's model's currently selected collection." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ((sel _ self selection) isKindOf: SequenceableCollection) ifFalse: [(sel isKindOf: MorphExtension) ifTrue: [^ sel inspectElement]. ^ sel inspect]. (selSize _ sel size) == 1 ifTrue: [^ sel first inspect]. selSize <= 15 ifTrue: [count _ (SelectionMenu selections: (1 to: selSize) asArray) startUpWithCaption: 'which element?'. count ifNil: [^ self] ifNotNil: [^ (sel at: count) inspect]]. countString _ FillInTheBlank request: 'Which element? (1 - ', selSize printString, ')' initialAnswer: '1'. countString isEmptyOrNil ifTrue: [^ self]. count _ Integer readFrom: (ReadStream on: countString). (count > 0 and: [count <= selSize]) ifTrue: [(sel at: count) inspect] ifFalse: [Beeper beep]! ! !EToyCommunicatorMorph class methodsFor: 'as yet unclassified'! playArrivalSound Preferences soundsEnabled ifTrue: [ SampledSound playSoundNamed: 'chirp'. ] ifFalse: [ Beeper beep ].! ! !BookMorph methodsFor: 'printing'! printPSToFile "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag | fileName _ ('MyBook') asFileName. fileName _ FillInTheBlank request: 'File name? (".ps" will be added to end)' initialAnswer: fileName. fileName size == 0 ifTrue: [^ Beeper beep]. (fileName endsWith: '.ps') ifFalse: [fileName _ fileName,'.ps']. rotateFlag _ ((PopUpMenu labels: 'portrait (tall) landscape (wide)') startUpWithCaption: 'Choose orientation...') = 2. (FileStream newFileNamed: fileName) nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close. ! ! !BookMorph methodsFor: 'menu'! makeUniformPageSize "Make all pages be of the same size as the current page." currentPage ifNil: [^ Beeper beep]. self resizePagesTo: currentPage extent. newPagePrototype ifNotNil: [newPagePrototype extent: currentPage extent]! ! !ReferenceMorph methodsFor: 'events'! tabSelected "Called when the receiver is hit. First, bulletproof against someone having taken the structure apart. My own action basically requires that my grand-owner be a TabbedPalette. Note that the 'opening' script concept has been left behind here." | gramps | (owner isKindOf: IndexTabs) ifFalse: [^ Beeper beep]. ((gramps _ owner owner) isKindOf: TabbedPalette) ifTrue: [gramps selectTab: self]! ! !ChangeSorter methodsFor: 'changeSet menu'! findCngSet "Search for a changeSet by name. Pop up a menu of all changeSets whose name contains the string entered by the user. If only one matches, then the pop-up menu is bypassed" | index pattern candidates nameList | self okToChange ifFalse: [^ self]. pattern _ FillInTheBlank request: 'ChangeSet name or fragment?'. pattern isEmpty ifTrue: [^ self]. nameList _ self changeSetList asSet. candidates _ AllChangeSets select: [:c | (nameList includes: c name) and: [c name includesSubstring: pattern caseSensitive: false]]. candidates size = 0 ifTrue: [^ Beeper beep]. candidates size = 1 ifTrue: [^ self showChangeSet: candidates first]. index _ (PopUpMenu labels: (candidates collect: [:each | each name]) asStringWithCr) startUp. index = 0 ifFalse: [self showChangeSet: (candidates at: index)]. ! rename "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" | newName | newName _ FillInTheBlank request: 'New name for this change set' initialAnswer: myChangeSet name. (newName = myChangeSet name or: [newName size == 0]) ifTrue: [^ Beeper beep]. (self class changeSetNamed: newName) ifNotNil: [^ Utilities inform: 'Sorry that name is already used']. myChangeSet name: newName. self update. self changed: #mainButtonName. self changed: #relabel.! ! !ChangeSorter methodsFor: 'message list'! moveMethodToOther "Place this change in the other changeSet and remove it from this side" | other cls sel | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ Beeper beep]. currentSelector ifNotNil: [other _ (parent other: self) changeSet. other == myChangeSet ifTrue: [^ self beep]. cls _ self selectedClassOrMetaClass. sel _ currentSelector asSymbol. other absorbMethod: sel class: cls from: myChangeSet. (parent other: self) showChangeSet: other. self forget "removes the method from this side"] ! ! !ChangeSorter methodsFor: 'class list'! copyClassToOther "Place these changes in the other changeSet also" | otherSorter otherChangeSet | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ Beeper beep]. currentClassName ifNil: [^ Beeper beep]. otherSorter _ parent other: self. otherChangeSet _ otherSorter changeSet. otherChangeSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet. otherSorter showChangeSet: otherChangeSet.! moveClassToOther "Place class changes in the other changeSet and remove them from this one" self checkThatSidesDiffer: [^ self]. (self okToChange and: [currentClassName notNil]) ifFalse: [^ Beeper beep]. self copyClassToOther. self forgetClass! ! !ChangeSorter class methodsFor: 'fileIn/Out'! fileIntoNewChangeSet: fullName "File in all of the contents of the currently selected file, if any, into a new change set." | fn ff | fullName ifNil: [^ Beeper beep]. ff _ FileStream readOnlyFileNamed: (fn _ GZipReadStream uncompressedFileName: fullName). ((FileDirectory extensionFor: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml]. self newChangesFromStream: ff named: (FileDirectory localNameFor: fn)! ! !GraphicalDictionaryMenu methodsFor: 'menu commands'! renameGraphicTo: newName | curr | curr _ entryNames at: currentIndex. (newName isEmptyOrNil or: [newName = curr]) ifTrue: [^ Beeper beep]. (baseDictionary includesKey: newName) ifTrue: [^ self inform: 'sorry that conflicts with the name of another entry in this dictionary']. baseDictionary at: newName put: (baseDictionary at: curr). baseDictionary removeKey: curr. self baseDictionary: baseDictionary. currentIndex _ entryNames indexOf: newName. self updateThumbnail! renameEntry | reply curr | reply _ FillInTheBlank request: 'New key? ' initialAnswer: (curr _ entryNames at: currentIndex) centerAt: self center. (reply isEmptyOrNil or: [reply = curr]) ifTrue: [^ Beeper beep]. (baseDictionary includesKey: reply) ifTrue: [^ self inform: 'sorry that conflicts with the name of another entry in this dictionary']. baseDictionary at: reply put: (baseDictionary at: curr). baseDictionary removeKey: curr. self baseDictionary: baseDictionary. self updateThumbnail! ! !Lexicon methodsFor: 'search'! setMethodListFromSearchString "Set the method list of the receiver based on matches from the search string" | fragment aList | self okToChange ifFalse: [^ self]. fragment _ currentQueryParameter. fragment _ fragment asString asLowercase withBlanksTrimmed. aList _ targetClass allSelectorsUnderstood select: [:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass]. fragment size > 0 ifTrue: [aList _ aList select: [:aSelector | aSelector includesSubstring: fragment caseSensitive: false]]. aList size == 0 ifTrue: [^ Beeper beep]. self initListFrom: aList asSortedArray highlighting: targetClass. messageListIndex _ messageListIndex min: messageList size. self changed: #messageList ! showSearchPane "Given that the receiver is showing the categories pane, replace that with a search pane. Though there is a residual UI for obtaining this variant, it is obscure and the integrity of the protocol-category-browser when there is no categories pane is not necessarily assured at the moment." | aPane | (aPane _ self categoriesPane) ifNil: [^ Beeper beep]. self containingWindow replacePane: aPane with: self newSearchPane. categoryList _ nil. self changed: #categoryList. self changed: #messageList! ! !Lexicon methodsFor: 'category list'! showCategoriesPane "Show the categories pane instead of the search pane" | aPane | (aPane _ self searchPane) ifNil: [^ Beeper beep]. self containingWindow replacePane: aPane with: self newCategoryPane. categoryList _ nil. self changed: #categoryList. self changed: #messageList! chooseCategory: aCategory "Choose the category of the given name, if there is one" self categoryListIndex: (categoryList indexOf: aCategory ifAbsent: [^ Beeper beep])! ! !Lexicon methodsFor: 'basic operation'! displaySelector: aSelector "Set aSelector to be the one whose source shows in the browser. If there is a category list, make it highlight a suitable category" | detectedItem messageIndex | self chooseCategory: (self categoryDefiningSelector: aSelector). detectedItem _ messageList detect: [:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ Beeper beep]. messageIndex _ messageList indexOf: detectedItem. self messageListIndex: messageIndex! ! !Lexicon methodsFor: 'within-tool queries'! seeAlso "Present a menu offering the selector of the currently selected message, as well as of all messages sent by it. If the chosen selector is showable in the current browser, show it here, minding unsubmitted edits however" self selectImplementedMessageAndEvaluate: [:aSelector | ((currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass) "i.e., is this aSelector available in this browser" and: [self okToChange]) ifTrue: [self displaySelector: aSelector] ifFalse: [Beeper beep.]]. "Initially I tried making this open an external implementors browser in this case, but later decided that the user model for this was unstable"! seeAlso: aSelector "If the requested selector is showable in the current browser, show it here, minding unsubmitted edits however" ((currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass) "i.e., is aSelector available in this browser" and: [self okToChange]) ifTrue: [self displaySelector: aSelector] ifFalse: [Beeper beep]! ! !Lexicon methodsFor: 'tiles'! acceptTiles | pp pq methodNode cls sel | "In complete violation of all the rules of pluggable panes, search dependents for my tiles, and tell them to accept." pp _ self dependents detect: [:pane | pane isKindOf: PluggableTileScriptorMorph] ifNone: [^ Beeper beep]. pq _ pp findA: TransformMorph. methodNode _ pq findA: SyntaxMorph. cls _ methodNode parsedInClass. sel _ cls compile: methodNode decompile classified: self selectedCategoryName notifying: nil. self noteAcceptanceOfCodeFor: sel. self reformulateListNoting: sel.! ! !Lexicon methodsFor: 'senders'! navigateToASender "Present the user with a list of senders of the currently-selected message, and navigate to the chosen one" | selectorSet chosen aSelector | aSelector _ self selectedMessageName. selectorSet _ Set new. (self systemNavigation allCallsOn: aSelector) do: [:anItem | selectorSet add: anItem methodSymbol]. selectorSet _ selectorSet select: [:sel | currentVocabulary includesSelector: sel forInstance: self targetObject ofClass: targetClass limitClass: limitClass]. selectorSet size == 0 ifTrue: [^ Beeper beep]. self okToChange ifFalse: [^ self]. chosen _ (SelectionMenu selections: selectorSet asSortedArray) startUp. chosen isEmptyOrNil ifFalse: [self displaySelector: chosen]! ! !TextMorphEditor methodsFor: 'attributes'! changeStyle "Let user change styles for the current text pane." | aList reply style theStyle menuList | self flag: #arNote. "Move this up once we get rid of MVC" aList _ StrikeFont familyNames remove: 'DefaultTextStyle' ifAbsent: []; asOrderedCollection. theStyle _ paragraph textStyle. menuList _ aList collect:[:styleName| "Hack!! use defaultFont for comparison - we have no name that we could use for compare and the style changes with alignment so they're no longer equal." (TextConstants at: styleName) defaultFont == theStyle defaultFont ifTrue:['', styleName] ifFalse:['',styleName]]. theStyle = TextStyle default ifTrue:[menuList addFirst: 'DefaultTextStyle'] ifFalse:[menuList addFirst: 'DefaultTextStyle']. aList addFirst: 'DefaultTextStyle'. reply _ (SelectionMenu labelList: menuList lines: #(1) selections: aList) startUp. reply ~~ nil ifTrue: [(style _ TextStyle named: reply) ifNil: [Beeper beep. ^ true]. paragraph textStyle: style copy. paragraph composeAll. self recomputeSelection. self mvcRedisplay]. ^ true! ! !CRDictionaryMorph methodsFor: 'updating'! acceptBasic "This method is called when a user accepts the basic section. It updates the model" "Dictionaries without name ar not accessible from the dictionary instance browser and they cannot have an exported name!!" self name isEmptyOrNil ifTrue: [self exportedName isEmptyOrNil ifTrue: [oldName isEmptyOrNil ifFalse: [(self confirm: 'Dictionary without a name are not accessible from withhin the dictionary tool and they cannot act as parents. Ok to continue?') ifFalse: [^ self]]] ifFalse: [Beeper beep. ^ self inform: 'Only named dictionaries can have an exported name']]. "Update the model" (model name: name asSymbol makeDistinct: false) ifFalse: [Beeper beep. self inform: 'Name already used. Please choose another name'. ^ self]. model exportedName: exportedName asSymbol. model parentsFromString: parents. parents _ model parentsAsString. parentCount _ model parentCount. model parameters setBasic: parameters. model changed: {self. #basic}. self setOldValues. ! ! !Player methodsFor: 'scripts-kernel'! pacifyScript: aSymbol "Make sure the script represented by the symbol doesn't do damage by lingering in related structures on the morph side" | aHandler aUserScript | aUserScript _ self class userScriptForPlayer: self selector: aSymbol. aUserScript ifNil: [self flag: #deferred. ^ Beeper beep]. "Maddeningly, without this line here the thing IS nil and the debugger is in a bad state (the above note dates from 1/12/99 ?!!" self class allInstancesDo: [:aPlayer | aPlayer actorState instantiatedUserScriptsDictionary removeKey: aSymbol ifAbsent: []. (aHandler _ aPlayer costume renderedMorph eventHandler) ifNotNil: [aHandler forgetDispatchesTo: aSymbol]]! renameScript: oldSelector "The user has asked to rename the script formerly known by oldSelector; obtain a new selector from the user, check it out, and if all is well, ascribe the new name as appropriate" | reply newSelector aUserScript | self flag: #deferred. "Relax the restriction below, before too long" aUserScript _ self class userScriptForPlayer: self selector: oldSelector. aUserScript okayToRename ifFalse: [self inform: 'Sorry, we do not permit you to rename classic-tiled scripts that are currently textually coded. Go back to tile scripts and try again. Humble apologies.'. ^ self]. reply _ FillInTheBlank request: 'Script Name' initialAnswer: oldSelector. reply size == 0 ifTrue: [^ self]. reply = oldSelector ifTrue:[^ Beeper beep]. newSelector _ self acceptableScriptNameFrom: reply forScriptCurrentlyNamed: oldSelector. Preferences universalTiles ifTrue: ["allow colons" (reply copyWithout: $:) = newSelector ifTrue: [newSelector _ reply asSymbol] ifFalse: [self inform: 'name will be modified']]. self renameScript: oldSelector newSelector: newSelector ! ! !Player methodsFor: 'misc'! adoptScriptsFrom "Let the user click on another object form which the receiver should obtain scripts and code" | aMorph | Sensor waitNoButton. aMorph _ ActiveWorld chooseClickTarget. aMorph ifNil: [^ Beeper beep]. (((aMorph isKindOf: SketchMorph) and: [aMorph player belongsToUniClass]) and: [self belongsToUniClass not]) ifTrue: [costume acquirePlayerSimilarTo: aMorph player] ifFalse: [self beep]! beep: soundName Preferences soundsEnabled ifTrue: [SampledSound playSoundNamed: soundName] ! ! !UpdatingStringMorph methodsFor: 'editing'! setFontStyle | aList reply style | aList _ (TextConstants select: [:anItem | anItem isKindOf: TextStyle]) keys asOrderedCollection. reply _ (SelectionMenu labelList: aList selections: aList) startUp. reply ~~ nil ifTrue: [(style _ TextStyle named: reply) ifNil: [Beeper beep. ^ true]. self font: (style defaultFont)]! ! !FillInTheBlankMorph methodsFor: 'event handling'! mouseDown: evt (self containsPoint: evt position) ifFalse:[^ Beeper beep]. "sent in response to outside modal click" evt hand grabMorph: self. "allow repositioning"! ! !PointerFinder methodsFor: 'morphic ui'! inspectObject pointerListIndex = 0 ifTrue: [^ Beeper beep]. (objectList at: pointerListIndex) inspect! ! !FatBitsPaint methodsFor: 'menu'! fileOut | fileName result | result _ StandardFileMenu newFile ifNil: [^Beeper beep]. fileName _ result directory fullNameFor: result name. Cursor normal showWhile: [self unmagnifiedForm writeOnFileNamed: fileName]! ! !CategoryViewer methodsFor: 'editing pane'! contents: c notifying: k "later, spruce this up so that it can accept input such as new method source" Beeper beep. ^ false! ! !CommandHistory methodsFor: 'called from the ui'! redoNextCommand "If there is a way to 'redo' (move FORWARD) in the undo/redo history tape, do it." | anIndex | lastCommand ifNil: [^ Beeper beep]. lastCommand phase == #undone ifFalse: [anIndex _ history indexOf: lastCommand. (anIndex < history size) ifTrue: [lastCommand _ history at: anIndex + 1] ifFalse: [^ Beeper beep]]. lastCommand redoCommand. lastCommand phase: #done ! undoLastCommand "Undo the last command, i.e. move backward in the recent-commands tape, if possible." | aPhase anIndex | lastCommand ifNil: [^ Beeper beep]. (aPhase _ lastCommand phase) == #done ifFalse: [aPhase == #undone ifTrue: [anIndex _ history indexOf: lastCommand. anIndex > 1 ifTrue: [lastCommand _ history at: anIndex - 1]]]. lastCommand undoCommand. lastCommand phase: #undone "Command undoLastCommand" ! undoOrRedoCommand "This gives a feature comparable to standard Mac undo/redo. If the undo/redo action taken was a simple do or a redo, then undo it. But if the last undo/redo action taken was an undo, then redo it." "Command undoOrRedoCommand" | aPhase | lastCommand ifNil: [^ Beeper beep]. (aPhase _ lastCommand phase) == #done ifTrue: [lastCommand undoCommand. lastCommand phase: #undone] ifFalse: [aPhase == #undone ifTrue: [lastCommand redoCommand. lastCommand phase: #done]]! undoTo "Not yet functional, and not yet sent. Allow the user to choose a point somewhere in the undo/redo tape, and undo his way to there. Applicable only if infiniteUndo is set. " | anIndex commandList aMenu reply | (anIndex _ self historyIndexOfLastCommand) == 0 ifTrue: [^ Beeper beep]. commandList _ history copyFrom: ((anIndex - 10) max: 1) to: ((anIndex + 10) min: history size). aMenu _ SelectionMenu labels: (commandList collect: [:cmd | cmd cmdWording truncateWithElipsisTo: 20]) selections: commandList. reply _ aMenu startUpWithCaption: 'undo or redo to...'. reply ifNotNil: [self inform: #deferred] "ActiveWorld commandHistory undoTo" ! ! !CautiousModel methodsFor: 'as yet unclassified'! okToChange Preferences cautionBeforeClosing ifFalse: [^ true]. Sensor leftShiftDown ifTrue: [^ true]. Beeper beep. ^ self confirm: 'Warning!! If you answer "yes" here, this window will disappear and its contents will be lost!! Do you really want to do that?' "CautiousModel new okToChange"! ! !NebraskaDebug class methodsFor: 'as yet unclassified'! showAndClearStats: queueName DEBUG ifNil: [^Beeper beep]. self showStats: queueName from: DEBUG. DEBUG _ nil.! showStats DEBUG ifNil: [^Beeper beep]. DEBUG explore.! showStats: queueName DEBUG ifNil: [^Beeper beep]. self showStats: queueName from: DEBUG. ! stopAndShowAll | prev | self halt. "not updated to new format" prev _ DEBUG. DEBUG _ nil. prev ifNil: [^Beeper beep]. prev keysAndValuesDo: [ :k :v | self showStats: k from: v ].! ! !EToyFridgeMorph methodsFor: 'as yet unclassified'! trulyFlashIndicator: aSymbol | state | state _ (self valueOfProperty: #fridgeFlashingState ifAbsent: [false]) not. self setProperty: #fridgeFlashingState toValue: state. self addMouseActionIndicatorsWidth: 15 color: (Color green alpha: (state ifTrue: [0.3] ifFalse: [0.7])). Beeper beep. "self world displayWorldSafely."! ! !ImageSegment methodsFor: 'read/write segment'! install "This operation retrieves the segment if necessary from file storage, installs it in memory, and replaces (using become:) all the root stubs with the reconstructed roots of the segment." | newRoots | state = #onFile ifTrue: [self readFromFile]. state = #onFileWithSymbols ifTrue: [self readFromFileWithSymbols. endMarker _ segment nextObject. "for enumeration of objects" endMarker == 0 ifTrue: [endMarker _ 'End' clone]]. (state = #active) | (state = #imported) ifFalse: [self errorWrongState]. newRoots _ self loadSegmentFrom: segment outPointers: outPointers. state = #imported ifTrue: ["just came in from exported file" arrayOfRoots _ newRoots] ifFalse: [ arrayOfRoots elementsForwardIdentityTo: newRoots]. state _ #inactive. Beeper beepPrimitive. "Don't use Squeak sound here. <- was the old comment of self beep." "I converted self beep as self beepPrimitive to avoid to use the sound system - sd 11/May/03" ! ! !SystemDictionary methodsFor: 'memory space'! lowSpaceWatcher "Wait until the low space semaphore is signalled, then take appropriate actions." | free | self garbageCollectMost <= self lowSpaceThreshold ifTrue: [ self garbageCollect <= self lowSpaceThreshold ifTrue: [ "free space must be above threshold before starting low space watcher" ^ Beeper beep]]. LowSpaceSemaphore _ Semaphore new. self primLowSpaceSemaphore: LowSpaceSemaphore. self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low space interrupts" LowSpaceSemaphore wait. "wait for a low space condition..." self primSignalAtBytesLeft: 0. "disable low space interrupts" self primLowSpaceSemaphore: nil. LowSpaceProcess _ nil. "Note: user now unprotected until the low space watcher is re-installed" self memoryHogs isEmpty ifFalse: [ free := self bytesLeft. self memoryHogs do: [ :hog | hog freeSomeSpace ]. self bytesLeft > free ifTrue: [ ^ self installLowSpaceWatcher ]]. Smalltalk isMorphic ifTrue: [CurrentProjectRefactoring currentInterruptName: 'Space is low'] ifFalse: [ScheduledControllers interruptName: 'Space is low']! ! !SystemDictionary methodsFor: 'deprecated'! beep self deprecatedExplanation: 'Use Beeper>>beep Beeper>>beepPrimitive instead of Smalltalk beep.'. Beeper beepPrimitive.! ! !SystemDictionary methodsFor: 'housekeeping'! removeAllLineFeeds "Smalltalk removeAllLineFeeds" "Scan all methods for source code with lineFeeds. Replaces all occurrences of by , noted by beep. Halts with a message if any other LFs are found." | oldCodeString n crlf cr newCodeString oldStamp oldCategory m | crlf _ String with: Character cr with: Character lf. cr _ String with: Character cr. Smalltalk forgetDoIts. 'Scanning sources for LineFeeds. This will take a few minutes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. m _ 0. self systemNavigation allBehaviorsDo: [:cls | cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. oldCodeString _ (cls sourceCodeAt: selector) asString. (oldCodeString indexOf: Character lf startingAt: 1) > 0 ifTrue: [Beeper beep. newCodeString _ oldCodeString copyReplaceAll: crlf with: cr asTokens: false. (newCodeString indexOf: Character lf startingAt: 1) > 0 ifTrue: [(self confirm: cls name , ' ' , (selector contractTo: 30) , ' has an isolated LineFeed (not part of CRLF). Shall I replace it?') ifFalse: [self halt]]. oldStamp _ Utilities timeStampForMethod: (cls compiledMethodAt: selector). oldCategory _ cls whichCategoryIncludesSelector: selector. cls compile: newCodeString classified: oldCategory withStamp: oldStamp notifying: nil. m _ m + 1]]]. ]. Transcript cr; show: m printString , ' methods stripped of LFs.'. ! ! !SystemDictionary methodsFor: 'miscellaneous'! verifyMorphicAvailability "If Morphic is available, return true; if not, put up an informer and return false" self hasMorphic ifFalse: [Beeper beep. self inform: 'Sorry, Morphic must be present to use this feature'. ^ false]. ^ true! ! !ScriptEditorMorph methodsFor: 'other'! toggleWhetherShowingTiles "Toggle between showing the method pane and showing the tiles pane" self showingMethodPane ifFalse: "currently showing tiles" [self showSourceInScriptor] ifTrue: "current showing textual source" [Preferences universalTiles ifTrue: [^ self revertToTileVersion]. self savedTileVersionsCount >= 1 ifTrue: [(self userScriptObject lastSourceString = (playerScripted class compiledMethodAt: scriptName) decompileString) ifFalse: [(self confirm: 'Caution -- this script was changed textually; if you revert to tiles at this point you will lose all the changes you may have made textually. Do you really want to do this?') ifFalse: [^ self]]. self revertToTileVersion] ifFalse: [Beeper beep]]! ! !TabMorph methodsFor: 'as yet unclassified'! tabSelected "Called when the receiver is hit. First, bulletproof against someone having taken the structure apart. My own action basically requires that my grand-owner be a TabbedPalette" self player ifNotNil: [self player runAllOpeningScripts ifTrue: [^ self]]. (owner isKindOf: IndexTabs) ifFalse: [^ Beeper beep]. (owner owner isKindOf: TabbedPalette) ifFalse: [^ Beeper beep]. owner owner selectTab: self! ! !ProjectViewMorph methodsFor: 'events'! enter "Enter my project." self world == self outermostWorldMorph ifFalse: [^Beeper beep]. "can't do this at the moment" project class == DiskProxy ifFalse: [ (project world notNil and: [project world isMorph and: [project world hasOwner: self outermostWorldMorph]]) ifTrue: [ ^1 beep "project is open in a window already" ]. ]. project class == DiskProxy ifTrue: ["When target is not in yet" self enterWhenNotPresent. "will bring it in" project class == DiskProxy ifTrue: [^self inform: 'Project not found']]. (owner isKindOf: SystemWindow) ifTrue: [project setViewSize: self extent]. self showMouseState: 3. project enter: false revert: false saveForRevert: false. ! ! "Change Set: KCP-0083-NewBeep Date: 17 May 2003 Author: stephane ducasse Introduce a better design for beep and deprecate beep, beep:, beepPrimitive, and playSoundNamed: from Object. English version by r.o keefe. Now we can invoke Beeper beep or Beeper beepPrimitive. However, the feedback can be changed by using my class-side method #setDefault: with an object understanding the message #play. Look at SampleSound class>>initialize, for example. "! !Beeper reorganize! ('play interface' play) ('beeping' beep beepPrimitive) ! !Object reorganize! ('Camp Smalltalk' sunitAddDependent: sunitChanged: sunitRemoveDependent:) ('accessing' addInstanceVarNamed:withValue: at: at:modify: at:put: basicAt: basicAt:put: basicSize bindWithTemp: doIfNotNil: ifNotNilDo: in: presenter readFromString: size yourself) ('associating' ->) ('binding' bindingOf:) ('casing' caseOf: caseOf:otherwise:) ('class membership' class inheritsFromAnyIn: isKindOf: isKindOf:orOf: isMemberOf: respondsTo: xxxClass) ('comparing' = closeTo: hash hashMappedBy: identityHashMappedBy: identityHashPrintString ~=) ('converting' adaptToFloat:andSend: adaptToFraction:andSend: adaptToInteger:andSend: as: asActionSequence asDraggableMorph asOrderedCollection asString complexContents mustBeBoolean printDirectlyToDisplay withoutListWrapper) ('copying' clone copy copyAddedStateFrom: copyFrom: copySameFrom: copyTwoLevel deepCopy initialDeepCopierSize shallowCopy veryDeepCopy veryDeepCopyWith: veryDeepCopyWithSiblingOf: veryDeepFixupWith: veryDeepInner: veryDeepPvtSibling:) ('creation' asMorph openAsMorph) ('dependents access' addDependent: breakDependents canDiscardEdits dependents evaluate:wheneverChangeIn: hasUnacceptedEdits myDependents myDependents: release removeDependent:) ('deprecated' beep beep: beepPrimitive playSoundNamed:) ('drag and drop' acceptDroppingMorph:event:inMorph: dragAnimationFor:transferMorph: dragPassengerFor:inMorph: dragTransferType dragTransferTypeForMorph: wantsDroppedMorph:event:inMorph:) ('error handling' assert: cannotInterpret: caseError confirm: confirm:orCancel: deprecated:explanation: deprecatedExplanation: doesNotUnderstand: error: externalCallFailed halt halt: handles: notify: notify:at: notifyWithLabel: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:) ('evaluating' value valueWithArguments:) ('events-accessing' actionForEvent: actionForEvent:ifAbsent: actionMap actionSequenceForEvent: actionsDo: createActionMap hasActionForEvent: setActionSequence:forEvent: updateableActionMap) ('events-registering' when:evaluate: when:send:to: when:send:to:with: when:send:to:withArguments:) ('events-removing' releaseActionMap removeAction:forEvent: removeActionsForEvent: removeActionsSatisfying:forEvent: removeActionsWithReceiver: removeActionsWithReceiver:forEvent:) ('events-triggering' triggerEvent: triggerEvent:ifNotHandled: triggerEvent:with: triggerEvent:with:ifNotHandled: triggerEvent:withArguments: triggerEvent:withArguments:ifNotHandled:) ('filter streaming' byteEncode: drawOnCanvas: elementSeparator encodePostscriptOn: flattenOnStream: fullDrawPostscriptOn: printOnStream: putOn: storeOnStream: writeOnFilterStream:) ('finalization' actAsExecutor executor finalize retryWithGC:until:) ('flagging' isThisEverCalled isThisEverCalled: logEntry logExecution logExit) ('logging' flag:log: flag:streamLog:) ('macpal' codeStrippedOut: contentsChanged currentEvent currentHand currentVocabulary currentWorld flash ifKindOf:thenDo: instanceVariableValues isUniversalTiles objectRepresented refusesToAcceptCode scriptPerformer slotInfo) ('message handling' perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass:) ('objects from disk' comeFullyUpOnReload: convertToCurrentVersion:refStream: indexIfCompact objectForDataStream: readDataFrom:size: saveOnFile storeDataOn:) ('parts bin' descriptionForPartsBin) ('printing' fullPrintString isLiteral longPrintOn: longPrintOn:limitedTo:indent: longPrintString nominallyUnsent: printOn: printString printStringLimitedTo: propertyList reportableSize storeOn: storeString stringForReadout stringRepresentation) ('scripting' adaptedToWorld: contentsGetz: defaultFloatPrecisionFor: evaluateUnloggedForSelf: methodInterfacesForCategory:inVocabulary:limitClass: methodInterfacesForInstanceVariablesCategoryIn: methodInterfacesForScriptsCategoryIn: selfWrittenAsIll selfWrittenAsIm selfWrittenAsMe selfWrittenAsMy selfWrittenAsThis) ('scripts-kernel' universalTilesForGetterOf: universalTilesForInterface:) ('system primitives' asOop becomeForward: className creationStamp instVarAt: instVarAt:put: instVarNamed: instVarNamed:put: oopString primitiveChangeClassTo: rootStubInImageSegment: someObject tryNamedPrimitive tryNamedPrimitive: tryNamedPrimitive:with: tryNamedPrimitive:with:with: tryNamedPrimitive:with:with:with: tryNamedPrimitive:with:with:with:with: tryNamedPrimitive:with:with:with:with:with: tryNamedPrimitive:with:with:with:with:with:with: tryNamedPrimitive:with:with:with:with:with:with:with: tryPrimitive:withArgs:) ('testing' basicType beViewed costumes haltIfNil haveFullProtocolBrowsed haveFullProtocolBrowsedShowingSelector: isBehavior isCollection isColor isFloat isForm isFraction isInteger isMessageSend isMorph isMorphicEvent isNumber isPoint isPseudoContext isStream isString isText isTransparent isVariableBinding isWebBrowser knownName name nameForViewer notNil openInstanceBrowserWithTiles renameTo: showDiffs stepAt:in: stepIn: stepTime stepTimeIn: vocabularyDemanded wantsDiffFeedback wantsSteps wantsStepsIn:) ('translation support' asIf:var: asIf:var:asValue: asIf:var:put: asOop: asSmallIntegerObj asValue: cCode: cCode:inSmalltalk: cCoerce:to: debugCode: export: inline: primitive:parameters:receiver: remapOop:in: returnTypeC: sharedCodeNamed:inCase: stAt: stAt:put: stSize static: suppressFailureGuards: var:declareC: var:type: var:type:array:) ('undo' capturedState commandHistory purgeAllCommands redoFromCapturedState: refineRedoTarget:selector:arguments:in: refineUndoTarget:selector:arguments:in: rememberCommand: rememberUndoableAction:named: undoFromCapturedState:) ('updating' changed changed: handledListVerification noteSelectionIndex:for: okToChange update: updateListsAndCodeIn: windowIsClosing) ('user interface' addModelItemsToWindowMenu: addModelMenuItemsTo:forMorph:hand: asExplorerString basicInspect browseHierarchy defaultBackgroundColor defaultLabelForInspector eToyStreamedRepresentationNotifying: explore fullScreenSize hasContentsInExplorer inform: initialExtent inspect inspectWithLabel: launchPartVia: launchPartVia:label: launchTileToRefer modelSleep modelWakeUp modelWakeUpIn: mouseUpBalk: newTileMorphRepresentative notYetImplemented windowActiveOnFirstClick windowReqNewLabel:) ('viewer' assureUniClass belongsToUniClass browseOwnClassSubProtocol categoriesForViewer: categoriesForVocabulary:limitClass: chooseNewNameForReference defaultLimitClassForVocabulary: defaultNameStemForInstances elementTypeFor:vocabulary: externalName graphicForViewerTab hasUserDefinedSlots infoFor:inViewer: initialTypeForSlotNamed: isPlayerLike methodInterfacesInPresentationOrderFrom:forCategory: newScriptorAround: offerViewerMenuFor:event: offerViewerMenuForEvt:morph: renameScript: tilePhrasesForCategory:inViewer: tilePhrasesForSelectorList:inViewer: tileToRefer uniqueInstanceVariableNameLike:excluding: uniqueNameForReference uniqueNameForReferenceFrom: uniqueNameForReferenceOrNil updateThresholdForGraphicInViewerTab usableMethodInterfacesIn:) ('world hacking' couldOpenInMorphic) ('private' errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: primitiveError: species storeAt:inTempFrame:) ! SampledSound initialize!