Squeak-dev September 2009

squeak-dev@lists.squeakfoundation.org

119 participants
370 discussions

Biology and computing and education for kids - interesting interview
by David T. Lewis 02 Sep '09

02 Sep '09

This is a fascinating interview (audio and text) that may be of interest to Squeakers: http://www.npr.org/templates/story/story.php?storyId=3 >From the NPR web page: "Will Wright, the mastermind behind the wildly successful computer game The Sims, ponders life, games and evolution with double Pulitzer-winning ant expert E. O. Wilson." They discuss art, science, education, biology, and more. Kindred spirits from seemingly different walks of life, both sharing insights that will resonate with many Squeakers. Dave

1 0

Re: [squeak-dev] The Trunk: Files-jcg.27.mcz
by Joshua Gargus 02 Sep '09

02 Sep '09

Does anyone know why several classes had their class variables alphabetized when I committed this version? I didn't do it explicitly. Is this the desired behavior? Cheers, Josh commits(a)source.squeak.org wrote: > Joshua Gargus uploaded a new version of Files to project The Trunk: > http://source.squeak.org/trunk/Files-jcg.27.mcz > > ==================== Summary ==================== > > Name: Files-jcg.27 > Author: jcg > Time: 1 September 2009, 12:56:15 pm > UUID: 1b72224b-d639-44fc-b7ef-3ea1d359f682 > Ancestors: Files-ar.26 > > RemoteString>>checkSum: relied on broken behavior in #mimeEncode: (see Collections-jcg.124). Fixed this assumption, and simplified the code at the same time. > > =============== Diff against Files-ar.26 =============== > > Item was changed: > ----- Method: RemoteString>>checkSum: (in category 'private') ----- > checkSum: aString > "Construct a checksum of the string. A three byte number represented as Base64 characters." > + | sum shift bytes | > + sum := aString size. > + shift := 0. > + aString do: [:char | > + (shift := shift + 7) > 16 ifTrue: [shift := shift - 17]. > + "shift by 7 to keep a change of adjacent chars from xoring to same value" > + sum := sum bitXor: (char asInteger bitShift: shift) > + ]. > + bytes := ByteArray new: 3. > + sum := sum + 16r10000000000. > + 1 to: 3 do: [:ind | bytes at: ind put: (sum digitAt: ind)]. > + ^bytes base64Encoded! > - > - | sum shift bytes ss bb | > - sum := aString size. > - shift := 0. > - aString do: [:char | > - (shift := shift + 7) > 16 ifTrue: [shift := shift - 17]. > - "shift by 7 to keep a change of adjacent chars from xoring to same value" > - sum := sum bitXor: (char asInteger bitShift: shift)]. > - bytes := ByteArray new: 3. > - sum := sum + 16r10000000000. > - 1 to: 3 do: [:ind | bytes at: ind put: (sum digitAt: ind)]. > - ss := ReadWriteStream on: (ByteArray new: 3). > - ss nextPutAll: bytes. > - bb := Base64MimeConverter mimeEncode: ss. > - ^ bb contents! > > Item was changed: > StandardFileStream subclass: #CrLfFileStream > instanceVariableNames: 'lineEndConvention' > + classVariableNames: 'Cr CrLf Lf LineEndDefault LineEndStrings LookAheadCount' > - classVariableNames: 'LookAheadCount LineEndDefault LineEndStrings CrLf Cr Lf' > poolDictionaries: '' > category: 'Files-Kernel'! > > !CrLfFileStream commentStamp: 'ls 11/10/2002 13:32' prior: 0! > I am the same as a regular file stream, except that when I am in text mode, I will automatically convert line endings between the underlying platform's convention, and Squeak's convention of carriage-return only. The goal is that Squeak text files can be treated as OS text files, and vice versa. > > In binary mode, I behave identically to a StandardFileStream. > > To enable CrLfFileStream as the default file stream class for an entire image, modify FileStream class concreteStream . > > > There are two caveats on programming with CrLfFileStream. > > First, the choice of text mode versus binary mode affects which characters are visible in Squeak, and no longer just affects whether those characters are returned as Character's or as Integer's. Thus the choice of mode needs to be made very carefully, and must be based on intent instead of convenience of representation. The methods asString, asByteArray, asCharacter, and asInteger can be used to convert between character and integer representations. (Arguably, file streams should accept either strings or characters in nextPut: and nextPutAll:, but that is not the case right now.) > > Second, arithmetic on positions no longer works, because one character that Squeak sees (carriage return) could map to two characters in the underlying file (carriage return plus line feed, on MS Windows and MS DOS). Comparison between positions still works. (This caveat could perhaps be fixed by maintaining a map between Squeak positions and positions in the underlying file, but it is complicated. Consider, for example, updates to the middle of the file. Also, consider that text files are rarely updated in the middle of the file, and that general random access to a text file is rarely very useful. If general random access with specific file counts is desired, then the file is starting to sound like a binary file instead of a text file.) > > ! > > Item was changed: > Object subclass: #FileDirectory > instanceVariableNames: 'pathName' > + classVariableNames: 'DefaultDirectory DirectoryClass StandardMIMEMappings' > - classVariableNames: 'StandardMIMEMappings DirectoryClass DefaultDirectory' > poolDictionaries: '' > category: 'Files-Directories'! > > !FileDirectory commentStamp: '<historical>' prior: 0! > A FileDirectory represents a folder or directory in the underlying platform's file system. It carries a fully-qualified path name for the directory it represents, and can enumerate the files and directories within that directory. > > A FileDirectory can be thought of as a Dictionary whose keys are the local names of files in that directory, and whose values are directory "entries". Each entry is an array of five items: > > <name> <creationTime> <modificationTime> <dirFlag> <fileSize> > > The times are given in seconds, and can be converted to a time and date via Time>dateAndTimeFromSeconds:. See the comment in lookupEntry:... which provides primitive access to this information. > ! > > Item was changed: > Object subclass: #RemoteString > instanceVariableNames: 'sourceFileNumber filePositionHi' > + classVariableNames: 'CurrentTextAttStructure CurrentTextAttVersion TextAttributeStructureVersions' > - classVariableNames: 'TextAttributeStructureVersions CurrentTextAttVersion CurrentTextAttStructure' > poolDictionaries: '' > category: 'Files-System'! > > !RemoteString commentStamp: '<historical>' prior: 0! > My instances provide an external file reference to a piece of text. It may be the sourceCode of a method, or the class comments of a class. > > The changes file or file-in file usually has a chunk that is just the source string of a method: > > max: aNumber > ^ self > aNumber ifTrue: [self] ifFalse: [aNumber]!! > > I can return either a String or a Text. Some a chunk is followed by a second chunk (beginning with ]style[) containing style information. The encoding is like this: > > max: aNumber > ^ self > aNumber ifTrue: [self] ifFalse: [aNumber]!! > ]style[(14 50 312)f1,f1b,f1LInteger +;i!! > > Allowed TextAttributes are TextFontChange, TextEmphasis, TextColor, TextDoIt, TextKern, TextLink, TextURL. TextFontReference and TextAnchor are not supported. > > See PositionableStream nextChunkText and RunArray class scanFrom:.! > > >

4 6

One-clicks for ESUG Aida tutorial
by Janko Mivsek 02 Sep '09

02 Sep '09

Hello everyone, For those who will attend Thursday's Aida tutorial on ESUG, there are preinstalled one-clicks and images with Aida and Scribo for Squeak, Pharo and VisualWorks, so I'd like to ask you to install them in advance. More on tutorial page: http://www.esug.org/Conferences/2009/Current+List+of+Talks/Aida+tutorial Thanks and apologies to others for spamming the lists with that note. Best regards Janko

3 2

Trunk Update Warning
by Andreas Raab 01 Sep '09

01 Sep '09

Folks - Just as a warning, something went wrong in the last round of updates I posted and I'm trying to understand what happened. I recommend you stay away from updating until I send an "all clear" message. Cheers, - Andreas

8 16

Date and Time parsing from String
by Tim Felgentreff 01 Sep '09

01 Sep '09

Hello Some time ago when I was parsing a lot of date+time strings from the web I came across quite a few who did not quite adhere to standards, so they would sometimes not get parsed properly. Currently the logic in parsing dates in "Date>>readFrom:" and times in "Time>>readFrom:" isnot used in "DateAndTime>>readFrom:", so I thought why not have the code in one place only and make it a bit more forgiving. So I added nanoSecond parsing to the Time>>readFrom: and ISO8601- format parsing to Date>>readFrom:. Now DateAndTime>>readFrom: just uses those two methods and only parses the optional offset at the end. The tests run through and I also added one test and changed another to test the "new" format allowed for Date and Time respectively. I'm not sure if something as this should be changed just like that, but I thought offering it can't hurt. -- Regards, Tim

4 3

Get rid of commits
by Keith Hodges 01 Sep '09

01 Sep '09

Please get rid of commits from squeak-dev we already have a mailing list for squeak source commits this is v annoying. Keith

2 1

The Trunk: MorphicExtras-Demo-edc.1.mcz
by commits＠source.squeak.org 01 Sep '09

01 Sep '09

Edgar J. De Cleene uploaded a new version of MorphicExtras-Demo to project The Trunk: http://source.squeak.org/trunk/MorphicExtras-Demo-edc.1.mcz ==================== Summary ==================== Name: MorphicExtras-Demo-edc.1 Author: edc Time: 1 September 2009, 11:50:25 am UUID: c33369bc-42c8-4ec8-a6eb-1f58c7b84559 Ancestors: initializeFlapsQuads lacks proper store of Scripting flap, should be same as EToys 4.0 until EToys was safe unload / load ==================== Snapshot ==================== SystemOrganization addCategory: #'MorphicExtras-Demo'! TransformationMorph subclass: #TransformationB2Morph instanceVariableNames: 'worldBoundsToShow useRegularWarpBlt' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! !TransformationB2Morph commentStamp: '<historical>' prior: 0! A transformation which: - is content to let someone else decide my bounds (I do not try to minimally enclose my submorphs) - can use bi-linear interpolation! ----- Method: TransformationB2Morph>>adjustAfter: (in category 'private') ----- adjustAfter: changeBlock "same as super, but without reference position stuff" changeBlock value. self chooseSmoothing. self layoutChanged. owner ifNotNil: [owner invalidRect: bounds] ! ----- Method: TransformationB2Morph>>computeBounds (in category 'geometry') ----- computeBounds "the transform bounds must remain under the control of the owner in this case"! ----- Method: TransformationB2Morph>>drawSubmorphsOn: (in category 'drawing') ----- drawSubmorphsOn: aCanvas | r1 fullG r2 actualCanvas newClip where deferredMorphs case | (self innerBounds intersects: aCanvas clipRect) ifFalse: [^self]. useRegularWarpBlt == true ifTrue: [ ^aCanvas transformBy: transform clippingTo: ((self innerBounds intersect: aCanvas clipRect) expandBy: 1) rounded during: [:myCanvas | submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] smoothing: smoothing ]. r1 := self innerBounds intersect: aCanvas clipRect. r1 area = 0 ifTrue: [^self]. fullG := (transform localBoundsToGlobal: self firstSubmorph fullBounds) rounded. r2 := r1 intersect: fullG. r2 area = 0 ifTrue: [^self]. newClip := (r2 expandBy: 1) rounded intersect: self innerBounds rounded. deferredMorphs := #(). aCanvas transform2By: transform "#transformBy: for pure WarpBlt" clippingTo: newClip during: [:myCanvas | self scale > 1.0 ifTrue: [ actualCanvas := MultiResolutionCanvas new initializeFrom: myCanvas. actualCanvas deferredMorphs: (deferredMorphs := OrderedCollection new). ] ifFalse: [ actualCanvas := myCanvas. ]. submorphs reverseDo:[:m | actualCanvas fullDrawMorph: m]. ] smoothing: smoothing. deferredMorphs do: [ :each | where := each bounds: each fullBounds in: self. case := 2. case = 1 ifTrue: [where := where origin rounded extent: where extent rounded]. case = 2 ifTrue: [where := where rounded]. each drawHighResolutionOn: aCanvas in: where. ]. ! ----- Method: TransformationB2Morph>>extent: (in category 'geometry') ----- extent: aPoint | newExtent | newExtent := aPoint truncated. bounds extent = newExtent ifTrue: [^self]. bounds := bounds topLeft extent: newExtent. "self recomputeExtent." ! ----- Method: TransformationB2Morph>>useRegularWarpBlt: (in category 'as yet unclassified') ----- useRegularWarpBlt: aBoolean useRegularWarpBlt := aBoolean! Morph subclass: #BouncingAtomsMorph instanceVariableNames: 'damageReported infectionHistory transmitInfection recentTemperatures temperature' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! !BouncingAtomsMorph commentStamp: '<historical>' prior: 0! This morph shows how an ideal gas simulation might work. When it gets step messages, it makes all its atom submorphs move along their velocity vectors, bouncing when they hit a wall. It also exercises the Morphic damage reporting and display architecture. Here are some things to try: 1. Resize this morph as the atoms bounce around. 2. In an inspector on this morph, evaluate "self addAtoms: 10." 3. Try setting quickRedraw to false in invalidRect:. This gives the default damage reporting and incremental redraw. Try it for 100 atoms. 4. In the drawOn: method of AtomMorph, change drawAsRect to true. 5. Create a HeaterCoolerMorph and embed it in the simulation. Extract it and use an inspector on it to evaluate "self velocityDelta: -5", then re-embed it. Note the effect on atoms passing over it. ! ----- Method: BouncingAtomsMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin ^ self partName: 'BouncingAtoms' categories: #('Demo') documentation: 'The original, intensively-optimized bouncing-atoms simulation by John Maloney'! ----- Method: BouncingAtomsMorph class>>initialize (in category 'class initialization') ----- initialize self registerInFlapsRegistry. ! ----- Method: BouncingAtomsMorph class>>registerInFlapsRegistry (in category 'class initialization') ----- registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(BouncingAtomsMorph new 'Bouncing Atoms' 'Atoms, mate') forFlapNamed: 'Widgets']! ----- Method: BouncingAtomsMorph class>>unload (in category 'class initialization') ----- unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ----- Method: BouncingAtomsMorph>>addAtoms: (in category 'other') ----- addAtoms: n "Add a bunch of new atoms." | a | n timesRepeat: [ a := AtomMorph new. a randomPositionIn: bounds maxVelocity: 10. self addMorph: a]. self stopStepping. ! ----- Method: BouncingAtomsMorph>>addCustomMenuItems:hand: (in category 'menu') ----- addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'startInfection' translated action: #startInfection. aCustomMenu add: 'set atom count' translated action: #setAtomCount. aCustomMenu add: 'show infection history' translated action: #showInfectionHistory:. ! ----- Method: BouncingAtomsMorph>>addMorphFront: (in category 'submorphs-add/remove') ----- addMorphFront: aMorph "Called by the 'embed' meta action. We want non-atoms to go to the back." "Note: A user would not be expected to write this method. However, a sufficiently advanced user (e.g, an e-toy author) might do something equivalent by overridding the drag-n-drop messages when they are implemented." (aMorph isMemberOf: AtomMorph) ifTrue: [super addMorphFront: aMorph] ifFalse: [super addMorphBack: aMorph].! ----- Method: BouncingAtomsMorph>>areasRemainingToFill: (in category 'drawing') ----- areasRemainingToFill: aRectangle color isTranslucent ifTrue: [^ Array with: aRectangle] ifFalse: [^ aRectangle areasOutside: self bounds]! ----- Method: BouncingAtomsMorph>>collisionPairs (in category 'other') ----- collisionPairs "Return a list of pairs of colliding atoms, which are assumed to be circles of known radius. This version uses the morph's positions--i.e. the top-left of their bounds rectangles--rather than their centers." | count sortedAtoms radius twoRadii radiiSquared collisions p1 continue j p2 distSquared m1 m2 | count := submorphs size. sortedAtoms := submorphs asSortedCollection: [:mt1 :mt2 | mt1 position x < mt2 position x]. radius := 8. twoRadii := 2 * radius. radiiSquared := radius squared * 2. collisions := OrderedCollection new. 1 to: count - 1 do: [:i | m1 := sortedAtoms at: i. p1 := m1 position. continue := (j := i + 1) <= count. [continue] whileTrue: [m2 := sortedAtoms at: j. p2 := m2 position. continue := p2 x - p1 x <= twoRadii ifTrue: [distSquared := (p1 x - p2 x) squared + (p1 y - p2 y) squared. distSquared < radiiSquared ifTrue: [collisions add: (Array with: m1 with: m2)]. (j := j + 1) <= count] ifFalse: [false]]]. ^collisions! ----- Method: BouncingAtomsMorph>>defaultColor (in category 'initialization') ----- defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 0.8! ----- Method: BouncingAtomsMorph>>drawOn: (in category 'drawing') ----- drawOn: aCanvas "Clear the damageReported flag when redrawn." super drawOn: aCanvas. damageReported := false.! ----- Method: BouncingAtomsMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" super initialize. "" damageReported := false. self extent: 400 @ 250. infectionHistory := OrderedCollection new. transmitInfection := false. self addAtoms: 30! ----- Method: BouncingAtomsMorph>>intoWorld: (in category 'initialization') ----- intoWorld: aWorld "Make sure report damage at least once" damageReported := false. super intoWorld: aWorld.! ----- Method: BouncingAtomsMorph>>invalidRect:from: (in category 'change reporting') ----- invalidRect: damageRect from: aMorph "Try setting 'quickRedraw' to true. This invalidates the entire morph, whose bounds typically subsume all it's submorphs. (However, this code checks that assumption and passes through any damage reports for out-of-bounds submorphs. Note that atoms with super-high velocities do occaisionally shoot through the walls!!) An additional optimization is to only submit only damage report per display cycle by using the damageReported flag, which is reset to false when the morph is drawn." | quickRedraw | quickRedraw := true. "false gives the original invalidRect: behavior" (quickRedraw and: [(bounds origin <= damageRect topLeft) and: [damageRect bottomRight <= bounds corner]]) ifTrue: [ "can use quick redraw if damage is within my bounds" damageReported ifFalse: [super invalidRect: bounds from: self]. "just report once" damageReported := true. ] ifFalse: [super invalidRect: damageRect from: aMorph]. "ordinary damage report"! ----- Method: BouncingAtomsMorph>>setAtomCount (in category 'menu') ----- setAtomCount | countString count | countString := UIManager default request: 'Number of atoms?' initialAnswer: self submorphCount printString. countString isEmpty ifTrue: [^ self]. count := Integer readFrom: (ReadStream on: countString). self removeAllMorphs. self addAtoms: count. ! ----- Method: BouncingAtomsMorph>>showInfectionHistory: (in category 'other') ----- showInfectionHistory: evt "Place a graph of the infection history in the world." | graph | infectionHistory isEmpty ifTrue: [^ self]. graph := GraphMorph new data: infectionHistory. graph extent: ((infectionHistory size + (2 * graph borderWidth) + 5)@(infectionHistory last max: 50)). evt hand attachMorph: graph. ! ----- Method: BouncingAtomsMorph>>startInfection (in category 'menu') ----- startInfection self submorphsDo: [:m | m infected: false]. self firstSubmorph infected: true. infectionHistory := OrderedCollection new: 500. transmitInfection := true. self startStepping. ! ----- Method: BouncingAtomsMorph>>step (in category 'stepping and presenter') ----- step "Bounce those atoms!!" | r bounces | super step. bounces := 0. r := bounds origin corner: (bounds corner - (8@8)). self submorphsDo: [ :m | (m isMemberOf: AtomMorph) ifTrue: [ (m bounceIn: r) ifTrue: [bounces := bounces + 1]]]. "compute a 'temperature' that is proportional to the number of bounces divided by the circumference of the enclosing rectangle" self updateTemperature: (10000.0 * bounces) / (r width + r height). transmitInfection ifTrue: [self transmitInfection]. ! ----- Method: BouncingAtomsMorph>>stepTime (in category 'testing') ----- stepTime "As fast as possible." ^ 0 ! ----- Method: BouncingAtomsMorph>>transmitInfection (in category 'other') ----- transmitInfection | infected count | self collisionPairs do: [:pair | infected := false. pair do: [:atom | atom infected ifTrue: [infected := true]]. infected ifTrue: [pair do: [:atom | atom infected: true]]]. count := 0. self submorphsDo: [:m | m infected ifTrue: [count := count + 1]]. infectionHistory addLast: count. count = submorphs size ifTrue: [ transmitInfection := false. self stopStepping]. ! ----- Method: BouncingAtomsMorph>>updateTemperature: (in category 'other') ----- updateTemperature: currentTemperature "Record the current temperature, which is taken to be the number of atoms that have bounced in the last cycle. To avoid too much jitter in the reading, the last several readings are averaged." recentTemperatures isNil ifTrue: [recentTemperatures := OrderedCollection new. 20 timesRepeat: [recentTemperatures add: 0]]. recentTemperatures removeLast. recentTemperatures addFirst: currentTemperature. temperature := recentTemperatures sum asFloat / recentTemperatures size! Morph subclass: #ScreeningMorph instanceVariableNames: 'screenForm displayMode passingColor passElseBlock' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! !ScreeningMorph commentStamp: '<historical>' prior: 0! ScreeningMorph uses its first submorph as a screen, and its second submorph as a source. It also wants you to choose (when showing only the screen) the passing color in the screen. It then makes up a 1-bit mask which clips the source, and displays transparently outside it.! ----- Method: ScreeningMorph>>addCustomMenuItems:hand: (in category 'menu') ----- addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. submorphs isEmpty ifTrue: [^ aCustomMenu add: '*Please add a source morph*' translated action: #itself]. submorphs size = 1 ifTrue: [^ aCustomMenu add: '*Please add a screen morph*' translated action: #itself]. submorphs size > 2 ifTrue: [^ aCustomMenu add: '*I have too many submorphs*' translated action: #itself]. aCustomMenu add: 'show screen only' translated action: #showScreenOnly. aCustomMenu add: 'show source only' translated action: #showSourceOnly. aCustomMenu add: 'show screen over source' translated action: #showScreenOverSource. aCustomMenu add: 'show source screened' translated action: #showScreened. aCustomMenu add: 'exchange source and screen' translated action: #exchange. displayMode == #showScreenOnly ifTrue: [aCustomMenu add: 'choose passing color' translated action: #choosePassingColor. aCustomMenu add: 'choose blocking color' translated action: #chooseBlockingColor]. ! ----- Method: ScreeningMorph>>addMorph: (in category 'submorphs-add/remove') ----- addMorph: aMorph | f | super addMorph: aMorph. submorphs size <= 2 ifTrue: [self bounds: submorphs last bounds]. submorphs size = 2 ifTrue: ["The screenMorph has just been added. Choose as the passingColor the center color of that morph" f := self screenMorph imageForm. passingColor := f colorAt: f boundingBox center. passElseBlock := true]! ----- Method: ScreeningMorph>>chooseBlockingColor (in category 'menu') ----- chooseBlockingColor passingColor := Color fromUser. passElseBlock := false. self layoutChanged! ----- Method: ScreeningMorph>>choosePassingColor (in category 'menu') ----- choosePassingColor passingColor := Color fromUser. passElseBlock := true. self layoutChanged! ----- Method: ScreeningMorph>>containsPoint: (in category 'geometry testing') ----- containsPoint: aPoint submorphs size = 2 ifFalse: [^ super containsPoint: aPoint]. ^ self screenMorph containsPoint: aPoint! ----- Method: ScreeningMorph>>exchange (in category 'menu') ----- exchange submorphs swap: 1 with: 2. self changed! ----- Method: ScreeningMorph>>fullDrawOn: (in category 'drawing') ----- fullDrawOn: aCanvas | mergeForm | submorphs isEmpty ifTrue: [^super fullDrawOn: aCanvas]. (aCanvas isVisible: self fullBounds) ifFalse: [^self]. (submorphs size = 1 or: [displayMode == #showScreenOnly]) ifTrue: [^aCanvas fullDrawMorph: self screenMorph]. displayMode == #showSourceOnly ifTrue: [^aCanvas fullDrawMorph: self sourceMorph]. displayMode == #showScreenOverSource ifTrue: [aCanvas fullDrawMorph: self sourceMorph. ^aCanvas fullDrawMorph: self screenMorph]. displayMode == #showScreened ifTrue: [aCanvas fullDrawMorph: self screenMorph. self flag: #fixCanvas. "There should be a more general way than this" mergeForm := self sourceMorph imageFormForRectangle: self screenMorph bounds. (BitBlt current toForm: mergeForm) copyForm: self screenForm to: 0 @ 0 rule: Form and colorMap: (Bitmap with: 0 with: 4294967295). aCanvas paintImage: mergeForm at: self screenMorph position]! ----- Method: ScreeningMorph>>initialize (in category 'initialization') ----- initialize super initialize. passingColor := Color black. passElseBlock := true. displayMode := #showScreened. self enableDragNDrop! ----- Method: ScreeningMorph>>layoutChanged (in category 'layout') ----- layoutChanged screenForm := nil. submorphs size >= 2 ifTrue: [self disableDragNDrop] ifFalse: [self enableDragNDrop]. submorphs size = 2 ifTrue: [bounds := ((self sourceMorph bounds merge: self screenMorph bounds) expandBy: 4)]. ^ super layoutChanged! ----- Method: ScreeningMorph>>passElseBlock: (in category 'accessing') ----- passElseBlock: aBool passElseBlock := aBool.! ----- Method: ScreeningMorph>>passingColor: (in category 'accessing') ----- passingColor: aColor passingColor := aColor.! ----- Method: ScreeningMorph>>removedMorph: (in category 'private') ----- removedMorph: aMorph submorphs size = 1 ifTrue: [self bounds: submorphs first bounds]. super removedMorph: aMorph.! ----- Method: ScreeningMorph>>screenForm (in category 'private') ----- screenForm | screenImage colorMap pickValue elseValue | screenForm ifNotNil: [^screenForm]. passElseBlock ifNil: [passElseBlock := true]. passingColor ifNil: [passingColor := Color black]. elseValue := passElseBlock ifTrue: [pickValue := 4294967295. 0] ifFalse: [pickValue := 0. 4294967295]. screenImage := self screenMorph imageFormForRectangle: self screenMorph bounds. colorMap := screenImage newColorMap atAllPut: elseValue. colorMap at: (passingColor indexInMap: colorMap) put: pickValue. screenForm := Form extent: screenImage extent. screenForm copyBits: screenForm boundingBox from: screenImage at: 0 @ 0 colorMap: colorMap. ^screenForm! ----- Method: ScreeningMorph>>screenMorph (in category 'private') ----- screenMorph ^submorphs first! ----- Method: ScreeningMorph>>showScreenOnly (in category 'menu') ----- showScreenOnly displayMode := #showScreenOnly. self changed! ----- Method: ScreeningMorph>>showScreenOverSource (in category 'menu') ----- showScreenOverSource displayMode := #showScreenOverSource. self changed! ----- Method: ScreeningMorph>>showScreened (in category 'menu') ----- showScreened displayMode := #showScreened. self changed! ----- Method: ScreeningMorph>>showSourceOnly (in category 'menu') ----- showSourceOnly displayMode := #showSourceOnly. self changed! ----- Method: ScreeningMorph>>sourceMorph (in category 'private') ----- sourceMorph ^submorphs second! ----- Method: ScreeningMorph>>wantsRecolorHandle (in category 'e-toy support') ----- wantsRecolorHandle "Answer whether the receiver would like a recolor handle to be put up for it. We'd want to disable this but for the moment that would cut off access to the button part of the properties sheet. So this remains a loose end." ^ false! RectangleMorph subclass: #AbstractMediaEventMorph instanceVariableNames: 'startTimeInScore endTimeInScore' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! !AbstractMediaEventMorph commentStamp: '<historical>' prior: 0! An abstract representation of media events to be placed in a PianoRollScoreMorph (or others as they are developed)! ----- Method: AbstractMediaEventMorph>>defaultBorderWidth (in category 'initialization') ----- defaultBorderWidth "answer the default border width for the receiver" ^ 1! ----- Method: AbstractMediaEventMorph>>defaultColor (in category 'initialization') ----- defaultColor "answer the default color/fill style for the receiver" ^ Color paleYellow! ----- Method: AbstractMediaEventMorph>>endTime (in category 'as yet unclassified') ----- endTime ^endTimeInScore ifNil: [startTimeInScore + 100]! ----- Method: AbstractMediaEventMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" super initialize. "" self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 2; rubberBandCells: true! AbstractMediaEventMorph subclass: #ZASMCameraMarkMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! ----- Method: ZASMCameraMarkMorph>>addCustomMenuItems:hand: (in category 'menu') ----- addCustomMenuItems: aMenu hand: aHandMorph "Add custom halo menu items" aMenu add: 'Go to this mark' translated target: self action: #gotoMark. aMenu add: 'Set transition' translated target: self action: #setTransition. super addCustomMenuItems: aMenu hand: aHandMorph ! ----- Method: ZASMCameraMarkMorph>>cameraController (in category 'as yet unclassified') ----- cameraController ^(self valueOfProperty: #cameraController)! ----- Method: ZASMCameraMarkMorph>>cameraPoint:cameraScale:controller: (in category 'as yet unclassified') ----- cameraPoint: aPoint cameraScale: aNumber controller: aController self setProperty: #cameraPoint toValue: aPoint. self setProperty: #cameraScale toValue: aNumber. self setProperty: #cameraController toValue: aController. self addMorph: ( StringMorph contents: aPoint printString,' ',(aNumber roundTo: 0.001) printString ) lock.! ----- Method: ZASMCameraMarkMorph>>cameraPoint:cameraScale:controller:page: (in category 'as yet unclassified') ----- cameraPoint: aPoint cameraScale: aNumber controller: aController page: aBookPage self setProperty: #cameraPoint toValue: aPoint. self setProperty: #cameraScale toValue: aNumber. self setProperty: #cameraController toValue: aController. self setProperty: #bookPage toValue: aBookPage. self addMorphBack: (ImageMorph new image: (aBookPage imageForm scaledToSize: 80@80)) lock. self setBalloonText: aPoint rounded printString,' ',(aNumber roundTo: 0.001) printString! ----- Method: ZASMCameraMarkMorph>>gotoMark (in category 'as yet unclassified') ----- gotoMark self cameraController turnToPage: (self valueOfProperty: #bookPage) position: (self valueOfProperty: #cameraPoint) scale: (self valueOfProperty: #cameraScale) transition: (self valueOfProperty: #transitionSpec). self setCameraValues. ! ----- Method: ZASMCameraMarkMorph>>handlesMouseDown: (in category 'event handling') ----- handlesMouseDown: evt ^true ! ----- Method: ZASMCameraMarkMorph>>justDroppedInto:event: (in category 'dropping/grabbing') ----- justDroppedInto: newOwner event: anEvent | holder | newOwner isWorldMorph ifTrue: [ holder := ZASMScriptMorph new. holder position: self position; setProperty: #cameraController toValue: self cameraController. self world addMorph: holder. holder addMorph: self. holder startStepping. ]. super justDroppedInto: newOwner event: anEvent! ----- Method: ZASMCameraMarkMorph>>menuPageVisualFor:event: (in category 'as yet unclassified') ----- menuPageVisualFor: target event: evt | tSpec menu subMenu directionChoices | tSpec := self valueOfProperty: #transitionSpec ifAbsent: [ (self valueOfProperty: #bookPage) valueOfProperty: #transitionSpec ifAbsent: [{ 'silence' . #none. #none}] ]. menu := (MenuMorph entitled: 'Choose an effect (it is now ' , tSpec second , ')') defaultTarget: self. TransitionMorph allEffects do: [:effect | directionChoices := TransitionMorph directionsForEffect: effect. directionChoices isEmpty ifTrue: [menu add: effect target: self selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (Array with: tSpec first with: effect with: #none))] ifFalse: [subMenu := MenuMorph new. directionChoices do: [:dir | subMenu add: dir target: self selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (Array with: tSpec first with: effect with: dir))]. menu add: effect subMenu: subMenu]]. menu popUpEvent: evt in: self world! ----- Method: ZASMCameraMarkMorph>>mouseDown: (in category 'event handling') ----- mouseDown: evt evt shiftPressed ifTrue: [^self]. self isSticky ifTrue: [^self]. evt hand grabMorph: self.! ----- Method: ZASMCameraMarkMorph>>mouseUp: (in category 'event handling') ----- mouseUp: evt evt shiftPressed ifTrue: [^self gotoMark]. ! ----- Method: ZASMCameraMarkMorph>>setCameraValues (in category 'as yet unclassified') ----- setCameraValues | camera | camera := self cameraController. "ick... since one may fail to fully take due to constraints, retry" 2 timesRepeat: [ camera cameraPoint: (self valueOfProperty: #cameraPoint). camera cameraScale: (self valueOfProperty: #cameraScale). ]. ! ----- Method: ZASMCameraMarkMorph>>setTransition (in category 'menu') ----- setTransition "Set the transition" ^ self setTransition: ActiveEvent! ----- Method: ZASMCameraMarkMorph>>setTransition: (in category 'as yet unclassified') ----- setTransition: evt | tSpec menu subMenu directionChoices | tSpec := self valueOfProperty: #transitionSpec ifAbsent: [ (self valueOfProperty: #bookPage) valueOfProperty: #transitionSpec ifAbsent: [{ 'silence' . #none. #none}] ]. menu := (MenuMorph entitled: 'Choose an effect (it is now ' , tSpec second , ')') defaultTarget: self. TransitionMorph allEffects do: [:effect | directionChoices := TransitionMorph directionsForEffect: effect. directionChoices isEmpty ifTrue: [menu add: effect target: self selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (Array with: tSpec first with: effect with: #none))] ifFalse: [subMenu := MenuMorph new. directionChoices do: [:dir | subMenu add: dir target: self selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (Array with: tSpec first with: effect with: dir))]. menu add: effect subMenu: subMenu]]. menu popUpEvent: evt in: self world! ----- Method: ZASMCameraMarkMorph>>veryDeepCopyWith: (in category 'copying') ----- veryDeepCopyWith: deepCopier | camera page | "Keep the same camera???" (camera := self cameraController) ifNotNil: [ (deepCopier references includesKey: camera) ifFalse: [ "not recorded, outside our tree, use same camera" deepCopier references at: camera put: camera]]. (page := self valueOfProperty: #bookPage) ifNotNil: [ (deepCopier references includesKey: page) ifFalse: [ deepCopier references at: page put: page]]. ^ super veryDeepCopyWith: deepCopier ! RectangleMorph subclass: #StickyPadMorph instanceVariableNames: '' classVariableNames: 'Colors LastColorIndex' poolDictionaries: '' category: 'MorphicExtras-Demo'! !StickyPadMorph commentStamp: 'sw 3/3/2004 13:31' prior: 0! A custom item for the Squeakland Supplies bin, as defined by Kim Rose and BJ Con.A parts bin will deliver up translucent, borderless Rectangles in a sequence of 6 colors. It offers some complication to the parts-bin protocols in two ways:: * The multi-colored icon seen in the parts bin is not a thumbnail of any actual instance, all of which are monochrome * New instances need to be given default names that are not the same as the name seen in the parts bin.! ----- Method: StickyPadMorph class>>defaultNameStemForInstances (in category 'parts bin') ----- defaultNameStemForInstances "Answer the default name stem to use" ^ 'tear off'! ----- Method: StickyPadMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin "Answer a description of the receiver for use in a parts bin" ^ self partName: 'Sticky Pad' categories: #('Graphics') documentation: 'A translucent, borderless rectangle of a standard size, delivered in a predictable sequence of pastel colors' sampleImageForm: (Form extent: 50@40 depth: 16 fromArray: #( 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461414680 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461414680 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1796762392 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461414680 1796762392 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1723098804 1723098804 1723098804 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521903284 1723098804 1723098804 1723096921 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1723098804 1723098804 1723098804 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521903284 1723098804 1723098804 1723096921 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1723098804 1723098804 1723098804 1599692633 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521903284 1723098804 1723098804 1723096921 1599692633 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322274512 1322274512 1389318863 1389318863 1389318863 1328697138 1328697138 1328697138 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322274512 1322275535 1389318863 1389318863 1389317938 1328697138 1328697138 1328702226 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322274512 1389318863 1389318863 1389318863 1328697138 1328697138 1328697138 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322275535 1389318863 1389318863 1389317938 1328697138 1328697138 1328702226 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1389318863 1389318863 1389318863 1328697138 1328697138 1328697138 1662149394 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322275535 1389318863 1389318863 1389317938 1328697138 1328697138 1328702226 1662149394 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1389318863 1389318863 1389318863 1460426508 1460426508 1460426508 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521903284 1389318863 1389318863 1389317938 1460426508 1460426508 1460429548 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1723098804 1389318863 1389318863 1328697138 1460426508 1460426508 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521903284 1723098804 1389318863 1389317938 1328697138 1460426508 1460429548 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1723098804 1723098804 1389318863 1328697138 1328697138 1460426508 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521903284 1723098804 1723098804 1389317938 1328697138 1328697138 1460429548 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1723098804 1723098804 1723098804 1328697138 1328697138 1328697138 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461414680 1723098804 1723098804 1723096921 1328697138 1328697138 1328702226 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1796762392 1723098804 1723098804 1599692633 1328697138 1328697138 1662149394 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461414680 1796762392 1723098804 1723096921 1599692633 1328697138 1328702226 1662149394 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1796762392 1796762392 1723098804 1599692633 1599692633 1328697138 1662149394 1662149394 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461414680 1796762392 1796762392 1723096921 1599692633 1599692633 1328702226 1662149394 1662149394 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741) offset: 0@0)! ----- Method: StickyPadMorph class>>initialize (in category 'class initialization') ----- initialize "Class initialization" LastColorIndex := 0. Colors := { TranslucentColor r: 0.0 g: 0.0 b: 0.839 alpha: 0.267. TranslucentColor r: 0.484 g: 1.0 b: 0.452 alpha: 0.706. TranslucentColor r: 1.0 g: 0.355 b: 0.71 alpha: 0.569. TranslucentColor r: 1.0 g: 1.0 b: 0.03 alpha: 0.561. TranslucentColor r: 0.484 g: 0.161 b: 1.0 alpha: 0.529. TranslucentColor r: 0.097 g: 0.097 b: 0.097 alpha: 0.192. }. self registerInFlapsRegistry. "StickyPadMorph initialize"! ----- Method: StickyPadMorph class>>launchPartVia:label: (in category 'parts bin') ----- launchPartVia: aSelector label: aString "Obtain a morph by sending aSelector to self, and attach it to the morphic hand. This provides a general protocol for parts bins. Overridden here so that all instances will be given the name, unlike the prevailing convention for other object types" | aMorph | aMorph := self perform: aSelector. aMorph setNameTo: self defaultNameStemForInstances. "i.e., circumvent uniqueness in this case" aMorph setProperty: #beFullyVisibleAfterDrop toValue: true. aMorph openInHand! ----- Method: StickyPadMorph class>>registerInFlapsRegistry (in category 'as yet unclassified') ----- registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(StickyPadMorph newStandAlone 'Sticky Pad' 'Each time you obtain one of these pastel, translucent, borderless rectangles, it will be a different color from the previous time.') forFlapNamed: 'Supplies'. cl registerQuad: #(StickyPadMorph newStandAlone 'Sticky Pad' 'Each time you obtain one of these pastel, translucent, borderless rectangles, it will be a different color from the previous time.') forFlapNamed: 'PlugIn Supplies'.]! ----- Method: StickyPadMorph>>canHaveFillStyles (in category 'visual properties') ----- canHaveFillStyles "Return true if the receiver can have general fill styles; not just colors. This method is for gradually converting old morphs." ^ true! ----- Method: StickyPadMorph>>initializeToStandAlone (in category 'parts bin') ----- initializeToStandAlone "Initialize the receiver to stand alone. Use the next color in the standard sequence." Colors ifNil: [self initialize]. LastColorIndex := LastColorIndex ifNil: [1] ifNotNil: [(LastColorIndex \\ Colors size) + 1]. super initializeToStandAlone. self assureExternalName. self color: (Colors at: LastColorIndex). self extent: 100@80. self borderWidth: 0 ! RectangleMorph subclass: #ZoomAndScrollControllerMorph instanceVariableNames: 'mouseDownPoint mouseMovePoint panAndTiltFactor zoomFactor target hasFocus currentKeyDown upDownCodes changeKeysState programmedMoves' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! ----- Method: ZoomAndScrollControllerMorph>>addCustomMenuItems:hand: (in category 'menus') ----- addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'change tilt and zoom keys' translated action: #changeKeys. aCustomMenu add: 'run an existing camera script' translated action: #runAScript. aCustomMenu add: 'edit an existing camera script' translated action: #editAScript. ! ----- Method: ZoomAndScrollControllerMorph>>cameraPoint (in category 'as yet unclassified') ----- cameraPoint target ifNil: [^0@0]. ^target cameraPoint ! ----- Method: ZoomAndScrollControllerMorph>>cameraPoint: (in category 'as yet unclassified') ----- cameraPoint: aPoint target ifNil: [^self]. target cameraPoint: aPoint! ----- Method: ZoomAndScrollControllerMorph>>cameraPointRounded (in category 'as yet unclassified') ----- cameraPointRounded ^self cameraPoint rounded! ----- Method: ZoomAndScrollControllerMorph>>cameraScale (in category 'as yet unclassified') ----- cameraScale target ifNil: [^1.0]. ^target scale ! ----- Method: ZoomAndScrollControllerMorph>>cameraScale: (in category 'as yet unclassified') ----- cameraScale: aNumber target ifNil: [^self]. target changeScaleTo: aNumber! ----- Method: ZoomAndScrollControllerMorph>>changeKeys (in category 'as yet unclassified') ----- changeKeys upDownCodes := Dictionary new. changeKeysState := #(up down in out). self changed.! ----- Method: ZoomAndScrollControllerMorph>>currentCameraVersion (in category 'as yet unclassified') ----- currentCameraVersion ^2! ----- Method: ZoomAndScrollControllerMorph>>deadZoneWidth (in category 'as yet unclassified') ----- deadZoneWidth ^8 ! ----- Method: ZoomAndScrollControllerMorph>>defaultBorderColor (in category 'initialization') ----- defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color transparent! ----- Method: ZoomAndScrollControllerMorph>>defaultBorderWidth (in category 'initialization') ----- defaultBorderWidth "answer the default border width for the receiver" ^ 0! ----- Method: ZoomAndScrollControllerMorph>>defaultColor (in category 'initialization') ----- defaultColor "answer the default color/fill style for the receiver" ^ Color lightBlue! ----- Method: ZoomAndScrollControllerMorph>>doProgrammedMoves (in category 'as yet unclassified') ----- doProgrammedMoves | thisMove startPoint endPoint startZoom endZoom newScale newPoint fractionLeft | programmedMoves isEmptyOrNil ifTrue: [ ^programmedMoves := nil ]. thisMove := programmedMoves first. thisMove at: #pauseTime ifPresent: [ :ignore | ^self]. fractionLeft := self fractionLeftInMove: thisMove. fractionLeft ifNil: [^programmedMoves := programmedMoves allButFirst]. startPoint := thisMove at: #startPoint ifAbsentPut: [self cameraPoint]. endPoint := thisMove at: #endPoint ifAbsentPut: [self cameraPoint]. startZoom := thisMove at: #startZoom ifAbsentPut: [self cameraScale]. endZoom := thisMove at: #endZoom ifAbsentPut: [self cameraScale]. newScale := endZoom - (endZoom - startZoom * fractionLeft). newPoint := (endPoint - (endPoint - startPoint * fractionLeft)) "rounded". target changeScaleTo: newScale. target cameraPoint: newPoint. fractionLeft <= 0 ifTrue: [^programmedMoves := programmedMoves allButFirst]. ! ----- Method: ZoomAndScrollControllerMorph>>drawOn: (in category 'drawing') ----- drawOn: aCanvas | dw bullsEye f | super drawOn: aCanvas. changeKeysState ifNotNil: [ f := ( StringMorph contents: 'Press the key to be used for "',changeKeysState first,'"' ) imageForm. aCanvas paintImage: f at: self center - (f extent // 2). ^self ]. mouseDownPoint ifNil: [^self]. dw := self deadZoneWidth. bullsEye := mouseDownPoint - (dw@dw//2) extent: dw@dw. aCanvas fillRectangle: (bullsEye left @ self top corner: bullsEye right @ self bottom) color: (Color red alpha: 0.3). aCanvas fillRectangle: (self left @ bullsEye top corner: self right @ bullsEye bottom) color: (Color red alpha: 0.3). aCanvas fillRectangle: bullsEye color: (Color red alpha: 0.4). ! ----- Method: ZoomAndScrollControllerMorph>>editAScript (in category 'as yet unclassified') ----- editAScript | d names reply s | d := self targetScriptDictionary. names := d keys asSortedCollection. reply := UIManager default chooseFrom: names values: names title: 'Script to edit?'. reply ifNil: [^ self]. (s := ZASMScriptMorph new) decompileScript: (d at: reply) named: reply for: self; fullBounds; align: s center with: self center; openInWorld ! ----- Method: ZoomAndScrollControllerMorph>>fractionLeftInMove: (in category 'as yet unclassified') ----- fractionLeftInMove: thisMove | steps stepsRemaining fractionLeft endTime startTime | (thisMove includesKey: #steps) ifTrue: [ steps := thisMove at: #steps ifAbsentPut: [1]. stepsRemaining := thisMove at: #stepsRemaining ifAbsentPut: [steps]. stepsRemaining < 1 ifTrue: [^nil]. stepsRemaining := stepsRemaining - 1. fractionLeft := stepsRemaining / steps. thisMove at: #stepsRemaining put: stepsRemaining. ] ifFalse: [ endTime := thisMove at: #endTime ifAbsent: [^nil]. startTime := thisMove at: #startTime ifAbsent: [^nil]. fractionLeft := (endTime - Time millisecondClockValue) / (endTime - startTime). ]. ^fractionLeft max: 0 ! ----- Method: ZoomAndScrollControllerMorph>>grabCameraPositionEvent:morph: (in category 'as yet unclassified') ----- grabCameraPositionEvent: anEvent morph: aMorph | mark | mark := ZASMCameraMarkMorph new. mark cameraPoint: self cameraPoint cameraScale: self cameraScale controller: self page: target. anEvent hand attachMorph: mark.! ----- Method: ZoomAndScrollControllerMorph>>handlesKeyboard: (in category 'event handling') ----- handlesKeyboard: evt ^true! ----- Method: ZoomAndScrollControllerMorph>>handlesMouseDown: (in category 'event handling') ----- handlesMouseDown: evt ^true! ----- Method: ZoomAndScrollControllerMorph>>handlesMouseOver: (in category 'event handling') ----- handlesMouseOver: evt ^true! ----- Method: ZoomAndScrollControllerMorph>>hasFocus (in category 'event handling') ----- hasFocus ^ hasFocus! ----- Method: ZoomAndScrollControllerMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" | displayer dataMorph | super initialize. "" hasFocus := true. currentKeyDown := Set new. upDownCodes := Dictionary new. upDownCodes at: 126 put: #up; at: 125 put: #down; at: 123 put: #out; at: 124 put: #in. "arrow keys on the mac" self extent: 40 @ 40; vResizing: #rigid; hResizing: #spaceFill; setBalloonText: 'Drag in here to zoom, tilt and pan the page above'. dataMorph := AlignmentMorph newColumn. dataMorph color: Color yellow; hResizing: #shrinkWrap; vResizing: #shrinkWrap. dataMorph on: #mouseDown send: #grabCameraPositionEvent:morph: to: self. displayer := UpdatingStringMorph new getSelector: #cameraPointRounded; target: self; growable: true; putSelector: nil. dataMorph addMorph: displayer lock. displayer := UpdatingStringMorph new getSelector: #cameraScale; target: self; growable: true; floatPrecision: 0.001; putSelector: nil. dataMorph addMorph: displayer lock. self addMorph: dataMorph! ----- Method: ZoomAndScrollControllerMorph>>keyDown: (in category 'event handling') ----- keyDown: anEvent changeKeysState ifNotNil: [ upDownCodes at: anEvent keyValue put: changeKeysState first. changeKeysState := changeKeysState allButFirst. changeKeysState isEmpty ifTrue: [changeKeysState := nil]. currentKeyDown := Set new. ^self changed ]. currentKeyDown add: anEvent keyValue. ! ----- Method: ZoomAndScrollControllerMorph>>keyStroke: (in category 'event handling') ----- keyStroke: anEvent ! ----- Method: ZoomAndScrollControllerMorph>>keyUp: (in category 'event handling') ----- keyUp: anEvent currentKeyDown remove: anEvent keyValue ifAbsent: [].! ----- Method: ZoomAndScrollControllerMorph>>mouseDown: (in category 'event handling') ----- mouseDown: evt mouseDownPoint := evt cursorPoint. self changed.! ----- Method: ZoomAndScrollControllerMorph>>mouseEnter: (in category 'event handling') ----- mouseEnter: evt evt hand newKeyboardFocus: self. currentKeyDown := Set new. hasFocus := true. ! ----- Method: ZoomAndScrollControllerMorph>>mouseLeave: (in category 'event handling') ----- mouseLeave: evt currentKeyDown := Set new. hasFocus := false. mouseMovePoint := mouseDownPoint := nil. ! ----- Method: ZoomAndScrollControllerMorph>>mouseMove: (in category 'event handling') ----- mouseMove: evt mouseMovePoint := evt cursorPoint. ! ----- Method: ZoomAndScrollControllerMorph>>mouseUp: (in category 'event handling') ----- mouseUp: evt mouseMovePoint := mouseDownPoint := nil. self changed.! ----- Method: ZoomAndScrollControllerMorph>>patchOldVersion1 (in category 'as yet unclassified') ----- patchOldVersion1 "hack.. use this as an opportunity to fix old versions" self allMorphsDo: [:m | ((m isKindOf: UpdatingStringMorph) and: [m getSelector == #cameraPoint]) ifTrue: [ m getSelector: #cameraPointRounded ]. ]. ! ----- Method: ZoomAndScrollControllerMorph>>pauseProgrammedMoves (in category 'as yet unclassified') ----- pauseProgrammedMoves programmedMoves isEmptyOrNil ifTrue: [^self]. programmedMoves first at: #pauseTime put: Time millisecondClockValue ! ----- Method: ZoomAndScrollControllerMorph>>resumeProgrammedMoves (in category 'as yet unclassified') ----- resumeProgrammedMoves | thisStep | programmedMoves isEmptyOrNil ifTrue: [^self]. (thisStep := programmedMoves first) at: #pauseTime ifPresent: [ :pauseTime | thisStep at: #startTime put: (thisStep at: #startTime) + Time millisecondClockValue - pauseTime. thisStep removeKey: #pauseTime ifAbsent: []. ]. ! ----- Method: ZoomAndScrollControllerMorph>>runAScript (in category 'as yet unclassified') ----- runAScript | d names reply | d := self targetScriptDictionary. names := d keys asSortedCollection. reply := UIManager default chooseFrom: names values: names title: 'Script to run?'. reply ifNil: [^ self]. programmedMoves := (d at: reply) veryDeepCopy.! ----- Method: ZoomAndScrollControllerMorph>>saveScript:as: (in category 'as yet unclassified') ----- saveScript: newScript as: scriptName self targetScriptDictionary at: scriptName put: newScript. ! ----- Method: ZoomAndScrollControllerMorph>>setProgrammedMoves: (in category 'as yet unclassified') ----- setProgrammedMoves: aCollection programmedMoves := aCollection ! ----- Method: ZoomAndScrollControllerMorph>>step (in category 'stepping and presenter') ----- step | delta halfDW action | (self valueOfProperty: #currentCameraVersion ifAbsent: [0]) = self currentCameraVersion ifFalse: [ self patchOldVersion1. self setProperty: #currentCameraVersion toValue: self currentCameraVersion. ]. super step. self doProgrammedMoves. (currentKeyDown ifNil: [#()]) do: [ :each | action := upDownCodes at: each ifAbsent: [#fugeddaboutit]. action == #in ifTrue: [ target scaleImageBy: -10. ]. action == #out ifTrue: [ target scaleImageBy: 10. ]. action == #up ifTrue: [ target tiltImageBy: -20. ]. action == #down ifTrue: [ target tiltImageBy: 20. ]. ]. mouseMovePoint ifNil: [^self]. mouseDownPoint ifNil: [^self]. target ifNil: [^self]. halfDW := self deadZoneWidth // 2. delta := mouseMovePoint - mouseDownPoint. delta x abs <= halfDW ifTrue: [delta := 0@delta y]. delta y abs <= halfDW ifTrue: [delta := delta x@0]. target panImageBy: delta x. ! ----- Method: ZoomAndScrollControllerMorph>>stepTime (in category 'testing') ----- stepTime ^10 ! ----- Method: ZoomAndScrollControllerMorph>>target: (in category 'as yet unclassified') ----- target: x target := x. ! ----- Method: ZoomAndScrollControllerMorph>>targetScriptDictionary (in category 'as yet unclassified') ----- targetScriptDictionary | scriptDict | target ifNil: [^Dictionary new]. ^target valueOfProperty: #namedCameraScripts ifAbsent: [ scriptDict := Dictionary new. target setProperty: #namedCameraScripts toValue: scriptDict. scriptDict ]. ! ----- Method: ZoomAndScrollControllerMorph>>turnToPage:position:scale:transition: (in category 'as yet unclassified') ----- turnToPage: page position: aPoint scale: aNumber transition: aSpec | myBook | target == page ifTrue: [^false]. page ifNil: [^false]. myBook := (self ownerThatIsA: StoryboardBookMorph) ifNil: [^ false]. 2 timesRepeat: [ page cameraPoint: aPoint; changeScaleTo: aNumber ]. BookMorph turnOffSoundWhile: [ myBook goToPageMorph: page transitionSpec: aSpec. ]. ^true! StringMorph subclass: #ClockMorph instanceVariableNames: 'showSeconds show24hr' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! ----- Method: ClockMorph class>>authoringPrototype (in category 'scripting') ----- authoringPrototype ^ super authoringPrototype contents: Time now printString! ----- Method: ClockMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin ^ self partName: 'Clock' categories: #('Useful') documentation: 'A digital clock'! ----- Method: ClockMorph class>>initialize (in category 'class initialization') ----- initialize self registerInFlapsRegistry. ! ----- Method: ClockMorph class>>registerInFlapsRegistry (in category 'class initialization') ----- registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(ClockMorph authoringPrototype 'Clock' 'A simple digital clock') forFlapNamed: 'Supplies'. cl registerQuad: #(ClockMorph authoringPrototype 'Clock' 'A simple digital clock') forFlapNamed: 'PlugIn Supplies'.]! ----- Method: ClockMorph class>>unload (in category 'class initialization') ----- unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ----- Method: ClockMorph>>addCustomMenuItems:hand: (in category 'menu') ----- addCustomMenuItems: aCustomMenu hand: aHandMorph "Note minor loose end here -- if the menu is persistent, then the wording will be wrong half the time" | item | super addCustomMenuItems: aCustomMenu hand: aHandMorph. item := showSeconds == true ifTrue: ['stop showing seconds'] ifFalse: ['start showing seconds']. aCustomMenu add: item translated target: self action: #toggleShowingSeconds. item := show24hr == true ifTrue: ['display Am/Pm'] ifFalse: ['display 24 hour']. aCustomMenu add: item translated target: self action: #toggleShowing24hr. ! ----- Method: ClockMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" super initialize. "" showSeconds := true. show24hr := false. self step! ----- Method: ClockMorph>>initializeToStandAlone (in category 'parts bin') ----- initializeToStandAlone super initializeToStandAlone. showSeconds := true. self step! ----- Method: ClockMorph>>show24hr: (in category '24hr') ----- show24hr: aBoolean show24hr := aBoolean! ----- Method: ClockMorph>>showSeconds: (in category 'seconds') ----- showSeconds: aBoolean showSeconds := aBoolean! ----- Method: ClockMorph>>step (in category 'stepping and presenter') ----- step | time | super step. time := String streamContents: [:aStrm | Time now print24: (show24hr == true) showSeconds: (showSeconds == true) on: aStrm]. self contents: time ! ----- Method: ClockMorph>>stepTime (in category 'testing') ----- stepTime "Answer the desired time between steps in milliseconds." ^ 1000! ----- Method: ClockMorph>>toggleShowing24hr (in category '24hr') ----- toggleShowing24hr show24hr := (show24hr == true) not ! ----- Method: ClockMorph>>toggleShowingSeconds (in category 'seconds') ----- toggleShowingSeconds showSeconds := (showSeconds == true) not ! StringMorph subclass: #FrameRateMorph instanceVariableNames: 'lastDisplayTime framesSinceLastDisplay' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! ----- Method: FrameRateMorph class>>authoringPrototype (in category 'scripting') ----- authoringPrototype "Answer a morph representing a prototypical instance of the receiver" | aMorph | aMorph := self new. aMorph color: Color blue. aMorph step. ^ aMorph! ----- Method: FrameRateMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin ^ self partName: 'FrameRate' categories: #('Useful') documentation: 'A readout that allows you to monitor the frame rate of your system'! ----- Method: FrameRateMorph class>>initialize (in category 'class initialization') ----- initialize self registerInFlapsRegistry. ! ----- Method: FrameRateMorph class>>registerInFlapsRegistry (in category 'class initialization') ----- registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(FrameRateMorph authoringPrototype 'Frame Rate' 'An indicator of how fast your system is running') forFlapNamed: 'Widgets']! ----- Method: FrameRateMorph class>>unload (in category 'class initialization') ----- unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ----- Method: FrameRateMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" super initialize. "" lastDisplayTime := 0. framesSinceLastDisplay := 0! ----- Method: FrameRateMorph>>initializeToStandAlone (in category 'parts bin') ----- initializeToStandAlone "Initialize the receiver as a stand-alone entity" super initializeToStandAlone. self color: Color blue. self step! ----- Method: FrameRateMorph>>step (in category 'stepping and presenter') ----- step "Compute and display (every half second or so) the current framerate" | now mSecs mSecsPerFrame framesPerSec newContents | framesSinceLastDisplay := framesSinceLastDisplay + 1. now := Time millisecondClockValue. mSecs := now - lastDisplayTime. (mSecs > 500 or: [mSecs < 0 "clock wrap-around"]) ifTrue: [mSecsPerFrame := mSecs // framesSinceLastDisplay. framesPerSec := (framesSinceLastDisplay * 1000) // mSecs. newContents := mSecsPerFrame printString, ' mSecs (', framesPerSec printString, ' frame', (framesPerSec == 1 ifTrue: [''] ifFalse: ['s']), '/sec)'. self contents: newContents. lastDisplayTime := now. framesSinceLastDisplay := 0]! ----- Method: FrameRateMorph>>stepTime (in category 'testing') ----- stepTime "Answer the desired time between steps in milliseconds." ^ 0 ! StringMorph subclass: #ZASMStepsMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! ----- Method: ZASMStepsMorph>>getStepCount (in category 'as yet unclassified') ----- getStepCount ^[self contents asNumber] ifError: [ :a :b | 10] ! ----- Method: ZASMStepsMorph>>handlesMouseDown: (in category 'event handling') ----- handlesMouseDown: evt ^ true! ----- Method: ZASMStepsMorph>>mouseDown: (in category 'event handling') ----- mouseDown: evt "If the shift key is pressed, make this string the keyboard input focus." self launchMiniEditor: evt ! ----- Method: ZASMStepsMorph>>setStepCount: (in category 'as yet unclassified') ----- setStepCount: n self contents: n printString. ! BorderedMorph subclass: #MagnifierMorph instanceVariableNames: 'magnification trackPointer srcExtent showPointer' classVariableNames: 'RecursionLock' poolDictionaries: '' category: 'MorphicExtras-Demo'! !MagnifierMorph commentStamp: '<historical>' prior: 0! MagnifierMorph instances are magnifying lenses that magnify the morphs below them (if grabbed or if trackPointer is false) or the area around the mouse pointer. Instance variables: magnification <Number> The magnification to use. If non-integer, smooths the magnified form. trackPointer <Boolean> If set, magnifies the area around the Hand. If not, magnfies the area underneath the magnifier center. showPointer <Boolean> If set, display a small reversed rectangle in the center of the lens. Also enables the display of Morphs in the Hand itself. srcExtent <Rectangle> The extent of the source rectangle. Class variables: RecursionLock <MagnifierMorph|nil> Used to avoid infinite recursion when getting the source patch to display.! ----- Method: MagnifierMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin ^ self partName: 'Magnifier' categories: #('Useful') documentation: 'A magnifying glass'! ----- Method: MagnifierMorph class>>initialize (in category 'class initialization') ----- initialize self registerInFlapsRegistry.! ----- Method: MagnifierMorph class>>newRound (in category 'instance creation') ----- newRound "Answer a round Magnifier" | aMagnifier sm | aMagnifier := self new. sm := ScreeningMorph new position: aMagnifier position. sm addMorph: aMagnifier. sm addMorph: (EllipseMorph newBounds: aMagnifier bounds). sm setNameTo: 'Magnifier'. ^ sm! ----- Method: MagnifierMorph class>>newShowingPointer (in category 'instance creation') ----- newShowingPointer "Answer a Magnifier that also displays Morphs in the Hand and the Hand position" ^(self new) showPointer: true; setNameTo: 'HandMagnifier'; yourself! ----- Method: MagnifierMorph class>>registerInFlapsRegistry (in category 'class initialization') ----- registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(MagnifierMorph newRound 'Magnifier' 'A magnifying glass') forFlapNamed: 'Widgets']! ----- Method: MagnifierMorph class>>supplementaryPartsDescriptions (in category 'parts bin') ----- supplementaryPartsDescriptions ^ {DescriptionForPartsBin formalName: 'RoundGlass' categoryList: #(Useful) documentation: 'A round magnifying glass' globalReceiverSymbol: #MagnifierMorph nativitySelector: #newRound. DescriptionForPartsBin formalName: 'Hand Magnifier' categoryList: #(Useful) documentation: 'A magnifying glass that also shows Morphs in the Hand and displays the Hand position.' globalReceiverSymbol: #MagnifierMorph nativitySelector: #newShowingPointer }! ----- Method: MagnifierMorph class>>unload (in category 'class initialization') ----- unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ----- Method: MagnifierMorph>>addCustomMenuItems:hand: (in category 'menu') ----- addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine; add: 'magnification...' translated action: #chooseMagnification; addUpdating: #trackingPointerString action: #toggleTrackingPointer; addUpdating: #showingPointerString action: #toggleShowingPointer; addUpdating: #toggleRoundString action: #toggleRoundness.! ----- Method: MagnifierMorph>>borderWidth: (in category 'accessing') ----- borderWidth: anInteger "Grow outwards preserving innerBounds" | c | c := self center. super borderWidth: anInteger. super extent: self defaultExtent. self center: c.! ----- Method: MagnifierMorph>>chooseMagnification (in category 'menu') ----- chooseMagnification | result | result := UIManager default chooseFrom: #(1.5 2 4 8) values: #(1.5 2 4 8) title: ('Choose magnification (currently {1})' translated format:{magnification}). (result isNil or: [result = magnification]) ifTrue: [^ self]. magnification := result. self extent: self extent. "round to new magnification" self changed. "redraw even if extent wasn't changed"! ----- Method: MagnifierMorph>>chooseMagnification: (in category 'menu') ----- chooseMagnification: evt | handle origin aHand currentMag | currentMag := magnification. aHand := evt ifNil: [self currentHand] ifNotNil: [evt hand]. origin := aHand position y. handle := HandleMorph new forEachPointDo: [:newPoint | self magnification: (newPoint y - origin) / 8.0 + currentMag]. aHand attachMorph: handle. handle startStepping. self changed. "Magnify handle"! ----- Method: MagnifierMorph>>defaultBorderWidth (in category 'initialization') ----- defaultBorderWidth "answer the default border width for the receiver" ^ 1! ----- Method: MagnifierMorph>>defaultColor (in category 'initialization') ----- defaultColor "answer the default color/fill style for the receiver" ^ Color black! ----- Method: MagnifierMorph>>defaultExtent (in category 'geometry') ----- defaultExtent ^(srcExtent * magnification) truncated + (2 * borderWidth)! ----- Method: MagnifierMorph>>drawOn: (in category 'drawing') ----- drawOn: aCanvas super drawOn: aCanvas. "border and fill" aCanvas isShadowDrawing ifFalse: [ "Optimize because #magnifiedForm is expensive" aCanvas paintImage: self magnifiedForm at: self innerBounds origin]! ----- Method: MagnifierMorph>>extent: (in category 'geometry') ----- extent: aPoint "Round to multiples of magnification" srcExtent := (aPoint - (2 * borderWidth)) // magnification. ^super extent: self defaultExtent! ----- Method: MagnifierMorph>>handlesMouseDown: (in category 'event handling') ----- handlesMouseDown: evt ^evt yellowButtonPressed or: [super handlesMouseDown: evt]! ----- Method: MagnifierMorph>>hasTranslucentColor (in category 'accessing') ----- hasTranslucentColor "I may show what's behind me, so tell the hand to don't cache" ^self sourceRect intersects: self bounds! ----- Method: MagnifierMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" super initialize. trackPointer := true. showPointer := false. magnification := 2. self extent: 128 @ 128! ----- Method: MagnifierMorph>>isRound (in category 'round view') ----- isRound ^ owner isMemberOf: ScreeningMorph! ----- Method: MagnifierMorph>>magnification: (in category 'magnifying') ----- magnification: aNumber | c | magnification := aNumber min: 8 max: 0.5. magnification := magnification roundTo: (magnification < 3 ifTrue: [0.5] ifFalse: [1]). srcExtent := srcExtent min: (512@512) // magnification. "to prevent accidents" c := self center. super extent: self defaultExtent. self center: c.! ----- Method: MagnifierMorph>>magnifiedForm (in category 'magnifying') ----- magnifiedForm "Answer the magnified form" | srcRect form exclusion magnified | srcRect := self sourceRectFrom: self sourcePoint. (RecursionLock isNil and: [ self showPointer or: [ srcRect intersects: self bounds ]]) ifTrue: [RecursionLock := self. exclusion := self isRound ifTrue: [owner] ifFalse: [self]. form := self currentWorld patchAt: srcRect without: exclusion andNothingAbove: false. RecursionLock := nil] ifFalse: ["cheaper method if the source is not occluded" form := Display copy: srcRect]. "smooth if non-integer scale" magnified := form magnify: form boundingBox by: magnification smoothing: (magnification isInteger ifTrue: [1] ifFalse: [2]). "display the pointer rectangle if desired" self showPointer ifTrue: [magnified reverse: (magnified center - (2 @ 2) extent: 4 @ 4) fillColor: Color white]. ^ magnified! ----- Method: MagnifierMorph>>mouseDown: (in category 'event handling') ----- mouseDown: evt evt yellowButtonPressed ifTrue: [self chooseMagnification: evt] ifFalse: [super mouseDown: evt]! ----- Method: MagnifierMorph>>showPointer (in category 'menu') ----- showPointer ^showPointer ifNil: [ showPointer := false ].! ----- Method: MagnifierMorph>>showPointer: (in category 'accessing') ----- showPointer: aBoolean "If aBoolean is true, display the current pointer position as a small square in the center of the lens." showPointer == aBoolean ifTrue: [ ^self ]. showPointer := aBoolean. self changed.! ----- Method: MagnifierMorph>>showingPointerString (in category 'menu') ----- showingPointerString ^ (self showPointer ifTrue: ['stop showing pointer'] ifFalse: ['start showing pointer']) translated! ----- Method: MagnifierMorph>>sourcePoint (in category 'magnifying') ----- sourcePoint "If we are being dragged use our center, otherwise use pointer position" ^(trackPointer not or: [owner notNil and: [owner isHandMorph]]) ifTrue: [self center] ifFalse: [self currentHand position]! ----- Method: MagnifierMorph>>sourceRect (in category 'magnifying') ----- sourceRect ^self sourceRectFrom: self sourcePoint ! ----- Method: MagnifierMorph>>sourceRectFrom: (in category 'magnifying') ----- sourceRectFrom: aPoint ^ (aPoint extent: srcExtent) translateBy: (srcExtent // -2) + 1. ! ----- Method: MagnifierMorph>>step (in category 'stepping and presenter') ----- step self changed! ----- Method: MagnifierMorph>>stepTime (in category 'testing') ----- stepTime ^ 0! ----- Method: MagnifierMorph>>toggleRoundString (in category 'round view') ----- toggleRoundString ^ (self isRound ifTrue: ['be square'] ifFalse: ['be round']) translated! ----- Method: MagnifierMorph>>toggleRoundness (in category 'round view') ----- toggleRoundness | sm w | w := self world. self isRound ifTrue: [owner delete. w addMorph: self] ifFalse: [sm := ScreeningMorph new position: self position. sm addMorph: self. sm addMorph: (EllipseMorph newBounds: self bounds). w addMorph: sm]! ----- Method: MagnifierMorph>>toggleShowingPointer (in category 'menu') ----- toggleShowingPointer self showPointer: self showPointer not! ----- Method: MagnifierMorph>>toggleTrackingPointer (in category 'menu') ----- toggleTrackingPointer trackPointer := trackPointer not! ----- Method: MagnifierMorph>>trackingPointerString (in category 'menu') ----- trackingPointerString ^ (trackPointer ifTrue: ['stop tracking pointer'] ifFalse: ['start tracking pointer']) translated! PasteUpMorph subclass: #ZASMScriptMorph instanceVariableNames: 'somethingChanged' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! ----- Method: ZASMScriptMorph>>acceptDroppingMorph:event: (in category 'layout') ----- acceptDroppingMorph: aMorph event: evt super acceptDroppingMorph: aMorph event: evt. somethingChanged := true. ! ----- Method: ZASMScriptMorph>>addCustomMenuItems:hand: (in category 'menus') ----- addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'save script' translated action: #saveScript. ! ----- Method: ZASMScriptMorph>>compileScript (in category 'as yet unclassified') ----- compileScript | newScript prevMark prevSteps data | self fixup. newScript := OrderedCollection new. prevMark := prevSteps := nil. submorphs do: [ :each | (each isKindOf: ZASMCameraMarkMorph) ifTrue: [ prevMark ifNotNil: [ data := Dictionary new. data at: #steps put: prevSteps; at: #startPoint put: (prevMark valueOfProperty: #cameraPoint); at: #endPoint put: (each valueOfProperty: #cameraPoint); at: #startZoom put: (prevMark valueOfProperty: #cameraScale); at: #endZoom put: (each valueOfProperty: #cameraScale). newScript add: data. ]. prevMark := each. ]. (each isKindOf: ZASMStepsMorph) ifTrue: [ prevSteps := each getStepCount. ]. ]. ^newScript ! ----- Method: ZASMScriptMorph>>decompileScript:named:for: (in category 'as yet unclassified') ----- decompileScript: aScript named: aString for: aController | newMorphs prevPt prevScale cameraPoint cameraScale mark | self removeAllMorphs. self setProperty: #cameraController toValue: aController. self setProperty: #cameraScriptName toValue: aString. newMorphs := OrderedCollection new. prevPt := prevScale := nil. aScript do: [ :each | cameraPoint := each at: #startPoint ifAbsent: [nil]. cameraScale := each at: #startZoom ifAbsent: [nil]. (prevPt = cameraPoint and: [prevScale = cameraScale]) ifFalse: [ mark := ZASMCameraMarkMorph new. mark cameraPoint: cameraPoint cameraScale: cameraScale controller: aController. newMorphs add: mark. ]. newMorphs add: (ZASMStepsMorph new setStepCount: (each at: #steps ifAbsent: [10])). cameraPoint := each at: #endPoint ifAbsent: [nil]. cameraScale := each at: #endZoom ifAbsent: [nil]. mark := ZASMCameraMarkMorph new. mark cameraPoint: cameraPoint cameraScale: cameraScale controller: aController. newMorphs add: mark. prevPt := cameraPoint. prevScale := cameraScale. ]. self addAllMorphs: newMorphs. ! ----- Method: ZASMScriptMorph>>defaultBorderColor (in category 'initialization') ----- defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color blue! ----- Method: ZASMScriptMorph>>defaultBorderWidth (in category 'initialization') ----- defaultBorderWidth "answer the default border width for the receiver" ^ 2! ----- Method: ZASMScriptMorph>>defaultColor (in category 'initialization') ----- defaultColor "answer the default color/fill style for the receiver" ^ Color lightBlue! ----- Method: ZASMScriptMorph>>fixup (in category 'as yet unclassified') ----- fixup | newMorphs state fixed | somethingChanged := false. newMorphs := OrderedCollection new. state := #new. fixed := false. submorphs do: [ :each | (each isKindOf: ZASMCameraMarkMorph) ifTrue: [ state == #mark ifTrue: [ newMorphs add: ( ZASMStepsMorph new setStepCount: 10 ). fixed := true. ]. newMorphs add: each. state := #mark. ]. (each isKindOf: ZASMStepsMorph) ifTrue: [ state == #steps ifTrue: [ fixed := true. ] ifFalse: [ newMorphs add: each. state := #steps. ]. ]. ]. fixed ifTrue: [ self removeAllMorphs. self addAllMorphs: newMorphs. ].! ----- Method: ZASMScriptMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" super initialize. "" somethingChanged := true. self dragEnabled: true; layoutPolicy: TableLayout new; listDirection: #topToBottom; wrapCentering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 6; rubberBandCells: true! ----- Method: ZASMScriptMorph>>layoutChanged (in category 'layout') ----- layoutChanged super layoutChanged. somethingChanged := true. ! ----- Method: ZASMScriptMorph>>saveScript (in category 'as yet unclassified') ----- saveScript | newScript scriptName | newScript := self compileScript. scriptName := UIManager default request: 'Name this script' initialAnswer: (self valueOfProperty: #cameraScriptName ifAbsent: ['']). scriptName isEmptyOrNil ifTrue: [^self]. (self valueOfProperty: #cameraController) saveScript: newScript as: scriptName. self delete.! ----- Method: ZASMScriptMorph>>step (in category 'stepping and presenter') ----- step super step. somethingChanged ifFalse: [^self]. self fixup. ! ----- Method: ZASMScriptMorph>>stepTime (in category 'testing') ----- stepTime ^500! ----- Method: ZASMScriptMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') ----- wantsDroppedMorph: aMorph event: evt ^aMorph isKindOf: ZASMCameraMarkMorph! ----- Method: ZASMScriptMorph>>wantsSteps (in category 'testing') ----- wantsSteps ^true! PasteUpMorph subclass: #ZoomAndScrollMorph instanceVariableNames: 'sourceRectangle usingBalloon panAndTiltFactor zoomFactor' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! !ZoomAndScrollMorph commentStamp: '<historical>' prior: 0! I am the outer part of a transformed view of another pasteup. I know how to translate requests to pan, tilt and zoom into appropriate changes to the transformation! ----- Method: ZoomAndScrollMorph>>acceptDroppingMorph:event: (in category 'layout') ----- acceptDroppingMorph: morphToDrop event: evt ^morphToDrop rejectDropMorphEvent: evt. "put it back where it came from" ! ----- Method: ZoomAndScrollMorph>>cameraPoint (in category 'scripting') ----- cameraPoint ^self myTransformMorph transform globalPointToLocal: self innerBounds center ! ----- Method: ZoomAndScrollMorph>>cameraPoint: (in category 'scripting') ----- cameraPoint: newPt | transform | transform := self myTransformMorph. self changeOffsetTo: newPt * transform scale - (transform innerBounds extent // 2) ! ----- Method: ZoomAndScrollMorph>>changeOffsetBy: (in category 'as yet unclassified') ----- changeOffsetBy: aPoint | transform rounder roundPt | "improve behavior at high magnification by rounding change to whole source pixels" transform := self myTransformMorph. rounder := [ :val | "(val abs + (transform scale * 0.99) roundTo: transform scale) * val sign" "looks like rounding wasn't a good solution" val ]. roundPt := (rounder value: aPoint x) @ (rounder value: aPoint y). self changeOffsetTo: transform offset + roundPt. ! ----- Method: ZoomAndScrollMorph>>changeOffsetTo: (in category 'as yet unclassified') ----- changeOffsetTo: aPoint | transform trialOffset innerPasteup keepWidth keepHeight | transform := self myTransformMorph. keepWidth := transform width "// 4". keepHeight := transform height "// 4". innerPasteup := transform firstSubmorph. trialOffset := aPoint. trialOffset := (trialOffset x min: (innerPasteup width * transform scale) - keepWidth max: keepWidth - transform width) @ (trialOffset y min: (innerPasteup height * transform scale) - keepHeight max: keepHeight - transform height). transform offset: trialOffset. ! ----- Method: ZoomAndScrollMorph>>changeScaleTo: (in category 'as yet unclassified') ----- changeScaleTo: aNumber | transform innerPasteup min1 min2 newScale oldPoint | transform := self myTransformMorph. "oldScale := transform scale." innerPasteup := transform firstSubmorph. min1 := transform width / innerPasteup width asFloat. min2 := transform height / innerPasteup height asFloat. newScale := (aNumber max: min1) max: min2. oldPoint := self cameraPoint. transform scale: newScale. self cameraPoint: oldPoint. "scaleR := newScale / oldScale. half := transform extent // 2. half := 0@0. self changeOffsetBy: scaleR * (transform offset + half) - half - transform offset." "==Alan's preferred factors pan = 0.0425531914893617 zoom = 0.099290780141844 ===" ! ----- Method: ZoomAndScrollMorph>>changeTiltFactor: (in category 'as yet unclassified') ----- changeTiltFactor: x panAndTiltFactor := x! ----- Method: ZoomAndScrollMorph>>changeZoomFactor: (in category 'as yet unclassified') ----- changeZoomFactor: x zoomFactor := x! ----- Method: ZoomAndScrollMorph>>createInteriorTransform (in category 'initialization') ----- createInteriorTransform | innerPasteUp tm | innerPasteUp := PasteUpMorph new. innerPasteUp borderWidth: 0; minHeight: 100; minWidth: 100; hResizing: #shrinkWrap; vResizing: #shrinkWrap; position: 0@0; extent: 100@100. tm := TransformationB2Morph new. tm setProperty: #rotationCenter toValue: 0@0. tm useRegularWarpBlt: usingBalloon not. self addMorph: tm. tm addMorph: innerPasteUp. tm beSticky. innerPasteUp beSticky. tm scale: 1.0; offset: 0@0. ! ----- Method: ZoomAndScrollMorph>>defaultBorderColor (in category 'initialization') ----- defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color red! ----- Method: ZoomAndScrollMorph>>defaultColor (in category 'initialization') ----- defaultColor "answer the default color/fill style for the receiver" ^ Color lightGray! ----- Method: ZoomAndScrollMorph>>extent: (in category 'geometry') ----- extent: extentPoint super extent: extentPoint. self myTransformMorph bounds: self innerBounds. ! ----- Method: ZoomAndScrollMorph>>getTiltFactor (in category 'as yet unclassified') ----- getTiltFactor ^panAndTiltFactor ifNil: [panAndTiltFactor := 0.5]. ! ----- Method: ZoomAndScrollMorph>>getZoomFactor (in category 'as yet unclassified') ----- getZoomFactor ^zoomFactor ifNil: [zoomFactor := 0.5]. ! ----- Method: ZoomAndScrollMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" super initialize. "" usingBalloon := true. self createInteriorTransform ! ----- Method: ZoomAndScrollMorph>>myTransformMorph (in category 'scripting') ----- myTransformMorph ^self firstSubmorph ! ----- Method: ZoomAndScrollMorph>>offsetX (in category 'scripting') ----- offsetX ^self myTransformMorph offset x ! ----- Method: ZoomAndScrollMorph>>offsetX: (in category 'scripting') ----- offsetX: aNumber | transform | transform := self myTransformMorph. transform offset: aNumber @ transform offset y ! ----- Method: ZoomAndScrollMorph>>offsetY (in category 'scripting') ----- offsetY ^self myTransformMorph offset y ! ----- Method: ZoomAndScrollMorph>>offsetY: (in category 'scripting') ----- offsetY: aNumber | transform | transform := self myTransformMorph. transform offset: transform offset x @ aNumber ! ----- Method: ZoomAndScrollMorph>>panImageBy: (in category 'as yet unclassified') ----- panImageBy: pixels self changeOffsetBy: (pixels * self getTiltFactor * 0.1) @ 0. "steps := (pixels abs / 6) exp rounded * pixels sign." "==Alan's preferred factors pan = 0.0425531914893617 zoom = 0.099290780141844 ===" ! ----- Method: ZoomAndScrollMorph>>scale (in category 'scripting') ----- scale ^self myTransformMorph scale ! ----- Method: ZoomAndScrollMorph>>scale: (in category 'scripting') ----- scale: aValue self myTransformMorph scale: aValue. ! ----- Method: ZoomAndScrollMorph>>scaleImageBy: (in category 'as yet unclassified') ----- scaleImageBy: pixels | scalePerPixel steps transform factor | transform := self myTransformMorph. (steps := (pixels * self getZoomFactor * 0.2) rounded) = 0 ifTrue: [^self]. scalePerPixel := 1.01. factor := scalePerPixel raisedTo: steps abs. steps > 0 ifTrue: [ factor := 1.0 / factor. ]. self changeScaleTo: (transform scale * factor min: 10.0 max: 0.1). ! ----- Method: ZoomAndScrollMorph>>step (in category 'stepping and presenter') ----- step | innerPasteUp overlap | innerPasteUp := self myTransformMorph firstSubmorph. overlap := (innerPasteUp submorphs inject: 0@0 into: [ :min :each | min min: each position]) rounded. overlap = (0@0) ifFalse: [ innerPasteUp submorphs do: [ :each | each position: each position - overlap]. innerPasteUp layoutChanged. ]. ! ----- Method: ZoomAndScrollMorph>>stepTime (in category 'testing') ----- stepTime ^10 "ms"! ----- Method: ZoomAndScrollMorph>>tiltImageBy: (in category 'as yet unclassified') ----- tiltImageBy: pixels self changeOffsetBy: 0 @ (pixels * self getTiltFactor * 0.1) " steps := (pixels abs / 6) exp rounded * pixels sign. " "==Alan's preferred factors pan = 0.0425531914893617 zoom = 0.099290780141844 ===" ! ----- Method: ZoomAndScrollMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') ----- wantsDroppedMorph: aMorph event: evt "we don't, really, but it avoids problem of outer pasteup rejecting a drop for inner pasteup" ^true! EllipseMorph subclass: #AtomMorph instanceVariableNames: 'velocity' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! !AtomMorph commentStamp: 'tbn 11/25/2004 09:06' prior: 0! AtomMorph represents an atom used in the simulation of an ideal gas. It's container is typically a BouncingAtomsMorph. Try: BouncingAtomsMorph new openInWorld to open the gas simulation or: AtomMorph example to open an instance in the current world! ----- Method: AtomMorph class>>example (in category 'examples') ----- example " AtomMorph example " |a| a := AtomMorph new openInWorld. a color: Color random. [1000 timesRepeat: [a bounceIn: World bounds. (Delay forMilliseconds: 50) wait]. a delete] fork.! ----- Method: AtomMorph class>>includeInNewMorphMenu (in category 'new-morph participation') ----- includeInNewMorphMenu "Not to be instantiated from the menu" ^ false! ----- Method: AtomMorph>>bounceIn: (in category 'private') ----- bounceIn: aRect "Move this atom one step along its velocity vector and make it bounce if it goes outside the given rectangle. Return true if it is bounced." | p vx vy px py bounced | p := self position. vx := velocity x. vy := velocity y. px := p x + vx. py := p y + vy. bounced := false. px > aRect right ifTrue: [ px := aRect right - (px - aRect right). vx := velocity x negated. bounced := true]. py > aRect bottom ifTrue: [ py := aRect bottom - (py - aRect bottom). vy := velocity y negated. bounced := true]. px < aRect left ifTrue: [ px := aRect left - (px - aRect left). vx := velocity x negated. bounced := true]. py < aRect top ifTrue: [ py := aRect top - (py - aRect top). vy := velocity y negated. bounced := true]. self position: px @ py. bounced ifTrue: [self velocity: vx @ vy]. ^ bounced ! ----- Method: AtomMorph>>defaultBorderWidth (in category 'initialization') ----- defaultBorderWidth "answer the default border width for the receiver" ^ 0! ----- Method: AtomMorph>>defaultColor (in category 'initialization') ----- defaultColor "answer the default color/fill style for the receiver" ^ Color blue! ----- Method: AtomMorph>>drawOn: (in category 'drawing') ----- drawOn: aCanvas "Note: Set 'drawAsRect' to true to make the atoms draw faster. When testing the speed of other aspects of Morphic, such as its damage handling efficiency for large numbers of atoms, it is useful to make drawing faster." | drawAsRect | drawAsRect := false. "rectangles are faster to draw" drawAsRect ifTrue: [aCanvas fillRectangle: self bounds color: color] ifFalse: [super drawOn: aCanvas].! ----- Method: AtomMorph>>infected (in category 'accessing') ----- infected ^ color = Color red! ----- Method: AtomMorph>>infected: (in category 'accessing') ----- infected: aBoolean aBoolean ifTrue: [self color: Color red] ifFalse: [self color: Color blue].! ----- Method: AtomMorph>>initialize (in category 'initialization') ----- initialize "Make a new atom with a random position and velocity." super initialize. "" self extent: 8 @ 7. self randomPositionIn: (0 @ 0 corner: 300 @ 300) maxVelocity: 10! ----- Method: AtomMorph>>randomPositionIn:maxVelocity: (in category 'initialization') ----- randomPositionIn: aRectangle maxVelocity: maxVelocity "Give this atom a random position and velocity." | origin extent | origin := aRectangle origin. extent := (aRectangle extent - self bounds extent) rounded. self position: (origin x + extent x atRandom) @ (origin y + extent y atRandom). velocity := (maxVelocity - (2 * maxVelocity) atRandom) @ (maxVelocity - (2 * maxVelocity) atRandom). ! ----- Method: AtomMorph>>velocity (in category 'accessing') ----- velocity ^ velocity! ----- Method: AtomMorph>>velocity: (in category 'accessing') ----- velocity: newVelocity velocity := newVelocity.! EllipseMorph subclass: #Flasher instanceVariableNames: 'onColor' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-Demo'! !Flasher commentStamp: '<historical>' prior: 0! A simple example - a circle that flashes. The "onColor" instance variable indicates the color to use when "on", A darker color is used to represent "off". The #step method, called every 500ms. by default, alternatively makes the flasher show its "on" and its "off" color.! ----- Method: Flasher class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin "Answer a description of the receiver for use in a parts bin" ^ self partName: 'Flasher' categories: #('Demo') documentation: 'A circle that flashes'! ----- Method: Flasher>>initializeToStandAlone (in category 'parts bin') ----- initializeToStandAlone "Initialize the flasher." super initializeToStandAlone. self color: Color red. self onColor: Color red. self borderWidth: 2. self extent: 25@25! ----- Method: Flasher>>onColor (in category 'operations') ----- onColor "Answer my onColor" ^ onColor ifNil: [onColor := Color red]! ----- Method: Flasher>>onColor: (in category 'operations') ----- onColor: aColor "Change my on color to be aColor" onColor := aColor. self color: aColor! ----- Method: Flasher>>step (in category 'stepping and presenter') ----- step "Perform my standard periodic action" super step. self color = self onColor ifTrue: [self color: (onColor alphaMixed: 0.5 with: Color black)] ifFalse: [self color: onColor]! ----- Method: Flasher>>stepTime (in category 'testing') ----- stepTime "Answer the desired time between steps, in milliseconds." ^ 500!

1 0

The Trunk: MorphicExtras-AdditionalSupport-edc.1.mcz
by commits＠source.squeak.org 01 Sep '09

01 Sep '09

Edgar J. De Cleene uploaded a new version of MorphicExtras-AdditionalSupport to project The Trunk: http://source.squeak.org/trunk/MorphicExtras-AdditionalSupport-edc.1.mcz ==================== Summary ==================== Name: MorphicExtras-AdditionalSupport-edc.1 Author: edc Time: 1 September 2009, 11:51:09 am UUID: 8ee10d83-a6ec-4745-b351-d4536350953e Ancestors: ==================== Snapshot ==================== SystemOrganization addCategory: #'MorphicExtras-AdditionalSupport'! HandMorph subclass: #HandMorphForReplay instanceVariableNames: 'recorder' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-AdditionalSupport'! !HandMorphForReplay commentStamp: '<historical>' prior: 0! I am a hand for replaying events stored in an EventRecorderMorph. When there are no more events, I delete myself.! ----- Method: HandMorphForReplay>>initialize (in category 'initialization') ----- initialize super initialize. self showTemporaryCursor: Cursor normal. ! ----- Method: HandMorphForReplay>>needsToBeDrawn (in category 'drawing') ----- needsToBeDrawn ^true! ----- Method: HandMorphForReplay>>pauseEventRecorderIn: (in category 'event handling') ----- pauseEventRecorderIn: aWorld "Suspend my recorder prior to a project change, and return it. It will be resumed after starting the new project." ^ recorder pauseIn: aWorld! ----- Method: HandMorphForReplay>>processEvents (in category 'event handling') ----- processEvents "Play back the next event" | evt hadMouse hadAny | hadMouse := hadAny := false. [(evt := recorder nextEventToPlay) isNil] whileFalse: [evt type == #EOF ifTrue: [recorder pauseIn: self world. ^self]. evt type == #startSound ifTrue: [evt argument play. recorder synchronize. ^self]. evt isMouse ifTrue: [hadMouse := true]. (evt isMouse or: [evt isKeyboard]) ifTrue: [self handleEvent: (evt setHand: self) resetHandlerFields. hadAny := true]]. (mouseClickState notNil and: [hadMouse not]) ifTrue: ["No mouse events during this cycle. Make sure click states time out accordingly" mouseClickState handleEvent: lastMouseEvent asMouseMove from: self]. hadAny ifFalse: ["No pending events. Make sure z-order is up to date" self mouseOverHandler processMouseOver: lastMouseEvent]! ----- Method: HandMorphForReplay>>recorder: (in category 'initialization') ----- recorder: anEventRecorder recorder := anEventRecorder! ----- Method: HandMorphForReplay>>showTemporaryCursor:hotSpotOffset: (in category 'cursor') ----- showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset "When I show my cursor, it appears double size, unless it is a form such as a paint brush." cursorOrNil ifNil: ["Setting cursor to nil cannot revert to hardware cursor -- just show normal." ^ self showTemporaryCursor: Cursor normal hotSpotOffset: Cursor normal offset] ifNotNil: [(cursorOrNil isKindOf: Cursor) ifTrue: ["Show cursors magnified for visibility" ^ super showTemporaryCursor: (CursorWithMask derivedFrom: (cursorOrNil magnifyBy: 2)) hotSpotOffset: (cursorOrNil offset negated*2) + hotSpotOffset] ifFalse: [^ super showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset]]! ----- Method: HandMorphForReplay>>veryDeepCopyWith: (in category 'copying') ----- veryDeepCopyWith: deepCopier ^ self copy! HandMorph subclass: #RemoteHandMorph instanceVariableNames: 'remoteWorldExtent remoteAddress sendSocket sendBuffer sendState socket waitingForConnection receiveBuffer' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-AdditionalSupport'! ----- Method: RemoteHandMorph class>>ensureNetworkConnected (in category 'utilities') ----- ensureNetworkConnected "Try to ensure that an intermittent network connection, such as a dialup or ISDN line, is actually connected. This is necessary to make sure a server is visible in order to accept an incoming connection." "RemoteHandMorph ensureNetworkConnected" Utilities informUser: 'Contacting domain name server...' during: [ NetNameResolver addressForName: 'squeak.org' timeout: 30]. ! ----- Method: RemoteHandMorph>>appendNewDataToReceiveBuffer (in category 'private') ----- appendNewDataToReceiveBuffer "Append all available raw data to my receive buffer. Assume that my socket is not nil." | newData tempBuf bytesRead | socket dataAvailable ifTrue: [ "get all the data currently available" newData := WriteStream on: (String new: receiveBuffer size + 1000). newData nextPutAll: receiveBuffer. tempBuf := String new: 1000. [socket dataAvailable] whileTrue: [ bytesRead := socket receiveDataInto: tempBuf. 1 to: bytesRead do: [:i | newData nextPut: (tempBuf at: i)]]. receiveBuffer := newData contents]. ! ----- Method: RemoteHandMorph>>drawOn: (in category 'drawing') ----- drawOn: aCanvas "For remote cursors, always draw the hand itself (i.e., the cursor)." super drawOn: aCanvas. aCanvas paintImage: NormalCursor at: self position. ! ----- Method: RemoteHandMorph>>getNextRemoteEvent (in category 'private') ----- getNextRemoteEvent "Return the next remote event, or nil if the receive buffer does not contain a full event record. An event record is the storeString for a MorphicEvent terminated by a <CR> character." | i s evt | self receiveData. receiveBuffer isEmpty ifTrue: [^ nil]. i := receiveBuffer indexOf: Character cr ifAbsent: [^ nil]. s := receiveBuffer copyFrom: 1 to: i - 1. receiveBuffer := receiveBuffer copyFrom: i + 1 to: receiveBuffer size. evt := (MorphicEvent readFromString: s). evt ifNil:[^nil]. evt setHand: self. evt isKeyboard ifTrue:[evt setPosition: self position]. ^evt resetHandlerFields! ----- Method: RemoteHandMorph>>handleListenEvent: (in category 'events-processing') ----- handleListenEvent: anEvent "Transmit the event to interested listeners" | currentExtent | currentExtent := self worldBounds extent. self lastWorldExtent ~= currentExtent ifTrue: [ self transmitEvent: (MorphicUnknownEvent new setType: #worldExtent argument: currentExtent). self lastWorldExtent: currentExtent]. self transmitEvent: anEvent.! ----- Method: RemoteHandMorph>>initialize (in category 'initialization') ----- initialize super initialize. remoteWorldExtent := 100@100. "initial guess" socket := nil. waitingForConnection := false. receiveBuffer := ''. sendState := #unconnected.! ----- Method: RemoteHandMorph>>lastEventTransmitted (in category 'connections') ----- lastEventTransmitted ^self valueOfProperty: #lastEventTransmitted! ----- Method: RemoteHandMorph>>lastEventTransmitted: (in category 'connections') ----- lastEventTransmitted: anEvent ^self setProperty: #lastEventTransmitted toValue: anEvent! ----- Method: RemoteHandMorph>>lastWorldExtent (in category 'connections') ----- lastWorldExtent ^self valueOfProperty: #lastWorldExtent! ----- Method: RemoteHandMorph>>lastWorldExtent: (in category 'connections') ----- lastWorldExtent: extent ^self setProperty: #lastWorldExtent toValue: extent! ----- Method: RemoteHandMorph>>needsToBeDrawn (in category 'drawing') ----- needsToBeDrawn ^true! ----- Method: RemoteHandMorph>>processEvents (in category 'event handling') ----- processEvents "Process user input events from the remote input devices." | evt | evt := self getNextRemoteEvent. [evt notNil] whileTrue: [evt type == #worldExtent ifTrue: [remoteWorldExtent := evt argument. ^self]. self handleEvent: evt. evt := self getNextRemoteEvent]! ----- Method: RemoteHandMorph>>readyToTransmit (in category 'connections') ----- readyToTransmit "Return true if the receiver is ready to send." (sendState == #connected) ifTrue:[ sendSocket sendDone ifFalse:[^false]. ^true]. sendState == #opening ifTrue:[ sendSocket isConnected ifTrue:[^true]. sendSocket isWaitingForConnection ifFalse:[ Transcript show: 'trying connection again...'; cr. sendSocket destroy. sendSocket := Socket new. sendSocket connectTo: self remoteHostAddress port: 54323]]. sendState == #closing ifTrue:[ sendSocket isUnconnectedOrInvalid ifTrue:[ sendSocket destroy. sendState := #unconnected]]. ^false! ----- Method: RemoteHandMorph>>receiveData (in category 'private') ----- receiveData "Check my connection status and withdraw from the world if the connection has been broken. Append any data that has arrived to receiveBuffer. " socket ifNotNil: [ socket isConnected ifTrue: [ "connected" waitingForConnection ifTrue: [ Transcript show: 'Remote hand ', userInitials, ' connected'; cr. waitingForConnection := false]. self appendNewDataToReceiveBuffer] ifFalse: [ "not connected" waitingForConnection ifFalse: [ "connection was established, then broken" self withdrawFromWorld. receiveBuffer := '']]]. ! ----- Method: RemoteHandMorph>>remoteHostAddress (in category 'connections') ----- remoteHostAddress "Return the address of the remote host or zero if not connected." ^remoteAddress ifNil:[0]! ----- Method: RemoteHandMorph>>startListening (in category 'connections') ----- startListening "Create a socket and start listening for a connection." self stopListening. Transcript show: 'My address is ', NetNameResolver localAddressString; cr. Transcript show: 'Remote hand ', self userInitials, ' waiting for a connection...'; cr. socket := Socket new. socket listenOn: 54323. waitingForConnection := true. ! ----- Method: RemoteHandMorph>>startTransmittingEvents (in category 'connections') ----- startTransmittingEvents "Attempt to broadcast events from this hand to a remote hand on the host with the given address. This method just creates the new socket and initiates a connection; it does not wait for the other end to answer." (sendSocket notNil and:[sendSocket isConnected]) ifTrue:[^self]. Transcript show: 'Connecting to remote WorldMorph at '; show: (NetNameResolver stringFromAddress: self remoteHostAddress), ' ...'; cr. sendSocket := OldSimpleClientSocket new. sendSocket connectTo: self remoteHostAddress port: 54323. sendState := #opening. owner primaryHand addEventListener: self.! ----- Method: RemoteHandMorph>>startTransmittingEventsTo: (in category 'connections') ----- startTransmittingEventsTo: remoteAddr "Attempt to broadcast events from this hand to a remote hand on the host with the given address. This method just creates the new socket and initiates a connection; it does not wait for the other end to answer." remoteAddress := remoteAddr. (sendSocket notNil and:[sendSocket isConnected]) ifTrue:[^self]. Transcript show: 'Connecting to remote WorldMorph at '; show: (NetNameResolver stringFromAddress: self remoteHostAddress), ' ...'; cr. sendSocket := OldSimpleClientSocket new. sendSocket connectTo: self remoteHostAddress port: 54323. sendState := #opening. owner primaryHand addEventListener: self.! ----- Method: RemoteHandMorph>>stopListening (in category 'connections') ----- stopListening "Destroy the socket, if any, terminating the connection." socket ifNotNil: [ socket destroy. socket := nil]. ! ----- Method: RemoteHandMorph>>stopTransmittingEvents (in category 'connections') ----- stopTransmittingEvents "Stop broadcasting events from this world's cursor to a remote cursor on the host with the given address. This method issues a 'close' but does not destroy the socket; it will be destroyed when the other end reads the last data and closes the connection." (sendSocket isUnconnectedOrInvalid) ifFalse:[ sendSocket close. sendState := #closing]. owner primaryHand removeEventListener: self.! ----- Method: RemoteHandMorph>>transmitEvent: (in category 'event handling') ----- transmitEvent: aMorphicEvent "Transmit the given event to all remote connections." | firstEvt | self readyToTransmit ifFalse: [^ self]. self lastEventTransmitted = aMorphicEvent ifTrue: [^ self]. sendBuffer ifNil: [sendBuffer _ WriteStream on: (String new: 10000)]. sendBuffer nextPutAll: aMorphicEvent storeString; cr. self lastEventTransmitted: aMorphicEvent. sendSocket isConnected ifTrue:[ sendState = #opening ifTrue: [ "connection established; disable TCP delays on sends" sendSocket setOption: 'TCP_NODELAY' value: true. "send worldExtent as first event" firstEvt _ MorphicUnknownEvent type: #worldBounds argument: self worldBounds extent. sendSocket sendData: firstEvt storeString, (String with: Character cr). Transcript show: 'Connection established with remote WorldMorph at '; show: (NetNameResolver stringFromAddress: sendSocket remoteAddress); cr. sendState _ #connected]. sendSocket sendData: sendBuffer contents. ] ifFalse: [ owner primaryHand removeEventListener: self. sendState = #connected ifTrue: [ "other end has closed; close our end" Transcript show: 'Closing connection with remote WorldMorph at '; show: (NetNameResolver stringFromAddress: sendSocket remoteAddress); cr. sendSocket close. sendState _ #closing]]. sendBuffer reset. ! ----- Method: RemoteHandMorph>>withdrawFromWorld (in category 'other') ----- withdrawFromWorld "Close the socket, if any, and remove this hand from the world." | addr | addr := self remoteHostAddress. addr = 0 ifFalse: [self stopTransmittingEvents]. self stopListening. Transcript show: 'Remote hand ', self userInitials, ' closed'; cr. owner ifNotNil: [owner removeHand: self]. ! ----- Method: RemoteHandMorph>>worldBounds (in category 'geometry') ----- worldBounds ^ 0@0 extent: remoteWorldExtent ! TransformationMorph subclass: #BOBTransformationMorph instanceVariableNames: 'worldBoundsToShow useRegularWarpBlt' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-AdditionalSupport'! ----- Method: BOBTransformationMorph>>adjustAfter: (in category 'private') ----- adjustAfter: changeBlock "Cause this morph to remain cetered where it was before, and choose appropriate smoothing, after a change of scale or rotation." | | "oldRefPos := self referencePosition." changeBlock value. self chooseSmoothing. "self penUpWhile: [self position: self position + (oldRefPos - self referencePosition)]." self layoutChanged. owner ifNotNil: [owner invalidRect: bounds] ! ----- Method: BOBTransformationMorph>>changeWorldBoundsToShow: (in category 'as yet unclassified') ----- changeWorldBoundsToShow: aRectangle aRectangle area = 0 ifTrue: [^self]. worldBoundsToShow := aRectangle. owner myWorldChanged.! ----- Method: BOBTransformationMorph>>drawSubmorphsOn: (in category 'drawing') ----- drawSubmorphsOn: aCanvas | t | t := [ self drawSubmorphsOnREAL: aCanvas ] timeToRun. "Q1 at: 3 put: t." ! ----- Method: BOBTransformationMorph>>drawSubmorphsOnREAL: (in category 'as yet unclassified') ----- drawSubmorphsOnREAL: aCanvas | newClip | (self innerBounds intersects: aCanvas clipRect) ifFalse: [^self]. newClip := ((self innerBounds intersect: aCanvas clipRect) expandBy: 1) truncated. useRegularWarpBlt == true ifTrue: [ transform scale asFloat = 1.0 ifFalse: [ newClip := self innerBounds. "avoids gribblies" ]. ^aCanvas transformBy: transform clippingTo: newClip during: [:myCanvas | submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] smoothing: smoothing ]. aCanvas transform2By: transform "#transformBy: for pure WarpBlt" clippingTo: newClip during: [:myCanvas | submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] smoothing: smoothing ! ----- Method: BOBTransformationMorph>>extent: (in category 'geometry') ----- extent: aPoint | newExtent | newExtent := aPoint truncated. bounds extent = newExtent ifTrue: [^self]. bounds := bounds topLeft extent: newExtent. self recomputeExtent. ! ----- Method: BOBTransformationMorph>>extentFromParent: (in category 'as yet unclassified') ----- extentFromParent: aPoint | newExtent | submorphs isEmpty ifTrue: [^self extent: aPoint]. newExtent := aPoint truncated. bounds := bounds topLeft extent: newExtent. newExtent := self recomputeExtent. newExtent ifNil: [^self]. bounds := bounds topLeft extent: newExtent. ! ----- Method: BOBTransformationMorph>>layoutChanged (in category 'layout') ----- layoutChanged "use the version from Morph" | myGuy | fullBounds := nil. owner ifNotNil: [owner layoutChanged]. submorphs notEmpty ifTrue: [(myGuy := self firstSubmorph) isWorldMorph ifFalse: [worldBoundsToShow = myGuy bounds ifFalse: [self changeWorldBoundsToShow: (worldBoundsToShow := myGuy bounds)]] "submorphs do: [:m | m ownerChanged]" "<< I don't see any reason for this"]! ----- Method: BOBTransformationMorph>>recomputeExtent (in category 'as yet unclassified') ----- recomputeExtent | scalePt newScale theGreenThingie greenIBE myNewExtent | submorphs isEmpty ifTrue: [^self extent]. worldBoundsToShow ifNil: [worldBoundsToShow := self firstSubmorph bounds]. worldBoundsToShow area = 0 ifTrue: [^self extent]. scalePt := owner innerBounds extent / worldBoundsToShow extent. newScale := scalePt x min: scalePt y. theGreenThingie := owner. greenIBE := theGreenThingie innerBounds extent. myNewExtent := (greenIBE min: worldBoundsToShow extent * newScale) truncated. self scale: newScale; offset: worldBoundsToShow origin * newScale. smoothing := (newScale < 1.0) ifTrue: [2] ifFalse: [1]. ^myNewExtent! ----- Method: BOBTransformationMorph>>useRegularWarpBlt: (in category 'as yet unclassified') ----- useRegularWarpBlt: aBoolean useRegularWarpBlt := aBoolean! AlignmentMorph subclass: #AlignmentMorphBob1 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-AdditionalSupport'! !AlignmentMorphBob1 commentStamp: 'sm 8/12/2009 22:34' prior: 0! A quick and easy way to space things vertically in absolute or proportional amounts.! ----- Method: AlignmentMorphBob1>>acceptDroppingMorph:event: (in category 'as yet unclassified') ----- acceptDroppingMorph: aMorph event: evt | handlerForDrops | handlerForDrops := self valueOfProperty: #handlerForDrops ifAbsent: [ ^super acceptDroppingMorph: aMorph event: evt ]. (handlerForDrops acceptDroppingMorph: aMorph event: evt in: self) ifFalse: [ aMorph rejectDropMorphEvent: evt. "send it back where it came from" ].! ----- Method: AlignmentMorphBob1>>addAColumn: (in category 'as yet unclassified') ----- addAColumn: aCollectionOfMorphs | col | col := self inAColumn: aCollectionOfMorphs. self addMorphBack: col. ^col! ----- Method: AlignmentMorphBob1>>addARow: (in category 'as yet unclassified') ----- addARow: aCollectionOfMorphs | row | row := self inARow: aCollectionOfMorphs. self addMorphBack: row. ^row! ----- Method: AlignmentMorphBob1>>addARowCentered: (in category 'as yet unclassified') ----- addARowCentered: aCollectionOfMorphs ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter! ----- Method: AlignmentMorphBob1>>addARowCentered:cellInset: (in category 'as yet unclassified') ----- addARowCentered: aCollectionOfMorphs cellInset: cellInsetInteger ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; cellInset: cellInsetInteger! ----- Method: AlignmentMorphBob1>>fancyText:font:color: (in category 'as yet unclassified') ----- fancyText: aString font: aFont color: aColor | answer tm col | col := ColorTheme current dialog3DTitles ifTrue: [aColor] ifFalse: [aColor negated]. tm := TextMorph new. tm beAllFont: aFont; color: col; contents: aString. answer := self inAColumn: {tm}. ColorTheme current dialog3DTitles ifTrue: ["" tm addDropShadow. tm shadowPoint: 5 @ 5 + tm bounds center]. tm lock. ^ answer! ----- Method: AlignmentMorphBob1>>fullDrawOn: (in category 'as yet unclassified') ----- fullDrawOn: aCanvas | mask | (aCanvas isVisible: self fullBounds) ifFalse:[^self]. super fullDrawOn: aCanvas. mask := self valueOfProperty: #disabledMaskColor ifAbsent: [^self]. aCanvas fillRectangle: bounds color: mask. ! ----- Method: AlignmentMorphBob1>>inAColumn: (in category 'as yet unclassified') ----- inAColumn: aCollectionOfMorphs | col | col := AlignmentMorph newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | col addMorphBack: each]. ^col! ----- Method: AlignmentMorphBob1>>inARightColumn: (in category 'as yet unclassified') ----- inARightColumn: aCollectionOfMorphs | col | col := AlignmentMorph newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #bottomRight; cellPositioning: #topCenter. aCollectionOfMorphs do: [:each | col addMorphBack: each]. ^ col! ----- Method: AlignmentMorphBob1>>inARow: (in category 'as yet unclassified') ----- inARow: aCollectionOfMorphs | row | row := AlignmentMorph newRow color: Color transparent; vResizing: #shrinkWrap; layoutInset: 2; wrapCentering: #center; cellPositioning: #leftCenter. aCollectionOfMorphs do: [:each | row addMorphBack: each]. ^ row! ----- Method: AlignmentMorphBob1>>initialize (in category 'initialization') ----- initialize super initialize. self listDirection: #topToBottom. self layoutInset: 0. self hResizing: #rigid. "... this is very unlikely..." self vResizing: #rigid! ----- Method: AlignmentMorphBob1>>simpleToggleButtonFor:attribute:help: (in category 'as yet unclassified') ----- simpleToggleButtonFor: target attribute: attribute help: helpText ^(EtoyUpdatingThreePhaseButtonMorph checkBox) target: target; actionSelector: #toggleChoice:; arguments: {attribute}; getSelector: #getChoice:; setBalloonText: helpText; step ! ----- Method: AlignmentMorphBob1>>wantsDroppedMorph:event: (in category 'as yet unclassified') ----- wantsDroppedMorph: aMorph event: evt | handlerForDrops | handlerForDrops := self valueOfProperty: #handlerForDrops ifAbsent: [ ^super wantsDroppedMorph: aMorph event: evt ]. ^handlerForDrops wantsDroppedMorph: aMorph event: evt in: self! AlignmentMorph subclass: #EmbeddedWorldBorderMorph instanceVariableNames: 'heights minWidth minHeight' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-AdditionalSupport'! ----- Method: EmbeddedWorldBorderMorph>>addCustomMenuItems:hand: (in category 'menus') ----- addCustomMenuItems: menu hand: aHandMorph super addCustomMenuItems: menu hand: aHandMorph. self worldIEnclose addScalingMenuItems: menu hand: aHandMorph ! ----- Method: EmbeddedWorldBorderMorph>>appViewBoxArea (in category 'boxes') ----- appViewBoxArea ^self genericBoxArea: 1 ! ----- Method: EmbeddedWorldBorderMorph>>boxesAndColorsAndSelectors (in category 'boxes') ----- boxesAndColorsAndSelectors ^{ {self zoomBoxArea. Color blue. #toggleZoom}. {self appViewBoxArea. Color yellow. #goAppView}. {self factoryViewBoxArea. Color red. #goFactoryView}. {self fullViewBoxArea. Color cyan. #goFullView}. {self normalEntryBoxArea. Color white. #goNormalProjectEntry}. }! ----- Method: EmbeddedWorldBorderMorph>>drawOn: (in category 'drawing') ----- drawOn: aCanvas super drawOn: aCanvas. self boxesAndColorsAndSelectors do: [ :each | aCanvas fillRectangle: each first fillStyle: each second ]. ! ----- Method: EmbeddedWorldBorderMorph>>extent: (in category 'geometry') ----- extent: aPoint bounds extent = aPoint ifFalse: [ self changed. bounds := bounds topLeft extent: aPoint. self myWorldChanged. ]. ! ----- Method: EmbeddedWorldBorderMorph>>factoryViewBoxArea (in category 'boxes') ----- factoryViewBoxArea ^self genericBoxArea: 2 ! ----- Method: EmbeddedWorldBorderMorph>>fullViewBoxArea (in category 'boxes') ----- fullViewBoxArea ^self genericBoxArea: 3 ! ----- Method: EmbeddedWorldBorderMorph>>genericBoxArea: (in category 'boxes') ----- genericBoxArea: countDownFromTop ^self innerBounds right @ (self top + (countDownFromTop * 2 * borderWidth)) extent: borderWidth @ borderWidth ! ----- Method: EmbeddedWorldBorderMorph>>goAppView (in category 'as yet unclassified') ----- goAppView self worldIEnclose showApplicationView ! ----- Method: EmbeddedWorldBorderMorph>>goFactoryView (in category 'as yet unclassified') ----- goFactoryView self worldIEnclose showFactoryView ! ----- Method: EmbeddedWorldBorderMorph>>goFullView (in category 'as yet unclassified') ----- goFullView self worldIEnclose showFullView ! ----- Method: EmbeddedWorldBorderMorph>>goNormalProjectEntry (in category 'as yet unclassified') ----- goNormalProjectEntry | w | w := self worldIEnclose. self delete. w project enter. ! ----- Method: EmbeddedWorldBorderMorph>>handlesMouseDown: (in category 'event handling') ----- handlesMouseDown: evt self boxesAndColorsAndSelectors do: [ :each | (each first containsPoint: evt cursorPoint) ifTrue: [^true] ]. ^false ! ----- Method: EmbeddedWorldBorderMorph>>initialize (in category 'initialization') ----- initialize super initialize. self setBalloonText: 'This is the frame of an embedded project. Click on the colored boxes: blue - expand or reduce yellow - app view red - factory view cyan - full view white - enter the project completely' translated! ----- Method: EmbeddedWorldBorderMorph>>minHeight: (in category 'layout') ----- minHeight: anInteger minHeight := anInteger! ----- Method: EmbeddedWorldBorderMorph>>minWidth: (in category 'layout') ----- minWidth: anInteger minWidth := anInteger! ----- Method: EmbeddedWorldBorderMorph>>morphicLayerNumber (in category 'WiW support') ----- morphicLayerNumber "helpful for insuring some morphs always appear in front of or behind others. smaller numbers are in front" ^20 "Embedded worlds come in front of other worlds' Project navigation morphs"! ----- Method: EmbeddedWorldBorderMorph>>mouseDown: (in category 'event handling') ----- mouseDown: evt self boxesAndColorsAndSelectors do: [ :each | (each first containsPoint: evt cursorPoint) ifTrue: [ ^self perform: each third ]. ]. ! ----- Method: EmbeddedWorldBorderMorph>>myTransformation (in category 'as yet unclassified') ----- myTransformation ^submorphs detect: [ :x | x isKindOf: TransformationMorph] ifNone: [nil] ! ----- Method: EmbeddedWorldBorderMorph>>myWorldChanged (in category 'as yet unclassified') ----- myWorldChanged | trans | trans := self myTransformation. self changed. self layoutChanged. trans ifNotNil:[ trans extentFromParent: self innerBounds extent. bounds := bounds topLeft extent: trans extent + (borderWidth * 2). ]. self changed. ! ----- Method: EmbeddedWorldBorderMorph>>normalEntryBoxArea (in category 'boxes') ----- normalEntryBoxArea ^self genericBoxArea: 4 ! ----- Method: EmbeddedWorldBorderMorph>>toggleZoom (in category 'as yet unclassified') ----- toggleZoom self bounds: ( bounds area > (Display boundingBox area * 0.9) ifTrue: [ Display extent // 4 extent: Display extent // 2. ] ifFalse: [ Display boundingBox ] ) ! ----- Method: EmbeddedWorldBorderMorph>>worldIEnclose (in category 'as yet unclassified') ----- worldIEnclose ^self myTransformation firstSubmorph "quick hack since this is the only usage pattern at the moment" ! ----- Method: EmbeddedWorldBorderMorph>>zoomBoxArea (in category 'boxes') ----- zoomBoxArea ^self genericBoxArea: 0 ! AlignmentMorph subclass: #EventRecorderMorph instanceVariableNames: 'tape state time deltaTime recHand playHand lastEvent lastDelta tapeStream saved statusLight voiceRecorder startSoundEvent recordMeter caption journalFile' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtras-AdditionalSupport'! !EventRecorderMorph commentStamp: '<historical>' prior: 0! During recording, the EventRecorder subscribes to all events of the normal morphic hand, and saves them as they occur. For replay, a second playback hand is created that reads events from the recorder and plays them back in the world. The EventRecorder began with the work of Ted Kaehler and John Malone. This was then signifcantly expanded by Leandro Caniglia and Valeria Murgia as a tutorial aid for the Morphic Wrapper project. Since that time, I have... Changed to a simple inboard array for the tape (event storage). Provided the ability to condense linear mouse movement with interpolation at replay. Made simple provisions for wrap-around of the millisecond clock. Eliminated step methods in favor of using the processEvents cycle in the playback hand. Provided a pause/resume mechanism that is capable of surviving project changes. Added the ability to spawn a simple 'play me' button that can be saved as a morph. Caused the playback hand to display its cursor double size for visibility. Integrated a voice recorder with on-the-fly compression. This currently does NOT survive project changes, not is its data stored on the tape. Right now it can only be saved by saving the entire recorder as a morph. This will be fixed by adding a startSound event at each project change. We will also convert read/write file to use saveOnFile. Added a journal file facility for recording sequences that end in a crash. The above two features can be engaged via the ER's morph menu. - Dan Ingalls 3/6/99! ----- Method: EventRecorderMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin "Answer a description for use in a parts bin" ^ self partName: 'Event Recorder' categories: #(Presentation Tools) documentation: 'Lets you record and play back interactions'! ----- Method: EventRecorderMorph class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') ----- fileReaderServicesForFile: fullName suffix: suffix ^(suffix = 'tape') | (suffix = '*') ifTrue: [ self services] ifFalse: [#()] ! ----- Method: EventRecorderMorph class>>fromFileNamed: (in category 'instance creation') ----- fromFileNamed: aFileName | file answer | file := FileStream readOnlyFileNamed: aFileName. answer := self readFrom: file setConverterForCode. file close. ^ answer! ----- Method: EventRecorderMorph class>>initialize (in category 'class initialization') ----- initialize FileList registerFileReader: self! ----- Method: EventRecorderMorph class>>openTapeFromFile: (in category 'instance creation') ----- openTapeFromFile: fullName "Open an eventRecorder tape for playback." (self new) readTape: fullName; openInWorld! ----- Method: EventRecorderMorph class>>readFrom: (in category 'instance creation') ----- readFrom: aStream ^ self new readFrom: aStream! ----- Method: EventRecorderMorph class>>services (in category 'fileIn/Out') ----- services ^{SimpleServiceEntry provider: self label: 'open for playback' selector: #openTapeFromFile:.} ! ----- Method: EventRecorderMorph class>>unload (in category 'initialize-release') ----- unload FileList unregisterFileReader: self ! ----- Method: EventRecorderMorph>>addButtons (in category 'initialization') ----- addButtons | r b | caption ifNotNil: ["Special setup for play-only interface" (r := self makeARowForButtons) addMorphBack: (SimpleButtonMorph new target: self; label: caption; actionSelector: #play); addMorphBack: self makeASpacer; addMorphBack: self makeStatusLight; addMorphBack: self makeASpacer. ^ self addMorphBack: r ]. (r := self makeARowForButtons) addMorphBack: (b := self buttonFor: {#record. nil. 'Begin recording'}); addMorphBack: self makeASpacer; addMorphBack: (self buttonFor: {#stop. b width. 'Stop recording - you can also use the ESC key to stop it'}); addMorphBack: self makeASpacer; addMorphBack: (self buttonFor: {#play. b width. 'Play current recording'}). self addMorphBack: r. (r := self makeARowForButtons) addMorphBack: (b := self buttonFor: {#writeTape. nil. 'Save current recording on disk'}); addMorphBack: self makeASpacer; addMorphBack: (self buttonFor: {#readTape. b width. 'Get a new recording from disk'}). self addMorphBack: r. (r := self makeARowForButtons) addMorphBack: (b := self buttonFor: {#shrink. nil. 'Make recording shorter by removing unneeded events'}); addMorphBack: self makeASpacer; addMorphBack: self makeStatusLight; addMorphBack: self makeASpacer; addMorphBack: (self buttonFor: {#button. b width. 'Make a simple button to play this recording'}). self addMorph: r. self setStatusLight: #ready.! ----- Method: EventRecorderMorph>>addCustomMenuItems:hand: (in category 'initialization') ----- addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'add voice controls' translated action: #addVoiceControls. aCustomMenu add: 'add journal file' translated action: #addJournalFile. ! ----- Method: EventRecorderMorph>>addJournalFile (in category 'initialization') ----- addJournalFile "In case there is a chance of not regaining control to stop recording and save a file, the EventRecorder can write directly to file as it is recording. This is useful for capturing a sequence that results in a nasty crash." journalFile ifNotNil: [journalFile close]. journalFile := FileStream newFileNamed: 'EventRecorder.tape'. journalFile nextPutAll:'Event Tape v1 ASCII'; cr.! ----- Method: EventRecorderMorph>>button (in category 'commands') ----- button "Make a simple button interface for replay only" | butnCaption erm | butnCaption := UIManager default request: 'Caption for this butn?' translated initialAnswer: 'play' translated. butnCaption isEmpty ifTrue: [^ self]. erm := (EventRecorderMorph basicNew caption: butnCaption voiceRecorder: voiceRecorder copy tape: tape) initialize. self world primaryHand attachMorph: erm! ----- Method: EventRecorderMorph>>button: (in category 'accessing') ----- button: label ^ self allMorphs detect: [:one | (one isKindOf: SimpleButtonMorph) and: [one label = label]] ifNone: []! ----- Method: EventRecorderMorph>>buttonFor: (in category 'initialization') ----- buttonFor: data | b | b := SimpleButtonMorph new target: self; label: data first asString translated; actionSelector: data first. data second ifNotNil: [b width < data second ifTrue: [b width: data second]]. data third ifNotNil: [b setBalloonText: data third translated]. ^b! ----- Method: EventRecorderMorph>>caption:voiceRecorder:tape: (in category 'initialization') ----- caption: butnCaption voiceRecorder: butnRecorder tape: butnTape caption := butnCaption. voiceRecorder := butnRecorder. tape := butnTape! ----- Method: EventRecorderMorph>>checkTape (in category 'fileIn/Out') ----- checkTape "See if this tape was already converted to the new format" tape ifNil: [^self]. tape isEmpty ifTrue: [^self]. (tape first isKindOf: Association) ifTrue: [tape := self convertV0Tape: tape]! ----- Method: EventRecorderMorph>>condense (in category 'commands') ----- condense "Shorten the tape by deleting mouseMove events that can just as well be interpolated later at playback time." "e1, e2, and e3 are three consecutive events on the tape. t1, t2, and t3 are the associated time steps for each of them." | e1 e2 t1 t2 e3 t3 | tape := Array streamContents: [:tStream | e1 := e2 := e3 := nil. t1 := t2 := t3 := nil. 1 to: tape size do: [:i | e1 := e2. t1 := t2. e2 := e3. t2 := t3. e3 := tape at: i. t3 := e3 timeStamp. ((e1 notNil and: [e2 type == #mouseMove & (e1 type == #mouseMove or: [e3 type == #mouseMove])]) and: ["Middle point within 3 pixels of mean of outer two" e2 position onLineFrom: e1 position to: e3 position within: 2.5]) ifTrue: ["Delete middle mouse move event. Absorb its time into e3" e2 := e1. t2 := t1] ifFalse: [e1 ifNotNil: [tStream nextPut: (e1 copy setTimeStamp: t1)]]]. e2 ifNotNil: [tStream nextPut: (e2 copy setTimeStamp: t2)]. e3 ifNotNil: [tStream nextPut: (e3 copy setTimeStamp: t3)]]! ----- Method: EventRecorderMorph>>convertV0Tape: (in category 'fileIn/Out') ----- convertV0Tape: anArray "Convert the tape into the new format" | lastKey evt | lastKey := 0. ^anArray collect:[:assn| evt := assn value. evt setTimeStamp: (lastKey := lastKey + assn key). evt]! ----- Method: EventRecorderMorph>>defaultBorderColor (in category 'initialization') ----- defaultBorderColor "answer the default border color/fill style for the receiver" ^ #raised! ----- Method: EventRecorderMorph>>defaultBorderWidth (in category 'initialization') ----- defaultBorderWidth "answer the default border width for the receiver" ^ 2! ----- Method: EventRecorderMorph>>defaultColor (in category 'initialization') ----- defaultColor "answer the default color/fill style for the receiver" ^ Color red! ----- Method: EventRecorderMorph>>handleListenEvent: (in category 'events-processing') ----- handleListenEvent: anEvent "Record the given event" (state == #record and:[anEvent hand == recHand]) ifFalse:[^self]. anEvent = lastEvent ifTrue: [^ self]. (anEvent isKeyboard and:[anEvent keyValue = 27 "esc"]) ifTrue: [^ self stop]. time := anEvent timeStamp. tapeStream nextPut: (anEvent copy setHand: nil). journalFile ifNotNil: [journalFile store: anEvent; cr; flush]. lastEvent := anEvent.! ----- Method: EventRecorderMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" super initialize. "" saved := true. self listDirection: #topToBottom; wrapCentering: #center; cellPositioning: #topCenter; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 2; minCellSize: 4; addButtons! ----- Method: EventRecorderMorph>>makeARowForButtons (in category 'initialization') ----- makeARowForButtons ^AlignmentMorph newRow vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; minCellSize: 4; color: Color blue! ----- Method: EventRecorderMorph>>makeASpacer (in category 'initialization') ----- makeASpacer ^AlignmentMorph newSpacer: Color transparent! ----- Method: EventRecorderMorph>>makeStatusLight (in category 'initialization') ----- makeStatusLight ^statusLight := EllipseMorph new extent: 11 @ 11; color: Color green; borderWidth: 0! ----- Method: EventRecorderMorph>>nextEventToPlay (in category 'event handling') ----- nextEventToPlay "Return the next event when it is time to be replayed. If it is not yet time, then return an interpolated mouseMove. Return nil if nothing has happened. Return an EOF event if there are no more events to be played." | nextEvent now nextTime lastP delta | (tapeStream isNil or:[tapeStream atEnd]) ifTrue:[^MorphicUnknownEvent new setType: #EOF argument: nil]. now := Time millisecondClockValue. nextEvent := tapeStream next. "nextEvent isKeyboard ifTrue: [ nextEvent setPosition: self position ]." deltaTime ifNil:[deltaTime := now - nextEvent timeStamp]. nextTime := nextEvent timeStamp + deltaTime. now < time ifTrue:["clock rollover" time := now. deltaTime := nil. ^nil "continue it on next cycle"]. time := now. (now >= nextTime) ifTrue:[ nextEvent := nextEvent copy setTimeStamp: nextTime. nextEvent isMouse ifTrue:[lastEvent := nextEvent] ifFalse:[lastEvent := nil]. ^nextEvent]. tapeStream skip: -1. "Not time for the next event yet, but interpolate the mouse. This allows tapes to be compressed when velocity is fairly constant." lastEvent ifNil: [^ nil]. lastP := lastEvent position. delta := (nextEvent position - lastP) * (now - lastEvent timeStamp) // (nextTime - lastEvent timeStamp). delta = lastDelta ifTrue: [^ nil]. "No movement" lastDelta := delta. ^MouseMoveEvent new setType: #mouseMove startPoint: lastEvent position endPoint: lastP + delta trail: #() buttons: lastEvent buttons hand: nil stamp: now.! ----- Method: EventRecorderMorph>>pauseIn: (in category 'pause/resume') ----- pauseIn: aWorld "Suspend playing or recording, either as part of a stop command, or as part of a project switch, after which it will be resumed." self setStatusLight: #ready. state = #play ifTrue: [state := #suspendedPlay. playHand delete. aWorld removeHand: playHand. playHand := nil]. state = #record ifTrue: [state := #suspendedRecord. recHand removeEventListener: self. recHand := nil]. voiceRecorder ifNotNil: [voiceRecorder pause. startSoundEvent ifNotNil: [startSoundEvent argument: voiceRecorder recordedSound. voiceRecorder clearRecordedSound. startSoundEvent := nil]]. ! ----- Method: EventRecorderMorph>>play (in category 'commands') ----- play self isInWorld ifFalse: [^ self]. self stop. tape ifNil: [^ self]. tapeStream := ReadStream on: tape. self resumePlayIn: self world. self setStatusLight: #nowPlaying. ! ----- Method: EventRecorderMorph>>readFrom: (in category 'fileIn/Out') ----- readFrom: aStream "Private" | cr header | cr := Character cr. header := aStream upTo: cr. (header = 'Event Tape v1 BINARY') ifTrue:[^aStream fileInObjectAndCode]. (header = 'Event Tape v1 ASCII') ifTrue:[^self readFromV1: aStream]. "V0 had no header so guess" aStream reset. header first isDigit ifFalse:[^self convertV0Tape: (aStream fileInObjectAndCode)]. ^self convertV0Tape: (self readFromV0: aStream). ! ----- Method: EventRecorderMorph>>readFromV0: (in category 'fileIn/Out') ----- readFromV0: aStream | cr line lineStream t evt | cr := Character cr. ^Array streamContents:[:tStream | [aStream atEnd] whileFalse: [line := aStream upTo: cr. line isEmpty "Some MW tapes have an empty record at the end" ifFalse: [lineStream := ReadStream on: line. t := Integer readFrom: lineStream. [lineStream peek isLetter] whileFalse: [lineStream next]. evt := MorphicEvent readFromObsolete: lineStream. tStream nextPut: t -> evt]]].! ----- Method: EventRecorderMorph>>readFromV1: (in category 'fileIn/Out') ----- readFromV1: aStream | cr | cr := Character cr. ^Array streamContents:[:tStream | [aStream atEnd] whileFalse:[ tStream nextPut: (MorphicEvent readFromString: (aStream upTo: cr))]]! ----- Method: EventRecorderMorph>>readTape (in category 'fileIn/Out') ----- readTape ^ self readTape: (UIManager default request: 'Tape to read' initialAnswer: 'tapeName.tape').! ----- Method: EventRecorderMorph>>readTape: (in category 'fileIn/Out') ----- readTape: fileName | file | self writeCheck. (FileStream isAFileNamed: fileName) ifFalse: [^ nil]. file := FileStream oldFileNamed: fileName. tape := self readFrom: file. file close. saved := true "Still exists on file"! ----- Method: EventRecorderMorph>>record (in category 'commands') ----- record self isInWorld ifFalse: [^ self]. self stop. self writeCheck. self addJournalFile. tapeStream := WriteStream on: (Array new: 10000). self resumeRecordIn: self world. self setStatusLight: #nowRecording. ! ----- Method: EventRecorderMorph>>resumeIn: (in category 'pause/resume') ----- resumeIn: aWorld "Resume playing or recording after a project switch." state = #suspendedPlay ifTrue: [self resumePlayIn: aWorld]. state = #suspendedRecord ifTrue: [self resumeRecordIn: aWorld]. ! ----- Method: EventRecorderMorph>>resumePlayIn: (in category 'pause/resume') ----- resumePlayIn: aWorld playHand := HandMorphForReplay new recorder: self. playHand position: tapeStream peek position. aWorld addHand: playHand. playHand newKeyboardFocus: aWorld. playHand userInitials: 'play' andPicture: nil. lastEvent := nil. lastDelta := 0@0. state := #play. self synchronize. ! ----- Method: EventRecorderMorph>>resumeRecordIn: (in category 'pause/resume') ----- resumeRecordIn: aWorld recHand := aWorld activeHand ifNil: [aWorld primaryHand]. recHand newKeyboardFocus: aWorld. recHand addEventListener: self. lastEvent := nil. state := #record. voiceRecorder ifNotNil: [voiceRecorder clearRecordedSound. voiceRecorder resumeRecording. startSoundEvent := MorphicUnknownEvent new setType: #startSound argument: nil hand: nil stamp: Time millisecondClockValue. tapeStream nextPut: startSoundEvent]. self synchronize. ! ----- Method: EventRecorderMorph>>setStatusLight: (in category 'commands') ----- setStatusLight: aSymbol aSymbol == #ready ifTrue: [ statusLight color: Color green. tape ifNil: [ statusLight setBalloonText: 'Ready to record'. ] ifNotNil: [ statusLight setBalloonText: 'Ready to record or play'. ]. ^self ]. aSymbol == #nowRecording ifTrue: [ statusLight color: Color red; setBalloonText: 'Recording is active'. ^self ]. aSymbol == #nowPlaying ifTrue: [ statusLight color: Color yellow; setBalloonText: 'Now playing'. ^self ]. ! ----- Method: EventRecorderMorph>>shrink (in category 'commands') ----- shrink "Shorten the tape by deleting mouseMove events that can just as well be interpolated later at playback time." | oldSize priorSize | self writeCheck. oldSize := priorSize := tape size. [self condense. tape size < priorSize] whileTrue: [priorSize := tape size]. self inform: ('{1} events reduced to {2}' translated format:{oldSize. tape size}). voiceRecorder ifNotNil: [voiceRecorder suppressSilence]. saved := false. ! ----- Method: EventRecorderMorph>>step (in category 'stepping and presenter') ----- step (state == #record and: [voiceRecorder notNil]) ifTrue: [ recordMeter width: (voiceRecorder meterLevel + 1). ]. ! ----- Method: EventRecorderMorph>>stepTime (in category 'testing') ----- stepTime ^500 ! ----- Method: EventRecorderMorph>>stop (in category 'stepping and presenter') ----- stop state = #record ifTrue: [tape := tapeStream contents. saved := false]. journalFile ifNotNil: [journalFile close]. self pauseIn: self world. tapeStream := nil. state := nil. self setStatusLight: #ready. recordMeter ifNotNil: [recordMeter width: 1]. self checkTape.! ----- Method: EventRecorderMorph>>synchronize (in category 'event handling') ----- synchronize time := Time millisecondClockValue. deltaTime := nil.! ----- Method: EventRecorderMorph>>wantsSteps (in category 'testing') ----- wantsSteps ^true ! ----- Method: EventRecorderMorph>>writeCheck (in category 'fileIn/Out') ----- writeCheck (saved not and: [self confirm: 'The current tape has not been saved. Would you like to do so now?']) ifTrue: [self writeTape]. ! ----- Method: EventRecorderMorph>>writeFileNamed: (in category 'fileIn/Out') ----- writeFileNamed: fileName | file noVoice delta | file := FileStream newFileNamed: fileName. noVoice := true. tape do:[:evt | evt type = #startSound ifTrue: [noVoice := false]]. noVoice ifTrue: ["Simple format (reads fast) for no voice" file nextPutAll:'Event Tape v1 ASCII'; cr. delta := tape first timeStamp. tape do: [:evt | file store: (evt copy setTimeStamp: evt timeStamp-delta); cr]. file close] ifFalse: ["Inclusion of voice events requires general object storage" file nextPutAll:'Event Tape v1 BINARY'; cr. file fileOutClass: nil andObject: tape]. saved := true. ^ file name! ----- Method: EventRecorderMorph>>writeTape (in category 'fileIn/Out') ----- writeTape | args b | args := (b := self button: 'writeTape') isNil ifTrue: [#()] ifFalse: [b arguments]. (args notEmpty and: [args first notEmpty]) ifTrue: [args first. self writeTape: args first] ifFalse: [^self writeTape: (UIManager default request: 'Tape to write' initialAnswer: 'tapeName.tape')].! ----- Method: EventRecorderMorph>>writeTape: (in category 'fileIn/Out') ----- writeTape: fileName | b name | name := self writeFileNamed: fileName. (b := self button: 'writeTape') ifNotNil: [ b actionSelector: #writeTape:. b arguments: (Array with: name)]. !

1 0

The Trunk: MorphicExtras-AdditionalSupport-edc.1.mcz
by commits＠source.squeak.org 01 Sep '09

01 Sep '09

1 0

The Trunk: MorphicExtras-Demo-edc.1.mcz
by commits＠source.squeak.org 01 Sep '09

01 Sep '09

1 0

Jump to page: