13 Jan '09
A new version of Tasks-Squeak310 was added to project Tasks:
http://www.squeaksource.com/Tasks/Tasks-Squeak310-kph.63.mcz
==================== Summary ====================
Name: Tasks-Squeak310-kph.63
Author: test
Time: 13 January 2009, 10:38:23 pm
UUID: 481ab23e-3953-4f91-91a3-4eca3441cfdb
Ancestors: Tasks-Squeak310-kph.62
upgrade Nebraska and MorphicBooks in 3.10.2bc to unloadable versions
=============== Diff against Tasks-Squeak310-kph.62 ===============
Item was changed:
----- Method: Squeak310MakeBuildCandidate class>>taskUpgradePackages (in category 'as yet unclassified') -----
taskUpgradePackages
^ {
[
(Packages current named: 'Monticello15') addToPackageInfo.
(Packages current named: 'Sake') addToPackageInfo.
(Packages current named: 'Packages') addToPackageInfo.
+
- [WorldState organization classify: #remoteCanvasesDo: under: '*morphicextras-nebraska compatible'].
].
Packages current named: 'SUnitGUI-improved'.
Packages current named: 'Universes'.
Packages current named: 'SqueakMap2 loader'.
Packages current named: 'Nebraska'.
Packages current named: 'MorphicBooks'.
} asTask
!
1
0
13 Jan '09
A new version of Packages-Library was added to project Packages:
http://www.squeaksource.com/Packages/Packages-Library-kph.27.mcz
==================== Summary ====================
Name: Packages-Library-kph.27
Author: test
Time: 13 January 2009, 10:33:10 pm
UUID: 8202d6c4-9cdc-480d-88fa-9994e278aa9b
Ancestors: Packages-Library-kph.26
Added MorphicBooks a load/unloadable package for BookMorph and Friends
=============== Diff against Packages-Library-kph.26 ===============
Item was changed:
+ ----- Method: PackagesDev>>Nebraska (in category 'Morphic') -----
- ----- Method: PackagesDev>>Nebraska (in category 'System') -----
Nebraska
self name: 'Nebraska'.
info category: 'Morphic'.
info description:
'Nebraska load/unload'.
info maintainer: 'kph'.
+ self version: '14'.
- self version: '0.14'.
self load: [
(WorldState respondsTo: #remoteCanvasesDo:) ifTrue: [
WorldState organization classify: #remoteCanvasessDo: under: '*morphicextras-nebraska compatible'.
].
Installer squeaksource project: '311' ; install: 'Nebraska-kph.14'.
].
!
Item was added:
+ ----- Method: PackagesDev>>MorphicBooks (in category 'Morphic') -----
+ MorphicBooks
+
+ self name: 'MorphicBooks'.
+ info category: 'Morphic'.
+ info description:
+ 'Unloadable version of Bookmorph and friends'.
+ info maintainer: 'kph'.
+
+ self version: '1'.
+
+ self info url: 'http://www.squeaksource.com/311/MorphicBooks-kph.1.mcz'.
+
+ !
1
0
13 Jan '09
A new version of Packages-Library was added to project Packages:
http://www.squeaksource.com/Packages/Packages-Library-kph.26.mcz
==================== Summary ====================
Name: Packages-Library-kph.26
Author: test
Time: 13 January 2009, 10:27:20 pm
UUID: b2ca5824-3026-4d80-a194-02220bceef8f
Ancestors: Packages-Library-kph.25
Added package Nebraska, load into any image that has Nebraska, and then it will be unloadable.
=============== Diff against Packages-Library-kph.25 ===============
Item was added:
+ ----- Method: PackagesDev>>Nebraska (in category 'System') -----
+ Nebraska
+
+ self name: 'Nebraska'.
+ info category: 'Morphic'.
+ info description:
+ 'Nebraska load/unload'.
+ info maintainer: 'kph'.
+
+ self version: '0.14'.
+
+ self load: [
+ (WorldState respondsTo: #remoteCanvasesDo:) ifTrue: [
+ WorldState organization classify: #remoteCanvasessDo: under: '*morphicextras-nebraska compatible'.
+ ].
+ Installer squeaksource project: '311' ; install: 'Nebraska-kph.14'.
+ ].
+ !
1
0
13 Jan '09
A new version of Tasks-Squeak310 was added to project Tasks:
http://www.squeaksource.com/Tasks/Tasks-Squeak310-kph.62.mcz
==================== Summary ====================
Name: Tasks-Squeak310-kph.62
Author: test
Time: 13 January 2009, 8:45:03 pm
UUID: 221dee11-436a-4437-a0b6-0a5e11baca7c
Ancestors: Tasks-Squeak310-kph.61
added reorg of Nebraska and MorphicBooks to 3.10.2bc
=============== Diff against Tasks-Squeak310-kph.61 ===============
Item was changed:
----- Method: Squeak310MakeBuildCandidate class>>taskUpgradePackages (in category 'as yet unclassified') -----
taskUpgradePackages
^ {
[
(Packages current named: 'Monticello15') addToPackageInfo.
(Packages current named: 'Sake') addToPackageInfo.
(Packages current named: 'Packages') addToPackageInfo.
+ [WorldState organization classify: #remoteCanvasesDo: under: '*morphicextras-nebraska compatible'].
].
Packages current named: 'SUnitGUI-improved'.
Packages current named: 'Universes'.
Packages current named: 'SqueakMap2 loader'.
+ Packages current named: 'Nebraska'.
+ Packages current named: 'MorphicBooks'.
-
} asTask
!
1
0
13 Jan '09
A new version of Tasks-Squeak310 was added to project Tasks:
http://www.squeaksource.com/Tasks/Tasks-Squeak310-kph.61.mcz
==================== Summary ====================
Name: Tasks-Squeak310-kph.61
Author: test
Time: 13 January 2009, 8:30:50 pm
UUID: 7e691805-aea7-4ab5-91d1-d8f6a3da518a
Ancestors: Tasks-Squeak310-test.60
before fixing update Nebraska and MorphicBooks to their new organisation (i.e. so that they are able to be removed)
=============== Diff against Tasks-Squeak310-test.60 ===============
Item was changed:
----- Method: ReleaseAfterSqueak310 class>>taskReorganizeCategories (in category 'as yet unclassified') -----
taskReorganizeCategories
^ self define: [ :task |
task dependsOn: {
"reorganize Kernel-Object"
self category: 'MorphicExtras-SqueakPage' classes: #ObjectOut.
self category: 'Kernel-Tracer' classes: #(ObjectTracer ObjectViewer).
self category: 'Kernel-Model' classes: #(Model DependantsArray MessageSend WeakMessageSend).
self category: 'Kernel-Model-Tests' classes: #(DependentsArrayTest WeakMessageSendTest).
self category: 'Kernel-Objects' classes: #(Null). "note: (Packages unload: 'Null) will stil remove it cleanly"
self category: 'Kernel-Classes' classes: #SharedPool.
self category: 'CollectionsTests-Sequenceable' classes: #SequenceableCollectionJoinSplitTest.
self category: 'Tools-Inspector-Tests' classes: #WeakSetInspectorTest.
self category: 'KernelTests-Chronology' classes: #DateAndTimeClockTest.
+
}.
task action: [
SystemOrganization removeEmptyCategories.
SystemOrganization renameCategory: 'KernelTests-Chronology' toBe: 'Kernel-Chronology-Tests'.
SystemOrganization renameCategory: 'KernelTests-Classes' toBe: 'Kernel-Classes-Tests'.
SystemOrganization renameCategory: 'KernelTests-Methods' toBe: 'Kernel-Methods-Tests'.
SystemOrganization renameCategory: 'KernelTests-Numbers' toBe: 'Kernel-Numbers-Tests'.
SystemOrganization renameCategory: 'KernelTests-Objects' toBe: 'Kernel-Objects-Tests'.
SystemOrganization renameCategory: 'KernelTests-Processes' toBe: 'Kernel-Processes-Tests'.
SystemOrganization renameCategory: 'KernelTests-Contexts' toBe: 'Kernel-Contexts-Tests'.
SystemOrganization renameCategory: 'CollectionsTests-Abstract' toBe: 'Collections-Abstract-Tests'.
SystemOrganization renameCategory: 'CollectionsTests-Arrayed' toBe: 'Collections-Arrayed-Tests'.
SystemOrganization renameCategory: 'CollectionsTests-Sequenceable' toBe: 'Collections-Sequenceable-Tests'.
SystemOrganization renameCategory: 'CollectionsTests-SkipLists' toBe: 'Collections-SkipLists-Tests'.
SystemOrganization renameCategory: 'CollectionsTests-Stack' toBe: 'Collections-Stack-Tests'.
SystemOrganization renameCategory: 'CollectionsTests-Streams' toBe: 'Collections-Streams-Tests'.
SystemOrganization renameCategory: 'CollectionsTests-Support' toBe: 'Collections-Support-Tests'.
SystemOrganization renameCategory: 'CollectionsTests-Text' toBe: 'Collections-Text-Tests'.
SystemOrganization renameCategory: 'CollectionsTests-Unordered' toBe: 'Collections-Unordered-Tests'.
SystemOrganization renameCategory: 'CollectionsTests-Weak' toBe: 'Collections-Weak-Tests'.
SystemOrganization renameCategory: 'GraphicsTests-Primitives' toBe: 'Graphics-Primitives-Tests'.
SystemOrganization renameCategory: 'GraphicsTests-Text' toBe: 'Graphics-Text-Tests'.
SystemOrganization renameCategory: 'GraphicsTests-Files' toBe: 'Graphics-Files-Tests'.
SystemOrganization renameCategory: 'MorphicTests-Basic' toBe: 'Morphic-Basic-Tests'.
SystemOrganization renameCategory: 'MorphicTests-Kernel' toBe: 'Morphic-Kernel-Tests'.
SystemOrganization renameCategory: 'MorphicTests-Text Support' toBe: 'Morphic-Text Support-Tests'.
SystemOrganization renameCategory: 'MorphicTests-Widgets' toBe: 'Morphic-Widgets-Tests'.
SystemOrganization renameCategory: 'MorphicTests-Worlds' toBe: 'Morphic-Worlds-Tests'.
SystemOrganization renameCategory: 'NetworkTests-Kernel' toBe: 'Network-Kernel-Tests'.
SystemOrganization renameCategory: 'NetworkTests-Protocols' toBe: 'Network-Protocols-Tests'.
SystemOrganization renameCategory: 'NetworkTests-RFC822' toBe: 'Network-RFC822-Tests'.
SystemOrganization renameCategory: 'NetworkTests-UUID' toBe: 'Network-UUID-Tests'.
SystemOrganization renameCategory: 'NetworkTests-Url' toBe: 'Network-Url-Tests'.
SystemOrganization renameCategory: 'NetworkTests-URI' toBe: 'Network-URI-Tests'.
SystemOrganization renameCategory: 'SystemChangeNotification-Tests' toBe: 'System-Change Notification-Tests'.
SystemOrganization classifyAll: #(AbstractMediaEventMorph ColorSwatch) under: 'MorphicExtras-AdditionalSupport'.
SystemOrganization removeCategoriesMatching: 'UserObjects'.
SystemOrganization sortCategories.
]
].!
Item was changed:
----- Method: ReleaseAfterSqueak310 class>>taskTESTCANDIDATE (in category 'as yet unclassified') -----
taskTESTCANDIDATE
^ self define: [ :task |
task dependsOn: { self taskBuildCandidate }.
task action: {
+ self taskUpgradePackages.
self taskKernelImports. "in BC?"
"
self taskBugFixes.
self taskDocumentFixes.
"
self taskReorganizeCategories.
self taskReorganizePackages.
self taskCleanDeprecated.
self taskCleanMiscellaneous.
self taskMarkNewlyDeprecated.
self taskCleanExcess.
self taskCleanUp.
self taskFinalize.
}.
].
!
Item was changed:
----- Method: ManualFixesTemp class>>fixesKernelStreams (in category 'as yet unclassified') -----
fixesKernelStreams
^ self dependingOn: {
- self fixOneDay: '0007167: ReadWriteStream opened with on: aCollection always has readLimit 0'.
}!
Item was added:
+ ----- Method: ReleaseAfterSqueak310 class>>taskUpgradePackages (in category 'as yet unclassified') -----
+ taskUpgradePackages
+
+ ^ {
+
+ Packages current named: 'Nebraska'.
+ Packages current named: 'MorphicBooks'.
+
+ } asTask
+ !
Item was removed:
- ----- Method: ManualFixesTemp class>>fixesKernelChronology (in category 'as yet unclassified') -----
- fixesKernelChronology
-
- ^ self dependingOn: {
-
- '474 Millisecond clock'.
- '6805 Seconds as fraction'.
-
- }!
1
0
Squeak3.11 Contributions: MorphicBooks-kph.1.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 13 Jan '09
by squeak-dev-noreply＠lists.squeakfoundation.org 13 Jan '09
13 Jan '09
A new version of MorphicBooks was added to project Squeak3.11 Contributions:
http://www.squeaksource.com/311/MorphicBooks-kph.1.mcz
==================== Summary ====================
Name: MorphicBooks-kph.1
Author: test
Time: 13 January 2009, 8:25:12 pm
UUID: 74927989-64fc-4fd4-b070-dc3c8e565033
Ancestors:
==================== Snapshot ====================
SystemOrganization addCategory: #MorphicBooks!
SketchMorph subclass: #BookPageThumbnailMorph
instanceVariableNames: 'page pageNumber bookMorph flipOnClick'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicBooks'!
!BookPageThumbnailMorph commentStamp: '<historical>' prior: 0!
A small picture representing a page of a BookMorph here or somewhere else. When clicked, make that book turn to the page and do a visual effect and a noise.
page either the morph of the page, or a url
pageNumber
bookMorph either the book, or a url
flipOnClick!
----- Method: BookPageThumbnailMorph>>addCustomMenuItems:hand: (in category 'menus') -----
addCustomMenuItems: aCustomMenu hand: aHandMorph
super addCustomMenuItems: aCustomMenu hand: aHandMorph.
aCustomMenu addLine.
aCustomMenu add: 'make a flex morph' translated selector: #makeFlexMorphFor: argument: aHandMorph.
flipOnClick
ifTrue: [aCustomMenu add: 'disable bookmark action' translated action: #toggleBookmark]
ifFalse: [aCustomMenu add: 'enable bookmark action' translated action: #toggleBookmark].
(bookMorph isKindOf: BookMorph)
ifTrue:
[aCustomMenu add: 'set page sound' translated action: #setPageSound:.
aCustomMenu add: 'set page visual' translated action: #setPageVisual:]
!
----- Method: BookPageThumbnailMorph>>bookMorph (in category 'as yet unclassified') -----
bookMorph
^bookMorph!
----- Method: BookPageThumbnailMorph>>computeThumbnail (in category 'as yet unclassified') -----
computeThumbnail
| f scale |
self objectsInMemory.
f _ page imageForm.
scale _ (self height / f height). "keep height invariant"
"(Sensor shiftPressed) ifTrue: [scale _ scale * 1.4]."
self form: (f magnify: f boundingBox by: scale@scale smoothing: 2).
!
----- Method: BookPageThumbnailMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color lightGray!
----- Method: BookPageThumbnailMorph>>doPageFlip (in category 'as yet unclassified') -----
doPageFlip
"Flip to this page"
self objectsInMemory.
bookMorph ifNil: [^ self].
bookMorph goToPageMorph: page
transitionSpec: (self valueOfProperty: #transitionSpec).
(owner isKindOf: PasteUpMorph) ifTrue:
[owner cursor: (owner submorphs indexOf: self ifAbsent: [1])]!
----- Method: BookPageThumbnailMorph>>handlesMouseDown: (in category 'event handling') -----
handlesMouseDown: event
^ event shiftPressed or: [flipOnClick and: [event controlKeyPressed not]]!
----- Method: BookPageThumbnailMorph>>inBook: (in category 'as yet unclassified') -----
inBook: book
bookMorph _ book!
----- Method: BookPageThumbnailMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
| f |
super initialize.
""
flipOnClick _ false.
f _ Form extent: 60 @ 80 depth: Display depth.
f fill: f boundingBox fillColor: color.
self form: f!
----- Method: BookPageThumbnailMorph>>makeFlexMorphFor: (in category 'as yet unclassified') -----
makeFlexMorphFor: aHand
aHand grabMorph: (FlexMorph new originalMorph: page)!
----- Method: BookPageThumbnailMorph>>mouseDown: (in category 'event handling') -----
mouseDown: event
"turn the book to that page"
"May need to lie to it so mouseUp won't go to menu that may come up during fetch of a page in doPageFlip. (Is this really true? --tk)"
self doPageFlip.
!
----- Method: BookPageThumbnailMorph>>objectForDataStream: (in category 'fileIn/Out') -----
objectForDataStream: refStrm
"I am about to be written on an object file. It would be bad to write a whole BookMorph out. Store a string that is the url of the book or page in my inst var."
| clone bookUrl bb stem ind |
(bookMorph isString) & (page isString) ifTrue: [
^ super objectForDataStream: refStrm].
(bookMorph isNil) & (page isString) ifTrue: [
^ super objectForDataStream: refStrm].
(bookMorph isNil) & (page url notNil) ifTrue: [
^ super objectForDataStream: refStrm].
(bookMorph isNil) & (page url isNil) ifTrue: [
self error: 'page should already have a url' translated.
"find page's book, and remember it"
"bookMorph _ "].
clone _ self clone.
(bookUrl _ bookMorph url)
ifNil: [bookUrl _ self valueOfProperty: #futureUrl].
bookUrl
ifNil: [ bb _ RectangleMorph new. "write out a dummy"
bb bounds: bounds.
refStrm replace: self with: bb.
^ bb]
ifNotNil: [clone instVarNamed: 'bookMorph' put: bookUrl].
page url ifNil: [
"Need to assign a url to a page that will be written later.
It might have bookmarks too. Don't want to recurse deeply.
Have that page write out a dummy morph to save its url on the server."
stem _ SqueakPage stemUrl: bookUrl.
ind _ bookMorph pages identityIndexOf: page.
page reserveUrl: stem,(ind printString),'.sp'].
clone instVarNamed: 'page' put: page url.
refStrm replace: self with: clone.
^ clone!
----- Method: BookPageThumbnailMorph>>objectsInMemory (in category 'fileIn/Out') -----
objectsInMemory
"See if page or bookMorph need to be brought in from a server."
| bookUrl bk wld try |
bookMorph ifNil: ["fetch the page"
page isString ifFalse: [^ self]. "a morph"
try _ (SqueakPageCache atURL: page) fetchContents.
try ifNotNil: [page _ try].
^ self].
bookMorph isString ifTrue: [
bookUrl _ bookMorph.
(wld _ self world) ifNil: [wld _ Smalltalk currentWorld].
bk _ BookMorph isInWorld: wld withUrl: bookUrl.
bk == #conflict ifTrue: [
^ self inform: 'This book is already open in some other project' translated].
bk == #out ifTrue: [
(bk _ BookMorph new fromURL: bookUrl) ifNil: [^ self]].
bookMorph _ bk].
page isString ifTrue: [
page _ (bookMorph pages detect: [:pg | pg url = page]
ifNone: [bookMorph pages first])].
!
----- Method: BookPageThumbnailMorph>>page (in category 'as yet unclassified') -----
page
^ page
!
----- Method: BookPageThumbnailMorph>>page: (in category 'as yet unclassified') -----
page: aMorph
page _ aMorph.
self computeThumbnail.
self setNameTo: aMorph externalName.
page fullReleaseCachedState.
!
----- Method: BookPageThumbnailMorph>>pageMorph:inBook: (in category 'as yet unclassified') -----
pageMorph: pageMorph inBook: book
page _ pageMorph.
bookMorph _ book!
----- Method: BookPageThumbnailMorph>>pageNumber:inBook: (in category 'as yet unclassified') -----
pageNumber: n inBook: b
pageNumber _ n.
bookMorph _ b!
----- Method: BookPageThumbnailMorph>>setPageSound: (in category 'as yet unclassified') -----
setPageSound: event
^ bookMorph menuPageSoundFor: self event: event!
----- Method: BookPageThumbnailMorph>>setPageVisual: (in category 'as yet unclassified') -----
setPageVisual: event
^ bookMorph menuPageVisualFor: self event: event!
----- Method: BookPageThumbnailMorph>>smaller (in category 'as yet unclassified') -----
smaller
self form: (self form copy: (0@0 extent: self form extent//2)).
!
----- Method: BookPageThumbnailMorph>>toggleBookmark (in category 'as yet unclassified') -----
toggleBookmark
"Enable or disable sensitivity as a bookmark
enabled means that a normal click will cause a pageFlip
disabled means this morph can be picked up normally by the hand."
flipOnClick _ flipOnClick not!
----- Method: BookPageThumbnailMorph>>veryDeepFixupWith: (in category 'copying') -----
veryDeepFixupWith: deepCopier
"If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
super veryDeepFixupWith: deepCopier.
page _ deepCopier references at: page ifAbsent: [page].
bookMorph _ deepCopier references at: bookMorph ifAbsent: [bookMorph].
!
----- Method: BookPageThumbnailMorph>>veryDeepInner: (in category 'copying') -----
veryDeepInner: deepCopier
"Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
super veryDeepInner: deepCopier.
"page _ page. Weakly copied"
pageNumber _ pageNumber veryDeepCopyWith: deepCopier.
"bookMorph _ bookMorph. All weakly copied"
flipOnClick _ flipOnClick veryDeepCopyWith: deepCopier. !
SketchMorph subclass: #FlexMorph
instanceVariableNames: 'originalMorph borderWidth borderColor'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicBooks'!
----- Method: FlexMorph>>addCustomMenuItems:hand: (in category 'menus') -----
addCustomMenuItems: aCustomMenu hand: aHandMorph
"super addCustomMenuItems: aCustomMenu hand: aHandMorph."
aCustomMenu addLine.
aCustomMenu add: 'update from original' translated action: #updateFromOriginal.
aCustomMenu addList: {
{'border color...' translated. #changeBorderColor:}.
{'border width...' translated. #changeBorderWidth:}.
}.
aCustomMenu addLine.
!
----- Method: FlexMorph>>borderColor: (in category 'accessing') -----
borderColor: aColor
borderColor _ aColor.
self updateFromOriginal!
----- Method: FlexMorph>>borderWidth: (in category 'accessing') -----
borderWidth: width
borderWidth _ width asPoint.
self updateFromOriginal!
----- Method: FlexMorph>>changeBorderColor: (in category 'as yet unclassified') -----
changeBorderColor: evt
| aHand |
aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand].
self changeColorTarget: self selector: #borderColor: originalColor: self borderColor hand: aHand.!
----- Method: FlexMorph>>changeBorderWidth: (in category 'as yet unclassified') -----
changeBorderWidth: evt
| handle origin aHand |
aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand].
origin _ aHand position.
handle _ HandleMorph new forEachPointDo:
[:newPoint | handle removeAllMorphs.
handle addMorph:
(LineMorph from: origin to: newPoint color: Color black width: 1).
self borderWidth: (newPoint - origin) r asInteger // 5].
aHand attachMorph: handle.
handle startStepping!
----- Method: FlexMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
originalForm _ nil. "Aggressively uncache the originalForm"
^ super drawOn: aCanvas!
----- Method: FlexMorph>>extent: (in category 'geometry') -----
extent: newExtent
self loadOriginalForm. "make sure it's not nil"
^ super extent: newExtent!
----- Method: FlexMorph>>form (in category 'accessing') -----
form
self loadOriginalForm. "make sure it's not nil"
^ super form!
----- Method: FlexMorph>>generateRotatedForm (in category 'drawing') -----
generateRotatedForm
self loadOriginalForm. "make sure it's not nil"
^ super generateRotatedForm!
----- Method: FlexMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
borderWidth _ 2@2.
borderColor _ Color black.!
----- Method: FlexMorph>>layoutChanged (in category 'layout') -----
layoutChanged
self loadOriginalForm. "make sure it's not nil"
^ super layoutChanged!
----- Method: FlexMorph>>loadOriginalForm (in category 'as yet unclassified') -----
loadOriginalForm
originalForm ifNil: [self updateFromOriginal].
!
----- Method: FlexMorph>>originalMorph (in category 'as yet unclassified') -----
originalMorph
^ originalMorph!
----- Method: FlexMorph>>originalMorph: (in category 'as yet unclassified') -----
originalMorph: aMorph
originalMorph _ aMorph.
scalePoint _ 0.25(a)0.25.
self updateFromOriginal.!
----- Method: FlexMorph>>releaseCachedState (in category 'caching') -----
releaseCachedState
"Clear cache of rotated, scaled Form."
originalForm _ Form extent: 10@10. "So super hibernate won't have to work hard
but won't crash either."
super releaseCachedState.
rotatedForm _ nil.
originalForm _ nil.!
----- Method: FlexMorph>>updateFromOriginal (in category 'as yet unclassified') -----
updateFromOriginal
| intermediateForm |
intermediateForm _ originalMorph imageForm offset: 0@0.
intermediateForm border: intermediateForm boundingBox
widthRectangle: (borderWidth corner: borderWidth+1)
rule: Form over fillColor: borderColor.
self form: intermediateForm.
originalMorph fullReleaseCachedState!
SketchMorph subclass: #MorphThumbnail
instanceVariableNames: 'morphRepresented'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicBooks'!
!MorphThumbnail commentStamp: '<historical>' prior: 0!
A morph whose appearance is a thumbnail of some other morph.!
----- Method: MorphThumbnail>>addCustomMenuItems:hand: (in category 'menus') -----
addCustomMenuItems: aCustomMenu hand: aHandMorph
super addCustomMenuItems: aCustomMenu hand: aHandMorph.
aCustomMenu add: 'reveal original morph' translated action: #revealOriginal.
aCustomMenu add: 'grab original morph' translated action: #grabOriginal.
!
----- Method: MorphThumbnail>>computeThumbnail (in category 'as yet unclassified') -----
computeThumbnail
"Assumption on entry:
The receiver's width represents the maximum width allowable.
The receiver's height represents the exact height desired."
| f scaleX scaleY |
f _ morphRepresented imageForm.
morphRepresented fullReleaseCachedState.
scaleY _ self height / f height. "keep height invariant"
scaleX _ ((morphRepresented width * scaleY) <= self width)
ifTrue:
[scaleY] "the usual case; same scale factor, to preserve aspect ratio"
ifFalse:
[self width / f width].
self form: (f magnify: f boundingBox by: (scaleX @ scaleY) smoothing: 2).
self extent: originalForm extent!
----- Method: MorphThumbnail>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color lightGray!
----- Method: MorphThumbnail>>grabOriginal (in category 'as yet unclassified') -----
grabOriginal
self primaryHand attachMorph: morphRepresented!
----- Method: MorphThumbnail>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
| f |
super initialize.
""
f _ Form extent: 60 @ 80 depth: Display depth.
f fill: f boundingBox fillColor: color.
self form: f!
----- Method: MorphThumbnail>>innocuousName (in category 'naming') -----
innocuousName
^ morphRepresented isNil
ifTrue: [super innocuousName]
ifFalse: [morphRepresented innocuousName]!
----- Method: MorphThumbnail>>isPartsDonor (in category 'parts bin') -----
isPartsDonor
"answer whether the receiver is PartsDonor"
^ self partRepresented isPartsDonor!
----- Method: MorphThumbnail>>isPartsDonor: (in category 'parts bin') -----
isPartsDonor: aBoolean
"change the receiver's isPartDonor property"
self partRepresented isPartsDonor: aBoolean!
----- Method: MorphThumbnail>>morphRepresented (in category 'thumbnail') -----
morphRepresented
^ morphRepresented
!
----- Method: MorphThumbnail>>morphRepresented: (in category 'as yet unclassified') -----
morphRepresented: aMorph
morphRepresented _ aMorph.
self computeThumbnail.
!
----- Method: MorphThumbnail>>partRepresented (in category 'parts bin') -----
partRepresented
^self morphRepresented!
----- Method: MorphThumbnail>>representativeNoTallerThan:norWiderThan:thumbnailHeight: (in category 'thumbnail') -----
representativeNoTallerThan: maxHeight norWiderThan: maxWidth thumbnailHeight: thumbnailHeight
"Return a morph representing the receiver but which is no taller than aHeight. If the receiver is already small enough, just return it, else return a MorphThumbnail companioned to the receiver, enforcing the maxWidth"
(self height <= maxHeight and: [self width <= maxWidth]) ifTrue: [^ self].
^ MorphThumbnail new
extent: maxWidth @ (thumbnailHeight min: self height);
morphRepresented: morphRepresented!
----- Method: MorphThumbnail>>revealOriginal (in category 'as yet unclassified') -----
revealOriginal
((owner isKindOf: PasteUpMorph) and: [owner alwaysShowThumbnail])
ifTrue: [^Beeper beep].
morphRepresented owner isNil
ifTrue: [^owner replaceSubmorph: self by: morphRepresented].
Beeper beep!
----- Method: MorphThumbnail>>smaller (in category 'as yet unclassified') -----
smaller
self form: (self form copy: (0@0 extent: self form extent // 2))!
----- Method: MorphThumbnail>>veryDeepFixupWith: (in category 'copying') -----
veryDeepFixupWith: deepCopier
"If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
super veryDeepFixupWith: deepCopier.
morphRepresented _ deepCopier references at: morphRepresented
ifAbsent: [morphRepresented].!
----- Method: MorphThumbnail>>veryDeepInner: (in category 'copying') -----
veryDeepInner: deepCopier
"Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
super veryDeepInner: deepCopier.
morphRepresented _ morphRepresented. "Weakly copied"!
Morph subclass: #KedamaMorph
instanceVariableNames: 'dimensions wrapX wrapY pixelsPerPatch patchesToDisplay patchVarDisplayForm lastTurtleID turtleCount turtlesDict turtlesDictSemaphore turtlesToDisplay magnifiedDisplayForm autoChanged topEdgeMode bottomEdgeMode leftEdgeMode rightEdgeMode topEdgeModeMnemonic bottomEdgeModeMnemonic leftEdgeModeMnemonic rightEdgeModeMnemonic'
classVariableNames: 'RandomSeed'
poolDictionaries: ''
category: 'MorphicBooks'!
!KedamaMorph commentStamp: 'yo 6/18/2004 18:29' prior: 0!
A tile-scriptable variant of StarSqueak.
!
----- Method: KedamaMorph class>>additionsToViewerCategories (in category 'class initialization') -----
additionsToViewerCategories
"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."
^ #(
(kedama (
(command addToPatchDisplayList: 'add patch to display list' Patch)
(command removeAllFromPatchDisplayList 'clear the patch display list')
(slot patchDisplayList 'patches to display' String readOnly Player getPatchesList unused unused)
(command addToTurtleDisplayList: 'add turtle to display list' Player)
(command removeAllFromTurtleDisplayList 'clear the turtle display list')
(slot turtleDisplayList 'turtles to display' String readOnly Player getTurtlesList unused unused)
(slot pixelsPerPatch 'the display scale' Number readWrite Player getPixelsPerPatch Player setPixelsPerPatch:)
(slot color 'The color of the object' Color readWrite Player getColor Player setColor:)
"(command makeTurtlesMap 'Internally create the map of turtles')"
(slot leftEdgeMode 'the mode of left edge' EdgeMode readWrite Player getLeftEdgeMode Player setLeftEdgeMode:)
(slot rightEdgeMode 'the mode of right edge' EdgeMode readWrite Player getRightEdgeMode Player setRightEdgeMode:)
(slot topEdgeMode 'the mode of top edge' EdgeMode readWrite Player getTopEdgeMode Player setTopEdgeMode:)
(slot bottomEdgeMode 'the mode of bottom edge' EdgeMode readWrite Player getBottomEdgeMode Player setBottomEdgeMode:)
))
).
!
----- Method: KedamaMorph class>>cleanUp (in category 'class initialization') -----
cleanUp
"
self cleanUp
"
self allInstancesDo: [:e | e cleanUp].
!
----- Method: KedamaMorph class>>defaultDimensions (in category 'class initialization') -----
defaultDimensions
"Answer the dimensions of this StarSqueak simulation. Subclasses can override this method to define their own world size."
^ 100@100.
!
----- Method: KedamaMorph class>>defaultNameStemForInstances (in category 'class initialization') -----
defaultNameStemForInstances
^ 'KedamaWorld' translated.
!
----- Method: KedamaMorph class>>degreesToRadians: (in category 'global primitive backup') -----
degreesToRadians: degrees
| deg q headingRadians |
deg := 90.0 - degrees.
q := (deg / 360.0) asInteger.
deg < 0.0 ifTrue: [q := q - 1].
headingRadians := (deg - (q * 360.0)) * 0.0174532925199433.
^ headingRadians.
!
----- Method: KedamaMorph class>>descriptionForPartsBin (in category 'class initialization') -----
descriptionForPartsBin
^ self partName: 'KedamaWorld'
categories: #('Kedama')
documentation: 'A tile scriptable particle system' translated!
----- Method: KedamaMorph class>>initialize (in category 'class initialization') -----
initialize
"Kedama initialize"
RandomSeed := 17.
!
----- Method: KedamaMorph class>>newSet (in category 'class initialization') -----
newSet
| k p t s w |
k := self new.
p := k assuredPlayer getPatch costume renderedMorph.
t := k assuredPlayer newTurtleForSet.
s := SelectionMorph new.
w := PasteUpMorph new.
w extent: 400@400.
p position: 275@50.
t position: 300@175.
k position: 25@25.
w addMorph: k.
w addMorph: t.
w addMorph: p.
w addMorph: s.
s bounds: w bounds.
s selectSubmorphsOf: w.
^ s.
!
----- Method: KedamaMorph class>>radiansToDegrees: (in category 'global primitive backup') -----
radiansToDegrees: radians
| degrees deg |
degrees := radians / 0.0174532925199433.
deg := 90.0 - degrees.
deg > 0.0 ifFalse: [deg := deg + 360.0].
^ deg.
!
----- Method: KedamaMorph class>>scalarXAt:xArray:headingArray:value:destWidth:leftEdgeMode:rightEdgeMode: (in category 'global primitive backup') -----
scalarXAt: index xArray: xArray headingArray: headingArray value: val destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode
| newX headingRadians |
newX := val.
newX < 0.0 ifTrue: [
leftEdgeMode = 1 ifTrue: [
"wrap"
newX := newX + destWidth.
].
leftEdgeMode = 2 ifTrue: [
"stick"
newX := 0.0.
].
leftEdgeMode = 3 ifTrue: [
"bounce"
newX := 0.0 - newX.
headingRadians := headingArray at: index.
headingRadians < 3.141592653589793
ifTrue: [headingArray at: index put: 3.141592653589793 - headingRadians]
ifFalse: [headingArray at: index put: 9.42477796076938 - headingRadians].
].
].
newX >= destWidth ifTrue: [
rightEdgeMode = 1 ifTrue: [
newX := newX - destWidth.
].
rightEdgeMode = 2 ifTrue: [
newX := destWidth - 0.000001.
].
rightEdgeMode = 3 ifTrue: [
newX := (destWidth - 0.000001) - (newX - destWidth).
headingRadians := headingArray at: index.
headingRadians < 3.141592653589793
ifTrue: [headingArray at: index put: (3.141592653589793 - headingRadians)]
ifFalse: [headingArray at: index put: (9.42477796076938 - headingRadians)].
]
].
xArray at: index put: newX.
!
----- Method: KedamaMorph class>>scalarYAt:yArray:headingArray:value:destHeight:topEdgeMode:bottomEdgeMode: (in category 'global primitive backup') -----
scalarYAt: index yArray: yArray headingArray: headingArray value: val destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode
| newY |
newY := val.
newY < 0.0 ifTrue: [
topEdgeMode = 1 ifTrue: [
"wrap"
newY := newY + destHeight.
].
topEdgeMode = 2 ifTrue: [
"stick"
newY := 0.0.
].
topEdgeMode = 3 ifTrue: [
"bounce"
newY := 0.0 - newY.
headingArray at: index put: (6.283185307179586 - (headingArray at: index)).
].
].
newY >= destHeight ifTrue: [
bottomEdgeMode = 1 ifTrue: [
newY := newY - destHeight.
].
bottomEdgeMode = 2 ifTrue: [
newY := destHeight - 0.000001.
].
bottomEdgeMode = 3 ifTrue: [
newY := (destHeight - 0.000001) - (newY - destHeight).
headingArray at: index put: (6.283185307179586 - (headingArray at: index)).
]
].
yArray at: index put: newY.
!
----- Method: KedamaMorph>>acceptDroppingMorph:event: (in category 'event handling') -----
acceptDroppingMorph: morphToDrop event: evt
| f turtle |
(morphToDrop renderedMorph isKindOf: SketchMorph) ifFalse: [
^morphToDrop rejectDropMorphEvent: evt.
].
f := morphToDrop renderedMorph rotatedForm.
f := f magnify: f boundingBox by: (1.0 / self pixelsPerPatch asFloat) smoothing: 1.
turtle := self player newTurtleSilently.
turtle createTurtlesAsIn: f originAt: ((morphToDrop topLeft - self topLeft) / self pixelsPerPatch asFloat) asIntegerPoint.
"turtle isGroup: true."
turtle color: (self dominantColorWithoutTransparent: f).
!
----- Method: KedamaMorph>>addToPatchDisplayList: (in category 'setup') -----
addToPatchDisplayList: p
| a |
a := patchesToDisplay copyWithout: p.
patchesToDisplay := a copyWith: p.
!
----- Method: KedamaMorph>>addToTurtleDisplayList: (in category 'setup') -----
addToTurtleDisplayList: p
| a |
(p isKindOf: KedamaExamplerPlayer) ifFalse: [^ self].
a := turtlesToDisplay copyWithout: p.
turtlesToDisplay := a copyWith: p.
!
----- Method: KedamaMorph>>allSubmorphNamesDo: (in category 'submorphs-accessing') -----
allSubmorphNamesDo: aBlock
super allSubmorphNamesDo: aBlock.
aBlock value: self player getPatch externalName.
!
----- Method: KedamaMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
"Drawing optimization. Since I completely fill my bounds with opaque pixels, this method tells Morphic that it isn't necessary to draw any morphs covered by me."
^ aRectangle areasOutside: self bounds
!
----- Method: KedamaMorph>>bottomEdgeMode (in category 'accessing') -----
bottomEdgeMode
^ bottomEdgeMode.
!
----- Method: KedamaMorph>>bottomEdgeMode: (in category 'accessing') -----
bottomEdgeMode: aSymbol
bottomEdgeMode := aSymbol asSymbol.
bottomEdgeMode == #wrap ifTrue: [
bottomEdgeModeMnemonic := 1.
^ self
].
bottomEdgeMode == #stick ifTrue: [
bottomEdgeModeMnemonic := 2.
^ self
].
(bottomEdgeMode == #bounce or: [bottomEdgeMode == #bouncing]) ifTrue: [
bottomEdgeModeMnemonic := 3.
^ self
].
!
----- Method: KedamaMorph>>bottomEdgeModeMnemonic (in category 'accessing') -----
bottomEdgeModeMnemonic
^ bottomEdgeModeMnemonic.
!
----- Method: KedamaMorph>>calcTurtlesCount (in category 'turtles') -----
calcTurtlesCount
turtleCount := 0.
turtlesDict do: [:a | turtleCount := turtleCount + a size].
SmalltalkImage current vmParameterAt: 5 put: ((turtleCount * 3) min: 16000 max: 4000).
SmalltalkImage current vmParameterAt: 6 put: ((turtleCount * 6) min: 32000 max: 8000).
!
----- Method: KedamaMorph>>categoriesForViewer (in category 'etoys') -----
categoriesForViewer
"Answer a list of symbols representing the categories to offer in the viewer, in order"
^ super categoriesForViewer.
"
| aList |
aList := OrderedCollection new.
aList addAllFirstUnlessAlreadyPresent: (self class additionsToViewerCategories collect:
[:categorySpec | categorySpec first]).
^ aList
"!
----- Method: KedamaMorph>>cleanUp (in category 'setup') -----
cleanUp
self extension actorState: nil.
self extension player: nil.
self initializeTurtlesDict.
!
----- Method: KedamaMorph>>clearAll (in category 'setup') -----
clearAll
"Reset this StarSqueak world. All patch variables are cleared, all turtles are removed, and all demons are turned off."
patchVarDisplayForm := Form extent: dimensions depth: 32.
self initializePatch.
self recreateMagnifiedDisplayForm.
self initializeTurtlesDict.
turtleCount := 0.
lastTurtleID := 0.
self color: Color black.
!
----- Method: KedamaMorph>>colorAt: (in category 'accessing') -----
colorAt: aLocalPoint
| pix |
pix := patchVarDisplayForm pixelValueAt: (aLocalPoint // pixelsPerPatch) asIntegerPoint.
^ Color colorFromPixelValue: (pix bitOr: 16rFF000000) depth: 32.
!
----- Method: KedamaMorph>>delete (in category 'deleting') -----
delete
| c |
super delete.
turtlesDict keysDo: [:k |
self deleteAllTurtlesOfExampler: k.
c := k costume.
c ifNotNil: [c renderedMorph delete].
].
!
----- Method: KedamaMorph>>deleteAllTurtlesOfExampler: (in category 'turtles') -----
deleteAllTurtlesOfExampler: examplerPlayer
turtlesDict removeKey: examplerPlayer ifAbsent: [].
self removeFromTurtleDisplayList: examplerPlayer.
self calcTurtlesCount.
!
----- Method: KedamaMorph>>deleteTurtleID:of: (in category 'turtles') -----
deleteTurtleID: who of: examplerPlayer
"Delete the given turtle from this world."
| array |
array := examplerPlayer turtles.
array ifNil: [^ self].
turtlesDictSemaphore critical: [
array deleteTurtleID: who.
].
self calcTurtlesCount.
examplerPlayer costume renderedMorph privateTurtleCount: array size.
"examplerPlayer allOpenViewers do: [:v | v resetWhoIfNecessary]."
!
----- Method: KedamaMorph>>dimensions (in category 'accessing') -----
dimensions
^ dimensions
!
----- Method: KedamaMorph>>display (in category 'drawing') -----
display
"Display this world on the Display. Used for debugging."
| c |
c := FormCanvas extent: (dimensions * pixelsPerPatch) depth: 32.
c := c copyOffset: bounds origin negated.
self drawOn: c.
c form display.
!
----- Method: KedamaMorph>>dominantColorWithoutTransparent: (in category 'event handling') -----
dominantColorWithoutTransparent: aForm
| tally max maxi |
aForm depth > 16 ifTrue:
[^self dominantColorWithoutTransparent: (aForm asFormOfDepth: 16)].
tally := aForm tallyPixelValues.
max := maxi := 0.
tally withIndexDo: [:n :i | n > max ifTrue: [ i ~= 1 ifTrue: [max := n. maxi := i]]].
^ Color colorFromPixelValue: maxi - 1 depth: aForm depth
!
----- Method: KedamaMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
"Display this StarSqueak world."
| result |
"Time millisecondClockValue printString displayAt: 0@0."
self player ifNil: [^ aCanvas fillRectangle: (self bounds) color: self color].
patchVarDisplayForm fillColor: self color.
patchesToDisplay do: [:p |
p displayPatchVariableOn: patchVarDisplayForm.
].
self drawTurtlesOnForm: patchVarDisplayForm.
pixelsPerPatch = 1 ifTrue: [
aCanvas drawImage: patchVarDisplayForm at: bounds origin.
] ifFalse: [
result := self zoom: patchVarDisplayForm into: magnifiedDisplayForm factor: pixelsPerPatch.
result ifNil: [
aCanvas warpImage: patchVarDisplayForm transform: (MatrixTransform2x3 withScale: pixelsPerPatch) at: self innerBounds origin.
] ifNotNil: [
aCanvas drawImage: magnifiedDisplayForm at: bounds origin.
]
].
autoChanged ifTrue: [self changed].
!
----- Method: KedamaMorph>>drawTurtlesOnForm: (in category 'drawing') -----
drawTurtlesOnForm: aForm
turtlesToDisplay do: [:exampler |
(self isVisible: exampler) ifTrue: [
turtlesDictSemaphore critical: [
exampler turtles drawOn: aForm.
].
].
].
!
----- Method: KedamaMorph>>extent: (in category 'geometry') -----
extent: aPoint
"Do nothing; my extent is determined by my StarSqueak world dimensions and pixelsPerPatch."
!
----- Method: KedamaMorph>>hasNoTurtleBreed (in category 'utils') -----
hasNoTurtleBreed
^ turtlesDict isEmpty.
!
----- Method: KedamaMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
dimensions := self class defaultDimensions. "dimensions of this StarSqueak world in patches"
wrapX := dimensions x asFloat.
wrapY := dimensions y asFloat.
pixelsPerPatch := 2.
super extent: dimensions * pixelsPerPatch.
self assuredPlayer assureUniClass.
self clearAll. "be sure this is done once in case setup fails to do it"
autoChanged := true.
self leftEdgeMode: #wrap.
self rightEdgeMode: #wrap.
self topEdgeMode: #wrap.
self bottomEdgeMode: #wrap.
turtlesDictSemaphore := Semaphore forMutualExclusion.
!
----- Method: KedamaMorph>>initializePatch (in category 'initialization') -----
initializePatch
| f |
f := self player addPatchVarNamed: #patch.
patchesToDisplay := Array new: 0.
self addToPatchDisplayList: f.
^ f.
!
----- Method: KedamaMorph>>initializeTurtlesDict (in category 'initialization') -----
initializeTurtlesDict
turtlesDict := IdentityDictionary new.
turtlesToDisplay := Array new.
!
----- Method: KedamaMorph>>isVisible: (in category 'private') -----
isVisible: examplerPlayer
| turtleMorph |
turtleMorph := examplerPlayer costume.
turtleMorph visible ifFalse: [^ false].
turtleMorph owner isRenderer ifFalse: [^ true].
^ turtleMorph owner visible.
!
----- Method: KedamaMorph>>lastWhoOf: (in category 'turtles') -----
lastWhoOf: exampler
| turtles |
turtles := turtlesDict at: exampler ifAbsent: [nil].
^ (turtles arrays first) at: turtles arrays first size.
!
----- Method: KedamaMorph>>leftEdgeMode (in category 'accessing') -----
leftEdgeMode
^ leftEdgeMode.
!
----- Method: KedamaMorph>>leftEdgeMode: (in category 'accessing') -----
leftEdgeMode: aSymbol
leftEdgeMode := aSymbol asSymbol.
leftEdgeMode == #wrap ifTrue: [
leftEdgeModeMnemonic := 1.
^ self
].
leftEdgeMode == #stick ifTrue: [
leftEdgeModeMnemonic := 2.
^ self
].
(leftEdgeMode == #bounce or: [leftEdgeMode == #bouncing]) ifTrue: [
leftEdgeModeMnemonic := 3.
^ self
].
!
----- Method: KedamaMorph>>leftEdgeModeMnemonic (in category 'accessing') -----
leftEdgeModeMnemonic
^ leftEdgeModeMnemonic.
!
----- Method: KedamaMorph>>makePrototypeOfExampler: (in category 'turtles') -----
makePrototypeOfExampler: examplerPlayer
^ self makePrototypeOfExampler: examplerPlayer color: nil.
!
----- Method: KedamaMorph>>makePrototypeOfExampler:color: (in category 'turtles') -----
makePrototypeOfExampler: examplerPlayer color: cPixel
| array inst info |
array := examplerPlayer turtles.
info := array info.
array size > 0 ifTrue: [
inst := array makePrototypeFromFirstInstance.
cPixel ifNotNil: [inst at: (info at: #color) put: cPixel].
^ inst.
].
inst := Array new: array instSize.
info associationsDo: [:assoc |
inst at: (assoc value) put: (examplerPlayer perform: (Utilities getterSelectorFor: assoc key)).
].
cPixel ifNotNil: [inst at: (info at: #color) put: cPixel] ifNil: [inst at: (info at: #color) put: ((examplerPlayer getColor pixelValueForDepth: 32) bitAnd: 16rFFFFFF)].
inst at: (info at: #visible) put: ((inst at: (info at: #visible)) ifTrue: [1] ifFalse: [0]).
^ inst.
!
----- Method: KedamaMorph>>makeReplicatedTurtles:examplerPlayer:color:ofPrototype:randomize: (in category 'turtles') -----
makeReplicatedTurtles: count examplerPlayer: tp color: c ofPrototype: prototype randomize: randomizeFlag
| array inst |
array := tp turtles.
inst := prototype ifNil: [self makePrototypeOfExampler: tp color: c].
turtlesDictSemaphore critical: [
array addTurtlesCount: count ofPrototype: inst for: self randomize: randomizeFlag.
].
self calcTurtlesCount.
self changed.
!
----- Method: KedamaMorph>>makeTurtles:examplerPlayer:color:ofPrototype:turtles:randomize: (in category 'turtles') -----
makeTurtles: count examplerPlayer: tp color: c ofPrototype: prototype turtles: turtles randomize: randomizeFlag
| array inst |
array := tp turtles.
(turtlesDict keys includes: tp) ifFalse: [
self addToTurtleDisplayList: tp.
turtlesDict at: tp put: (array := turtles).
].
inst := prototype ifNil: [self makePrototypeOfExampler: tp color: c].
turtlesDictSemaphore critical: [array setTurtlesCount: count prototype: inst for: self randomize: randomizeFlag].
self calcTurtlesCount.
self changed.
!
----- Method: KedamaMorph>>makeTurtlesAtPositionsIn:examplerPlayer:ofPrototype: (in category 'turtles') -----
makeTurtlesAtPositionsIn: positionAndColorArray examplerPlayer: tp ofPrototype: prototype
| array inst |
array := tp turtles.
inst := prototype ifNil: [self makePrototypeOfExampler: tp].
turtlesDictSemaphore critical: [array addTurtlesCount: positionAndColorArray first size ofPrototype: inst for: self positionAndColorArray: positionAndColorArray].
self calcTurtlesCount.
self changed.
!
----- Method: KedamaMorph>>nextTurtleID (in category 'turtles') -----
nextTurtleID
^ lastTurtleID := lastTurtleID + 1.
!
----- Method: KedamaMorph>>offerCostumeViewerMenu: (in category 'menu') -----
offerCostumeViewerMenu: aMenu
aMenu add: 'add a new patch variable' translated action: #newPatch.
aMenu balloonTextForLastItem: 'Add a new patch variable' translated.
aMenu add: 'add a new breed of turtle' translated action: #newTurtle.
aMenu balloonTextForLastItem: 'Add a new turtle' translated.
aMenu addLine.
!
----- Method: KedamaMorph>>patchesToDisplayAsString (in category 'drawing') -----
patchesToDisplayAsString
^ String streamContents: [:strm |
strm nextPutAll: '#('.
patchesToDisplay do: [:p |
strm nextPutAll: p externalName.
strm nextPut: Character space.
].
strm nextPutAll: ')'.
].
!
----- Method: KedamaMorph>>pixelsPerPatch (in category 'accessing') -----
pixelsPerPatch
^ pixelsPerPatch
!
----- Method: KedamaMorph>>pixelsPerPatch: (in category 'accessing') -----
pixelsPerPatch: anInteger
"Set the width of one patch in pixels. Larger numbers scale up this StarSqueak world, but numbers larger than 2 or 3 result in a blocky look. The useful range is 1 to 10."
pixelsPerPatch := (anInteger rounded max: 1) min: 10.
super extent: dimensions * pixelsPerPatch.
self recreateMagnifiedDisplayForm
!
----- Method: KedamaMorph>>primSetRandomSeed: (in category 'private-primitives') -----
primSetRandomSeed: seed
<primitive: 'kedamaSetRandomSeed' module: 'KedamaPlugin'>
^ nil.
!
----- Method: KedamaMorph>>primZoom:into:srcWidth:height:multX:y: (in category 'private-primitives') -----
primZoom: src into: dst srcWidth: sWidth height: sHeight multX: xFactor y: yFactor
<primitive: 'zoomBitmap' module: 'KedamaPlugin'>
"^ KedamaSqueakPlugin doPrimitive: #zoomBitmap."
^ nil.
!
----- Method: KedamaMorph>>random: (in category 'utils') -----
random: range
"Answer a random integer between 0 and range."
| r val |
<primitive: 'randomRange' module: 'KedamaPlugin'>
r := range < 0 ifTrue: [range negated] ifFalse: [range].
RandomSeed := ((RandomSeed * 1309) + 13849) bitAnd: 65535.
val := (RandomSeed * (r + 1)) >> 16.
^ range < 0 ifTrue: [val negated] ifFalse: [^ val].
!
----- Method: KedamaMorph>>recreateMagnifiedDisplayForm (in category 'private') -----
recreateMagnifiedDisplayForm
magnifiedDisplayForm := Form extent: self dimensions * pixelsPerPatch depth: 32.
self changed.
!
----- Method: KedamaMorph>>removeAllFromPatchDisplayList (in category 'drawing') -----
removeAllFromPatchDisplayList
patchesToDisplay := #().
!
----- Method: KedamaMorph>>removeAllFromTurtleDisplayList (in category 'drawing') -----
removeAllFromTurtleDisplayList
turtlesToDisplay := #().
!
----- Method: KedamaMorph>>removeFromTurtleDisplayList: (in category 'turtles') -----
removeFromTurtleDisplayList: examplerPlayer
turtlesToDisplay := turtlesToDisplay copyWithout: examplerPlayer.
!
----- Method: KedamaMorph>>rightEdgeMode (in category 'accessing') -----
rightEdgeMode
^ rightEdgeMode.
!
----- Method: KedamaMorph>>rightEdgeMode: (in category 'accessing') -----
rightEdgeMode: aSymbol
rightEdgeMode := aSymbol asSymbol.
rightEdgeMode == #wrap ifTrue: [
rightEdgeModeMnemonic := 1.
^ self
].
rightEdgeMode == #stick ifTrue: [
rightEdgeModeMnemonic := 2.
^ self
].
(rightEdgeMode == #bounce or: [rightEdgeMode == #bouncing]) ifTrue: [
rightEdgeModeMnemonic := 3.
^ self
].
!
----- Method: KedamaMorph>>rightEdgeModeMnemonic (in category 'accessing') -----
rightEdgeModeMnemonic
^ rightEdgeModeMnemonic.
!
----- Method: KedamaMorph>>setScale (in category 'menu') -----
setScale
| reply |
reply := FillInTheBlank
request: 'Set the number of pixels per patch (a number between 1 and 10)?'
initialAnswer: pixelsPerPatch printString.
reply isEmpty ifTrue: [^ self].
self pixelsPerPatch: reply asNumber.
!
----- Method: KedamaMorph>>setTurtlesCount:examplerPlayer:color: (in category 'turtles') -----
setTurtlesCount: count examplerPlayer: tp color: cPixel
| prototype |
prototype := self makePrototypeOfExampler: tp color: cPixel.
turtlesDictSemaphore critical: [(tp turtles) setTurtlesCount: count prototype: prototype for: self randomize: true].
self calcTurtlesCount.
!
----- Method: KedamaMorph>>setup (in category 'setup') -----
setup
"Subclasses should override this to setup the initial conditions of this StarSqueak world. The method should start with 'self clearAll'."
self clearAll.
!
----- Method: KedamaMorph>>topEdgeMode (in category 'accessing') -----
topEdgeMode
^ topEdgeMode.
!
----- Method: KedamaMorph>>topEdgeMode: (in category 'accessing') -----
topEdgeMode: aSymbol
topEdgeMode := aSymbol asSymbol.
topEdgeMode == #wrap ifTrue: [
topEdgeModeMnemonic := 1.
^ self
].
topEdgeMode == #stick ifTrue: [
topEdgeModeMnemonic := 2.
^ self
].
(topEdgeMode == #bounce or: [topEdgeMode == #bouncing]) ifTrue: [
topEdgeModeMnemonic := 3.
^ self
].
!
----- Method: KedamaMorph>>topEdgeModeMnemonic (in category 'accessing') -----
topEdgeModeMnemonic
^ topEdgeModeMnemonic.
!
----- Method: KedamaMorph>>turtleCount (in category 'etoys') -----
turtleCount
^ turtleCount.
!
----- Method: KedamaMorph>>turtlesCountOf: (in category 'turtles') -----
turtlesCountOf: exampler
| array |
array := exampler turtles.
array ifNil: [^ 0].
^ array size.
!
----- Method: KedamaMorph>>turtlesToDisplayAsString (in category 'drawing') -----
turtlesToDisplayAsString
^ String streamContents: [:strm |
strm nextPutAll: '#('.
turtlesToDisplay do: [:p |
strm nextPutAll: p externalName.
strm nextPut: Character space.
].
strm nextPutAll: ')'.
].
!
----- Method: KedamaMorph>>wantsDroppedMorph:event: (in category 'event handling') -----
wantsDroppedMorph: aMorph event: anEvent
^ aMorph isMemberOf: SketchMorph.
!
----- Method: KedamaMorph>>wrapX (in category 'accessing') -----
wrapX
^ wrapX.
!
----- Method: KedamaMorph>>wrapY (in category 'accessing') -----
wrapY
^ wrapY.
!
----- Method: KedamaMorph>>zoom:into:factor: (in category 'private') -----
zoom: src into: dst factor: f
src unhibernate.
dst unhibernate.
^ self primZoom: src bits into: dst bits srcWidth: src width height: src height multX: f y: f.
!
AlignmentMorph subclass: #BookPageSorterMorph
instanceVariableNames: 'book pageHolder'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicBooks'!
----- Method: BookPageSorterMorph>>acceptSort (in category 'as yet unclassified') -----
acceptSort
book acceptSortedContentsFrom: pageHolder.
self delete.
!
----- Method: BookPageSorterMorph>>addControls (in category 'as yet unclassified') -----
addControls
| bb r aButton str |
r _ AlignmentMorph newRow color: Color transparent; borderWidth: 0; layoutInset: 0.
r wrapCentering: #center; cellPositioning: #topCenter;
hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
bb _ SimpleButtonMorph new target: self; borderColor: Color black.
r addMorphBack: (self wrapperFor: (bb label: 'Okay' translated; actionSelector: #acceptSort)).
bb _ SimpleButtonMorph new target: self; borderColor: Color black.
r addMorphBack: (self wrapperFor: (bb label: 'Cancel' translated; actionSelector: #delete)).
r addTransparentSpacerOfSize: 8 @ 0.
r addMorphBack: (self wrapperFor: (aButton _ UpdatingThreePhaseButtonMorph checkBox)).
aButton
target: self;
actionSelector: #togglePartsBinStatus;
arguments: #();
getSelector: #getPartsBinStatus.
str _ StringMorph contents: 'Parts bin' translated.
r addMorphBack: (self wrapperFor: str lock).
self addMorphFront: r.
!
----- Method: BookPageSorterMorph>>book:morphsToSort: (in category 'as yet unclassified') -----
book: aBookMorph morphsToSort: morphList
| innerBounds |
book _ aBookMorph.
pageHolder removeAllMorphs.
pageHolder addAllMorphs: morphList.
pageHolder extent: pageHolder width@pageHolder fullBounds height.
innerBounds _ Rectangle merging: (morphList collect: [:m | m bounds]).
pageHolder extent: innerBounds extent + pageHolder borderWidth + 6.!
----- Method: BookPageSorterMorph>>changeExtent: (in category 'as yet unclassified') -----
changeExtent: aPoint
self extent: aPoint.
pageHolder extent: self extent - self borderWidth!
----- Method: BookPageSorterMorph>>closeButtonOnly (in category 'as yet unclassified') -----
closeButtonOnly
"Replace my default control panel with one that has only a close button."
| b r |
self firstSubmorph delete. "remove old control panel"
b _ SimpleButtonMorph new target: self; borderColor: Color black.
r _ AlignmentMorph newRow.
r color: b color; borderWidth: 0; layoutInset: 0.
r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
r wrapCentering: #topLeft.
r addMorphBack: (b label: 'Close' translated; actionSelector: #delete).
self addMorphFront: r.
!
----- Method: BookPageSorterMorph>>columnWith: (in category 'as yet unclassified') -----
columnWith: aMorph
^AlignmentMorph newColumn
color: Color transparent;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
wrapCentering: #center;
cellPositioning: #topCenter;
layoutInset: 1;
addMorph: aMorph
!
----- Method: BookPageSorterMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 2!
----- Method: BookPageSorterMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color lightGray!
----- Method: BookPageSorterMorph>>getPartsBinStatus (in category 'as yet unclassified') -----
getPartsBinStatus
^pageHolder isPartsBin!
----- Method: BookPageSorterMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self extent: Display extent - 100;
listDirection: #topToBottom;
wrapCentering: #topLeft;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
layoutInset: 3.
pageHolder _ PasteUpMorph new behaveLikeHolder extent: self extent -self borderWidth.
pageHolder hResizing: #shrinkWrap.
"pageHolder cursor: 0."
"causes a walkback as of 5/25/2000"
self addControls.
self addMorphBack: pageHolder!
----- Method: BookPageSorterMorph>>pageHolder (in category 'as yet unclassified') -----
pageHolder
^ pageHolder
!
----- Method: BookPageSorterMorph>>rowWith: (in category 'as yet unclassified') -----
rowWith: aMorph
^AlignmentMorph newColumn
color: Color transparent;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
wrapCentering: #center;
cellPositioning: #topCenter;
layoutInset: 1;
addMorph: aMorph
!
----- Method: BookPageSorterMorph>>togglePartsBinStatus (in category 'as yet unclassified') -----
togglePartsBinStatus
pageHolder isPartsBin: pageHolder isPartsBin not!
----- Method: BookPageSorterMorph>>veryDeepFixupWith: (in category 'copying') -----
veryDeepFixupWith: deepCopier
"If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals."
super veryDeepFixupWith: deepCopier.
book _ deepCopier references at: book ifAbsent: [book].
!
----- Method: BookPageSorterMorph>>veryDeepInner: (in category 'copying') -----
veryDeepInner: deepCopier
"Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
super veryDeepInner: deepCopier.
"book _ book. Weakly copied"
pageHolder _ pageHolder veryDeepCopyWith: deepCopier.!
----- Method: BookPageSorterMorph>>wantsToBeDroppedInto: (in category 'dropping/grabbing') -----
wantsToBeDroppedInto: aMorph
"Return true if it's okay to drop the receiver into aMorph"
^aMorph isWorldMorph "only into worlds"!
----- Method: BookPageSorterMorph>>wrapperFor: (in category 'as yet unclassified') -----
wrapperFor: aMorph
^self columnWith: (self rowWith: aMorph)
!
AlignmentMorph subclass: #BooklikeMorph
instanceVariableNames: 'pageSize newPagePrototype'
classVariableNames: 'PageFlipSoundOn'
poolDictionaries: ''
category: 'MorphicBooks'!
!BooklikeMorph commentStamp: '<historical>' prior: 0!
A common superclass for BookMorph and WebBookMorph!
BooklikeMorph subclass: #BookMorph
instanceVariableNames: 'pages currentPage'
classVariableNames: 'VersionNames VersionTimes MethodHolders'
poolDictionaries: ''
category: 'MorphicBooks'!
!BookMorph commentStamp: '<historical>' prior: 0!
A collection of pages, each of which is a place to put morphs. Allows one or another page to show; orchestrates the page transitions; offers control panel for navigating among pages and for adding and deleting pages.
To write a book out to the disk or to a file server, decide what folder it goes in. Construct a url to a typical page:
file://myDisk/folder/myBook1.sp
or
ftp://aServer/folder/myBook1.sp
Choose "send all pages to server" from the book's menu (press the <> part of the controls). Choose "use page numbers". Paste in the url.
To load an existing book, find its ".bo" file in the file list browser. Choose "load as book".
To load an existing book from its url, execute:
Š(URLMorph grabURL: 'ftp://aServer/folder/myBook1.sp') book: true.
Multiple people may modify a book. If other people may have changed a book you have on your screen, choose "reload all from server".
Add or modify a page, and choose "send this page to server".
The polite thing to do is to reload before changing a book. Then write one or all pages soon after making your changes. If you store a stale book, it will wipe out changes that other people made in the mean time.
Pages may be linked to each other. To create a named link to a new page, type the name of the page in a text area in a page. Select it and do Cmd-6. Choose 'link to'. A new page of that name will be added at the back of the book. Clicking on the blue text flips to that page.
To create a link to an existing page, first name the page. Go to that page and Cmd-click on it. The name of the page is below the page. Click in it and backspace and type. Return to the page you are linking from. Type the name. Cmd-6, 'link to'.
Text search: Search for a set of fragments. allStrings collects text of fields. Turn to page with all fragments on it and highlight the first one. Save the container and offset in properties: #searchContainer, #searchOffset, #searchKey. Search again from there. Clear those at each page turn, or change of search key.
[rules about book indexes and pages: Index and pages must live in the same directory. They have the same file prefix, followed by .bo for the index or 4.sp for a page (or x4.sp). When a book is moved to a new directory, the load routine gets the new urls for all pages and saves those in the index. Book stores index url in property #url.
Allow mulitple indexes (books) on the same shared set of pages. If book has a url in same directory as pages, allow them to have different prefixes.
save all pages first time, save one page first time, fromRemoteStream: (first time)
save all pages normal , save one page normal, reload
where I check if same dir]
URLMorph holds url of both page and book.!
----- Method: BookMorph class>>alreadyInFromUrl: (in category 'url') -----
alreadyInFromUrl: aUrl
"Does a bookMorph living in some world in this image represent the same set of server pages? If so, don't create another one. It will steal pages from the existing one. Go delete the first one."
self withAllSubclassesDo: [:cls |
cls allInstancesDo: [:aBook |
(aBook valueOfProperty: #url) = aUrl ifTrue: [
aBook world ifNotNil: [
self inform: 'This book is already open in some project'.
^ true]]]].
^ false!
----- Method: BookMorph class>>authoringPrototype (in category 'scripting') -----
authoringPrototype
"Answer an instance of the receiver suitable for placing in a parts bin for authors"
| book |
book _ self new markAsPartsDonor.
book removeEverything; pageSize: 360@228; color: (Color gray: 0.9).
book borderWidth: 1; borderColor: Color black.
book beSticky.
book showPageControls; insertPage.
^ book!
----- Method: BookMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Book'
categories: #('Presentation')
documentation: 'Multi-page structures'!
----- Method: BookMorph class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') -----
fileReaderServicesForFile: fullName suffix: suffix
^(suffix = 'bo') | (suffix = '*')
ifTrue: [ Array with: self serviceLoadAsBook]
ifFalse: [#()]
!
----- Method: BookMorph class>>grabURL: (in category 'url') -----
grabURL: aURLString
"Create a BookMorph for this url and put it in the hand."
| book |
book _ self new fromURL: aURLString.
"If this book is already in, we will steal the pages out of it!!!!!!!!"
book goToPage: 1. "install it"
HandMorph attach: book!
----- Method: BookMorph class>>initialize (in category 'class initialization') -----
initialize
FileList registerFileReader: self.
self registerInFlapsRegistry. !
----- Method: BookMorph class>>isInWorld:withUrl: (in category 'url') -----
isInWorld: aWorld withUrl: aUrl
| urls bks short |
"If a book with this url is in the that (current) world, return it. Say if it is out or in another world."
urls _ OrderedCollection new.
bks _ OrderedCollection new.
aWorld allMorphsDo: [:aBook | (aBook isKindOf: BookMorph) ifTrue: [
bks add: aBook.
(urls add: (aBook valueOfProperty: #url)) = aUrl ifTrue: [
aBook world == aWorld
ifTrue: [^ aBook]]]]. "shortcut"
self withAllSubclassesDo: [:cls |
cls allInstancesDo: [:aBook |
(aBook valueOfProperty: #url) = aUrl ifTrue: [
aBook world == aWorld
ifTrue: [^ aBook]
ifFalse: [
self inform: 'Book may be open in some other project'.
^ aBook]]]].
"if same book name, use it"
short _ (aUrl findTokens: '/') last.
urls withIndexDo: [:kk :ind | (kk findTokens: '/') last = short ifTrue: [
^ bks at: ind]].
^ #out!
----- Method: BookMorph class>>makeBookOfProjects:named: (in category 'booksAsProjects') -----
makeBookOfProjects: aListOfProjects named: aString
"
BookMorph makeBookOfProjects: (Project allProjects select: [ :each | each world isMorph])
"
| book pvm page |
book _ self new.
book setProperty: #transitionSpec toValue: {'silence'. #none. #none}.
aListOfProjects do: [ :each |
pvm _ ProjectViewMorph on: each.
page _ PasteUpMorph new addMorph: pvm; extent: pvm extent.
book insertPage: page pageSize: page extent
].
book goToPage: 1.
book deletePageBasic.
book setProperty: #nameOfThreadOfProjects toValue: aString.
book removeProperty: #transitionSpec.
book openInWorld!
----- Method: BookMorph class>>nextPageButton (in category 'scripting') -----
nextPageButton
"Answer a button that will take the user to the next page of its enclosing book"
| aButton |
aButton _ SimpleButtonMorph new.
aButton target: aButton; actionSelector: #nextOwnerPage; label: '->'; color: Color yellow.
aButton setNameTo: 'next'.
^ aButton!
----- Method: BookMorph class>>openFromFile: (in category 'fileIn/Out') -----
openFromFile: fullName
"Reconstitute a Morph from the selected file, presumed to be represent
a Morph saved via the SmartRefStream mechanism, and open it in an
appropriate Morphic world"
| book aFileStream |
Smalltalk verifyMorphicAvailability ifFalse: [^ self].
aFileStream _ FileStream oldFileNamed: fullName.
book _ BookMorph new.
book setProperty: #url toValue: aFileStream url.
book fromRemoteStream: aFileStream.
aFileStream close.
Smalltalk isMorphic
ifTrue: [ActiveWorld addMorphsAndModel: book]
ifFalse:
[book isMorph ifFalse: [^self inform: 'Can only load a single morph
into an mvc project via this mechanism.'].
book openInWorld].
book goToPage: 1!
----- Method: BookMorph class>>previousPageButton (in category 'scripting') -----
previousPageButton
"Answer a button that will take the user to the previous page of its enclosing book"
| aButton |
aButton _ SimpleButtonMorph new.
aButton target: aButton; actionSelector: #previousOwnerPage; color: Color yellow; label: '<-'.
aButton setNameTo: 'previous'.
^ aButton!
----- Method: BookMorph class>>registerInFlapsRegistry (in category 'class initialization') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"
self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: #(BookMorph nextPageButton 'NextPage' 'A button that takes you to the next page')
forFlapNamed: 'PlugIn Supplies'.
cl registerQuad: #(BookMorph previousPageButton 'PreviousPage' 'A button that takes you to the previous page')
forFlapNamed: 'PlugIn Supplies'.
cl registerQuad: #(BookMorph authoringPrototype 'Book' 'A multi-paged structure')
forFlapNamed: 'PlugIn Supplies'.
cl registerQuad: #(BookMorph nextPageButton 'NextPage' 'A button that takes you to the next page')
forFlapNamed: 'Supplies'.
cl registerQuad: #(BookMorph previousPageButton 'PreviousPage' 'A button that takes you to the previous page')
forFlapNamed: 'Supplies'.
cl registerQuad: #(BookMorph authoringPrototype 'Book' 'A multi-paged structure')
forFlapNamed: 'Supplies']!
----- Method: BookMorph class>>serviceLoadAsBook (in category 'fileIn/Out') -----
serviceLoadAsBook
^ SimpleServiceEntry
provider: self
label: 'load as book'
selector: #openFromFile:
description: 'open as bookmorph'!
----- Method: BookMorph class>>services (in category 'fileIn/Out') -----
services
^ Array with: self serviceLoadAsBook!
----- Method: BookMorph class>>unload (in category 'initialize-release') -----
unload
"Unload the receiver from global registries"
self environment
at: #FileList
ifPresent: [:cl | cl unregisterFileReader: self].
self environment
at: #Flaps
ifPresent: [:cl | cl unregisterQuadsWithReceiver: self]!
----- Method: BookMorph>>abandon (in category 'submorphs-add/remove') -----
abandon
"Like delete, but we really intend not to use this morph again. Make the page cache release the page object."
| pg |
self delete.
pages do: [:aPage |
(pg _ aPage sqkPage) ifNotNil: [
pg contentsMorph == aPage ifTrue: [
pg contentsMorph: nil]]].!
----- Method: BookMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: aMorph event: evt
"Allow the user to add submorphs just by dropping them on this morph."
(currentPage allMorphs includes: aMorph)
ifFalse: [currentPage addMorph: aMorph]!
----- Method: BookMorph>>acceptSortedContentsFrom: (in category 'sorting') -----
acceptSortedContentsFrom: aHolder
"Update my page list from the given page sorter."
| goodPages rejects toAdd sqPage |
goodPages := OrderedCollection new.
rejects := OrderedCollection new.
aHolder submorphs doWithIndex:
[:m :i |
toAdd := nil.
(m isKindOf: PasteUpMorph) ifTrue: [toAdd := m].
(m isKindOf: BookPageThumbnailMorph)
ifTrue:
[toAdd := m page.
m bookMorph == self
ifFalse:
["borrowed from another book. preserve the original"
toAdd := toAdd veryDeepCopy.
"since we came from elsewhere, cached strings are wrong"
self removeProperty: #allTextUrls.
self removeProperty: #allText]].
toAdd isString
ifTrue:
["a url"
toAdd := pages detect: [:aPage | aPage url = toAdd] ifNone: [toAdd]].
toAdd isString
ifTrue:
[sqPage := SqueakPageCache atURL: toAdd.
toAdd := sqPage contentsMorph
ifNil: [sqPage copyForSaving "a MorphObjectOut"]
ifNotNil: [sqPage contentsMorph]].
toAdd ifNil: [rejects add: m] ifNotNil: [goodPages add: toAdd]].
self newPages: goodPages.
goodPages isEmpty ifTrue: [self insertPage].
rejects notEmpty
ifTrue:
[self
inform: rejects size printString , ' objects vanished in this process.']!
----- Method: BookMorph>>addBookMenuItemsTo:hand: (in category 'menu') -----
addBookMenuItemsTo: aMenu hand: aHandMorph
| controlsShowing subMenu |
subMenu _ MenuMorph new defaultTarget: self.
subMenu add: 'previous page' translated action: #previousPage.
subMenu add: 'next page' translated action: #nextPage.
subMenu add: 'goto page' translated action: #goToPage.
subMenu add: 'insert a page' translated action: #insertPage.
subMenu add: 'delete this page' translated action: #deletePage.
controlsShowing _ self hasSubmorphWithProperty: #pageControl.
controlsShowing
ifTrue:
[subMenu add: 'hide page controls' translated action: #hidePageControls.
subMenu add: 'fewer page controls' translated action: #fewerPageControls]
ifFalse:
[subMenu add: 'show page controls' translated action: #showPageControls].
self isInFullScreenMode ifTrue: [
subMenu add: 'exit full screen' translated action: #exitFullScreen.
] ifFalse: [
subMenu add: 'show full screen' translated action: #goFullScreen.
].
subMenu addLine.
subMenu add: 'sound effect for all pages' translated action: #menuPageSoundForAll:.
subMenu add: 'sound effect this page only' translated action: #menuPageSoundForThisPage:.
subMenu add: 'visual effect for all pages' translated action: #menuPageVisualForAll:.
subMenu add: 'visual effect this page only' translated action: #menuPageVisualForThisPage:.
subMenu addLine.
subMenu add: 'sort pages' translated action: #sortPages:.
subMenu add: 'uncache page sorter' translated action: #uncachePageSorter.
(self hasProperty: #dontWrapAtEnd)
ifTrue: [subMenu add: 'wrap after last page' translated selector: #setWrapPages: argument: true]
ifFalse: [subMenu add: 'stop at last page' translated selector: #setWrapPages: argument: false].
subMenu addLine.
subMenu add: 'search for text' translated action: #textSearch.
(aHandMorph pasteBuffer class isKindOf: PasteUpMorph class) ifTrue:
[subMenu add: 'paste book page' translated action: #pasteBookPage].
subMenu add: 'send all pages to server' translated action: #savePagesOnURL.
subMenu add: 'send this page to server' translated action: #saveOneOnURL.
subMenu add: 'reload all from server' translated action: #reload.
subMenu add: 'copy page url to clipboard' translated action: #copyUrl.
subMenu add: 'keep in one file' translated action: #keepTogether.
subMenu add: 'save as new-page prototype' translated action: #setNewPagePrototype.
newPagePrototype ifNotNil:
[subMenu add: 'clear new-page prototype' translated action: #clearNewPagePrototype].
aMenu add: 'book...' translated subMenu: subMenu
!
----- Method: BookMorph>>adjustCurrentPageForFullScreen (in category 'other') -----
adjustCurrentPageForFullScreen
"Adjust current page to conform to whether or not I am in full-screen mode. Also, enforce uniform page size constraint if appropriate"
self isInFullScreenMode
ifTrue:
[(currentPage hasProperty: #sizeWhenNotFullScreen) ifFalse:
[currentPage setProperty: #sizeWhenNotFullScreen toValue: currentPage extent].
currentPage extent: Display extent]
ifFalse:
[(currentPage hasProperty: #sizeWhenNotFullScreen) ifTrue:
[currentPage extent: (currentPage valueOfProperty: #sizeWhenNotFullScreen).
currentPage removeProperty: #sizeWhenNotFullScreen].
self uniformPageSize ifNotNilDo:
[:anExtent | currentPage extent: anExtent]].
(self valueOfProperty: #floatingPageControls) ifNotNilDo:
[:pc | pc isInWorld ifFalse: [pc openInWorld]]!
----- Method: BookMorph>>allNonSubmorphMorphs (in category 'submorphs-accessing') -----
allNonSubmorphMorphs
"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy. Especially the non-showing pages in BookMorphs. (As needed, make a variant of this that brings in all pages that are not in memory.)"
| coll |
coll _ OrderedCollection new.
pages do: [:pg |
pg isInMemory ifTrue: [
pg == currentPage ifFalse: [coll add: pg]]].
^ coll!
----- Method: BookMorph>>allowSubmorphExtraction (in category 'dropping/grabbing') -----
allowSubmorphExtraction
^ false!
----- Method: BookMorph>>asPostscript (in category 'Postscript Canvases') -----
asPostscript
^self asPostscriptPrintJob.
!
----- Method: BookMorph>>bookmarkForThisPage (in category 'menu') -----
bookmarkForThisPage
"If this book exists on a server, make the reference via a URL"
| bb url um |
(url _ self url) ifNil: [
bb _ SimpleButtonMorph new target: self.
bb actionSelector: #goToPageMorph:fromBookmark:.
bb label: 'Bookmark' translated.
bb arguments: (Array with: currentPage with: bb).
self primaryHand attachMorph: bb.
^ bb].
currentPage url ifNil: [currentPage saveOnURLbasic].
um _ URLMorph newForURL: currentPage url.
um setURL: currentPage url page: currentPage sqkPage.
(SqueakPage stemUrl: url) = (SqueakPage stemUrl: currentPage url)
ifTrue: [um book: true]
ifFalse: [um book: url]. "remember which book"
um isBookmark: true; label: 'Bookmark' translated.
um borderWidth: 1; borderColor: #raised.
um color: (Color r: 0.4 g: 0.8 b: 0.6).
self primaryHand attachMorph: um.
^ um!
----- Method: BookMorph>>buildFloatingPageControls (in category 'navigation') -----
buildFloatingPageControls
| pageControls |
pageControls _ self makePageControlsFrom: self fullControlSpecs.
pageControls borderWidth: 0; layoutInset: 4.
pageControls setProperty: #pageControl toValue: true.
pageControls setNameTo: 'Page Controls'.
pageControls color: Color yellow.
^FloatingBookControlsMorph new addMorph: pageControls.
!
----- Method: BookMorph>>buildThreadOfProjects (in category 'menu') -----
buildThreadOfProjects
| thisPVM projectNames threadName |
projectNames _ pages collect: [ :each |
(thisPVM _ each findA: ProjectViewMorph) ifNil: [
nil
] ifNotNil: [
{thisPVM project name}.
].
].
projectNames _ projectNames reject: [ :each | each isNil].
threadName _ FillInTheBlank
request: 'Please name this thread.' translated
initialAnswer: (
self valueOfProperty: #nameOfThreadOfProjects ifAbsent: ['Projects on Parade' translated]
).
threadName isEmptyOrNil ifTrue: [^self].
InternalThreadNavigationMorph
know: projectNames as: threadName;
openThreadNamed: threadName atIndex: nil.
!
----- Method: BookMorph>>cardsOrPages (in category 'accessing') -----
cardsOrPages
"The turnable and printable entities"
^ pages!
----- Method: BookMorph>>chooseAndRevertToVersion (in category 'scripting') -----
chooseAndRevertToVersion
| time which |
"Let the user choose an older version for all code in MethodMorphs in this book. Run through that code and revert each one to that time."
self methodHolders. "find them in me"
self methodHolderVersions.
which _ PopUpMenu withCaption:
'Put all scripts in this book back
the way they were at this time:'
chooseFrom: #('leave as is'), VersionNames.
which <= 1 ifTrue: [^ self].
time _ VersionTimes at: which-1.
self revertToCheckpoint: time.!
----- Method: BookMorph>>copyUrl (in category 'menu') -----
copyUrl
"Copy this page's url to the clipboard"
| str |
str _ currentPage url ifNil: [str _ 'Page does not have a url. Send page to server first.' translated].
Clipboard clipboardText: str asText.
!
----- Method: BookMorph>>currentPage (in category 'accessing') -----
currentPage
(submorphs includes: currentPage) ifFalse: [currentPage _ nil].
^ currentPage!
----- Method: BookMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color white!
----- Method: BookMorph>>defaultNameStemForNewPages (in category 'insert and delete') -----
defaultNameStemForNewPages
"Answer a stem onto which to build default names for fresh pages"
^ 'page'
!
----- Method: BookMorph>>defersHaloOnClickTo: (in category 'halos and balloon help') -----
defersHaloOnClickTo: aSubMorph
"If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"
^ currentPage notNil and:
[aSubMorph hasOwner: currentPage]
!
----- Method: BookMorph>>deletePage (in category 'insert and delete') -----
deletePage
| message |
message _
'Are you certain that you
want to delete this page and
everything that is on it? ' translated.
(self confirm: message) ifTrue:
[self deletePageBasic].
!
----- Method: BookMorph>>deletePageBasic (in category 'insert and delete') -----
deletePageBasic
| thisPage |
thisPage _ self pageNumberOf: currentPage.
pages remove: currentPage.
currentPage delete.
currentPage _ nil.
pages isEmpty ifTrue: [^ self insertPage].
self goToPage: (thisPage min: pages size)
!
----- Method: BookMorph>>exitFullScreen (in category 'other') -----
exitFullScreen
| floater |
self isInFullScreenMode ifFalse: [^self].
self setProperty: #fullScreenMode toValue: false.
floater _ self valueOfProperty: #floatingPageControls ifAbsent: [nil].
floater ifNotNil: [
floater delete.
self removeProperty: #floatingPageControls.
].
self position: 0@0.
self adjustCurrentPageForFullScreen.
!
----- Method: BookMorph>>findText: (in category 'menu') -----
findText: wants
"Turn to the next page that has all of the strings mentioned on it. Highlight where it is found. allText and allTextUrls have been set. Case insensitive search.
Resuming a search. If container's text is still in the list and secondary keys are still in the page, (1) search rest of that container. (2) search rest of containers on that page (3) pages till end of book, (4) from page 1 to this page again."
"Later sort wants so longest key is first"
| allText good thisWord here fromHereOn startToHere oldContainer oldIndex otherKeys strings |
allText _ self valueOfProperty: #allText ifAbsent: [#()].
here _ pages identityIndexOf: currentPage ifAbsent: [1].
fromHereOn _ here+1 to: pages size.
startToHere _ 1 to: here. "repeat this page"
(self valueOfProperty: #searchKey ifAbsent: [#()]) = wants ifTrue: [
"does page have all the other keys? No highlight if found!!"
otherKeys _ wants allButFirst.
strings _ allText at: here.
good _ true.
otherKeys do: [:searchString | "each key"
good ifTrue: [thisWord _ false.
strings do: [:longString |
(longString findString: searchString startingAt: 1
caseSensitive: false) > 0 ifTrue: [
thisWord _ true]].
good _ thisWord]].
good ifTrue: ["all are on this page. Look in rest for string again."
oldContainer _ self valueOfProperty: #searchContainer.
oldIndex _ self valueOfProperty: #searchOffset.
(self findText: (OrderedCollection with: wants first) inStrings: strings
startAt: oldIndex+1 container: oldContainer
pageNum: here) ifTrue: [
self setProperty: #searchKey toValue: wants.
^ true]]]
ifFalse: [fromHereOn _ here to: pages size]. "do search this page"
"other pages"
allText ifNotEmpty: [
fromHereOn do: [:pageNum |
(self findText: wants inStrings: (allText at: pageNum) startAt: 1 container: nil
pageNum: pageNum)
ifTrue: [^ true]].
startToHere do: [:pageNum |
(self findText: wants inStrings: (allText at: pageNum) startAt: 1 container: nil
pageNum: pageNum)
ifTrue: [^ true]]].
"if fail"
self setProperty: #searchContainer toValue: nil.
self setProperty: #searchOffset toValue: nil.
self setProperty: #searchKey toValue: nil.
^ false!
----- Method: BookMorph>>findText:inStrings:startAt:container:pageNum: (in category 'menu') -----
findText: keys inStrings: rawStrings startAt: startIndex container: oldContainer pageNum: pageNum
"Call once to search a page of the book. Return true if found and highlight the text. oldContainer should be NIL.
(oldContainer is only non-nil when (1) doing a 'search again' and (2) the page is in memory and (3) keys has just one element. oldContainer is a TextMorph.)"
| good thisWord index insideOf place container start wasIn strings old |
good := true.
start := startIndex.
strings := oldContainer ifNil:
["normal case"
rawStrings]
ifNotNil:
[(pages at: pageNum) isInMemory
ifFalse: [rawStrings]
ifTrue: [(pages at: pageNum) allStringsAfter: oldContainer]].
keys do:
[:searchString |
"each key"
good
ifTrue:
[thisWord := false.
strings do:
[:longString |
(index := longString
findString: searchString
startingAt: start
caseSensitive: false) > 0
ifTrue:
[thisWord not & (searchString == keys first)
ifTrue:
[insideOf := longString.
place := index].
thisWord := true].
start := 1]. "only first key on first container"
good := thisWord]].
good
ifTrue:
["all are on this page"
wasIn := (pages at: pageNum) isInMemory.
self goToPage: pageNum.
wasIn
ifFalse:
["search again, on the real current text. Know page is in."
^self
findText: keys
inStrings: ((pages at: pageNum) allStringsAfter: nil)
startAt: startIndex
container: oldContainer
pageNum: pageNum "recompute"]].
(old := self valueOfProperty: #searchContainer) ifNotNil:
[(old respondsTo: #editor)
ifTrue:
[old editor selectFrom: 1 to: 0. "trying to remove the previous selection!!"
old changed]].
good
ifTrue:
["have the exact string object"
(container := oldContainer) ifNil:
[container := self
highlightText: keys first
at: place
in: insideOf]
ifNotNil:
[container userString == insideOf
ifFalse:
[container := self
highlightText: keys first
at: place
in: insideOf]
ifTrue:
[(container isTextMorph)
ifTrue:
[container editor selectFrom: place to: keys first size - 1 + place.
container changed]]].
self setProperty: #searchContainer toValue: container.
self setProperty: #searchOffset toValue: place.
self setProperty: #searchKey toValue: keys. "override later"
ActiveHand newKeyboardFocus: container.
^true].
^false!
----- Method: BookMorph>>forgetURLs (in category 'menu') -----
forgetURLs
"About to save these objects in a new place. Forget where stored now. Must bring in all pages we don't have."
| pg |
pages do: [:aPage |
aPage yourself. "bring it into memory"
(pg _ aPage valueOfProperty: #SqueakPage) ifNotNil: [
SqueakPageCache removeURL: pg url.
pg contentsMorph setProperty: #SqueakPage toValue: nil]].
self setProperty: #url toValue: nil.!
----- Method: BookMorph>>fromRemoteStream: (in category 'initialization') -----
fromRemoteStream: strm
"Make a book from an index and a bunch of pages on a server. NOT showing any page!! Index and pages must live in the same directory. If the book has moved, save the current correct urls for each of the pages. Self must already have a url stored in property #url."
| remote dict bookUrl oldStem stem oldUrl endPart |
remote := strm fileInObjectAndCode.
bookUrl := (SqueakPage new)
url: (self valueOfProperty: #url);
url.
"expand a relative url"
oldStem := SqueakPage stemUrl: (remote second) url.
oldStem := oldStem copyUpToLast: $/.
stem := SqueakPage stemUrl: bookUrl.
stem := stem copyUpToLast: $/.
oldStem = stem
ifFalse:
["Book is in new directory, fix page urls"
2 to: remote size
do:
[:ii |
oldUrl := (remote at: ii) url.
endPart := oldUrl copyFrom: oldStem size + 1 to: oldUrl size.
(remote at: ii) url: stem , endPart]].
self initialize.
pages := OrderedCollection new.
2 to: remote size do: [:ii | pages add: (remote at: ii)].
currentPage
fullReleaseCachedState;
delete. "the blank one"
currentPage := remote second.
dict := remote first.
self setProperty: #modTime toValue: (dict at: #modTime).
dict at: #allText
ifPresent: [:val | self setProperty: #allText toValue: val].
dict at: #allTextUrls
ifPresent: [:val | self setProperty: #allTextUrls toValue: val].
#(#color #borderWidth #borderColor #pageSize)
with: #(#color: #borderWidth: #borderColor: #pageSize:)
do: [:key :sel | dict at: key ifPresent: [:val | self perform: sel with: val]].
^self!
----- Method: BookMorph>>fromURL: (in category 'initialization') -----
fromURL: url
"Make a book from an index and a bunch of pages on a server. NOT showing any page!!"
| strm |
Cursor wait showWhile: [
strm _ (ServerFile new fullPath: url) asStream].
strm isString ifTrue: [self inform: 'Sorry, ',strm. ^ nil].
self setProperty: #url toValue: url.
self fromRemoteStream: strm.
^ self!
----- Method: BookMorph>>fullDrawPostscriptOn: (in category 'Postscript Canvases') -----
fullDrawPostscriptOn:aCanvas
^aCanvas fullDrawBookMorph:self.
!
----- Method: BookMorph>>getAllText (in category 'menu') -----
getAllText
"Collect the text for each page. Just point at strings so don't have to recopy them. Parallel array of urls for ID of pages.
allText = Array (pages size) of arrays (fields in it) of strings of text.
allTextUrls = Array (pages size) of urls or page numbers.
For any page that is out, text data came from .bo file on server.
Is rewritten when one or all pages are stored."
| oldUrls oldStringLists allText allTextUrls aUrl which |
oldUrls _ self valueOfProperty: #allTextUrls ifAbsent: [#()].
oldStringLists _ self valueOfProperty: #allText ifAbsent: [#()].
allText _ pages collect: [:pg | OrderedCollection new].
allTextUrls _ Array new: pages size.
pages doWithIndex: [:aPage :ind | aUrl _ aPage url. aPage isInMemory
ifTrue: [(allText at: ind) addAll: (aPage allStringsAfter: nil).
aUrl ifNil: [aUrl _ ind].
allTextUrls at: ind put: aUrl]
ifFalse: ["Order of pages on server may be different. (later keep up to date?)"
which _ oldUrls indexOf: aUrl.
allTextUrls at: ind put: aUrl.
which = 0 ifFalse: [allText at: ind put: (oldStringLists at: which)]]].
self setProperty: #allText toValue: allText.
self setProperty: #allTextUrls toValue: allTextUrls.
^ allText!
----- Method: BookMorph>>getStemUrl (in category 'menu') -----
getStemUrl
"Try to find the old place where this book was stored. Confirm with the
user. Else ask for new place."
| initial pg url knownURL |
knownURL _ false.
initial _ ''.
(pg _ currentPage valueOfProperty: #SqueakPage)
ifNotNil: [pg contentsMorph == currentPage
ifTrue: [initial _ pg url.
knownURL _ true]].
"If this page has a url"
pages
doWithIndex: [:aPage :ind | initial isEmpty
ifTrue: [aPage isInMemory
ifTrue: [(pg _ aPage valueOfProperty: #SqueakPage)
ifNotNil: [initial _ pg url]]]].
"any page with a url"
initial isEmpty
ifTrue: [initial _ ServerDirectory defaultStemUrl , '1.sp'].
"A new legal place"
url _ knownURL
ifTrue: [initial]
ifFalse: [FillInTheBlank request: 'url of the place to store a typical page in this book.
Must begin with file:// or ftp://' translated initialAnswer: initial].
^ SqueakPage stemUrl: url!
----- Method: BookMorph>>goFullScreen (in category 'other') -----
goFullScreen
| floater |
self isInFullScreenMode ifTrue: [^self].
self setProperty: #fullScreenMode toValue: true.
self position: (currentPage topLeft - self topLeft) negated.
self adjustCurrentPageForFullScreen.
floater _ self buildFloatingPageControls.
self setProperty: #floatingPageControls toValue: floater.
floater openInWorld.
!
----- Method: BookMorph>>goToPage (in category 'menu') -----
goToPage
| pageNum |
pageNum _ FillInTheBlank request: 'Page?' translated initialAnswer: '0'.
pageNum isEmptyOrNil ifTrue: [^true].
self goToPage: pageNum asNumber.
!
----- Method: BookMorph>>goToPage: (in category 'navigation') -----
goToPage: pageNumber
^ self goToPage: pageNumber transitionSpec: nil!
----- Method: BookMorph>>goToPage:transitionSpec: (in category 'navigation') -----
goToPage: pageNumber transitionSpec: transitionSpec
| pageMorph |
pages isEmpty ifTrue: [^ self].
pageMorph _ (self hasProperty: #dontWrapAtEnd)
ifTrue: [pages atPin: pageNumber]
ifFalse: [pages atWrap: pageNumber].
^ self goToPageMorph: pageMorph transitionSpec: transitionSpec!
----- Method: BookMorph>>goToPage:transitionSpec:runTransitionScripts: (in category 'navigation') -----
goToPage: pageNumber transitionSpec: transitionSpec runTransitionScripts: aBoolean
"Go the the given page number; use the transitionSpec supplied, and if the boolean parameter is true, run opening and closing scripts as appropriate"
| pageMorph |
pages isEmpty ifTrue: [^ self].
pageMorph _ (self hasProperty: #dontWrapAtEnd)
ifTrue: [pages atPin: pageNumber]
ifFalse: [pages atWrap: pageNumber].
^ self goToPageMorph: pageMorph transitionSpec: transitionSpec runTransitionScripts: aBoolean!
----- Method: BookMorph>>goToPageMorph: (in category 'navigation') -----
goToPageMorph: aMorph
"Set the given morph as the current page; run closing and opening scripts as appropriate"
self goToPageMorph: aMorph runTransitionScripts: true!
----- Method: BookMorph>>goToPageMorph:fromBookmark: (in category 'navigation') -----
goToPageMorph: aMorph fromBookmark: aBookmark
"This protocol enables sensitivity to a transitionSpec on the bookmark"
self goToPageMorph: aMorph
transitionSpec: (aBookmark valueOfProperty: #transitionSpec).
!
----- Method: BookMorph>>goToPageMorph:runTransitionScripts: (in category 'navigation') -----
goToPageMorph: aMorph runTransitionScripts: aBoolean
"Set the given morph as the current page. If the boolean parameter is true, then opening and closing scripts will be run"
self goToPage: (pages identityIndexOf: aMorph ifAbsent: [^ self "abort"]) transitionSpec: nil runTransitionScripts: aBoolean
!
----- Method: BookMorph>>goToPageMorph:transitionSpec: (in category 'navigation') -----
goToPageMorph: newPage transitionSpec: transitionSpec
| pageIndex aWorld oldPageIndex ascending tSpec readIn |
pages isEmpty ifTrue: [^self].
self setProperty: #searchContainer toValue: nil. "forget previous search"
self setProperty: #searchOffset toValue: nil.
self setProperty: #searchKey toValue: nil.
pageIndex := pages identityIndexOf: newPage ifAbsent: [^self "abort"].
readIn := newPage isInMemory not.
oldPageIndex := pages identityIndexOf: currentPage ifAbsent: [nil].
ascending := (oldPageIndex isNil or: [newPage == currentPage])
ifTrue: [nil]
ifFalse: [oldPageIndex < pageIndex].
tSpec := transitionSpec ifNil:
["If transition not specified by requestor..."
newPage valueOfProperty: #transitionSpec
ifAbsent:
[" ... then consult new page"
self transitionSpecFor: self " ... otherwise this is the default"]].
self flag: #arNote. "Probably unnecessary"
(aWorld := self world) ifNotNil: [self primaryHand releaseKeyboardFocus].
currentPage ifNotNil: [currentPage updateCachedThumbnail].
self currentPage notNil
ifTrue:
[(((pages at: pageIndex) owner isKindOf: TransitionMorph)
and: [(pages at: pageIndex) isInWorld])
ifTrue: [^self "In the process of a prior pageTurn"].
self currentPlayerDo: [:aPlayer | aPlayer runAllClosingScripts].
ascending ifNotNil:
["Show appropriate page transition and start new page when done"
currentPage stopStepping.
(pages at: pageIndex) position: currentPage position.
^(TransitionMorph
effect: tSpec second
direction: tSpec third
inverse: (ascending or: [transitionSpec notNil]) not)
showTransitionFrom: currentPage
to: (pages at: pageIndex)
in: self
whenStart: [self playPageFlipSound: tSpec first]
whenDone:
[currentPage
delete;
fullReleaseCachedState.
self insertPageMorphInCorrectSpot: (pages at: pageIndex).
self adjustCurrentPageForFullScreen.
self snapToEdgeIfAppropriate.
aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage].
self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts].
(aWorld := self world) ifNotNil:
["WHY??"
aWorld displayWorld].
readIn
ifTrue:
[currentPage updateThumbnailUrlInBook: self url.
currentPage sqkPage computeThumbnail "just store it"]]].
"No transition, but at least decommission current page"
currentPage
delete;
fullReleaseCachedState].
self insertPageMorphInCorrectSpot: (pages at: pageIndex).
self adjustCurrentPageForFullScreen.
self snapToEdgeIfAppropriate.
aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage].
self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts].
(aWorld := self world) ifNotNil:
["WHY??"
aWorld displayWorld].
readIn
ifTrue:
[currentPage updateThumbnailUrl.
currentPage sqkPage computeThumbnail "just store it"]!
----- Method: BookMorph>>goToPageMorph:transitionSpec:runTransitionScripts: (in category 'navigation') -----
goToPageMorph: newPage transitionSpec: transitionSpec runTransitionScripts: aBoolean
"Install the given page as the new current page; use the given transition spec, and if the boolean parameter is true, run closing and opening scripts on the outgoing and incoming players"
| pageIndex aWorld oldPageIndex ascending tSpec readIn |
pages isEmpty ifTrue: [^self].
self setProperty: #searchContainer toValue: nil. "forget previous search"
self setProperty: #searchOffset toValue: nil.
self setProperty: #searchKey toValue: nil.
pageIndex := pages identityIndexOf: newPage ifAbsent: [^self "abort"].
readIn := newPage isInMemory not.
oldPageIndex := pages identityIndexOf: currentPage ifAbsent: [nil].
ascending := (oldPageIndex isNil or: [newPage == currentPage])
ifTrue: [nil]
ifFalse: [oldPageIndex < pageIndex].
tSpec := transitionSpec ifNil:
["If transition not specified by requestor..."
newPage valueOfProperty: #transitionSpec
ifAbsent:
[" ... then consult new page"
self transitionSpecFor: self " ... otherwise this is the default"]].
self flag: #arNote. "Probably unnecessary"
(aWorld := self world) ifNotNil: [self primaryHand releaseKeyboardFocus].
currentPage ifNotNil: [currentPage updateCachedThumbnail].
self currentPage notNil
ifTrue:
[(((pages at: pageIndex) owner isKindOf: TransitionMorph)
and: [(pages at: pageIndex) isInWorld])
ifTrue: [^self "In the process of a prior pageTurn"].
aBoolean
ifTrue: [self currentPlayerDo: [:aPlayer | aPlayer runAllClosingScripts]].
ascending ifNotNil:
["Show appropriate page transition and start new page when done"
currentPage stopStepping.
(pages at: pageIndex) position: currentPage position.
^(TransitionMorph
effect: tSpec second
direction: tSpec third
inverse: (ascending or: [transitionSpec notNil]) not)
showTransitionFrom: currentPage
to: (pages at: pageIndex)
in: self
whenStart: [self playPageFlipSound: tSpec first]
whenDone:
[currentPage
delete;
fullReleaseCachedState.
self insertPageMorphInCorrectSpot: (pages at: pageIndex).
self adjustCurrentPageForFullScreen.
self snapToEdgeIfAppropriate.
aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage].
aBoolean
ifTrue: [self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]].
(aWorld := self world) ifNotNil:
["WHY??"
aWorld displayWorld].
readIn
ifTrue:
[currentPage updateThumbnailUrlInBook: self url.
currentPage sqkPage computeThumbnail "just store it"]]].
"No transition, but at least decommission current page"
currentPage
delete;
fullReleaseCachedState].
self insertPageMorphInCorrectSpot: (pages at: pageIndex).
self adjustCurrentPageForFullScreen.
self snapToEdgeIfAppropriate.
aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage].
self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts].
(aWorld := self world) ifNotNil:
["WHY??"
aWorld displayWorld].
readIn
ifTrue:
[currentPage updateThumbnailUrl.
currentPage sqkPage computeThumbnail "just store it"]!
----- Method: BookMorph>>goToPageUrl: (in category 'navigation') -----
goToPageUrl: aUrl
| pp short |
pp := pages detect: [:pg | pg url = aUrl] ifNone: [nil].
pp ifNil:
[short := (aUrl findTokens: '/') last.
pp := pages detect:
[:pg |
pg url ifNil: [false] ifNotNil: [(pg url findTokens: '/') last = short] "it moved"]
ifNone: [pages first]].
self goToPageMorph: pp!
----- Method: BookMorph>>goto: (in category 'navigation') -----
goto: aPlayer
self goToPageMorph: aPlayer costume!
----- Method: BookMorph>>highlightText:at:in: (in category 'menu') -----
highlightText: stringToHilite at: index in: insideOf
"Find the container with this text and highlight it. May not be able to do it for stringMorphs."
"Find the container with that text"
| container |
self
allMorphsDo: [:sub | insideOf == sub userString ifTrue: [container := sub]].
container ifNil:
[self
allMorphsDo: [:sub | insideOf = sub userString ifTrue: [container := sub]]]. "any match"
container ifNil: [^nil].
"Order it highlighted"
(container isTextMorph)
ifTrue:
[container editor selectFrom: index to: stringToHilite size - 1 + index].
container changed.
^container!
----- Method: BookMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self setInitialState.
pages _ OrderedCollection new.
self showPageControls.
self class
turnOffSoundWhile: [self insertPage]!
----- Method: BookMorph>>initializeToStandAlone (in category 'parts bin') -----
initializeToStandAlone
self initialize.
self removeEverything; pageSize: 360@228; color: (Color gray: 0.9).
self borderWidth: 1; borderColor: Color black.
self beSticky.
self showPageControls; insertPage.
^ self!
----- Method: BookMorph>>insertPage:pageSize: (in category 'insert and delete') -----
insertPage: aPage pageSize: aPageSize
^ self insertPage: aPage pageSize: aPageSize atIndex: (pages size + 1)!
----- Method: BookMorph>>insertPage:pageSize:atIndex: (in category 'insert and delete') -----
insertPage: aPage pageSize: aPageSize atIndex: anIndex
| sz predecessor |
sz := aPageSize
ifNil: [currentPage isNil ifTrue: [pageSize] ifFalse: [currentPage extent]]
ifNotNil: [aPageSize].
aPage extent: sz.
(pages isEmpty | anIndex isNil or: [anIndex > pages size])
ifTrue: [pages add: aPage]
ifFalse:
[anIndex <= 1
ifTrue: [pages addFirst: aPage]
ifFalse:
[predecessor := anIndex isNil
ifTrue: [currentPage]
ifFalse: [pages at: anIndex].
self pages add: aPage after: predecessor]].
self goToPageMorph: aPage!
----- Method: BookMorph>>insertPageColored: (in category 'insert and delete') -----
insertPageColored: aColor
"Insert a new page for the receiver, using the given color as its background color"
| sz newPage bw bc |
bc := currentPage isNil
ifTrue:
[sz := pageSize.
bw := 0.
Color blue muchLighter]
ifFalse:
[sz := currentPage extent.
bw := currentPage borderWidth.
currentPage borderColor].
newPagePrototype ifNil:
[newPage := (PasteUpMorph new)
extent: sz;
color: aColor.
newPage
borderWidth: bw;
borderColor: bc]
ifNotNil: [Cursor wait showWhile: [newPage := newPagePrototype veryDeepCopy]].
newPage setNameTo: self defaultNameStemForNewPages.
newPage vResizeToFit: false.
pages isEmpty
ifTrue: [pages add: (currentPage := newPage)]
ifFalse: [pages add: newPage after: currentPage].
self nextPage!
----- Method: BookMorph>>insertPageLabel:morphs: (in category 'insert and delete') -----
insertPageLabel: labelString morphs: morphList
| m c labelAllowance |
self insertPage.
labelString ifNotNil:
[m _ (TextMorph new extent: currentPage width@20; contents: labelString).
m lock.
m position: currentPage position + (((currentPage width - m width) // 2) @ 5).
currentPage addMorph: m.
labelAllowance _ 40]
ifNil:
[labelAllowance _ 0].
"use a column to align the given morphs, then add them to the page"
c _ AlignmentMorph newColumn wrapCentering: #center; cellPositioning: #topCenter.
c addAllMorphs: morphList.
c position: currentPage position + (0 @ labelAllowance).
currentPage addAllMorphs: morphList.
^ currentPage
!
----- Method: BookMorph>>insertPageMorphInCorrectSpot: (in category 'navigation') -----
insertPageMorphInCorrectSpot: aPageMorph
self addMorphBack: (currentPage _ aPageMorph).
!
----- Method: BookMorph>>insertPageSilentlyAtEnd (in category 'insert and delete') -----
insertPageSilentlyAtEnd
"Create a new page at the end of the book. Do not turn to it."
| sz newPage bw bc cc |
cc := currentPage isNil
ifTrue:
[sz := pageSize.
bw := 0.
bc := Color blue muchLighter.
color]
ifFalse:
[sz := currentPage extent.
bw := currentPage borderWidth.
bc := currentPage borderColor.
currentPage color].
newPagePrototype ifNil:
[newPage := (PasteUpMorph new)
extent: sz;
color: cc.
newPage
borderWidth: bw;
borderColor: bc]
ifNotNil: [Cursor wait showWhile: [newPage := newPagePrototype veryDeepCopy]].
newPage setNameTo: self defaultNameStemForNewPages.
newPage vResizeToFit: false.
pages isEmpty
ifTrue: [pages add: (currentPage := newPage) "had been none"]
ifFalse: [pages add: newPage after: pages last].
^newPage!
----- Method: BookMorph>>installRollBackButtons (in category 'scripting') -----
installRollBackButtons
| all |
"In each script in me, put a versions button it the upper right."
all _ IdentitySet new.
self allMorphsAndBookPagesInto: all.
all _ all select: [:mm | mm class = MethodMorph].
all do: [:mm | mm installRollBackButtons: self].!
----- Method: BookMorph>>invokeBookMenu (in category 'menu') -----
invokeBookMenu
"Invoke the book's control panel menu."
| aMenu |
aMenu _ MenuMorph new defaultTarget: self.
aMenu addTitle: 'Book' translated.
Preferences noviceMode
ifFalse:[aMenu addStayUpItem].
aMenu add: 'find...' translated action: #textSearch.
aMenu add: 'go to page...' translated action: #goToPage.
aMenu addLine.
aMenu addList: {
{'sort pages' translated. #sortPages}.
{'uncache page sorter' translated. #uncachePageSorter}}.
(self hasProperty: #dontWrapAtEnd)
ifTrue: [aMenu add: 'wrap after last page' translated selector: #setWrapPages: argument: true]
ifFalse: [aMenu add: 'stop at last page' translated selector: #setWrapPages: argument: false].
aMenu addList: {
{'make bookmark' translated. #bookmarkForThisPage}.
{'make thumbnail' translated. #thumbnailForThisPage}}.
aMenu addUpdating: #showingPageControlsString action: #toggleShowingOfPageControls.
aMenu addUpdating: #showingFullScreenString action: #toggleFullScreen.
aMenu addLine.
aMenu add: 'sound effect for all pages' translated action: #menuPageSoundForAll:.
aMenu add: 'sound effect this page only' translated action: #menuPageSoundForThisPage:.
aMenu add: 'visual effect for all pages' translated action: #menuPageVisualForAll:.
aMenu add: 'visual effect this page only' translated action: #menuPageVisualForThisPage:.
aMenu addLine.
(self primaryHand pasteBuffer class isKindOf: PasteUpMorph class) ifTrue:
[aMenu add: 'paste book page' translated action: #pasteBookPage].
aMenu add: 'save as new-page prototype' translated action: #setNewPagePrototype.
newPagePrototype ifNotNil: [
aMenu add: 'clear new-page prototype' translated action: #clearNewPagePrototype].
aMenu add: (self dragNDropEnabled ifTrue: ['close dragNdrop'] ifFalse: ['open dragNdrop']) translated
action: #toggleDragNDrop.
aMenu add: 'make all pages this size' translated action: #makeUniformPageSize.
aMenu
addUpdating: #keepingUniformPageSizeString
target: self
action: #toggleMaintainUniformPageSize.
aMenu addLine.
aMenu add: 'send all pages to server' translated action: #savePagesOnURL.
aMenu add: 'send this page to server' translated action: #saveOneOnURL.
aMenu add: 'reload all from server' translated action: #reload.
aMenu add: 'copy page url to clipboard' translated action: #copyUrl.
aMenu add: 'keep in one file' translated action: #keepTogether.
aMenu addLine.
aMenu add: 'load PPT images from slide #1' translated action: #loadImagesIntoBook.
aMenu add: 'background color for all pages...' translated action: #setPageColor.
aMenu add: 'make a thread of projects in this book' translated action: #buildThreadOfProjects.
aMenu popUpEvent: self world activeHand lastEvent in: self world
!
----- Method: BookMorph>>isInFullScreenMode (in category 'other') -----
isInFullScreenMode
^self valueOfProperty: #fullScreenMode ifAbsent: [false]!
----- Method: BookMorph>>keepTogether (in category 'menu') -----
keepTogether
"Mark this book so that each page will not go into a separate file. Do this when pages share referenes to a common Player. Don't want many copies of that Player when bring in. Do not write pages of book out. Write the PasteUpMorph that the entire book lives in."
self setProperty: #keepTogether toValue: true.!
----- Method: BookMorph>>keepingUniformPageSizeString (in category 'uniform page size') -----
keepingUniformPageSizeString
"Answer a string characterizing whether I am currently maintaining uniform page size"
^ (self maintainsUniformPageSize
ifTrue: ['<yes>']
ifFalse: ['<no>']), 'keep all pages the same size' translated!
----- Method: BookMorph>>lastPage (in category 'navigation') -----
lastPage
self goToPage: pages size
!
----- Method: BookMorph>>loadImagesIntoBook (in category 'menu') -----
loadImagesIntoBook
"PowerPoint stores GIF presentations as individual slides named Slide1, Slide2, etc.
Load these into the book. mjg 9/99"
| directory filenumber form newpage |
directory := ((StandardFileMenu oldFileFrom: FileDirectory default)
ifNil: [^nil]) directory.
directory isNil ifTrue: [^nil].
"Start loading 'em up!!"
filenumber := 1.
[directory fileExists: 'Slide' , filenumber asString] whileTrue:
[Transcript
show: 'Slide' , filenumber asString;
cr.
Smalltalk bytesLeft < 1000000
ifTrue:
["Make some room"
(self valueOfProperty: #url) isNil
ifTrue: [self savePagesOnURL]
ifFalse: [self saveAsNumberedURLs]].
form := Form
fromFileNamed: (directory fullNameFor: 'Slide' , filenumber asString).
newpage := PasteUpMorph new extent: form extent.
newpage addMorph: (World drawingClass withForm: form).
self pages addLast: newpage.
filenumber := filenumber + 1].
"After adding all, delete the first page."
self goToPage: 1.
self deletePageBasic.
"Save the book"
(self valueOfProperty: #url) isNil
ifTrue: [self savePagesOnURL]
ifFalse: [self saveAsNumberedURLs]!
----- Method: BookMorph>>maintainsUniformPageSize (in category 'uniform page size') -----
maintainsUniformPageSize
"Answer whether I am currently set up to maintain uniform page size"
^ self uniformPageSize notNil!
----- Method: BookMorph>>maintainsUniformPageSize: (in category 'uniform page size') -----
maintainsUniformPageSize: aBoolean
"Set the property governing whether I maintain uniform page size"
aBoolean
ifFalse:
[self removeProperty: #uniformPageSize]
ifTrue:
[self setProperty: #uniformPageSize toValue: currentPage extent]!
----- Method: BookMorph>>makeMinimalControlsWithColor:title: (in category 'other') -----
makeMinimalControlsWithColor: aColor title: aString
| aButton aColumn aRow but |
aButton _ SimpleButtonMorph new target: self; borderColor: Color black;
color: aColor; borderWidth: 0.
aColumn _ AlignmentMorph newColumn.
aColumn color: aButton color; borderWidth: 0; layoutInset: 0.
aColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
aRow _ AlignmentMorph newRow.
aRow color: aButton color; borderWidth: 0; layoutInset: 0.
aRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
aRow addTransparentSpacerOfSize: 40@0.
aRow addMorphBack: (but _ aButton label: ' < ' ; actionSelector: #previousPage).
"copy is OK, since we just made it and it can't own any Players"
but setBalloonText: 'Go to previous page'.
aRow addTransparentSpacerOfSize: 82@0.
aRow addMorphBack: (StringMorph contents: aString) lock.
aRow addTransparentSpacerOfSize: 82@0.
aButton _ SimpleButtonMorph new target: self; borderColor: Color black;
color: aColor; borderWidth: 0.
aRow addMorphBack: (but _ aButton label: ' > ' ; actionSelector: #nextPage).
but setBalloonText: 'Go to next page'.
aRow addTransparentSpacerOfSize: 40@0.
aColumn addMorphBack: aRow.
aColumn setNameTo: 'Page Controls'.
^ aColumn!
----- Method: BookMorph>>makeUniformPageSize (in category 'menu') -----
makeUniformPageSize
"Make all pages be of the same size as the current page."
currentPage ifNil: [^ Beeper beep].
self resizePagesTo: currentPage extent.
newPagePrototype ifNotNil:
[newPagePrototype extent: currentPage extent]!
----- Method: BookMorph>>menuPageSoundFor:event: (in category 'menu') -----
menuPageSoundFor: target event: evt
| tSpec menu |
tSpec _ self transitionSpecFor: target.
menu _ (MenuMorph entitled: 'Choose a sound
(it is now ' translated, tSpec first translated, ')') defaultTarget: target.
SoundService default sampledSoundChoices do:
[:soundName |
menu add: soundName translated target: target
selector: #setProperty:toValue:
argumentList: (Array with: #transitionSpec
with: (tSpec copy at: 1 put: soundName; yourself))].
menu popUpEvent: evt in: self world!
----- Method: BookMorph>>menuPageSoundForAll: (in category 'menu') -----
menuPageSoundForAll: evt
^ self menuPageSoundFor: self event: evt!
----- Method: BookMorph>>menuPageSoundForThisPage: (in category 'menu') -----
menuPageSoundForThisPage: evt
currentPage ifNotNil:
[^ self menuPageSoundFor: currentPage event: evt]!
----- Method: BookMorph>>menuPageVisualFor:event: (in category 'menu') -----
menuPageVisualFor: target event: evt
| tSpec menu subMenu directionChoices |
tSpec _ self transitionSpecFor: target.
menu _ (MenuMorph entitled: ('Choose an effect
(it is now {1})' translated format:{tSpec second asString translated})) defaultTarget: target.
TransitionMorph allEffects do:
[:effect |
directionChoices _ TransitionMorph directionsForEffect: effect.
directionChoices isEmpty
ifTrue: [menu add: effect asString translated target: target
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 asString translated target: target
selector: #setProperty:toValue:
argumentList: (Array with: #transitionSpec
with: (Array with: tSpec first with: effect with: dir))].
menu add: effect asString translated subMenu: subMenu]].
menu popUpEvent: evt in: self world!
----- Method: BookMorph>>menuPageVisualForAll: (in category 'menu') -----
menuPageVisualForAll: evt
^ self menuPageVisualFor: self event: evt!
----- Method: BookMorph>>menuPageVisualForThisPage: (in category 'menu') -----
menuPageVisualForThisPage: evt
currentPage ifNotNil:
[^ self menuPageVisualFor: currentPage event: evt]!
----- Method: BookMorph>>methodHolderVersions (in category 'scripting') -----
methodHolderVersions
| arrayOfVersions vTimes strings |
"Create lists of times of older versions of all code in MethodMorphs in this book."
arrayOfVersions _ MethodHolders collect: [:mh |
mh versions]. "equality, hash for MethodHolders?"
vTimes _ SortedCollection new.
arrayOfVersions do: [:versionBrowser |
versionBrowser changeList do: [:cr |
(strings _ cr stamp findTokens: ' ') size > 2 ifTrue: [
vTimes add: strings second asDate asSeconds +
strings third asTime asSeconds]]].
VersionTimes _ Time condenseBunches: vTimes.
VersionNames _ Time namesForTimes: VersionTimes.
!
----- Method: BookMorph>>methodHolders (in category 'scripting') -----
methodHolders
| all |
"search for all scripts that are in MethodHolders. These are the ones that have versions."
all _ IdentitySet new.
self allMorphsAndBookPagesInto: all.
all _ all select: [:mm | mm class = MethodMorph].
MethodHolders _ all asArray collect: [:mm | mm model].
!
----- Method: BookMorph>>morphsForPageSorter (in category 'sorting') -----
morphsForPageSorter
| i thumbnails |
'Assembling thumbnail images...'
displayProgressAt: self cursorPoint
from: 0 to: pages size
during:
[:bar | i _ 0.
thumbnails _ pages collect:
[:p | bar value: (i_ i+1).
pages size > 40
ifTrue: [p smallThumbnailForPageSorter inBook: self]
ifFalse: [p thumbnailForPageSorter inBook: self]]].
^ thumbnails!
----- Method: BookMorph>>newPages: (in category 'initialization') -----
newPages: pageList
"Replace all my pages with the given list of BookPageMorphs. After this call, currentPage may be invalid."
pages _ pages species new.
pages addAll: pageList!
----- Method: BookMorph>>newPages:currentIndex: (in category 'initialization') -----
newPages: pageList currentIndex: index
"Replace all my pages with the given list of BookPageMorphs. Make the current page be the page with the given index."
pages _ pages species new.
pages addAll: pageList.
pages isEmpty ifTrue: [^ self insertPage].
self goToPage: index.
!
----- Method: BookMorph>>nextPage (in category 'navigation') -----
nextPage
currentPage isNil ifTrue: [^self goToPage: 1].
self goToPage: (self pageNumberOf: currentPage) + 1!
----- Method: BookMorph>>pageControlsVisible (in category 'menu') -----
pageControlsVisible
^ self hasSubmorphWithProperty: #pageControl!
----- Method: BookMorph>>pageNamed: (in category 'accessing') -----
pageNamed: aName
^ pages detect: [:p | p knownName = aName] ifNone: [nil]!
----- Method: BookMorph>>pageNumber (in category 'navigation') -----
pageNumber
^ self pageNumberOf: currentPage!
----- Method: BookMorph>>pageNumberOf: (in category 'accessing') -----
pageNumberOf: aMorph
"Modified so that if the page IS in memory, other pages don't have to be brought in. (This method may wrongly say a page is not here if pages has a tombstone (MorphObjectOut) and that tombstone would resolve to an object already in this image. This is an unlikely case, and callers just have to tolerate it.)"
^ pages identityIndexOf: aMorph ifAbsent: [0]
!
----- Method: BookMorph>>pages (in category 'accessing') -----
pages
^ pages
!
----- Method: BookMorph>>pages: (in category 'accessing') -----
pages: aMorphList
pages _ aMorphList asOrderedCollection.
"It is tempting to force the first page to be the current page. But then, two pages might be shown at once!! Just trust the copying mechanism and let currentPage be copied correctly. --Ted."!
----- Method: BookMorph>>pagesHandledAutomatically (in category 'printing') -----
pagesHandledAutomatically
^true!
----- Method: BookMorph>>pasteBookPage (in category 'menu') -----
pasteBookPage
| aPage |
aPage _ self primaryHand objectToPaste.
self insertPage: aPage pageSize: aPage extent atIndex: ((pages indexOf: currentPage) - 1).
"self goToPageMorph: aPage"!
----- Method: BookMorph>>previousPage (in category 'navigation') -----
previousPage
currentPage isNil ifTrue: [^self goToPage: 1].
self goToPage: (self pageNumberOf: currentPage) - 1!
----- Method: BookMorph>>printPSToFile (in category 'menus') -----
printPSToFile
"Ask the user for a filename and print this morph as postscript."
| fileName rotateFlag |
fileName _ ('MyBook') translated asFileName.
fileName _ FillInTheBlank request: 'File name? (".ps" will be added to end)' translated
initialAnswer: fileName.
fileName isEmpty ifTrue: [^ Beeper beep].
(fileName endsWith: '.ps') ifFalse: [fileName _ fileName,'.ps'].
rotateFlag _ ((PopUpMenu labels:
'portrait (tall)
landscape (wide)' translated)
startUpWithCaption: 'Choose orientation...' translated) = 2.
(FileStream newFileNamed: fileName asFileName)
nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close.
!
----- Method: BookMorph>>releaseCachedState (in category 'caching') -----
releaseCachedState
"Release the cached state of all my pages."
super releaseCachedState.
self removeProperty: #allText. "the cache for text search"
pages do: [:page |
page == currentPage ifFalse: [page fullReleaseCachedState]].
!
----- Method: BookMorph>>reload (in category 'menu') -----
reload
"Fetch the pages of this book from the server again. For all pages that have not been modified, keep current ones. Use new pages. For each, look up in cache, if time there is equal to time of new, and its in, use the current morph.
Later do fancy things when a page has changed here, and also on the server."
| url onServer onPgs sq which |
(url _ self valueOfProperty: #url) ifNil: ["for .bo index file"
url _ FillInTheBlank
request: 'url of the place where this book''s index is stored.
Must begin with file:// or ftp://' translated
initialAnswer: (self getStemUrl, '.bo').
url notEmpty ifTrue: [self setProperty: #url toValue: url]
ifFalse: [^ self]].
onServer _ self class new fromURL: url.
"Later: test book times?"
onPgs _ onServer pages collect: [:out |
sq _ SqueakPageCache pageCache at: out url ifAbsent: [nil].
(sq notNil and: [sq contentsMorph isInMemory])
ifTrue: [((out sqkPage lastChangeTime > sq lastChangeTime) or:
[sq contentsMorph isNil])
ifTrue: [SqueakPageCache atURL: out url put: out sqkPage.
out]
ifFalse: [sq contentsMorph]]
ifFalse: [SqueakPageCache atURL: out url put: out sqkPage.
out]].
which _ (onPgs findFirst: [:pg | pg url = currentPage url]) max: 1.
self newPages: onPgs currentIndex: which.
"later stay at current page"
self setProperty: #modTime toValue: (onServer valueOfProperty: #modTime).
self setProperty: #allText toValue: (onServer valueOfProperty: #allText).
self setProperty: #allTextUrls toValue: (onServer valueOfProperty: #allTextUrls).
!
----- Method: BookMorph>>removeEverything (in category 'initialization') -----
removeEverything
currentPage _ nil.
pages _ OrderedCollection new.
self removeAllMorphs!
----- Method: BookMorph>>reserveUrls (in category 'menu') -----
reserveUrls
"Save a dummy version of the book first, assign all pages URLs, write dummy files to reserve the url, and write the index. Good when I have pages with interpointing bookmarks."
| stem |
(stem := self getStemUrl) isEmpty ifTrue: [^self].
pages doWithIndex:
[:pg :ind |
"does write the current page too"
pg url ifNil: [pg reserveUrl: stem , ind printString , '.sp']]
"self saveIndexOnURL."!
----- Method: BookMorph>>reserveUrlsIfNeeded (in category 'menu') -----
reserveUrlsIfNeeded
"See if this book needs to pre-allocate urls. Harmless if have urls already. Actually writes dummy files to reserve names."
| baddies bad2 |
pages size > 25 ifTrue: [^ self reserveUrls].
baddies _ BookPageThumbnailMorph withAllSubclasses.
bad2 _ FlexMorph withAllSubclasses.
pages do: [:aPage |
aPage allMorphsDo: [:mm |
(baddies includes: mm class) ifTrue: [^ self reserveUrls].
(bad2 includes: mm class) ifTrue: [
mm originalMorph class == aPage class ifTrue: [
^ self reserveUrls]]]].
!
----- Method: BookMorph>>resizePagesTo: (in category 'other') -----
resizePagesTo: anExtent
pages do:
[:aPage | aPage extent: anExtent]!
----- Method: BookMorph>>revertToCheckpoint: (in category 'scripting') -----
revertToCheckpoint: secsSince1901
| cngRecord |
"Put all scripts (that appear in MethodPanes) back to the way they were at an earlier time."
MethodHolders do: [:mh |
cngRecord _ mh versions versionFrom: secsSince1901.
cngRecord ifNotNil: [
(cngRecord stamp: Utilities changeStamp) fileIn]].
"does not delete method if no earlier version"
!
----- Method: BookMorph>>saveAsNumberedURLs (in category 'menu') -----
saveAsNumberedURLs
"Write out all pages in this book that are not showing, onto a server. The local disk could be the server. For any page that does not have a SqueakPage and a url already, name that page file by its page number. Any pages that are already totally out will stay that way."
| stem list firstTime |
firstTime := (self valueOfProperty: #url) isNil.
stem := self getStemUrl. "user must approve"
stem isEmpty ifTrue: [^self].
firstTime ifTrue: [self setProperty: #futureUrl toValue: stem , '.bo'].
self reserveUrlsIfNeeded.
pages doWithIndex:
[:aPage :ind |
"does write the current page too"
aPage isInMemory
ifTrue:
["not out now"
aPage presenter ifNotNil: [aPage presenter flushPlayerListCache].
aPage saveOnURL: stem , ind printString , '.sp']].
list := pages collect: [:aPage | aPage sqkPage prePurge].
"knows not to purge the current page"
list := (list select: [:each | each notNil]) asArray.
"do bulk become:"
(list collect: [:each | each contentsMorph])
elementsExchangeIdentityWith: (list
collect: [:spg | MorphObjectOut new xxxSetUrl: spg url page: spg]).
self saveIndexOnURL.
self presenter ifNotNil: [self presenter flushPlayerListCache].
firstTime
ifTrue:
["Put a thumbnail into the hand"
URLMorph grabForBook: self.
self setProperty: #futureUrl toValue: nil "clean up"]!
----- Method: BookMorph>>saveIndexOfOnly: (in category 'menu') -----
saveIndexOfOnly: aPage
"Modify the index of this book on a server. Read the index, modify the entry for just this page, and write back. See saveIndexOnURL. (page file names must be unique even if they live in different directories.)"
| mine sf remoteFile strm remote pageURL num pre index after dict allText allTextUrls fName |
mine _ self valueOfProperty: #url.
mine ifNil: [^ self saveIndexOnURL].
Cursor wait showWhile: [strm _ (ServerFile new fullPath: mine)].
strm ifNil: [^ self saveIndexOnURL].
strm isString ifTrue: [^ self saveIndexOnURL].
strm exists ifFalse: [^ self saveIndexOnURL]. "write whole thing if missing"
strm _ strm asStream.
strm isString ifTrue: [^ self saveIndexOnURL].
remote _ strm fileInObjectAndCode.
dict _ remote first.
allText _ dict at: #allText ifAbsent: [nil]. "remote, not local"
allTextUrls _ dict at: #allTextUrls ifAbsent: [nil].
allText size + 1 ~= remote size ifTrue: [self error: '.bo size mismatch. Please tell Ted what you just did to this book.' translated].
(pageURL _ aPage url) ifNil: [self error: 'just had one!!' translated].
fName _ pageURL copyAfterLast: $/.
2 to: remote size do: [:ii |
((remote at: ii) url findString: fName startingAt: 1
caseSensitive: false) > 0 ifTrue: [index _ ii]. "fast"
(remote at: ii) xxxReset].
index ifNil: ["new page, what existing page does it follow?"
num _ self pageNumberOf: aPage.
1 to: num-1 do: [:ii | (pages at: ii) url ifNotNil: [pre _ (pages at: ii) url]].
pre ifNil: [after _ remote size+1]
ifNotNil: ["look for it on disk, put me after"
pre _ pre copyAfterLast: $/.
2 to: remote size do: [:ii |
((remote at: ii) url findString: pre startingAt: 1
caseSensitive: false) > 0 ifTrue: [after _ ii+1]].
after ifNil: [after _ remote size+1]].
remote _ remote copyReplaceFrom: after to: after-1 with: #(1).
allText ifNotNil: [
dict at: #allText put: (allText copyReplaceFrom: after-1 to: after-2 with: #(())).
dict at: #allTextUrls put: (allTextUrls copyReplaceFrom: after-1 to: after-2 with: #(()))].
index _ after].
remote at: index put: (aPage sqkPage copyForSaving).
(dict at: #modTime ifAbsent: [0]) < Time totalSeconds ifTrue:
[dict at: #modTime put: Time totalSeconds].
allText ifNotNil: [
(dict at: #allText) at: index-1 put: (aPage allStringsAfter: nil).
(dict at: #allTextUrls) at: index-1 put: pageURL].
sf _ ServerDirectory new fullPath: mine.
Cursor wait showWhile: [
remoteFile _ sf fileNamed: mine.
remoteFile fileOutClass: nil andObject: remote.
"remoteFile close"].
!
----- Method: BookMorph>>saveIndexOnURL (in category 'menu') -----
saveIndexOnURL
"Make up an index to the pages of this book, with thumbnails, and store it on the server. (aDictionary, aMorphObjectOut, aMorphObjectOut, aMorphObjectOut). The last part corresponds exactly to what pages looks like when they are all out. Each holds onto a SqueakPage, which holds a url and a thumbnail."
| dict list mine sf remoteFile urlList |
pages isEmpty ifTrue: [^self].
dict := Dictionary new.
dict at: #modTime put: Time totalSeconds.
"self getAllText MUST have been called at start of this operation."
dict at: #allText put: (self valueOfProperty: #allText).
#(#color #borderWidth #borderColor #pageSize)
do: [:sel | dict at: sel put: (self perform: sel)].
self reserveUrlsIfNeeded. "should already be done"
list := pages copy. "paste dict on front below"
"Fix up the entries, should already be done"
list doWithIndex:
[:out :ind |
out isInMemory
ifTrue:
[(out valueOfProperty: #SqueakPage) ifNil: [out saveOnURLbasic].
list at: ind put: out sqkPage copyForSaving]].
urlList := list collect: [:ppg | ppg url].
self setProperty: #allTextUrls toValue: urlList.
dict at: #allTextUrls put: urlList.
list := (Array with: dict) , list.
mine := self valueOfProperty: #url.
mine ifNil:
[mine := self getStemUrl , '.bo'.
self setProperty: #url toValue: mine].
sf := ServerDirectory new fullPath: mine.
Cursor wait showWhile:
[remoteFile := sf fileNamed: mine.
remoteFile dataIsValid.
remoteFile fileOutClass: nil andObject: list
"remoteFile close"]!
----- Method: BookMorph>>saveOnUrlPage: (in category 'menu') -----
saveOnUrlPage: pageMorph
"Write out this single page in this book onto a server. See savePagesOnURL. (Don't compute the texts, only this page's is written.)"
| stem ind response rand newPlace dir |
(self valueOfProperty: #keepTogether) ifNotNil: [
self inform: 'This book is marked ''keep in one file''.
Several pages use a common Player.
Save the owner of the book instead.' translated.
^ self].
"Don't give the chance to put in a different place. Assume named by number"
((self valueOfProperty: #url) isNil and: [pages first url notNil]) ifTrue: [
response _ (PopUpMenu labels: 'Old book
New book sharing old pages' translated)
startUpWithCaption: 'Modify the old book, or make a new
book sharing its pages?' translated.
response = 2 ifTrue: [
"Make up new url for .bo file and confirm with user." "Mark as shared"
[rand _ String new: 4.
1 to: rand size do: [:ii |
rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)].
(newPlace _ self getStemUrl) isEmpty ifTrue: [^ self].
newPlace _ (newPlace copyUpToLast: $/), '/BK', rand, '.bo'.
dir _ ServerFile new fullPath: newPlace.
(dir includesKey: dir fileName)] whileTrue. "keep doing until a new file"
self setProperty: #url toValue: newPlace].
response = 0 ifTrue: [^ self]].
stem _ self getStemUrl. "user must approve"
stem isEmpty ifTrue: [^ self].
ind _ pages identityIndexOf: pageMorph ifAbsent: [self error: 'where is the page?' translated].
pageMorph isInMemory ifTrue: ["not out now"
pageMorph saveOnURL: stem,(ind printString),'.sp'].
self saveIndexOfOnly: pageMorph.!
----- Method: BookMorph>>saveOneOnURL (in category 'menu') -----
saveOneOnURL
"Write out this single page onto a server. See savePagesOnURL. (Don't compute the texts, only this page's is written.)"
^ self saveOnUrlPage: currentPage!
----- Method: BookMorph>>savePagesOnURL (in category 'menu') -----
savePagesOnURL
"Write out all pages in this book onto a server. For any page that does not have a SqueakPage and a url already, ask the user for one. Give the option of naming all page files by page number. Any pages that are not in memory will stay that way. The local disk could be the server."
| response list firstTime newPlace rand dir bookUrl |
(self valueOfProperty: #keepTogether) ifNotNil: [
self inform: 'This book is marked ''keep in one file''.
Several pages use a common Player.
Save the owner of the book instead.' translated.
^ self].
self getAllText. "stored with index later"
response _ (PopUpMenu labels: 'Use page numbers
Type in file names
Save in a new place (using page numbers)
Save in a new place (typing names)
Save new book sharing old pages' translated)
startUpWithCaption: 'Each page will be a file on the server.
Do you want to page numbers be the names of the files?
or name each one yourself?' translated.
response = 1 ifTrue: [self saveAsNumberedURLs. ^ self].
response = 3 ifTrue: [self forgetURLs; saveAsNumberedURLs. ^ self].
response = 4 ifTrue: [self forgetURLs].
response = 5 ifTrue: [
"Make up new url for .bo file and confirm with user." "Mark as shared"
[rand _ String new: 4.
1 to: rand size do: [:ii |
rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)].
(newPlace _ self getStemUrl) isEmpty ifTrue: [^ self].
newPlace _ (newPlace copyUpToLast: $/), '/BK', rand, '.bo'.
dir _ ServerFile new fullPath: newPlace.
(dir includesKey: dir fileName)] whileTrue. "keep doing until a new file"
self setProperty: #url toValue: newPlace.
self saveAsNumberedURLs.
bookUrl _ self valueOfProperty: #url.
(SqueakPage stemUrl: bookUrl) =
(SqueakPage stemUrl: currentPage url) ifTrue: [
bookUrl _ true]. "not a shared book"
(URLMorph grabURL: currentPage url) book: bookUrl.
^ self].
response = 0 ifTrue: [^ self].
"self reserveUrlsIfNeeded. Need two passes here -- name on one, write on second"
pages do: [:aPage | "does write the current page too"
aPage isInMemory ifTrue: ["not out now"
aPage presenter ifNotNil: [aPage presenter flushPlayerListCache].
aPage saveOnURLbasic.
]]. "ask user if no url"
list _ pages collect: [:aPage | aPage sqkPage prePurge].
"knows not to purge the current page"
list _ (list select: [:each | each notNil]) asArray.
"do bulk become:"
(list collect: [:each | each contentsMorph])
elementsExchangeIdentityWith:
(list collect: [:spg | MorphObjectOut new xxxSetUrl: spg url page: spg]).
firstTime _ (self valueOfProperty: #url) isNil.
self saveIndexOnURL.
self presenter ifNotNil: [self presenter flushPlayerListCache].
firstTime ifTrue: ["Put a thumbnail into the hand"
URLMorph grabForBook: self.
self setProperty: #futureUrl toValue: nil]. "clean up"
!
----- Method: BookMorph>>setAllPagesColor: (in category 'accessing') -----
setAllPagesColor: aColor
"Set the color of all the pages to a new color"
self pages do: [:page | page color: aColor].!
----- Method: BookMorph>>setExtentFromHalo: (in category 'other') -----
setExtentFromHalo: anExtent
"The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed. For a BookMorph, we assume any resizing attempt is a request that the book-page currently being viewed be resized accoringly; this will typically not affect unseen book pages, though there is a command that can be issued to harmonize all book-page sizes, and also an option to set that will maintain all pages at the same size no matter what."
currentPage isInWorld
ifFalse: "doubtful case mostly"
[super setExtentFromHalo: anExtent]
ifTrue:
[currentPage width: anExtent x.
currentPage height: (anExtent y - (self innerBounds height - currentPage height)).
self maintainsUniformPageSize ifTrue:
[self setProperty: #uniformPageSize toValue: currentPage extent]]!
----- Method: BookMorph>>setInitialState (in category 'initialization') -----
setInitialState
self listDirection: #topToBottom;
wrapCentering: #topLeft;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
layoutInset: 5.
pageSize _ 160 @ 300.
self enableDragNDrop!
----- Method: BookMorph>>setNewPagePrototype (in category 'menu') -----
setNewPagePrototype
"Record the current page as the prototype to be copied when inserting new pages."
currentPage ifNotNil:
[newPagePrototype _ currentPage veryDeepCopy].
!
----- Method: BookMorph>>setPageColor (in category 'menu') -----
setPageColor
"Get a color from the user, then set all the pages to that color"
self currentPage ifNil: [^ self].
ColorPickerMorph new
choseModalityFromPreference;
sourceHand: self activeHand;
target: self;
selector: #setAllPagesColor:;
originalColor: self currentPage color;
putUpFor: self near: self fullBoundsInWorld!
----- Method: BookMorph>>setWrapPages: (in category 'navigation') -----
setWrapPages: doWrap
doWrap
ifTrue: [self removeProperty: #dontWrapAtEnd]
ifFalse: [self setProperty: #dontWrapAtEnd toValue: true].
!
----- Method: BookMorph>>showMoreControls (in category 'navigation') -----
showMoreControls
self currentEvent shiftPressed
ifTrue:
[self hidePageControls]
ifFalse:
[self showPageControls: self fullControlSpecs]!
----- Method: BookMorph>>sortPages (in category 'menu commands') -----
sortPages
currentPage ifNotNil: [currentPage updateCachedThumbnail].
^ super sortPages!
----- Method: BookMorph>>sortPages: (in category 'sorting') -----
sortPages: evt
^ self sortPages!
----- Method: BookMorph>>textSearch (in category 'menu') -----
textSearch
"search the text on all pages of this book"
| wanted wants list str |
list _ self valueOfProperty: #searchKey ifAbsent: [#()].
str _ String streamContents: [:strm |
list do: [:each | strm nextPutAll: each; space]].
wanted _ FillInTheBlank request: 'words to search for. Order is not important.
Beginnings of words are OK.' translated
initialAnswer: str.
wants _ wanted findTokens: Character separators.
wants isEmpty ifTrue: [^ self].
self getAllText. "save in allText, allTextUrls"
^ self findText: wants "goes to the page and highlights the text"!
----- Method: BookMorph>>textSearch: (in category 'menu') -----
textSearch: stringWithKeys
"search the text on all pages of this book"
| wants |
wants := stringWithKeys findTokens: Character separators.
wants isEmpty ifTrue: [^self].
self getAllText. "save in allText, allTextUrls"
^self findText: wants "goes to the page and highlights the text"!
----- Method: BookMorph>>thumbnailForThisPage (in category 'menu') -----
thumbnailForThisPage
self primaryHand attachMorph:
(currentPage thumbnailForPageSorter pageMorph: currentPage inBook: self)
!
----- Method: BookMorph>>toggleFullScreen (in category 'menu') -----
toggleFullScreen
self isInFullScreenMode
ifTrue: [self exitFullScreen]
ifFalse: [self goFullScreen]!
----- Method: BookMorph>>toggleMaintainUniformPageSize (in category 'uniform page size') -----
toggleMaintainUniformPageSize
"Toggle whether or not the receiver should maintain uniform page size"
self maintainsUniformPageSize: self maintainsUniformPageSize not!
----- Method: BookMorph>>toggleShowingOfPageControls (in category 'menu') -----
toggleShowingOfPageControls
self pageControlsVisible
ifTrue: [self hidePageControls]
ifFalse: [self showPageControls]!
----- Method: BookMorph>>transitionSpecFor: (in category 'navigation') -----
transitionSpecFor: aMorph
^ aMorph valueOfProperty: #transitionSpec " check for special propety"
ifAbsent: [Array with: 'camera' " ... otherwise this is the default"
with: #none
with: #none]!
----- Method: BookMorph>>uncachePageSorter (in category 'menu') -----
uncachePageSorter
pages do: [:aPage | aPage removeProperty: #cachedThumbnail].!
----- Method: BookMorph>>uniformPageSize (in category 'uniform page size') -----
uniformPageSize
"Answer the uniform page size to maintain, or nil if the option is not set"
^ self valueOfProperty: #uniformPageSize ifAbsent: [nil]!
----- Method: BookMorph>>updateReferencesUsing: (in category 'copying') -----
updateReferencesUsing: aDictionary
super updateReferencesUsing: aDictionary.
pages do: [:page |
page allMorphsDo: [:m | m updateReferencesUsing: aDictionary]].
!
----- Method: BookMorph>>userString (in category 'accessing') -----
userString
"Do I have a text string to be searched on?"
| list |
self getAllText.
list _ OrderedCollection new.
(self valueOfProperty: #allText ifAbsent: #()) do: [:aList |
list addAll: aList].
^ list!
----- Method: BookMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
(currentPage bounds containsPoint: (self pointFromWorld: evt cursorPoint)) ifFalse: [^ false].
^ super wantsDroppedMorph: aMorph event: evt!
BookMorph subclass: #StoryboardBookMorph
instanceVariableNames: 'alansSliders panAndTiltFactor zoomFactor zoomController'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicBooks'!
!StoryboardBookMorph commentStamp: '<historical>' prior: 0!
A BookMorph variant whose pages are instances of ZoomAndScrollMorph. I have a control area where the user may pan, tilt and zoom over the image shown in the page.
- drag up and down to zoom in and out
- drag left and right to pan
- shift-drag up and down to tilt.!
----- Method: StoryboardBookMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Storyboard'
categories: #('Presentation')
documentation: 'A storyboard authoring tool'!
----- Method: StoryboardBookMorph>>changeTiltFactor: (in category 'as yet unclassified') -----
changeTiltFactor: x
currentPage changeTiltFactor: x.
panAndTiltFactor _ x.
!
----- Method: StoryboardBookMorph>>changeZoomFactor: (in category 'as yet unclassified') -----
changeZoomFactor: x
currentPage changeZoomFactor: x.
zoomFactor _ x.!
----- Method: StoryboardBookMorph>>getTiltFactor (in category 'as yet unclassified') -----
getTiltFactor
^panAndTiltFactor ifNil: [panAndTiltFactor _ 0.5].!
----- Method: StoryboardBookMorph>>getZoomFactor (in category 'as yet unclassified') -----
getZoomFactor
^zoomFactor ifNil: [zoomFactor _ 0.5]!
----- Method: StoryboardBookMorph>>initialize (in category 'initialization') -----
initialize
newPagePrototype _ ZoomAndScrollMorph new extent: Display extent // 3.
zoomController _ ZoomAndScrollControllerMorph new
setBalloonText: 'Drag in here to zoom, tilt and pan the page above'.
super initialize.
self addMorphBack: zoomController.
alansSliders _ {
{#changeTiltFactor: . #getTiltFactor . 'Pan and tilt sensitivity'}.
{#changeZoomFactor: . #getZoomFactor . 'Zoom sensitivity'}.
} collect: [ :sData |
{
SimpleSliderMorph new
extent: 150@10;
color: Color orange;
sliderColor: Color gray;
target: self;
actionSelector: sData first;
setBalloonText: sData third;
adjustToValue: (self perform: sData second).
sData second
}
].
alansSliders do: [ :each | self addMorphBack: each first]
!
----- Method: StoryboardBookMorph>>insertPageMorphInCorrectSpot: (in category 'navigation') -----
insertPageMorphInCorrectSpot: aPageMorph
"Insert the page morph at the correct spot"
| place |
place _ submorphs size > 1 ifTrue: [submorphs second] ifFalse: [submorphs first].
"Old architecture had a tiny spacer morph as the second morph; now architecture does not"
self addMorph: (currentPage _ aPageMorph) behind: place.
self changeTiltFactor: self getTiltFactor.
self changeZoomFactor: self getZoomFactor.
zoomController target: currentPage.
!
----- Method: StoryboardBookMorph>>offsetX (in category 'as yet unclassified') -----
offsetX
^currentPage offsetX!
----- Method: StoryboardBookMorph>>offsetX: (in category 'as yet unclassified') -----
offsetX: aNumber
currentPage offsetX: aNumber!
----- Method: StoryboardBookMorph>>offsetY (in category 'as yet unclassified') -----
offsetY
^currentPage offsetY!
----- Method: StoryboardBookMorph>>offsetY: (in category 'as yet unclassified') -----
offsetY: aNumber
currentPage offsetY: aNumber!
----- Method: StoryboardBookMorph>>scale (in category 'as yet unclassified') -----
scale
^currentPage scale!
----- Method: StoryboardBookMorph>>scale: (in category 'as yet unclassified') -----
scale: aValue
currentPage scale: aValue!
----- Method: BooklikeMorph class>>initialize (in category 'class initialization') -----
initialize
"BooklikeMorph initialize"
PageFlipSoundOn _ true
!
----- Method: BooklikeMorph class>>turnOffSoundWhile: (in category 'as yet unclassified') -----
turnOffSoundWhile: aBlock
"Turn off page flip sound during the given block."
| old |
old _ PageFlipSoundOn.
PageFlipSoundOn _ false.
aBlock value.
PageFlipSoundOn _ old!
----- Method: BooklikeMorph>>addBookMenuItemsTo:hand: (in category 'misc') -----
addBookMenuItemsTo: aCustomMenu hand: aHandMorph
(self hasSubmorphWithProperty: #pageControl)
ifTrue: [aCustomMenu add: 'hide page controls' translated action: #hidePageControls]
ifFalse: [aCustomMenu add: 'show page controls' translated action: #showPageControls]!
----- Method: BooklikeMorph>>addCustomMenuItems:hand: (in category 'menus') -----
addCustomMenuItems: aCustomMenu hand: aHandMorph
"This factoring allows subclasses to have different menu yet still use the super call for the rest of the metamenu."
super addCustomMenuItems: aCustomMenu hand: aHandMorph.
self addBookMenuItemsTo: aCustomMenu hand: aHandMorph!
----- Method: BooklikeMorph>>addPageControlMorph: (in category 'page controls') -----
addPageControlMorph: aMorph
"Add the morph provided as a page control, at the appropriate place"
aMorph setProperty: #pageControl toValue: true.
self addMorph: aMorph asElementNumber: self indexForPageControls!
----- Method: BooklikeMorph>>clearNewPagePrototype (in category 'menu commands') -----
clearNewPagePrototype
newPagePrototype _ nil
!
----- Method: BooklikeMorph>>currentPlayerDo: (in category 'e-toy support') -----
currentPlayerDo: aBlock
| aPlayer aPage |
(aPage _ self currentPage) ifNil: [^ self].
(aPlayer _ aPage player) ifNotNil:
[aBlock value: aPlayer]!
----- Method: BooklikeMorph>>fewerPageControls (in category 'page controls') -----
fewerPageControls
self currentEvent shiftPressed
ifTrue:
[self hidePageControls]
ifFalse:
[self showPageControls: self shortControlSpecs]!
----- Method: BooklikeMorph>>firstPage (in category 'menu commands') -----
firstPage
self goToPage: 1!
----- Method: BooklikeMorph>>fullControlSpecs (in category 'page controls') -----
fullControlSpecs
^ {
#spacer.
#variableSpacer.
{'-'. #deletePage. 'Delete this page' translated}.
#spacer.
{'«'. #firstPage. 'First page' translated}.
#spacer.
{'<'. #previousPage. 'Previous page' translated}.
#spacer.
{'·'. #invokeBookMenu. 'Click here to get a menu of options for this book.' translated}.
#spacer.
{'>'. #nextPage. 'Next page' translated}.
#spacer.
{ '»'. #lastPage. 'Final page' translated}.
#spacer.
{'+'. #insertPage. 'Add a new page after this one' translated}.
#variableSpacer.
{'³'. #fewerPageControls. 'Fewer controls' translated}
}
!
----- Method: BooklikeMorph>>hidePageControls (in category 'page controls') -----
hidePageControls
"Delete all submorphs answering to the property #pageControl"
self deleteSubmorphsWithProperty: #pageControl!
----- Method: BooklikeMorph>>indexForPageControls (in category 'page controls') -----
indexForPageControls
"Answer which submorph should hold the page controls"
^ (submorphs size > 0 and: [submorphs first hasProperty: #header])
ifTrue: [2]
ifFalse: [1]!
----- Method: BooklikeMorph>>insertPage (in category 'menu commands') -----
insertPage
self insertPageColored: self color!
----- Method: BooklikeMorph>>makePageControlsFrom: (in category 'page controls') -----
makePageControlsFrom: controlSpecs
"From the controlSpecs, create a set of page control and return them -- this method does *not* add the controls to the receiver."
| c col row b lastGuy |
c _ (color saturation > 0.1) ifTrue: [color slightlyLighter] ifFalse: [color slightlyDarker].
col _ AlignmentMorph newColumn.
col color: c; borderWidth: 0; layoutInset: 0.
col hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5.
row _ AlignmentMorph newRow.
row color: c; borderWidth: 0; layoutInset: 0.
row hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5.
controlSpecs do: [:spec |
spec == #spacer
ifTrue:
[row addTransparentSpacerOfSize: (10 @ 0)]
ifFalse:
[spec == #variableSpacer
ifTrue:
[row addMorphBack: AlignmentMorph newVariableTransparentSpacer]
ifFalse:
[b _ SimpleButtonMorph new target: self; borderWidth: 1;
borderColor: Color veryLightGray; color: c.
b label: spec first;
actionSelector: spec second;
borderWidth: 0;
setBalloonText: spec third.
row addMorphBack: b.
(((lastGuy _ spec last asLowercase) includesSubString: 'menu') or:
[lastGuy includesSubString: 'designations'])
ifTrue: [b actWhen: #buttonDown]]]]. "pop up menu on mouseDown"
col addMorphBack: row.
^ col!
----- Method: BooklikeMorph>>move (in category 'misc') -----
move
(owner isWorldMorph and:[self isSticky not]) ifTrue: [self activeHand grabMorph: self]!
----- Method: BooklikeMorph>>pageSize (in category 'misc') -----
pageSize
^ pageSize
!
----- Method: BooklikeMorph>>pageSize: (in category 'misc') -----
pageSize: aPoint
pageSize _ aPoint!
----- Method: BooklikeMorph>>playPageFlipSound: (in category 'misc') -----
playPageFlipSound: soundName
self presenter ifNil: [^ self]. "Avoid failures when called too early"
PageFlipSoundOn "mechanism to suppress sounds at init time"
ifTrue: [self playSoundNamed: soundName].
!
----- Method: BooklikeMorph>>setEventHandlerForPageControls: (in category 'page controls') -----
setEventHandlerForPageControls: controls
"Set the controls' event handler if appropriate. Default is to let the tool be dragged by the controls"
controls eventHandler: (EventHandler new on: #mouseDown send: #move to: self)!
----- Method: BooklikeMorph>>shortControlSpecs (in category 'page controls') -----
shortControlSpecs
^ {
#spacer.
#variableSpacer.
{'<'. #previousPage. 'Previous page' translated}.
#spacer.
{'·'. #invokeBookMenu. 'Click here to get a menu of options for this book.' translated}.
#spacer.
{'>'. #nextPage. 'Next page' translated}.
#spacer.
#variableSpacer.
{'³'. #showMoreControls. 'More controls' translated}
}
!
----- Method: BooklikeMorph>>showPageControls (in category 'page controls') -----
showPageControls
self showPageControls: self shortControlSpecs!
----- Method: BooklikeMorph>>showPageControls: (in category 'page controls') -----
showPageControls: controlSpecs
"Remove any existing page controls, and add fresh controls at the top of the receiver (or in position 2 if the receiver's first submorph is one with property #header). Add a single column of controls."
| pageControls column |
self hidePageControls.
column _ AlignmentMorph newColumn beTransparent.
pageControls _ self makePageControlsFrom: controlSpecs.
pageControls borderWidth: 0; layoutInset: 4.
pageControls beSticky.
pageControls setNameTo: 'Page Controls'.
self setEventHandlerForPageControls: pageControls.
column addMorphBack: pageControls.
self addPageControlMorph: column!
----- Method: BooklikeMorph>>showingFullScreenString (in category 'misc') -----
showingFullScreenString
^ (self isInFullScreenMode
ifTrue: ['exit full screen']
ifFalse: ['show full screen']) translated!
----- Method: BooklikeMorph>>showingPageControlsString (in category 'misc') -----
showingPageControlsString
^ (self pageControlsVisible
ifTrue: ['hide page controls']
ifFalse: ['show page controls']) translated!
----- Method: BooklikeMorph>>sortPages (in category 'menu commands') -----
sortPages
| sorter |
sorter _ BookPageSorterMorph new
book: self morphsToSort: self morphsForPageSorter.
sorter pageHolder cursor: self pageNumber.
"Align at bottom right of screen, but leave 20-pix margin."
self bottom + sorter height < Display height ifTrue: "Place it below if it fits"
[^ self world addMorphFront: (sorter align: sorter topLeft with: self bottomLeft)].
self right + sorter width < Display width ifTrue: "Place it below if it fits"
[^ self world addMorphFront: (sorter align: sorter bottomLeft with: self bottomRight)].
"Otherwise, place it at lower right of screen"
self world addMorphFront: (sorter position: Display extent - (20@20) - sorter extent).
!
AlignmentMorph subclass: #FloatingBookControlsMorph
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicBooks'!
----- Method: FloatingBookControlsMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 1!
----- Method: FloatingBookControlsMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self layoutInset: 0;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap !
----- Method: FloatingBookControlsMorph>>morphicLayerNumber (in category 'WiW support') -----
morphicLayerNumber
"helpful for insuring some morphs always appear in front of or behind others.
smaller numbers are in front"
^23 "page controls are behind menus and balloons, but in front of most other stuff"!
----- Method: FloatingBookControlsMorph>>step (in category 'stepping and presenter') -----
step
owner == self world ifFalse: [^ self].
owner addMorphInLayer: self.
!
----- Method: FloatingBookControlsMorph>>stepTime (in category 'testing') -----
stepTime
^1000!
----- Method: FloatingBookControlsMorph>>wantsSteps (in category 'testing') -----
wantsSteps
^true!
PluggableTextMorph subclass: #MethodMorph
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicBooks'!
----- Method: MethodMorph class>>defaultNameStemForInstances (in category 'as yet unclassified') -----
defaultNameStemForInstances
^ 'Method'!
----- Method: MethodMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
includeInNewMorphMenu
"Not to be instantiated from the menu"
^ false!
----- Method: MethodMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
self useRoundedCorners!
----- Method: MethodMorph>>installRollBackButtons: (in category 'as yet unclassified') -----
installRollBackButtons: target
| mine |
"If I don't already have such a button, put one in at the upper right. Set its target to the furtherest enclosing book. Send chooseAndRevertToVersion when clicked. Stay in place via scrollBar install."
mine := self submorphNamed: #chooseAndRevertToVersion ifNone: [nil].
mine ifNil: [mine := SimpleButtonMorph new.
"mine height: mine height - 2."
mine label: 'Roll Back'; cornerStyle: #square.
mine color: Color white; borderColor: Color black.
mine actionSelector: #chooseAndRevertToVersion.
mine align: mine topRight with: (self findA: ScrollBar) topLeft +(1@1).
self addMorphFront: mine.
mine height: mine height - 5 "14"].
mine target: target.!
----- Method: MethodMorph>>showScrollBar (in category 'scrolling') -----
showScrollBar
"Copied down and modified to get rid of the ruinous comeToFront of the inherited version."
| scriptor |
(submorphs includes: scrollBar)
ifTrue: [^ self].
self vResizeScrollBar.
self privateAddMorph: scrollBar atIndex: 1.
retractableScrollBar
ifTrue:
["Bring the pane to the front so that it is fully visible"
"self comeToFront. -- thanks but no thanks"
(scriptor := self ownerThatIsA: ScriptEditorMorph)
ifNotNil:
[scriptor comeToFront]]
ifFalse: [self resetExtent]!
----- Method: MethodMorph>>step (in category 'stepping and presenter') -----
step
model updateCodePaneIfNeeded!
----- Method: MethodMorph>>stepTime (in category 'testing') -----
stepTime
^ 3000!
1
0
Squeak3.11 Contributions: Nebraska-kph.14.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 13 Jan '09
by squeak-dev-noreply＠lists.squeakfoundation.org 13 Jan '09
13 Jan '09
A new version of Nebraska was added to project Squeak3.11 Contributions:
http://www.squeaksource.com/311/Nebraska-kph.14.mcz
==================== Summary ====================
Name: Nebraska-kph.14
Author: test
Time: 13 January 2009, 8:19:14 pm
UUID: 1e817ff3-170f-43e7-adf3-2ab89ab3d72c
Ancestors: Nebraska-md.13
Included edgars reorganization #prepareForNebraskaRemoval
==================== Snapshot ====================
SystemOrganization addCategory: #'Nebraska-Audio Chat'!
SystemOrganization addCategory: #'Nebraska-Morphic-Collaborative'!
SystemOrganization addCategory: #'Nebraska-Morphic-Experimental'!
SystemOrganization addCategory: #'Nebraska-Morphic-Remote'!
SystemOrganization addCategory: #'Nebraska-Network-EToy Communications'!
SystemOrganization addCategory: #'Nebraska-Network-ObjectSocket'!
SystemOrganization addCategory: #Nebraska!
SystemOrganization addCategory: #'Nebraska-Refactoring'!
Object subclass: #CanvasDecoder
instanceVariableNames: 'drawingCanvas clipRect transform connection fonts'
classVariableNames: 'CachedForms DecodeTable'
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!CanvasDecoder commentStamp: '<historical>' prior: 0!
Decodes commands encoded by MREncoder, and draws them onto a canvas.!
----- Method: CanvasDecoder class>>connection: (in category 'instance creation') -----
connection: aConnection
^(self new)
connection: aConnection;
yourself!
----- Method: CanvasDecoder class>>decodeColor: (in category 'decoding') -----
decodeColor: string
| rgb a rgb1 rgb2 |
rgb1 := string getInteger32: 1.
rgb2 := string getInteger32: 5.
a := string getInteger32: 9.
rgb := rgb2 << 16 + rgb1.
a < 255
ifTrue: [ ^TranslucentColor basicNew setRgb: rgb alpha: a/255.0 ]
ifFalse: [ ^Color basicNew setRGB: rgb ]!
----- Method: CanvasDecoder class>>decodeFillStyle: (in category 'decoding') -----
decodeFillStyle: string
^DataStream unStream: string!
----- Method: CanvasDecoder class>>decodeFont: (in category 'decoding') -----
decodeFont: fontString
^StrikeFont decodedFromRemoteCanvas: fontString.
!
----- Method: CanvasDecoder class>>decodeFontSet: (in category 'decoding') -----
decodeFontSet: fontString
^ StrikeFontSet decodedFromRemoteCanvas: fontString
!
----- Method: CanvasDecoder class>>decodeImage: (in category 'decoding') -----
decodeImage: string
| bitsStart depth width height bits rs numColors colorArray |
bitsStart := string indexOf: $|.
bitsStart = 0 ifTrue: [^nil].
rs := ReadStream on: string.
rs peek == $C ifTrue: [
rs next.
numColors := Integer readFromString: (rs upTo: $,).
colorArray := Array new: numColors.
1 to: numColors do: [ :i |
colorArray at: i put: (self decodeColor: (rs next: 12))
].
].
depth := Integer readFromString: (rs upTo: $,).
width := Integer readFromString: (rs upTo: $,).
height := Integer readFromString: (rs upTo: $|).
bits := Bitmap newFromStream: (RWBinaryOrTextStream with: rs upToEnd) binary reset.
colorArray ifNil: [
^Form extent: width@height depth: depth bits: bits
].
^(ColorForm extent: width@height depth: depth bits: bits)
colors: colorArray
!
----- Method: CanvasDecoder class>>decodeInteger: (in category 'decoding') -----
decodeInteger: string
^Integer readFromString: string!
----- Method: CanvasDecoder class>>decodePoint: (in category 'decoding') -----
decodePoint: string
| x y |
x := string getInteger32: 1.
y := string getInteger32: 5.
^x@y!
----- Method: CanvasDecoder class>>decodePoints: (in category 'decoding') -----
decodePoints: aString
^(aString findTokens: '|') asArray collect: [ :encPoint | self decodePoint: encPoint ]!
----- Method: CanvasDecoder class>>decodeRectangle: (in category 'decoding') -----
decodeRectangle: string
| x y cornerX cornerY |
x := string getInteger32: 1.
y := string getInteger32: 5.
cornerX := string getInteger32: 9.
cornerY := string getInteger32: 13.
^x@y corner: cornerX@cornerY!
----- Method: CanvasDecoder class>>decodeTTCFont: (in category 'decoding') -----
decodeTTCFont: fontString
"Decode a string that consists of <familyName> <pointSize> <emphasis> (e.g. 'ComicSansMS 12 0') into a proper instance."
| first second |
first := fontString indexOf: $ startingAt: 1.
second := fontString indexOf: $ startingAt: first + 1.
(first ~= 0 and: [second ~= 0]) ifTrue: [
^ (TTCFont family: (fontString copyFrom: 1 to: (first - 1))
size: (fontString copyFrom: first + 1 to: second - 1) asNumber)
emphasized: (fontString copyFrom: second + 1 to: fontString size) asNumber.
].
^ TextStyle defaultFont.
!
----- Method: CanvasDecoder class>>decodeTransform: (in category 'decoding') -----
decodeTransform: transformEnc
"decode an encoded transform"
^DisplayTransform fromRemoteCanvasEncoding: transformEnc!
----- Method: CanvasDecoder class>>decodeVerb:toSelector: (in category 'decode table modification') -----
decodeVerb: verb toSelector: selector
"verb is a single character which will be ferformed by my instances using selector"
DecodeTable at: verb asciiValue + 1 put: selector. !
----- Method: CanvasDecoder class>>initialize (in category 'class initialization') -----
initialize
"CanvasDecoder initialize"
"Set up my cache and decode table if necessary."
CachedForms ifNil: [CachedForms := Array new: 100].
DecodeTable ifNotNil: [ ^self ].
DecodeTable _ Array new: 128.
#((codeClip setClip:)
(codeTransform setTransform:)
(codeText drawText:)
(codeLine drawLine:)
(codeRect drawRect:)
(codeBalloonRect drawBalloonRect:)
(codeBalloonOval drawBalloonOval:)
(codeInfiniteFill drawInfiniteFill:)
(codeOval drawOval:)
(codeImage drawImage:)
(codeReleaseCache releaseImage:)
(codePoly drawPoly:)
(codeStencil drawStencil:)
(codeForce forceToScreen:)
(codeFont addFontToCache:)
(codeFontSet addFontSetToCache:)
(codeMultiText drawMultiText:)
(codeTTCFont addTTCFontToCache:)
(codeExtentDepth extentDepth:)
(codeShadowColor shadowColor:))
do: [ :arr |
(DecodeTable at: ((CanvasEncoder perform: arr first) asciiValue + 1)) ifNotNil: [self error: 'duplicated code'].
DecodeTable
at: ((CanvasEncoder perform: arr first) asciiValue + 1)
put: arr second
].
!
----- Method: CanvasDecoder class>>reinitialize (in category 'class initialization') -----
reinitialize
"CanvasDecoder reinitialize"
"Set up my cache and decode table, removing old contents."
CachedForms := nil.
DecodeTable := nil.
self initialize.
!
----- Method: CanvasDecoder>>addFontSetToCache: (in category 'decoding') -----
addFontSetToCache: command
| index font |
index := self class decodeInteger: command second.
font := self class decodeFontSet: command third.
index > fonts size ifTrue: [
| newFonts |
newFonts := Array new: index.
newFonts replaceFrom: 1 to: fonts size with: fonts.
fonts := newFonts ].
fonts at: index put: font
!
----- Method: CanvasDecoder>>addFontToCache: (in category 'decoding') -----
addFontToCache: command
| index font |
index := self class decodeInteger: command second.
font := self class decodeFont: command third.
index > fonts size ifTrue: [
| newFonts |
newFonts := Array new: index.
newFonts replaceFrom: 1 to: fonts size with: fonts.
fonts := newFonts ].
fonts at: index put: font!
----- Method: CanvasDecoder>>addTTCFontToCache: (in category 'decoding') -----
addTTCFontToCache: command
| index font |
index := self class decodeInteger: command second.
font := self class decodeTTCFont: command third.
index > fonts size ifTrue: [
| newFonts |
newFonts := Array new: index.
newFonts replaceFrom: 1 to: fonts size with: fonts.
fonts := newFonts ].
fonts at: index put: font.
!
----- Method: CanvasDecoder>>connection: (in category 'network') -----
connection: aStringSocket
"set this terminal to talk over the given socket"
connection := aStringSocket!
----- Method: CanvasDecoder>>delete (in category 'shutting down') -----
delete
connection ifNotNil: [ connection destroy ].!
----- Method: CanvasDecoder>>drawBalloonOval: (in category 'decoding') -----
drawBalloonOval: command
| aRectangle aFillStyle borderWidth borderColor |
aRectangle := self class decodeRectangle: command second.
aFillStyle := self class decodeFillStyle: command third.
borderWidth := self class decodeInteger: command fourth.
borderColor := self class decodeColor: (command fifth).
self drawCommand:
[:c |
c asBalloonCanvas
fillOval: aRectangle
fillStyle: aFillStyle
borderWidth: borderWidth
borderColor: borderColor]!
----- Method: CanvasDecoder>>drawBalloonRect: (in category 'decoding') -----
drawBalloonRect: command
| aRectangle aFillStyle |
aRectangle := self class decodeRectangle: (command second).
aFillStyle := self class decodeFillStyle: command third.
self drawCommand:
[:c |
c asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle]!
----- Method: CanvasDecoder>>drawCommand: (in category 'decoding') -----
drawCommand: aBlock
"call aBlock with the canvas it should actually draw on so that the clipping rectangle and transform are set correctly"
drawingCanvas transformBy: transform clippingTo: clipRect during: aBlock!
----- Method: CanvasDecoder>>drawImage: (in category 'decoding') -----
drawImage: command
| image point sourceRect rule cacheID cacheNew previousImage |
image := self class decodeImage: command second.
point := self class decodePoint: command third.
sourceRect := self class decodeRectangle: command fourth.
rule := self class decodeInteger: command fifth.
command size >= 7
ifTrue:
[false ifTrue: [self showSpaceUsed]. "debugging"
cacheID := self class decodeInteger: (command sixth).
cacheNew := (self class decodeInteger: command seventh) = 1.
cacheID > 0
ifTrue:
[
cacheNew
ifTrue: [CachedForms at: cacheID put: image]
ifFalse:
[previousImage := CachedForms at: cacheID.
image ifNil: [image := previousImage]
ifNotNil:
[(previousImage notNil and: [image depth > 8])
ifTrue: [image := previousImage addDeltasFrom: image].
CachedForms at: cacheID put: image]]]].
self drawCommand:
[:c |
c
image: image
at: point
sourceRect: sourceRect
rule: rule]!
----- Method: CanvasDecoder>>drawInfiniteFill: (in category 'decoding') -----
drawInfiniteFill: command
| aRectangle aFillStyle |
aRectangle := self class decodeRectangle: (command second).
aFillStyle := InfiniteForm with: (self class decodeImage: command third).
self drawCommand:
[:c |
c asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle]!
----- Method: CanvasDecoder>>drawLine: (in category 'decoding') -----
drawLine: command
| verb pt1Enc pt2Enc widthEnc colorEnc pt1 pt2 width color |
verb := command first.
pt1Enc := command second.
pt2Enc := command third.
widthEnc := command fourth.
colorEnc := command fifth.
""
pt1 := self class decodePoint: pt1Enc.
pt2 := self class decodePoint: pt2Enc.
width := self class decodeInteger: widthEnc.
color := self class decodeColor: colorEnc.
""
self
drawCommand: [:c | c
line: pt1
to: pt2
width: width
color: color]!
----- Method: CanvasDecoder>>drawMultiText: (in category 'decoding') -----
drawMultiText: command
| boundsEnc colorEnc text bounds color fontIndexEnc fontIndex |
text := WideString fromByteArray: (command at: 2) asByteArray.
"text asByteArray printString displayAt: 800@0."
"self halt."
boundsEnc := command at: 3.
fontIndexEnc := command at: 4.
colorEnc := command at: 5.
bounds := self class decodeRectangle: boundsEnc.
fontIndex := self class decodeInteger: fontIndexEnc.
color := self class decodeColor: colorEnc.
self drawCommand: [ :c |
c drawString: text in: bounds font: (fonts at: fontIndex) color: color ]
!
----- Method: CanvasDecoder>>drawOval: (in category 'decoding') -----
drawOval: command
| verb rectEnc colorEnc borderWidthEnc borderColorEnc rect color borderWidth borderColor |
verb := command first.
rectEnc := command second.
colorEnc := command third.
borderWidthEnc := command fourth.
borderColorEnc := command fifth.
""
rect := self class decodeRectangle: rectEnc.
color := self class decodeColor: colorEnc.
borderWidth := self class decodeInteger: borderWidthEnc.
borderColor := self class decodeColor: borderColorEnc.
""
self
drawCommand: [:c | c
fillOval: rect
color: color
borderWidth: borderWidth
borderColor: borderColor]!
----- Method: CanvasDecoder>>drawPoly: (in category 'decoding') -----
drawPoly: command
| verticesEnc fillColorEnc borderWidthEnc borderColorEnc vertices fillColor borderWidth borderColor |
fillColorEnc := command second.
borderWidthEnc := command third.
borderColorEnc := command fourth.
verticesEnc := command copyFrom: 5 to: command size.
fillColor := self class decodeColor: fillColorEnc.
borderWidth := self class decodeInteger: borderWidthEnc.
borderColor := self class decodeColor: borderColorEnc.
vertices := verticesEnc collect: [:enc | self class decodePoint: enc].
self drawCommand:
[:c |
c
drawPolygon: vertices
color: fillColor
borderWidth: borderWidth
borderColor: borderColor]!
----- Method: CanvasDecoder>>drawRect: (in category 'decoding') -----
drawRect: command
| verb rectEnc fillColorEnc borderWidthEnc borderColorEnc rect fillColor borderWidth borderColor |
verb := command first.
rectEnc := command second.
fillColorEnc := command third.
borderWidthEnc := command fourth.
borderColorEnc := command fifth.
""
rect := self class decodeRectangle: rectEnc.
fillColor := self class decodeColor: fillColorEnc.
borderWidth := self class decodeInteger: borderWidthEnc.
borderColor := self class decodeColor: borderColorEnc.
""
self
drawCommand: [:c | c
frameAndFillRectangle: rect
fillColor: fillColor
borderWidth: borderWidth
borderColor: borderColor]!
----- Method: CanvasDecoder>>drawStencil: (in category 'decoding') -----
drawStencil: command
| stencilFormEnc locationEnc sourceRectEnc colorEnc stencilForm location sourceRect color |
stencilFormEnc := command second.
locationEnc := command third.
sourceRectEnc := command fourth.
colorEnc := command fifth.
stencilForm := self class decodeImage: stencilFormEnc.
location := self class decodePoint: locationEnc.
sourceRect := self class decodeRectangle: sourceRectEnc.
color := self class decodeColor: colorEnc.
self drawCommand:
[:executor |
executor
stencil: stencilForm
at: location
sourceRect: sourceRect
color: color]!
----- Method: CanvasDecoder>>drawText: (in category 'decoding') -----
drawText: command
| boundsEnc colorEnc text bounds color fontIndexEnc fontIndex |
text := command second.
boundsEnc := command third.
fontIndexEnc := command fourth.
colorEnc := command fifth.
bounds := self class decodeRectangle: boundsEnc.
fontIndex := self class decodeInteger: fontIndexEnc.
color := self class decodeColor: colorEnc.
self drawCommand:
[:c |
c
drawString: text
in: bounds
font: (fonts at: fontIndex)
color: color]!
----- Method: CanvasDecoder>>drawingForm (in category 'attributes') -----
drawingForm
"return the form that we are drawing on behind thescenes"
^drawingCanvas form!
----- Method: CanvasDecoder>>extentDepth: (in category 'decoding') -----
extentDepth: command
| depth extent |
extent := self class decodePoint: (command second).
depth := self class decodeInteger: (command third).
drawingCanvas := FormCanvas extent: extent depth: depth!
----- Method: CanvasDecoder>>forceToScreen:withBlock: (in category 'decoding') -----
forceToScreen: aCommand withBlock: forceBlock
| region |
region := self class decodeRectangle: aCommand second.
forceBlock value: region.!
----- Method: CanvasDecoder>>initialize (in category 'initialization') -----
initialize
"set the canvas to draw on"
drawingCanvas := FormCanvas extent: 100@100 depth: 16.
clipRect := drawingCanvas extent.
transform := MorphicTransform identity.
fonts := Array new: 2.!
----- Method: CanvasDecoder>>processCommand:onForceDo: (in category 'decoding') -----
processCommand: command onForceDo: forceBlock
"Decode the given string command and perform the required action.
If the command is a forceToScreen command, also pass the forceBlock.
The previous chained equality tests and conditionals have been replaced by a lookup table in my class variable DecodeTable, which is set in the class-side initialize method."
| verb verbCode selector |
command isEmpty ifTrue: [ ^self ].
verb := command first.
verbCode := verb first.
selector := DecodeTable
at: (verbCode asciiValue + 1)
ifAbsent: [ self error: 'unknown command: ', verb ].
"note: codeForce is the only odd one"
^(selector == #forceToScreen:)
ifTrue: [ self forceToScreen: command withBlock: forceBlock ]
ifFalse: [ self perform: selector withArguments: { command } ]
!
----- Method: CanvasDecoder>>processIO (in category 'network') -----
processIO
| command didSomething |
connection ifNil: [ ^self ].
connection processIO.
didSomething := false.
[ command := connection nextOrNil. command notNil ] whileTrue: [
didSomething := true.
self processCommand: command ].
^didSomething!
----- Method: CanvasDecoder>>processIOOnForce: (in category 'network') -----
processIOOnForce: forceBlock
| command didSomething |
connection ifNil: [ ^self ].
connection processIO.
didSomething := false.
[ command := connection nextOrNil. command notNil ] whileTrue: [
didSomething := true.
self processCommand: command onForceDo: forceBlock].
^didSomething!
----- Method: CanvasDecoder>>releaseImage: (in category 'decoding') -----
releaseImage: command
| cacheID |
CachedForms ifNil: [^self].
cacheID := self class decodeInteger: (command second).
CachedForms at: cacheID put: nil!
----- Method: CanvasDecoder>>setClip: (in category 'decoding') -----
setClip: command
| clipRectEnc |
clipRectEnc := command second.
clipRect := self class decodeRectangle: clipRectEnc!
----- Method: CanvasDecoder>>setTransform: (in category 'decoding') -----
setTransform: command
| transformEnc |
transformEnc := command second.
transform := self class decodeTransform: transformEnc!
----- Method: CanvasDecoder>>shadowColor: (in category 'decoding') -----
shadowColor: command
drawingCanvas shadowColor: (
command second = '0' ifTrue: [nil] ifFalse: [self class decodeColor: command second]
)
!
----- Method: CanvasDecoder>>showSpaceUsed (in category 'decoding') -----
showSpaceUsed
| total |
CachedForms ifNil: [^self].
total := 0.
CachedForms do: [ :each |
each ifNotNil: [
total := total + (each depth * each width * each height // 8).
].
].
(total // 1024) printString,' ',
(Smalltalk garbageCollectMost // 1024) printString,' ' displayAt: 0@0!
Object subclass: #CanvasEncoder
instanceVariableNames: 'connection lastClipRect lastTransform fontCache cachedObjects cachingEnabled'
classVariableNames: 'SentTypesAndSizes SimpleCounters'
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!CanvasEncoder commentStamp: '<historical>' prior: 0!
Encodes canvas commands into string-arrays format.
---possible further compression for forms ---
600 * 359 * 4 861600
self encodeForRemoteCanvas size 76063
Time millisecondsToRun: [self encodeForRemoteCanvas]
| raw data |
data _ self encodeForRemoteCanvas.
raw _ RWBinaryOrTextStream on: (String new: 1000).
Time millisecondsToRun: [(GZipWriteStream on: raw) nextPutAll: data; close].
raw contents size
(GZipReadStream on: (ReadStream on: raw contents)) upToEnd size
| raw |
raw _ RWBinaryOrTextStream on: (String new: bits size).
raw nextPutAll: bits
Time millisecondsToRun: [bits compressGZip] 50
bits compressGZip size 861620!
----- Method: CanvasEncoder class>>aaaReadme (in category 'codes') -----
aaaReadme
"these codes are used instead of strings, because String>>= was taking around 20% of the decoder's time"
!
----- Method: CanvasEncoder class>>at:count: (in category 'as yet unclassified') -----
at: anIndex count: anInteger
SimpleCounters ifNil: [(SimpleCounters := Array new: 10) atAllPut: 0].
SimpleCounters at: anIndex put: (SimpleCounters at: anIndex) + anInteger.!
----- Method: CanvasEncoder class>>beginStats (in category 'as yet unclassified') -----
beginStats
SentTypesAndSizes := Dictionary new.!
----- Method: CanvasEncoder class>>clearTestVars (in category 'as yet unclassified') -----
clearTestVars
"
CanvasEncoder clearTestVars
"
SimpleCounters := nil
!
----- Method: CanvasEncoder class>>codeBalloonOval (in category 'codes') -----
codeBalloonOval
^$O!
----- Method: CanvasEncoder class>>codeBalloonRect (in category 'codes') -----
codeBalloonRect
^$R!
----- Method: CanvasEncoder class>>codeClip (in category 'codes') -----
codeClip
^$A!
----- Method: CanvasEncoder class>>codeExtentDepth (in category 'codes') -----
codeExtentDepth
^$M!
----- Method: CanvasEncoder class>>codeFont (in category 'codes') -----
codeFont
^$L!
----- Method: CanvasEncoder class>>codeFontSet (in category 'codes') -----
codeFontSet
^ $S
!
----- Method: CanvasEncoder class>>codeForce (in category 'codes') -----
codeForce
^$J!
----- Method: CanvasEncoder class>>codeImage (in category 'codes') -----
codeImage
^$G!
----- Method: CanvasEncoder class>>codeInfiniteFill (in category 'codes') -----
codeInfiniteFill
^$i!
----- Method: CanvasEncoder class>>codeLine (in category 'codes') -----
codeLine
^$D!
----- Method: CanvasEncoder class>>codeMultiText (in category 'codes') -----
codeMultiText
^ $c
!
----- Method: CanvasEncoder class>>codeOval (in category 'codes') -----
codeOval
^$F!
----- Method: CanvasEncoder class>>codePoly (in category 'codes') -----
codePoly
^$H!
----- Method: CanvasEncoder class>>codeRect (in category 'codes') -----
codeRect
^$E!
----- Method: CanvasEncoder class>>codeReleaseCache (in category 'codes') -----
codeReleaseCache
^$z!
----- Method: CanvasEncoder class>>codeShadowColor (in category 'codes') -----
codeShadowColor
^$s!
----- Method: CanvasEncoder class>>codeStencil (in category 'codes') -----
codeStencil
^$I!
----- Method: CanvasEncoder class>>codeTTCFont (in category 'codes') -----
codeTTCFont
^ $T.
!
----- Method: CanvasEncoder class>>codeText (in category 'codes') -----
codeText
^$C!
----- Method: CanvasEncoder class>>codeTransform (in category 'codes') -----
codeTransform
^$B!
----- Method: CanvasEncoder class>>encodeColor: (in category 'encoding') -----
encodeColor: color
^color encodeForRemoteCanvas!
----- Method: CanvasEncoder class>>encodeFillStyle: (in category 'encoding') -----
encodeFillStyle: aFillStyle
^aFillStyle encodeForRemoteCanvas!
----- Method: CanvasEncoder class>>encodeFont: (in category 'encoding') -----
encodeFont: aFont
^aFont encodedForRemoteCanvas!
----- Method: CanvasEncoder class>>encodeImage: (in category 'encoding') -----
encodeImage: form
| t answer |
form ifNil: [^''].
t := Time millisecondsToRun: [answer := form encodeForRemoteCanvas].
form boundingBox area > 5000 ifTrue: [
NebraskaDebug at: #FormEncodeTimes add: {t. form extent. answer size}
].
^answer
"HandMorph>>restoreSavedPatchOn: is one culprit here"
!
----- Method: CanvasEncoder class>>encodeInteger: (in category 'encoding') -----
encodeInteger: integer
^integer asInteger storeString!
----- Method: CanvasEncoder class>>encodePoint: (in category 'encoding') -----
encodePoint: point
^point encodeForRemoteCanvas!
----- Method: CanvasEncoder class>>encodeRectangle: (in category 'encoding') -----
encodeRectangle: rectangle
| x y encoded cornerX cornerY |
x := rectangle origin x asInteger.
y := rectangle origin y asInteger.
cornerX := rectangle corner x asInteger.
cornerY := rectangle corner y asInteger.
CanvasEncoder at: 2 count: 1.
encoded := String new: 16.
encoded putInteger32: x at: 1.
encoded putInteger32: y at: 5.
encoded putInteger32: cornerX at: 9.
encoded putInteger32: cornerY at: 13.
^encoded!
----- Method: CanvasEncoder class>>encodeTransform: (in category 'encoding') -----
encodeTransform: transform
^transform encodeForRemoteCanvas!
----- Method: CanvasEncoder class>>explainTestVars (in category 'as yet unclassified') -----
explainTestVars
"
CanvasEncoder explainTestVars
"
| answer total oneBillion data putter nReps |
SimpleCounters ifNil: [^ Beeper beep].
total := 0.
oneBillion := 1000 * 1000 * 1000.
answer := String streamContents: [ :strm |
data := SimpleCounters copy.
putter := [ :msg :index :nSec |
nReps := data at: index.
total := total + (nSec * nReps).
strm nextPutAll: nReps asStringWithCommas,' * ',nSec printString,' ',
(nSec * nReps / oneBillion roundTo: 0.01) printString,' secs for ',msg; cr
].
putter value: 'string socket' value: 1 value: 8000.
putter value: 'rectangles' value: 2 value: 40000.
putter value: 'points' value: 3 value: 18000.
putter value: 'colors' value: 4 value: 8000.
].
StringHolder new
contents: answer;
openLabel: 'put integer times'.
!
----- Method: CanvasEncoder class>>inspectTestVars (in category 'as yet unclassified') -----
inspectTestVars
"
CanvasEncoder inspectTestVars
"
^SimpleCounters
!
----- Method: CanvasEncoder class>>killStats (in category 'as yet unclassified') -----
killStats
SentTypesAndSizes := nil!
----- Method: CanvasEncoder class>>nameForCode: (in category 'as yet unclassified') -----
nameForCode: aStringOrChar
| ch |
ch := (aStringOrChar isString) ifTrue: [aStringOrChar first] ifFalse: [aStringOrChar].
ch == self codeBalloonOval ifTrue: [^'balloon oval'].
ch == self codeBalloonRect ifTrue: [^'balloon rectangle'].
ch == self codeClip ifTrue: [^'clip'].
ch == self codeExtentDepth ifTrue: [^'codeExtentDepth'].
ch == self codeFont ifTrue: [^'codeFont'].
ch == self codeTTCFont ifTrue: [^'codeTTCFont'].
ch == self codeForce ifTrue: [^'codeForce'].
ch == self codeImage ifTrue: [^'codeImage'].
ch == self codeLine ifTrue: [^'codeLine'].
ch == self codeOval ifTrue: [^'codeOval'].
ch == self codePoly ifTrue: [^'codePoly'].
ch == self codeRect ifTrue: [^'codeRect'].
ch == self codeReleaseCache ifTrue: [^'codeReleaseCache'].
ch == self codeStencil ifTrue: [^'codeStencil'].
ch == self codeText ifTrue: [^'codeText'].
ch == self codeTransform ifTrue: [^'codeTransform'].
ch == self codeInfiniteFill ifTrue: [^'codeInfiniteFill'].
ch == self codeShadowColor ifTrue: [^'shadowColor'].
^'????'
!
----- Method: CanvasEncoder class>>on: (in category 'instance creation') -----
on: connection
^self new connection: connection!
----- Method: CanvasEncoder class>>showStats (in category 'as yet unclassified') -----
showStats
"
CanvasEncoder showStats
"
| answer bucket |
SentTypesAndSizes ifNil: [^Beeper beep].
answer := WriteStream on: String new.
SentTypesAndSizes keys asSortedCollection do: [ :each |
bucket := SentTypesAndSizes at: each.
answer nextPutAll: each printString,' ',
bucket first printString,' ',
bucket second asStringWithCommas,' ',
(self nameForCode: each); cr.
].
StringHolder new contents: answer contents; openLabel: 'send/receive stats'.
!
----- Method: CanvasEncoder class>>timeSomeThings (in category 'as yet unclassified') -----
timeSomeThings
"
CanvasEncoder timeSomeThings
"
| s iter answer ms pt rect bm writer array color |
iter := 1000000.
array := Array new: 4.
color := Color red.
answer := String streamContents: [ :strm |
writer := [ :msg :doer |
ms := [iter timesRepeat: doer] timeToRun.
strm nextPutAll: msg,((ms * 1000 / iter) roundTo: 0.01) printString,' usec'; cr.
].
s := String new: 4.
bm := Bitmap new: 20.
pt := 100@300.
rect := pt extent: pt.
iter := 1000000.
writer value: 'empty loop ' value: [self].
writer value: 'modulo ' value: [12345678 \\ 256].
writer value: 'bitAnd: ' value: [12345678 bitAnd: 255].
strm cr.
iter := 100000.
writer value: 'putInteger ' value: [s putInteger32: 12345678 at: 1].
writer value: 'bitmap put ' value: [bm at: 1 put: 12345678].
writer value: 'encodeBytesOf: (big) ' value: [bm encodeInt: 12345678 in: bm at: 1].
writer value: 'encodeBytesOf: (small) ' value: [bm encodeInt: 5000 in: bm at: 1].
writer value: 'array at: (in) ' value: [array at: 1].
writer value: 'array at: (out) ' value: [array at: 6 ifAbsent: []].
strm cr.
iter := 10000.
writer value: 'color encode ' value: [color encodeForRemoteCanvas].
writer value: 'pt encode ' value: [pt encodeForRemoteCanvas].
writer value: 'rect encode ' value: [self encodeRectangle: rect].
writer value: 'rect encode2 ' value: [rect encodeForRemoteCanvas].
writer value: 'rect encodeb ' value: [rect encodeForRemoteCanvasB].
].
StringHolder new contents: answer; openLabel: 'send/receive stats'.
!
----- Method: CanvasEncoder>>backlog (in category 'connection') -----
backlog
^connection backlog!
----- Method: CanvasEncoder>>balloonFillOval:fillStyle:borderWidth:borderColor: (in category 'drawing') -----
balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
self sendCommand: {
String with: CanvasEncoder codeBalloonOval.
self class encodeRectangle: aRectangle.
aFillStyle encodeForRemoteCanvas.
self class encodeInteger: bw.
self class encodeColor: bc.
}!
----- Method: CanvasEncoder>>balloonFillRectangle:fillStyle: (in category 'drawing') -----
balloonFillRectangle: aRectangle fillStyle: aFillStyle
self sendCommand: {
String with: CanvasEncoder codeBalloonRect.
self class encodeRectangle: aRectangle.
aFillStyle encodeForRemoteCanvas
}!
----- Method: CanvasEncoder>>cachingEnabled: (in category 'drawing') -----
cachingEnabled: aBoolean
(cachingEnabled := aBoolean) ifFalse: [
cachedObjects := nil.
].
!
----- Method: CanvasEncoder>>connection: (in category 'connection') -----
connection: aStringSocket
"set this connection to talk over the given socket"
cachingEnabled := true.
connection := aStringSocket!
----- Method: CanvasEncoder>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
convertToCurrentVersion: varDict refStream: smartRefStrm
cachingEnabled ifNil: [cachingEnabled := true].
^super convertToCurrentVersion: varDict refStream: smartRefStrm.
!
----- Method: CanvasEncoder>>destroy (in category 'network') -----
destroy
self disconnect.!
----- Method: CanvasEncoder>>disconnect (in category 'connection') -----
disconnect
connection ifNotNil: [
connection destroy.
connection := nil.
].!
----- Method: CanvasEncoder>>drawPolygon:color:borderWidth:borderColor: (in category 'drawing') -----
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
| encodedVertices |
encodedVertices := vertices collect: [ :vertex | self class encodePoint: vertex ].
self sendCommand: {
String with: CanvasEncoder codePoly.
self class encodeColor: aColor.
self class encodeInteger: bw.
self class encodeColor: bc}, encodedVertices .!
----- Method: CanvasEncoder>>drawString:from:to:in:font:color: (in category 'drawing') -----
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
| fontIndex str |
fontIndex := self establishFont: (fontOrNil ifNil: [ TextStyle defaultFont ]).
str _ s asString copyFrom: firstIndex to: lastIndex.
str isWideString ifTrue: [
self sendCommand: {
String with: CanvasEncoder codeMultiText.
str asByteArray asString.
self class encodeRectangle: boundsRect.
self class encodeInteger: fontIndex.
self class encodeColor: c
}
] ifFalse: [
self sendCommand: {
String with: CanvasEncoder codeText.
str.
self class encodeRectangle: boundsRect.
self class encodeInteger: fontIndex.
self class encodeColor: c
}
].
!
----- Method: CanvasEncoder>>establishFont: (in category 'fonts') -----
establishFont: aFont
"make sure that the given font is in the fonts cache. If it is not there already, then transmit it. Either way, after this returns, the font is in the cache at the index specified by the return value"
| index |
(fontCache includesFont: aFont) ifTrue: [ ^fontCache indexOf: aFont ].
index := fontCache indexForNewFont: aFont.
self sendFont: aFont atIndex: index.
^index!
----- Method: CanvasEncoder>>extent:depth: (in category 'drawing') -----
extent: newExtent depth: newDepth
self sendCommand: {
self class codeExtentDepth asString.
self class encodePoint: newExtent.
self class encodeInteger: newDepth.
}!
----- Method: CanvasEncoder>>fillOval:color:borderWidth:borderColor: (in category 'drawing') -----
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
self sendCommand: {
String with: CanvasEncoder codeOval.
self class encodeRectangle: r.
self class encodeColor: c.
self class encodeInteger: borderWidth.
self class encodeColor: borderColor
}!
----- Method: CanvasEncoder>>flush (in category 'network') -----
flush
connection ifNotNil: [
connection flush ]!
----- Method: CanvasEncoder>>forceToScreen: (in category 'drawing') -----
forceToScreen: aRectangle
self sendCommand: {
String with: CanvasEncoder codeForce.
self class encodeRectangle: aRectangle }!
----- Method: CanvasEncoder>>frameAndFillRectangle:fillColor:borderWidth:borderColor: (in category 'drawing') -----
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
self sendCommand: {
String with: CanvasEncoder codeRect.
self class encodeRectangle: r.
fillColor encodeForRemoteCanvas.
self class encodeInteger: borderWidth.
self class encodeColor: borderColor
}!
----- Method: CanvasEncoder>>image:at:sourceRect:rule: (in category 'drawing') -----
image: aForm at: aPoint sourceRect: sourceRect rule: argRule
| cacheID cacheNew cacheReply formToSend cacheEntry destRect visRect aFormArea d2 rule |
rule _ argRule.
"first if we are only going to be able to draw a small part of the form,
it may be faster just to send the part of the form that will actually show up"
destRect _ aPoint extent: sourceRect extent.
d2 _ (lastTransform invertBoundsRect: destRect) expandBy: 1.
(d2 intersects: lastClipRect) ifFalse: [
^NebraskaDebug at: #bigImageSkipped add: {lastClipRect. d2}.
].
aFormArea _ aForm boundingBox area.
(aFormArea > 20000 and: [aForm isStatic not and: [lastTransform isPureTranslation]]) ifTrue: [
visRect _ destRect intersect: lastClipRect.
visRect area < (aFormArea // 20) ifTrue: [
"NebraskaDebug
at: #bigImageReduced
add: {lastClipRect. aPoint. sourceRect extent. lastTransform}."
formToSend _ aForm copy: (visRect translateBy: sourceRect origin - aPoint).
formToSend depth = 32 ifTrue: [formToSend _ formToSend asFormOfDepth: 16. rule = 24 ifTrue: [rule _ 25]].
^self
image: formToSend
at: visRect origin
sourceRect: formToSend boundingBox
rule: rule
cacheID: 0 "no point in trying to cache this - it's a one-timer"
newToCache: false.
].
].
cacheID _ 0.
cacheNew _ false.
formToSend _ aForm.
(aFormArea > 1000 and: [(cacheReply _ self testCache: aForm) notNil]) ifTrue: [
cacheID _ cacheReply first.
cacheEntry _ cacheReply third.
(cacheNew _ cacheReply second) ifFalse: [
formToSend _ aForm isStatic
ifTrue: [nil]
ifFalse: [aForm depth <= 8 ifTrue: [aForm] ifFalse: [aForm deltaFrom: cacheEntry fourth]].
].
cacheEntry at: 4 put: (aForm isStatic ifTrue: [aForm] ifFalse: [aForm deepCopy]).
].
(formToSend notNil and: [formToSend depth = 32]) ifTrue: [formToSend _ formToSend asFormOfDepth: 16. rule = 24 ifTrue: [rule _ 25]].
self
image: formToSend
at: aPoint
sourceRect: sourceRect
rule: rule
cacheID: cacheID
newToCache: cacheNew.
!
----- Method: CanvasEncoder>>image:at:sourceRect:rule:cacheID:newToCache: (in category 'drawing') -----
image: aFormOrNil at: aPoint sourceRect: sourceRect rule: rule cacheID: cacheID newToCache: newToCache
| t destRect d2 |
destRect := aPoint extent: sourceRect extent.
d2 := (lastTransform invertBoundsRect: destRect) expandBy: 1.
(d2 intersects: lastClipRect) ifFalse: [
^NebraskaDebug at: #bigImageSkipped add: {lastClipRect. d2}.
].
t := Time millisecondsToRun: [
self sendCommand: {
String with: CanvasEncoder codeImage.
self class encodeImage: aFormOrNil.
self class encodePoint: aPoint.
self class encodeRectangle: sourceRect.
self class encodeInteger: rule.
self class encodeInteger: cacheID.
self class encodeInteger: (newToCache ifTrue: [1] ifFalse: [0]).
}.
].
(aFormOrNil notNil and: [aFormOrNil boundingBox area > 10000]) ifTrue: [
NebraskaDebug
at: #bigImage
add: {lastClipRect. aPoint. sourceRect extent. t. cacheID. newToCache}.
].
!
----- Method: CanvasEncoder>>infiniteFillRectangle:fillStyle: (in category 'drawing') -----
infiniteFillRectangle: aRectangle fillStyle: aFillStyle
self sendCommand: {
String with: CanvasEncoder codeInfiniteFill.
self class encodeRectangle: aRectangle.
aFillStyle encodeForRemoteCanvas
}!
----- Method: CanvasEncoder>>initialize (in category 'initialization') -----
initialize
cachingEnabled := true.
fontCache := FontCache new: 5.!
----- Method: CanvasEncoder>>isConnected (in category 'connection') -----
isConnected
^connection notNil and: [ connection isConnected ]!
----- Method: CanvasEncoder>>line:to:width:color: (in category 'drawing') -----
line: pt1 to: pt2 width: w color: c
"Smalltalk at: #Q3 put: thisContext longStack."
self sendCommand: {
String with: CanvasEncoder codeLine.
self class encodePoint: pt1.
self class encodePoint: pt2.
self class encodeInteger: w.
self class encodeColor: c
}!
----- Method: CanvasEncoder>>processIO (in category 'network') -----
processIO
connection ifNil: [ ^self ].
connection isConnected ifFalse: [ ^self ].
connection processIO.!
----- Method: CanvasEncoder>>purgeCache (in category 'drawing') -----
purgeCache
| spaceUsed spaceBefore s |
spaceBefore := spaceUsed := self purgeCacheInner.
spaceBefore > 8000000 ifTrue: [
Smalltalk garbageCollect.
spaceUsed := self purgeCacheInner.
].
false ifTrue: [
s := (spaceBefore // 1024) printString,' ',(spaceUsed // 1024) printString,' ',
Time now printString,' '.
WorldState addDeferredUIMessage: [s displayAt: 0@0.] fixTemps.
].
^spaceUsed
!
----- Method: CanvasEncoder>>purgeCacheInner (in category 'drawing') -----
purgeCacheInner
| cachedObject totalSize thisSize |
cachedObjects ifNil: [^0].
totalSize := 0.
cachedObjects withIndexDo: [ :each :index |
cachedObject := each first first.
cachedObject ifNil: [
each second ifNotNil: [
2 to: each size do: [ :j | each at: j put: nil].
self sendCommand: {
String with: CanvasEncoder codeReleaseCache.
self class encodeInteger: index.
}.
].
] ifNotNil: [
thisSize := cachedObject depth * cachedObject width * cachedObject height // 8.
totalSize := totalSize + thisSize.
].
].
^totalSize
"---
newEntry := {
WeakArray with: anObject.
1.
Time millisecondClockValue.
nil.
}.
---"
!
----- Method: CanvasEncoder>>purgeOutputQueue (in category 'connection') -----
purgeOutputQueue
connection purgeOutputQueue.!
----- Method: CanvasEncoder>>sendCommand: (in category 'private') -----
sendCommand: stringArray
| bucket |
connection ifNil: [^self].
connection isConnected ifFalse: [^self].
connection nextPut: stringArray.
SentTypesAndSizes ifNil: [^self].
bucket := SentTypesAndSizes at: stringArray first
ifAbsentPut:
[{
0.
0.
0}].
bucket at: 1 put: bucket first + 1.
bucket at: 2
put: (bucket second)
+ (stringArray inject: 4 into: [:sum :array | sum + (array size + 4)])!
----- Method: CanvasEncoder>>sendFont:atIndex: (in category 'fonts') -----
sendFont: aFont atIndex: index
"Transmits the given fint to the other side"
| code |
code := CanvasEncoder codeFont.
aFont isTTCFont ifTrue: [code := CanvasEncoder codeTTCFont].
self sendCommand: {
String with: code.
self class encodeInteger: index.
self class encodeFont: aFont }.
!
----- Method: CanvasEncoder>>setClipRect: (in category 'clipping and transforming') -----
setClipRect: newClipRect
self sendCommand: {
String with: CanvasEncoder codeClip.
self class encodeRectangle: newClipRect }!
----- Method: CanvasEncoder>>setTransform: (in category 'clipping and transforming') -----
setTransform: newTransform
self sendCommand: {
String with: CanvasEncoder codeTransform.
self class encodeTransform: newTransform }!
----- Method: CanvasEncoder>>shadowColor: (in category 'drawing') -----
shadowColor: aFillStyle
self sendCommand: {
String with: CanvasEncoder codeShadowColor.
aFillStyle ifNil: ['0'] ifNotNil: [aFillStyle encodeForRemoteCanvas].
}!
----- Method: CanvasEncoder>>stencil:at:sourceRect:color: (in category 'drawing') -----
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
self sendCommand: {
String with: CanvasEncoder codeStencil.
self class encodeImage: stencilForm.
self class encodePoint: aPoint.
self class encodeRectangle: sourceRect.
self class encodeColor: aColor }!
----- Method: CanvasEncoder>>testCache: (in category 'drawing') -----
testCache: anObject
| firstFree cachedObject newEntry |
cachingEnabled
ifFalse:
[cachedObjects := nil.
^nil].
cachedObjects ifNil:
[cachedObjects := (1 to: 100) collect:
[:x |
{
WeakArray new: 1.
nil.
nil.
nil}]].
self purgeCache.
firstFree := nil.
cachedObjects withIndexDo:
[:each :index |
cachedObject := each first first.
firstFree ifNil: [cachedObject ifNil: [firstFree := index]].
cachedObject == anObject
ifTrue:
[each at: 2 put: (each second) + 1.
^{
index.
false.
each}]].
firstFree ifNil: [^nil].
newEntry := {
WeakArray with: anObject.
1.
Time millisecondClockValue.
nil}.
cachedObjects at: firstFree put: newEntry.
^{
firstFree.
true.
newEntry}!
----- Method: CanvasEncoder>>testRectangleFillTiming (in category 'drawing') -----
testRectangleFillTiming
| r fillColor borderWidth borderColor t |
"
CanvasEncoder new testRectangleFillTiming
"
r := 100@100 extent: 300@300.
fillColor := Color blue.
borderWidth := 1.
borderColor := Color red.
t := Time millisecondsToRun: [
1000 timesRepeat: [
{
String with: CanvasEncoder codeRect.
self class encodeRectangle: r.
self class encodeColor: fillColor.
self class encodeInteger: borderWidth.
self class encodeColor: borderColor }
].
].
t inspect.!
----- Method: CanvasEncoder>>updateTransform:andClipRect: (in category 'clipping and transforming') -----
updateTransform: aTransform andClipRect: aClipRect
"sets the given transform and clip rectangle, if they aren't already the ones being used"
aTransform = lastTransform ifFalse: [
self setTransform: aTransform.
lastTransform := aTransform ].
aClipRect = lastClipRect ifFalse: [
self setClipRect: aClipRect.
lastClipRect := aClipRect. ].!
Object subclass: #EToyIncomingMessage
instanceVariableNames: ''
classVariableNames: 'MessageHandlers MessageTypes'
poolDictionaries: ''
category: 'Nebraska-Morphic-Experimental'!
----- Method: EToyIncomingMessage class>>allTypes (in category 'message types') -----
allTypes
^MessageTypes ifNil: [
MessageTypes := {
self typeKeyboardChat.
self typeMorph.
self typeFridge.
self typeStatusRequest.
self typeStatusReply.
self typeSeeDesktop.
self typeAudioChat.
self typeAudioChatContinuous.
self typeMultiChat.
}
]
!
----- Method: EToyIncomingMessage class>>forType:send:to: (in category 'as yet unclassified') -----
forType: aMessageType send: aSymbol to: anObject
self messageHandlers at: aMessageType put: {aSymbol. anObject}!
----- Method: EToyIncomingMessage class>>handleNewChatFrom:sentBy:ipAddress: (in category 'handlers') -----
handleNewChatFrom: dataStream sentBy: senderName ipAddress: ipAddressString
^ EToyChatMorph
chatFrom: ipAddressString
name: senderName
text: (self newObjectFromStream: dataStream).
!
----- Method: EToyIncomingMessage class>>handleNewFridgeMorphFrom:sentBy:ipAddress: (in category 'handlers') -----
handleNewFridgeMorphFrom: dataStream sentBy: senderName ipAddress: ipAddressString
| newObject |
newObject := self newObjectFromStream: dataStream.
newObject
setProperty: #fridgeSender toValue: senderName;
setProperty: #fridgeIPAddress toValue: ipAddressString;
setProperty: #fridgeDate toValue: Time dateAndTimeNow.
WorldState addDeferredUIMessage: [EToyFridgeMorph newItem: newObject] fixTemps.
!
----- Method: EToyIncomingMessage class>>handleNewMorphFrom:sentBy:ipAddress: (in category 'handlers') -----
handleNewMorphFrom: dataStream sentBy: senderName ipAddress: ipAddressString
| newObject thumbForm targetWorld |
newObject := self newObjectFromStream: dataStream.
EToyCommunicatorMorph playArrivalSound.
targetWorld := self currentWorld.
(EToyMorphsWelcomeMorph morphsWelcomeInWorld: targetWorld) ifTrue: [
newObject position: (
newObject
valueOfProperty: #positionInOriginatingWorld
ifAbsent: [(targetWorld randomBoundsFor: newObject) topLeft]
).
WorldState addDeferredUIMessage: [
newObject openInWorld: targetWorld.
] fixTemps.
^self
].
thumbForm := newObject imageForm scaledToSize: 50@50.
EToyListenerMorph addToGlobalIncomingQueue: {
thumbForm. newObject. senderName. ipAddressString
}.
WorldState addDeferredUIMessage: [
EToyListenerMorph ensureListenerInCurrentWorld
] fixTemps.
!
----- Method: EToyIncomingMessage class>>handleNewMultiChatFrom:sentBy:ipAddress: (in category 'handlers') -----
handleNewMultiChatFrom: dataStream sentBy: senderName ipAddress: ipAddressString
^ EToyMultiChatMorph
chatFrom: ipAddressString
name: senderName
text: (self newObjectFromStream: dataStream).
!
----- Method: EToyIncomingMessage class>>handleNewSeeDesktopFrom:sentBy:ipAddress: (in category 'handlers') -----
handleNewSeeDesktopFrom: dataStream sentBy: senderName ipAddress: ipAddressString
"more later"
^ EToyChatMorph
chatFrom: ipAddressString
name: senderName
text: ipAddressString,' would like to see your desktop'.
!
----- Method: EToyIncomingMessage class>>handleNewStatusReplyFrom:sentBy:ipAddress: (in category 'handlers') -----
handleNewStatusReplyFrom: dataStream sentBy: senderName ipAddress: ipAddressString
(EToyGateKeeperMorph entryForIPAddress: ipAddressString) statusReplyReceived: (
self newObjectFromStream: dataStream
)
!
----- Method: EToyIncomingMessage class>>handleNewStatusRequestFrom:sentBy:ipAddress: (in category 'handlers') -----
handleNewStatusRequestFrom: dataStream sentBy: senderName ipAddress: ipAddressString
"more later"
^ EToyChatMorph
chatFrom: ipAddressString
name: senderName
text: ipAddressString,' would like to know if you are available'.
!
----- Method: EToyIncomingMessage class>>initializeMessageHandlers (in category 'as yet unclassified') -----
initializeMessageHandlers
self
forType: self typeMorph
send: #handleNewMorphFrom:sentBy:ipAddress:
to: self;
forType: self typeFridge
send: #handleNewFridgeMorphFrom:sentBy:ipAddress:
to: self;
forType: self typeKeyboardChat
send: #handleNewChatFrom:sentBy:ipAddress:
to: self;
forType: self typeMultiChat
send: #handleNewMultiChatFrom:sentBy:ipAddress:
to: self;
forType: self typeStatusRequest
send: #handleNewStatusRequestFrom:sentBy:ipAddress:
to: self;
forType: self typeStatusReply
send: #handleNewStatusReplyFrom:sentBy:ipAddress:
to: self;
forType: self typeSeeDesktop
send: #handleNewSeeDesktopFrom:sentBy:ipAddress:
to: self.
!
----- Method: EToyIncomingMessage class>>messageHandlers (in category 'as yet unclassified') -----
messageHandlers
^MessageHandlers ifNil: [MessageHandlers := Dictionary new].!
----- Method: EToyIncomingMessage class>>newObjectFromStream: (in category 'as yet unclassified') -----
newObjectFromStream: dataStream
| newObject |
[newObject := SmartRefStream objectFromStreamedRepresentation: dataStream upToEnd.]
on: ProgressInitiationException
do: [ :ex |
ex sendNotificationsTo: [ :min :max :curr |
"self flashIndicator: #working."
].
].
"self resetIndicator: #working."
^newObject
!
----- Method: EToyIncomingMessage class>>registerType: (in category 'message types') -----
registerType: aMessageType
MessageTypes := self allTypes copyWith: aMessageType!
----- Method: EToyIncomingMessage class>>typeAudioChat (in category 'message types') -----
typeAudioChat
^'audiochat'!
----- Method: EToyIncomingMessage class>>typeAudioChatContinuous (in category 'message types') -----
typeAudioChatContinuous
^'audiochat2'!
----- Method: EToyIncomingMessage class>>typeFridge (in category 'message types') -----
typeFridge
^'fridge'!
----- Method: EToyIncomingMessage class>>typeKeyboardChat (in category 'message types') -----
typeKeyboardChat
^'chat'!
----- Method: EToyIncomingMessage class>>typeMorph (in category 'message types') -----
typeMorph
^'morph'!
----- Method: EToyIncomingMessage class>>typeMultiChat (in category 'message types') -----
typeMultiChat
^'multichat'!
----- Method: EToyIncomingMessage class>>typeSeeDesktop (in category 'message types') -----
typeSeeDesktop
^'seedesktop'!
----- Method: EToyIncomingMessage class>>typeStatusReply (in category 'message types') -----
typeStatusReply
^'statusreply'!
----- Method: EToyIncomingMessage class>>typeStatusRequest (in category 'message types') -----
typeStatusRequest
^'statusrequest'!
----- Method: EToyIncomingMessage class>>unregisterType: (in category 'message types') -----
unregisterType: aMessageType
MessageTypes := self allTypes copyWithout: aMessageType!
----- Method: EToyIncomingMessage>>incomingMessgage:fromIPAddress: (in category 'as yet unclassified') -----
incomingMessgage: dataStream fromIPAddress: ipAddress
| nullChar messageType senderName selectorAndReceiver |
nullChar := 0 asCharacter.
messageType := dataStream upTo: nullChar.
senderName := dataStream upTo: nullChar.
(EToyGateKeeperMorph acceptRequest: messageType from: senderName at: ipAddress) ifFalse: [
^self
].
selectorAndReceiver := self class messageHandlers at: messageType ifAbsent: [^self].
^selectorAndReceiver second
perform: selectorAndReceiver first
withArguments: {dataStream. senderName. ipAddress}
!
Object subclass: #EToyPeerToPeer
instanceVariableNames: 'socket communicatorMorph process ipAddress connectionQueue dataQueue remoteSocketAddress leftOverData'
classVariableNames: 'DEBUG PREVTICK'
poolDictionaries: ''
category: 'Nebraska-Network-EToy Communications'!
----- Method: EToyPeerToPeer class>>eToyCommunicationsPort (in category 'as yet unclassified') -----
eToyCommunicationsPort
^34151 "picked at random"!
----- Method: EToyPeerToPeer class>>transmitStreamedObject:as:to:for: (in category 'as yet unclassified') -----
transmitStreamedObject: outData as: objectCategory to: anIPAddress for: aCommunicator
| null |
null := String with: 0 asCharacter.
self new
sendSomeData: {
objectCategory,null.
Preferences defaultAuthorName,null.
outData
}
to: anIPAddress
for: aCommunicator
!
----- Method: EToyPeerToPeer>>awaitDataFor: (in category 'receiving') -----
awaitDataFor: aCommunicatorMorph
Socket initializeNetwork.
connectionQueue := ConnectionQueue
portNumber: self class eToyCommunicationsPort
queueLength: 6.
communicatorMorph := aCommunicatorMorph.
process := [self doAwaitData] newProcess.
process priority: Processor highIOPriority.
process resume.
!
----- Method: EToyPeerToPeer>>doAwaitData (in category 'receiving') -----
doAwaitData
[true] whileTrue: [
socket := connectionQueue getConnectionOrNilLenient.
socket ifNil: [
(Delay forMilliseconds: 50) wait
] ifNotNil: [
self class new receiveDataOn: socket for: communicatorMorph
]
].
!
----- Method: EToyPeerToPeer>>doConnectForSend (in category 'sending') -----
doConnectForSend
| addr |
addr := NetNameResolver addressForName: ipAddress.
addr ifNil: [
communicatorMorph commResult: {#message -> ('could not find ',ipAddress)}.
^false
].
socket connectNonBlockingTo: addr port: self class eToyCommunicationsPort.
[socket waitForConnectionFor: 15]
on: ConnectionTimedOut
do: [:ex |
communicatorMorph commResult: {#message -> ('no connection to ',ipAddress,' (',
(NetNameResolver stringFromAddress: addr),')')}.
^false].
^true
!
----- Method: EToyPeerToPeer>>doReceiveData (in category 'receiving') -----
doReceiveData
| answer |
[answer := self doReceiveOneMessage]
on: Error
do: [ :ex |
communicatorMorph commResult: {#message -> (ex description,' ',socket printString)}.
^false
].
communicatorMorph commResult: {
#message -> 'OK'.
#data -> answer .
#ipAddress -> remoteSocketAddress.
}.
^answer size > 0
!
----- Method: EToyPeerToPeer>>doReceiveOneMessage (in category 'receiving') -----
doReceiveOneMessage
| awaitingLength i length answer |
awaitingLength := true.
answer := WriteStream on: String new.
[awaitingLength] whileTrue: [
leftOverData := leftOverData , socket receiveData.
(i := leftOverData indexOf: $ ) > 0 ifTrue: [
awaitingLength := false.
length := (leftOverData first: i - 1) asNumber.
answer nextPutAll: (leftOverData allButFirst: i).
].
].
leftOverData := ''.
[answer size < length] whileTrue: [
answer nextPutAll: socket receiveData.
communicatorMorph commResult: {#commFlash -> true}.
].
answer := answer contents.
answer size > length ifTrue: [
leftOverData := answer allButFirst: length.
answer := answer first: length
].
^answer
!
----- Method: EToyPeerToPeer>>doSendData (in category 'sending') -----
doSendData
| totalLength myData allTheData |
myData := dataQueue next ifNil: [socket sendData: '0 '. ^false].
totalLength := (myData collect: [ :x | x size]) sum.
socket sendData: totalLength printString,' '.
allTheData := WriteStream on: (String new: totalLength).
myData do: [ :chunk | allTheData nextPutAll: chunk asString].
NebraskaDebug at: #peerBytesSent add: {totalLength}.
self sendDataCautiously: allTheData contents.
^true
!
----- Method: EToyPeerToPeer>>receiveDataOn:for: (in category 'receiving') -----
receiveDataOn: aSocket for: aCommunicatorMorph
socket := aSocket.
remoteSocketAddress := socket remoteAddress.
communicatorMorph := aCommunicatorMorph.
process := [
leftOverData := ''.
[self doReceiveData] whileTrue.
socket closeAndDestroy.
] newProcess.
process priority: Processor highIOPriority.
process resume.
!
----- Method: EToyPeerToPeer>>sendDataCautiously: (in category 'sending') -----
sendDataCautiously: aStringOrByteArray
"Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent. Try not to send too much at once since this seemed to cause problems talking to a port on the same machine"
| bytesSent bytesToSend count |
bytesToSend := aStringOrByteArray size.
bytesSent := 0.
[bytesSent < bytesToSend] whileTrue: [
count := socket
sendSomeData: aStringOrByteArray
startIndex: bytesSent + 1
count: (bytesToSend - bytesSent min: 4000).
bytesSent := bytesSent + count.
communicatorMorph commResult: {#commFlash -> true}.
(Delay forMilliseconds: 10) wait.
].
^ bytesSent
!
----- Method: EToyPeerToPeer>>sendSomeData:to:for: (in category 'sending') -----
sendSomeData: arrayOfByteObjects to: anIPAddress for: aCommunicatorMorph
dataQueue := self
sendSomeData: arrayOfByteObjects
to: anIPAddress
for: aCommunicatorMorph
multiple: false.
dataQueue nextPut: nil. "only this message to send"
!
----- Method: EToyPeerToPeer>>sendSomeData:to:for:multiple: (in category 'sending') -----
sendSomeData: arrayOfByteObjects to: anIPAddress for: aCommunicatorMorph multiple: aBoolean
Socket initializeNetwork.
socket := Socket newTCP.
dataQueue := SharedQueue new.
dataQueue nextPut: arrayOfByteObjects.
communicatorMorph := aCommunicatorMorph.
ipAddress := anIPAddress.
process := [
self doConnectForSend ifTrue: [
[self doSendData] whileTrue.
communicatorMorph commResult: {#message -> 'OK'}.
socket closeAndDestroy.
].
] newProcess.
process priority: Processor highIOPriority.
process resume.
^dataQueue
!
----- Method: EToyPeerToPeer>>stopListening (in category 'receiving') -----
stopListening
process ifNotNil: [process terminate. process := nil].
connectionQueue ifNotNil: [connectionQueue destroy. connectionQueue := nil].
!
Object subclass: #FontCache
instanceVariableNames: 'fonts'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!FontCache commentStamp: '<historical>' prior: 0!
Used by MREncoder and MRDecoder. It associates an integer index with a number of fonts. Fonts can be searched by index, and the index can be found for a font that isn't present. If a font is added to the cache, sometimes the cache will discard another font to make room.!
----- Method: FontCache class>>new: (in category 'instance creation') -----
new: size
^super new initialize: size!
----- Method: FontCache>>fontAt: (in category 'lookups') -----
fontAt: index
"return the font associated with the given index"
^fonts at: index!
----- Method: FontCache>>includesFont: (in category 'lookups') -----
includesFont: aFont
"decide whether the given font is included in the collection"
^fonts identityIncludes: aFont !
----- Method: FontCache>>indexForNewFont: (in category 'lookups') -----
indexForNewFont: aFont
"add aFont to the cache. Return its index. The receiver will sometimes choose an index that is already used; that means that aFont is replacing the other font"
| index |
index := fonts size atRandom. "random is simpler to manage than anything else"
fonts at: index put: aFont.
^index!
----- Method: FontCache>>indexOf: (in category 'lookups') -----
indexOf: aFont
"return the index for a given font"
^fonts identityIndexOf: aFont!
----- Method: FontCache>>initialize: (in category 'initialization') -----
initialize: cacheSize
fonts := Array new: cacheSize.!
Object subclass: #LoopbackStringSocket
instanceVariableNames: 'associate inArrays outArrays'
classVariableNames: 'WRITESTRINGSIZES'
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!LoopbackStringSocket commentStamp: '<historical>' prior: 0!
a string socket which is connected to another string sockt on the local computer. Used mostly for testing.!
----- Method: LoopbackStringSocket class>>clearStats (in category 'as yet unclassified') -----
clearStats
WRITESTRINGSIZES := nil!
----- Method: LoopbackStringSocket class>>newPair (in category 'instance creation') -----
newPair
"create a connected pair of sockets"
| a b |
a := self new.
b := self new.
a associate: b.
b associate: a.
^{a. b}!
----- Method: LoopbackStringSocket class>>stats (in category 'as yet unclassified') -----
stats
^WRITESTRINGSIZES!
----- Method: LoopbackStringSocket>>arraysFromAssociate: (in category 'private') -----
arraysFromAssociate: arrays
"new string-arrays have arrived from our associate"
inArrays ifNil: [^self].
inArrays addAll: arrays.!
----- Method: LoopbackStringSocket>>associate: (in category 'initialization') -----
associate: aLoopbackStringSocket
associate := aLoopbackStringSocket.
inArrays := OrderedCollection new.
outArrays := OrderedCollection new.!
----- Method: LoopbackStringSocket>>destroy (in category 'as yet unclassified') -----
destroy
associate := inArrays := outArrays := nil.!
----- Method: LoopbackStringSocket>>flush (in category 'I/O') -----
flush!
----- Method: LoopbackStringSocket>>isConnected (in category 'I/O') -----
isConnected
^true!
----- Method: LoopbackStringSocket>>nextOrNil (in category 'I/O') -----
nextOrNil
inArrays ifNil: [^nil].
inArrays isEmpty
ifTrue: [ ^nil ]
ifFalse: [
^inArrays removeFirst. ] !
----- Method: LoopbackStringSocket>>nextPut: (in category 'I/O') -----
nextPut: aStringArray
inArrays ifNil: [^self].
outArrays add: aStringArray.
"WRITESTRINGSIZES ifNil: [WRITESTRINGSIZES := Bag new].
aStringArray do: [ :each | WRITESTRINGSIZES add: each size]."!
----- Method: LoopbackStringSocket>>processIO (in category 'I/O') -----
processIO
inArrays ifNil: [^self].
associate arraysFromAssociate: outArrays.
outArrays := OrderedCollection new.!
Object subclass: #MorphicEventDecoder
instanceVariableNames: 'connection'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!MorphicEventDecoder commentStamp: '<historical>' prior: 0!
decode messages sent via a MorphicEventEncoder.!
----- Method: MorphicEventDecoder class>>on: (in category 'instance creation') -----
on: aStringArray
^self basicNew connection: aStringArray!
----- Method: MorphicEventDecoder>>apply:to: (in category 'handling messages') -----
apply: aStringArray to: aHand
"decode aStringArray, and apply the encoded command to aHand"
aStringArray first = 'event' ifTrue: [
^self applyEventMessage: aStringArray to: aHand
].
aStringArray first = 'viewExtent' ifTrue: [
^self applyViewExtentMessage: aStringArray to: aHand
].
aStringArray first = 'beginBuffering' ifTrue: [
^aHand convertRemoteClientToBuffered
].
^self error: 'unknown message type: ', aStringArray first!
----- Method: MorphicEventDecoder>>applyEventMessage:to: (in category 'handling messages') -----
applyEventMessage: aStringArray to: aHand
| event |
event := MorphicEvent fromStringArray: (aStringArray copyFrom: 2 to: aStringArray size).
event ifNotNil:[aHand queueEvent: event].!
----- Method: MorphicEventDecoder>>applyMessagesTo: (in category 'handling messages') -----
applyMessagesTo: aHand
| msg |
"apply all queued events to the given hand"
"currently, there is no way to extract the rawmessages. This is simply because I didn't feel like implementing individual classes for each message -lex"
[ msg := connection nextOrNil. msg notNil ] whileTrue: [
self apply: msg to: aHand ].
!
----- Method: MorphicEventDecoder>>applyViewExtentMessage:to: (in category 'handling messages') -----
applyViewExtentMessage: aStringArray to: aHand
| newViewExtent |
newViewExtent := CanvasDecoder decodePoint: aStringArray second.
aHand setViewExtent: newViewExtent!
----- Method: MorphicEventDecoder>>connection: (in category 'initialization') -----
connection: aConnection
connection := aConnection!
----- Method: MorphicEventDecoder>>processIO (in category 'handling messages') -----
processIO
connection processIO!
Object subclass: #MorphicEventEncoder
instanceVariableNames: 'connection lastEventSent'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!MorphicEventEncoder commentStamp: '<historical>' prior: 0!
A filter which translates MorphEvent's into StringArray's.!
----- Method: MorphicEventEncoder class>>on: (in category 'instance creation') -----
on: aStringArray
^self basicNew connection: aStringArray!
----- Method: MorphicEventEncoder>>connection: (in category 'initialization') -----
connection: aConnection
connection := aConnection!
----- Method: MorphicEventEncoder>>flush (in category 'network I/O') -----
flush
connection flush!
----- Method: MorphicEventEncoder>>processIO (in category 'network I/O') -----
processIO
connection processIO!
----- Method: MorphicEventEncoder>>requestBufferedConnection (in category 'network I/O') -----
requestBufferedConnection
"request the opposite side to send complete screen updates rather than discrete drawing commands"
connection nextPut: { 'beginBuffering' }
!
----- Method: MorphicEventEncoder>>sendEvent: (in category 'network I/O') -----
sendEvent: anEvent
(anEvent isMouseMove and: [ anEvent = lastEventSent ]) ifTrue: [
"save on network traffic--don't send duplicate mouse moves"
^self ].
lastEventSent := anEvent.
connection nextPut: #('event'), anEvent encodedAsStringArray!
----- Method: MorphicEventEncoder>>sendViewExtent: (in category 'network I/O') -----
sendViewExtent: newExtent
"inform the opposite side that our view extent has changed"
connection nextPut: { 'viewExtent'. CanvasEncoder encodePoint: newExtent }
!
Object subclass: #NebraskaClient
instanceVariableNames: 'connection encoder hand canvas'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!NebraskaClient commentStamp: '<historical>' prior: 0!
A client that has connected to a Nebraska server, seen from the server's point of view.!
----- Method: NebraskaClient class>>onConnection: (in category 'instance creation') -----
onConnection: aStringSocket
^self new initialize: aStringSocket!
----- Method: NebraskaClient>>backlog (in category 'as yet unclassified') -----
backlog
^connection backlog!
----- Method: NebraskaClient>>canvas (in category 'attributes') -----
canvas
"return the hand this canvas that should be drawn on for this client"
^canvas!
----- Method: NebraskaClient>>convertToBuffered (in category 'initialization') -----
convertToBuffered
canvas purgeOutputQueue.
canvas := canvas asBufferedCanvas.!
----- Method: NebraskaClient>>currentStatusString (in category 'as yet unclassified') -----
currentStatusString
(connection isNil or: [connection isConnected not]) ifTrue: [^'nada'].
^(NetNameResolver stringFromAddress: connection remoteAddress),
' - ',
(self backlog // 1024) printString,'k'!
----- Method: NebraskaClient>>destroy (in category 'initialization') -----
destroy
hand ifNotNil:[hand world ifNotNil:[hand world removeHand: hand]].
connection ifNotNil:[connection destroy].
encoder := canvas := hand := connection := nil.!
----- Method: NebraskaClient>>extent:depth: (in category 'network') -----
extent: newExtent depth: newDepth
encoder extent: newExtent depth: newDepth!
----- Method: NebraskaClient>>hand (in category 'attributes') -----
hand
"return the hand this client is controlling"
^hand!
----- Method: NebraskaClient>>initialize: (in category 'initialization') -----
initialize: aConnection
| remoteAddress userPicture |
connection := aConnection.
hand := RemoteControlledHandMorph on: (MorphicEventDecoder on: aConnection).
hand nebraskaClient: self.
remoteAddress := connection remoteAddress.
remoteAddress ifNotNil: [remoteAddress := NetNameResolver stringFromAddress: remoteAddress].
userPicture := EToySenderMorph pictureForIPAddress: remoteAddress.
hand
userInitials: ((EToySenderMorph nameForIPAddress: remoteAddress) ifNil: ['???'])
andPicture: (userPicture ifNotNil: [userPicture scaledToSize: 16@20]).
encoder := CanvasEncoder on: aConnection.
canvas := RemoteCanvas
connection: encoder
clipRect: NebraskaServer extremelyBigRectangle
transform: MorphicTransform identity!
----- Method: NebraskaClient>>isConnected (in category 'network') -----
isConnected
^connection isConnected!
----- Method: NebraskaClient>>processIO (in category 'network') -----
processIO
connection processIO.!
Object subclass: #NebraskaDebug
instanceVariableNames: ''
classVariableNames: 'DEBUG Details'
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!NebraskaDebug commentStamp: '<historical>' prior: 0!
BufferedCanvas enabled: false.
BufferedCanvas enabled: true.
NebraskaDebug beginStats
NebraskaDebug showStats
NebraskaDebug stopAndShowAll
NebraskaDebug killStats
StringSocket showRatesSeen
StringSocket clearRatesSeen
NebraskaDebug showAndClearStats: #allStats
NebraskaDebug showAndClearStats: #queuedbufferSizes
CanvasEncoder beginStats
CanvasEncoder showStats
CanvasEncoder killStats
NebraskaDebug showStats: #peerBytesSent
NebraskaDebug showStats: #soundReductionTime
NebraskaDebug showStats: #FormEncodeTimes
NebraskaDebug showStats: #SendReceiveStats
NebraskaDebug showStats: #sendDeltas
NebraskaDebug showStats: #bigImage
NebraskaDebug showStats: #sketch
NebraskaDebug showStats: #addToOutBuf:
----
buffered off, painting 125kb/s, dragging 400kb/s
buffered on, painting 100kb/s, dragging 170kb/s!
----- Method: NebraskaDebug class>>at:add: (in category 'as yet unclassified') -----
at: queueName add: anArray
| now |
DEBUG ifNil: [
queueName == #sketchZZZ ifFalse: [^self].
"Details := OrderedCollection new."
self beginStats.
].
(Details notNil and: [Details size < 20]) ifTrue: [
Details add: thisContext longStack
].
now := Time millisecondClockValue.
DEBUG add: {now},anArray,{queueName}.
!
----- Method: NebraskaDebug class>>beginStats (in category 'as yet unclassified') -----
beginStats
DEBUG := OrderedCollection new!
----- Method: NebraskaDebug class>>killStats (in category 'as yet unclassified') -----
killStats
DEBUG := nil.
!
----- Method: NebraskaDebug class>>showAndClearStats: (in category 'as yet unclassified') -----
showAndClearStats: queueName
DEBUG ifNil: [^Beeper beep].
self
showStats: queueName
from: DEBUG.
DEBUG := nil.!
----- Method: NebraskaDebug class>>showStats (in category 'as yet unclassified') -----
showStats
DEBUG ifNil: [^Beeper beep].
DEBUG explore.!
----- Method: NebraskaDebug class>>showStats: (in category 'as yet unclassified') -----
showStats: queueName
DEBUG ifNil: [^Beeper beep].
self
showStats: queueName
from: DEBUG.
!
----- Method: NebraskaDebug class>>showStats:from: (in category 'as yet unclassified') -----
showStats: queueName from: aCollection
| xx answer prevTime currTime |
prevTime := nil.
answer := String streamContents: [ :s |
s nextPutAll: (aCollection last first - aCollection first first) asStringWithCommas,' ms';cr;cr.
aCollection withIndexDo: [ :each :index |
(queueName == #allStats or: [queueName == each last]) ifTrue: [
currTime := each first.
xx := currTime printString.
prevTime ifNil: [prevTime := currTime].
s nextPutAll: index printString,'. ',
(xx allButLast: 3),'.',(xx last: 3),' ',(currTime - prevTime) printString,' '.
s nextPutAll: each allButFirst printString; cr.
prevTime := currTime.
].
]
].
StringHolder new
contents: answer;
openLabel: queueName!
----- Method: NebraskaDebug class>>stopAndShowAll (in category 'as yet unclassified') -----
stopAndShowAll
| prev |
self halt. "not updated to new format"
prev := DEBUG.
DEBUG := nil.
prev ifNil: [^Beeper beep].
prev keysAndValuesDo: [ :k :v |
self showStats: k from: v
].!
----- Method: Color>>encodeForRemoteCanvas (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvas
| encoded |
CanvasEncoder at: 4 count: 1.
(encoded := String new: 12)
putInteger32: (rgb bitAnd: 16rFFFF) at: 1;
putInteger32: (rgb >> 16) at: 5;
putInteger32: self privateAlpha at: 9.
^encoded!
TestCase subclass: #ArbitraryObjectSocketTestCase
instanceVariableNames: 'socket1 socket2 end1 end2'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Network-ObjectSocket'!
----- Method: ArbitraryObjectSocketTestCase>>setUp (in category 'setup') -----
setUp
"it would be nice to have an in-image loopback socket, so that the tests do not need the underlying platform's sockets to behave nicely"
socket1 := Socket newTCP.
socket2 := Socket newTCP.
socket1 listenOn: 9999.
socket2 connectTo: (NetNameResolver localHostAddress) port: 9999.
socket1 waitForConnectionFor: 60.
socket2 waitForConnectionFor: 60.
end1 := ArbitraryObjectSocket on: socket1.
end2 := ArbitraryObjectSocket on: socket2.
!
----- Method: ArbitraryObjectSocketTestCase>>testBasics (in category 'testing') -----
testBasics
end1 nextPut: 'hello'.
end1 nextPut: 42.
end1 nextPut: 3@5.
end1 processIO. "hopefully one call is enough...."
end2 processIO. "hopefully one call is enough...."
self should: [ end2 next = 'hello' ].
self should: [ end2 next = 42 ].
self should: [ end2 next = (3@5) ].
!
TestCase subclass: #StringSocketTestCase
instanceVariableNames: 'socket1 socket2 end1 end2'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Network-ObjectSocket'!
----- Method: StringSocketTestCase>>setUp (in category 'running') -----
setUp
"it would be nice to have an in-image loopback socket, so that the tests do not need the underlying platform's sockets to behave nicely"
socket1 := Socket newTCP.
socket2 := Socket newTCP.
socket1 listenOn: 9999.
socket2 connectTo: (NetNameResolver localHostAddress) port: 9999.
socket1 waitForConnectionFor: 60.
socket2 waitForConnectionFor: 60.
end1 := StringSocket on: socket1.
end2 := StringSocket on: socket2.
!
----- Method: StringSocketTestCase>>tearDown (in category 'running') -----
tearDown
end1 destroy.
end2 destroy.
!
----- Method: StringSocketTestCase>>testBasics (in category 'running') -----
testBasics
end1 nextPut: #().
end1 nextPut: #('').
end1 nextPut: #('hello' 'world').
end1 processIO.
end2 processIO.
self should: [ end2 next = #() ].
self should: [ end2 next = #('') ].
self should: [ end2 next = #('hello' 'world') ].
!
----- Method: StringSocketTestCase>>testBogusInput1 (in category 'running') -----
testBogusInput1
| negString |
negString := String new: 4.
negString putInteger32: -10 at: 1.
socket1 sendData: negString.
end2 processIO.
self should: [ end2 isConnected not ].
!
----- Method: StringSocketTestCase>>testBogusInput2 (in category 'running') -----
testBogusInput2
| bogoString |
bogoString := String new: 8.
bogoString putInteger32: 2 at: 1.
bogoString putInteger32: -10 at: 5.
socket1 sendData: bogoString.
end2 processIO.
self should: [ end2 isConnected not ].
!
Stream subclass: #ObjectSocket
instanceVariableNames: 'socket outBuf outBufIndex outBufSize inBuf inBufIndex inBufLastIndex outObjects inObjects'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Network-ObjectSocket'!
!ObjectSocket commentStamp: 'ls 2/10/2005 21:27' prior: 0!
This is a socket which exchanges medium-level packets instead of low-level bytes. This class is abstract; see the subclasses for particular kinds of medium-level packets which can be used.!
ObjectSocket subclass: #ArbitraryObjectSocket
instanceVariableNames: 'encodingOfLastEncodedObject lastEncodedObject'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Network-ObjectSocket'!
!ArbitraryObjectSocket commentStamp: '<historical>' prior: 0!
A network connection that passes objects instead of bytes. The objects are encoded with SmartRefStreams.
!
----- Method: ArbitraryObjectSocket>>encodeObject:into:startingAt: (in category 'private') -----
encodeObject: object into: buffer startingAt: startIndex
"encode the given object into the given buffer"
| encoded |
encoded := self smartRefStreamEncode: object.
buffer putInteger32: encoded size at: startIndex.
buffer replaceFrom: startIndex+4 to: startIndex+4+(encoded size)-1 with: encoded.
!
----- Method: ArbitraryObjectSocket>>inBufSize (in category 'private') -----
inBufSize
inBuf ifNil: [^0].
^inBufLastIndex - inBufIndex + 1!
----- Method: ArbitraryObjectSocket>>nextObjectLength (in category 'private') -----
nextObjectLength
"read the next object length from inBuf. Returns nil if less than 4 bytes are available in inBuf"
self inBufSize < 4 ifTrue: [ ^nil ].
^inBuf getInteger32: inBufIndex!
----- Method: ArbitraryObjectSocket>>processInput (in category 'private') -----
processInput
"recieve some data"
| inObjectData |
[ socket dataAvailable ] whileTrue: [
"read as much data as possible"
self addToInBuf: socket receiveAvailableData.
"decode as many objects as possible"
[self nextObjectLength ~~ nil and: [ self nextObjectLength <= (self inBufSize + 4) ]] whileTrue: [
"a new object has arrived"
inObjectData := inBuf copyFrom: (inBufIndex + 4) to: (inBufIndex + 3 + self nextObjectLength).
inBufIndex := inBufIndex + 4 + self nextObjectLength.
inObjects addLast: (RWBinaryOrTextStream with: inObjectData) reset fileInObjectAndCode ].
self shrinkInBuf. ].!
----- Method: ArbitraryObjectSocket>>smartRefStreamEncode: (in category 'private') -----
smartRefStreamEncode: anObject
| encodingStream |
"encode an object using SmartRefStream"
anObject == lastEncodedObject ifTrue: [
^encodingOfLastEncodedObject ].
encodingStream := RWBinaryOrTextStream on: ''.
encodingStream reset.
(SmartRefStream on: encodingStream) nextPut: anObject.
lastEncodedObject := anObject.
encodingOfLastEncodedObject := encodingStream contents.
^encodingOfLastEncodedObject!
----- Method: ArbitraryObjectSocket>>spaceToEncode: (in category 'private') -----
spaceToEncode: anObject
"return the number of characters needed to encode the given object"
^ 4 + (self smartRefStreamEncode: anObject) size!
----- Method: ObjectSocket class>>on: (in category 'as yet unclassified') -----
on: aSocket
^self basicNew initialize: aSocket!
----- Method: ObjectSocket>>addToInBuf: (in category 'encoding/decoding') -----
addToInBuf: aString
| newAlloc |
newAlloc := aString size * 2 max: 8000.
inBuf ifNil: [
inBuf := String new: newAlloc.
inBufIndex := 1.
inBufLastIndex := 0.
].
aString size > (inBuf size - inBufLastIndex) ifTrue: [
inBuf := inBuf , (String new: newAlloc)
].
inBuf
replaceFrom: inBufLastIndex + 1
to: inBufLastIndex + aString size
with: aString
startingAt: 1.
inBufLastIndex := inBufLastIndex + aString size.
!
----- Method: ObjectSocket>>destroy (in category 'as yet unclassified') -----
destroy
socket destroy.
socket := nil.!
----- Method: ObjectSocket>>initialize: (in category 'private-initialization') -----
initialize: aSocket
socket := aSocket.
inBuf := String new: 1000.
inBufIndex := 1.
inBufLastIndex := 0.
outBuf := nil.
inObjects := OrderedCollection new.
outObjects := OrderedCollection new.
!
----- Method: ObjectSocket>>isConnected (in category 'as yet unclassified') -----
isConnected
^socket notNil and: [socket isConnected]!
----- Method: ObjectSocket>>next (in category 'stream protocol') -----
next
^inObjects removeFirst !
----- Method: ObjectSocket>>nextOrNil (in category 'stream protocol') -----
nextOrNil
inObjects isEmpty
ifTrue: [ ^nil ]
ifFalse: [ ^inObjects removeFirst ]!
----- Method: ObjectSocket>>nextPut: (in category 'stream protocol') -----
nextPut: anObject
outObjects addLast: anObject!
----- Method: ObjectSocket>>processIO (in category 'as yet unclassified') -----
processIO
"do some as much network IO as possible"
self processOutput.
self processInput.!
----- Method: ObjectSocket>>processOutput (in category 'encoding/decoding') -----
processOutput
"loop sending data as long as there is data to send, and the socket is ready to receive more data"
[ socket sendDone and: [ outBuf notNil or: [ outObjects isEmpty not ] ] ] whileTrue: [
| amountSent |
outBuf isNil ifTrue: [
| nextSize |
"no data in the current buffer; make a new buffer and encode some more"
outBuf := String new: ((self spaceToEncode: outObjects first) max: 8000).
outBufIndex := 1.
outBufSize := 0.
[ outObjects isEmpty not and: [
nextSize := self spaceToEncode: outObjects first.
nextSize <= (outBuf size - outBufSize + 1) ]
] whileTrue: [
self encodeObject: outObjects first into: outBuf startingAt: outBufSize+1.
outBufSize := outBufSize + nextSize.
outObjects removeFirst ] ].
"at this point, the buffer definitely has data in it to send. Send some"
amountSent := socket sendSomeData: outBuf startIndex: outBufIndex count: (outBufSize - outBufIndex + 1).
outBufIndex := outBufIndex + amountSent.
outBufIndex > outBufSize ifTrue: [ outBuf := nil ] ].
!
----- Method: ObjectSocket>>remoteAddress (in category 'as yet unclassified') -----
remoteAddress
self isConnected ifFalse: [^nil].
^socket remoteAddress!
----- Method: ObjectSocket>>shrinkInBuf (in category 'encoding/decoding') -----
shrinkInBuf
inBuf ifNil: [^self].
inBufLastIndex < inBufIndex ifTrue: [
inBufLastIndex := 0.
inBufIndex := 1.
inBuf size > 20000 ifTrue: [inBuf := nil]. "if really big, kill it"
^self
].
inBuf := inBuf copyFrom: inBufIndex to: inBufLastIndex.
inBufLastIndex := inBuf size.
inBufIndex := 1.
!
ObjectSocket subclass: #StringSocket
instanceVariableNames: 'numStringsInNextArray stringsForNextArray nextStringSize files startTime stringCounter socketWriterProcess outputQueue bytesInOutputQueue extraUnsentBytes transmissionError readBuffer'
classVariableNames: 'MaxRatesSeen RunningSendCount RecentSendHistory'
poolDictionaries: ''
category: 'Nebraska-Network-ObjectSocket'!
!StringSocket commentStamp: 'ls 8/4/2004 15:15' prior: 0!
This is a socket which sends arrays of strings back and forth. This is less convenient than ObjectSockets, but it is more secure and it makes it easier to reason about updates to the protocol.
An array of strings is represented on the network as:
4-bytes number of strings in the array
4-byte number of bytes in the first string
n1-bytes characters in the first string
4-bytes number of bytes in the second string
n2-bytes characters in the second string
...
!
----- Method: StringSocket class>>clearRatesSeen (in category 'as yet unclassified') -----
clearRatesSeen
"
StringSocket clearRatesSeen
"
MaxRatesSeen := nil !
----- Method: StringSocket class>>compareFiles (in category 'as yet unclassified') -----
compareFiles
"
StringSocket compareFiles
"
| data1 data2 |
data1 := (FileStream fileNamed: 'Macintosh HD:bob:nebraska test:58984048.1')
contentsOfEntireFile.
data2 := (FileStream fileNamed: 'BobsG3:squeak:dsqueak:DSqueak2.7 folder:58795431.3')
contentsOfEntireFile.
1 to: (data1 size min: data2 size) do: [ :i |
(data1 at: i) = (data2 at: i) ifFalse: [self halt].
].
!
----- Method: StringSocket class>>showRatesSeen (in category 'as yet unclassified') -----
showRatesSeen
"
StringSocket showRatesSeen
"
| answer |
MaxRatesSeen ifNil: [^Beeper beep].
answer := WriteStream on: String new.
MaxRatesSeen keys asSortedCollection do: [ :key |
answer nextPutAll: key printString,' ',((MaxRatesSeen at: key) // 10000) printString; cr
].
StringHolder new contents: answer contents; openLabel: 'send rates at 10 second intervals'.!
----- Method: StringSocket>>addToInBuf: (in category 'private-IO') -----
addToInBuf: aString
| newAlloc |
newAlloc _ aString size * 2 max: 80000.
inBuf ifNil: [
inBuf _ String new: newAlloc.
inBufIndex _ 1.
inBufLastIndex _ 0.
].
aString size > (inBuf size - inBufLastIndex) ifTrue: [
inBuf _ inBuf , (String new: newAlloc)
].
inBuf
replaceFrom: inBufLastIndex + 1
to: inBufLastIndex + aString size
with: aString
startingAt: 1.
inBufLastIndex _ inBufLastIndex + aString size.
!
----- Method: StringSocket>>addToOutBuf: (in category 'private-IO') -----
addToOutBuf: arrayToWrite
| size newAlloc |
size := self spaceToEncode: arrayToWrite.
newAlloc := size * 2 max: 8000. "gives us room to grow"
outBuf ifNil: [
outBuf := String new: newAlloc.
outBufIndex := 1.
].
outBuf size - outBufIndex + 1 < size ifTrue: [
outBuf := outBuf , (String new: newAlloc).
].
CanvasEncoder at: 1 count: arrayToWrite size + 1.
outBuf putInteger32: arrayToWrite size at: outBufIndex.
outBufIndex := outBufIndex + 4.
arrayToWrite do: [ :each |
outBuf putInteger32: each size at: outBufIndex.
outBufIndex := outBufIndex + 4.
outBuf
replaceFrom: outBufIndex
to: outBufIndex + each size - 1
with: each
startingAt: 1.
outBufIndex := outBufIndex + each size.
].
^size!
----- Method: StringSocket>>backlog (in category 'private-IO') -----
backlog
^bytesInOutputQueue + extraUnsentBytes!
----- Method: StringSocket>>destroy (in category 'as yet unclassified') -----
destroy
socketWriterProcess ifNotNil: [socketWriterProcess terminate. socketWriterProcess := nil].
outputQueue := nil.
bytesInOutputQueue := 0.
socket ifNotNil: [socket destroy. socket := nil.].
!
----- Method: StringSocket>>gotSomething (in category 'private-IO') -----
gotSomething
numStringsInNextArray ifNil: [^self tryForNumStringsInNextArray ].
numStringsInNextArray = 0 ifTrue: [
inObjects add: #().
numStringsInNextArray := nil.
^true ].
nextStringSize ifNil: [^ self tryForNextStringSize ].
^self tryForString
!
----- Method: StringSocket>>inBufNext: (in category 'private-IO') -----
inBufNext: anInteger
| answer |
answer := inBuf copyFrom: inBufIndex to: inBufIndex + anInteger - 1.
inBufIndex := inBufIndex + anInteger.
^answer!
----- Method: StringSocket>>inBufSize (in category 'private-IO') -----
inBufSize
inBuf ifNil: [^0].
^inBufLastIndex - inBufIndex + 1!
----- Method: StringSocket>>initialize: (in category 'as yet unclassified') -----
initialize: aSocket
transmissionError := false.
super initialize: aSocket.
outputQueue := SharedQueue new.
extraUnsentBytes := bytesInOutputQueue := 0.
socketWriterProcess := [
[self transmitQueueNext] whileTrue.
socketWriterProcess := nil.
outputQueue := nil.
bytesInOutputQueue := 0.
] forkAt: Processor lowIOPriority.!
----- Method: StringSocket>>isConnected (in category 'private-IO') -----
isConnected
^super isConnected and: [socketWriterProcess notNil]!
----- Method: StringSocket>>nextPut: (in category 'private-IO') -----
nextPut: anObject
socketWriterProcess ifNil: [^self].
outObjects addLast: anObject.
"return the argument - added by kwl"
^ anObject!
----- Method: StringSocket>>processIO (in category 'private-IO') -----
processIO
"do some as much network IO as possible"
socketWriterProcess ifNil: [^self].
self processOutput.
self processInput.!
----- Method: StringSocket>>processInput (in category 'private-IO') -----
processInput
| totalReceived chunkOfData |
"do as much input as possible"
self flag: #XXX. "should have resource limits here--no more than X objects and Y bytes"
chunkOfData _ socket receiveAvailableDataIntoBuffer: self readBuffer.
self addToInBuf: chunkOfData.
totalReceived _ chunkOfData size.
totalReceived > 0 ifTrue: [
NebraskaDebug at: #SendReceiveStats add: {'GET'. totalReceived}.
].
[ self gotSomething ] whileTrue: []. "decode as many string arrays as possible"
self shrinkInBuf.!
----- Method: StringSocket>>processOutput (in category 'private-IO') -----
processOutput
| arrayToWrite size bytesSent timeStartSending t itemsSent now timeSlot bucketAgeInMS bytesThisSlot |
outBufIndex := 1.
itemsSent := bytesSent := 0.
timeStartSending := Time millisecondClockValue.
[outObjects isEmpty not and: [self isConnected]] whileTrue: [
arrayToWrite := outObjects removeFirst.
size := self addToOutBuf: arrayToWrite.
bytesSent := bytesSent + size.
itemsSent := itemsSent + 1.
outBufIndex > 10000 ifTrue: [self queueOutBufContents].
].
outBufIndex > 1 ifTrue: [self queueOutBufContents].
bytesSent > 0 ifTrue: [
MaxRatesSeen ifNil: [MaxRatesSeen := Dictionary new].
now := Time millisecondClockValue.
t := now - timeStartSending.
timeSlot := now // 10000. "ten second buckets"
bucketAgeInMS := now \\ 10.
bytesThisSlot := (MaxRatesSeen at: timeSlot ifAbsent: [0]) + bytesSent.
MaxRatesSeen
at: timeSlot
put: bytesThisSlot.
NebraskaDebug
at: #SendReceiveStats
add: {'put'. bytesSent. t. itemsSent. bytesThisSlot // (bucketAgeInMS max: 100)}.
].
!
----- Method: StringSocket>>purgeOutputQueue (in category 'private-IO') -----
purgeOutputQueue
bytesInOutputQueue := 0.
[outputQueue nextOrNil notNil] whileTrue.!
----- Method: StringSocket>>queueOutBufContents (in category 'private-IO') -----
queueOutBufContents
bytesInOutputQueue := bytesInOutputQueue + outBufIndex - 1.
outputQueue nextPut: {outBuf. outBufIndex - 1}.
NebraskaDebug at: #queuedbufferSizes add: {outBufIndex - 1}.
outBufIndex := 1.
outBuf := String new: 11000.
!
----- Method: StringSocket>>readBuffer (in category 'as yet unclassified') -----
readBuffer
^ readBuffer ifNil: [readBuffer _ String new: 20000].
!
----- Method: StringSocket>>sendDataCautiously:bytesToSend: (in category 'private-IO') -----
sendDataCautiously: aStringOrByteArray bytesToSend: bytesToSend
"Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent. Try not to send too much at once since this seemed to cause problems talking to a port on the same machine"
| bytesSent count |
bytesSent := 0.
[bytesSent < bytesToSend] whileTrue: [
extraUnsentBytes := bytesToSend - bytesSent.
count := socket
sendSomeData: aStringOrByteArray
startIndex: bytesSent + 1
count: (bytesToSend - bytesSent min: 6000).
bytesSent := bytesSent + count.
(Delay forMilliseconds: 1) wait.
].
extraUnsentBytes := 0.
^ bytesSent
!
----- Method: StringSocket>>shrinkInBuf (in category 'private-IO') -----
shrinkInBuf
inBuf ifNil: [^self].
inBufLastIndex < inBufIndex ifTrue: [
inBufLastIndex := 0.
inBufIndex := 1.
inBuf size > 20000 ifTrue: [inBuf := nil]. "if really big, kill it"
^self
].
inBuf := inBuf copyFrom: inBufIndex to: inBufLastIndex.
inBufLastIndex := inBuf size.
inBufIndex := 1.
!
----- Method: StringSocket>>spaceToEncode: (in category 'private-IO') -----
spaceToEncode: anArray
"return the number of characters needed to encode the given string array"
^anArray inject: 4 into: [ :sum :array |
sum + (array size + 4) ].!
----- Method: StringSocket>>transmitQueueNext (in category 'private-IO') -----
transmitQueueNext
| bufTuple |
bufTuple := outputQueue next.
bytesInOutputQueue := bytesInOutputQueue - bufTuple second max: 0.
[
self
sendDataCautiously: bufTuple first
bytesToSend: bufTuple second.
]
on: Error
do: [ :ex |
transmissionError := true.
].
^transmissionError not
!
----- Method: StringSocket>>tryForNextStringSize (in category 'private-IO') -----
tryForNextStringSize
"grab the size of the next string, if it's available"
self inBufSize >= 4 ifFalse: [^false].
nextStringSize := inBuf getInteger32: inBufIndex.
"nextStringSize > 100000 ifTrue: [self barf]."
inBufIndex := inBufIndex + 4.
nextStringSize < 0 ifTrue: [
socket disconnect.
^false ].
^true
!
----- Method: StringSocket>>tryForNumStringsInNextArray (in category 'private-IO') -----
tryForNumStringsInNextArray
"input numStringsInNextARray, if 4 bytes are available"
self inBufSize >= 4 ifFalse: [^false].
numStringsInNextArray := inBuf getInteger32: inBufIndex.
"(numStringsInNextArray > 100 or: [numStringsInNextArray < 1]) ifTrue: [self barf]."
inBufIndex := inBufIndex + 4.
numStringsInNextArray < 0 ifTrue: [
socket disconnect.
^false ].
stringsForNextArray := Array new: numStringsInNextArray.
stringCounter := 0.
nextStringSize := nil.
^true!
----- Method: StringSocket>>tryForString (in category 'private-IO') -----
tryForString
"try to grab an actual string"
self inBufSize >= nextStringSize ifFalse: [^false].
stringsForNextArray
at: (stringCounter := stringCounter + 1)
put: (self inBufNext: nextStringSize) asString.
stringCounter = numStringsInNextArray ifTrue: [ "we have finished another array!!"
inObjects addLast: stringsForNextArray.
stringCounter := stringsForNextArray := numStringsInNextArray := nextStringSize := nil.
] ifFalse: [ "still need more strings for this array"
nextStringSize := nil.
].
^true
!
----- Method: MouseMoveEvent>>decodeFromStringArray: (in category '*nebraska-*nebraska-Morphic-Remote') -----
decodeFromStringArray: array
"decode the receiver from an array of strings"
type := array first asSymbol.
position := CanvasDecoder decodePoint: (array second).
buttons := CanvasDecoder decodeInteger: (array third).
startPoint := CanvasDecoder decodePoint: (array fourth)!
----- Method: MouseMoveEvent>>encodedAsStringArray (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodedAsStringArray
"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
^{
type.
CanvasEncoder encodePoint: position.
CanvasEncoder encodeInteger: buttons.
CanvasEncoder encodePoint: startPoint.
}!
Morph subclass: #NetworkTerminalMorph
instanceVariableNames: 'connection decoder eventEncoder backgroundForm enteringHand'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!NetworkTerminalMorph commentStamp: '<historical>' prior: 0!
A morph used to communicate with a remote image. It sends all mouse/keyboard events to the remote side, and it displays canvas commands that are sent back.!
----- Method: NetworkTerminalMorph class>>connectTo: (in category 'instance creation') -----
connectTo: serverHost
^self connectTo: serverHost port: NebraskaServer defaultPort
!
----- Method: NetworkTerminalMorph class>>connectTo:port: (in category 'instance creation') -----
connectTo: serverHost port: serverPort
| stringSock |
stringSock := self socketConnectedTo: serverHost port: serverPort.
^self new connection: stringSock
!
----- Method: NetworkTerminalMorph class>>openAndConnectTo: (in category 'instance creation') -----
openAndConnectTo: serverHost
^self openAndConnectTo: serverHost port: NebraskaServer defaultPort
!
----- Method: NetworkTerminalMorph class>>openAndConnectTo:port: (in category 'instance creation') -----
openAndConnectTo: serverHost port: serverPort
| stringSock me |
stringSock := self socketConnectedTo: serverHost port: serverPort.
me := self new connection: stringSock.
^me openInStyle: #naked
!
----- Method: NetworkTerminalMorph class>>socketConnectedTo:port: (in category 'instance creation') -----
socketConnectedTo: serverHost port: serverPort
| sock |
Socket initializeNetwork.
sock := Socket new.
[sock connectTo: (NetNameResolver addressForName: serverHost) port: serverPort]
on: ConnectionTimedOut
do: [:ex | self error: 'could not connect to server' ].
^StringSocket on: sock
!
----- Method: NetworkTerminalMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
| myCopy outData null |
(morphToDrop isKindOf: NewHandleMorph) ifTrue: [ "don't send these"
^morphToDrop rejectDropMorphEvent: evt.
].
self eToyRejectDropMorph: morphToDrop event: evt. "we don't really want it"
"7 mar 2001 - remove #veryDeepCopy"
myCopy := morphToDrop. "gradient fills require doing this second"
myCopy setProperty: #positionInOriginatingWorld toValue: morphToDrop position.
outData := myCopy eToyStreamedRepresentationNotifying: nil.
null := String with: 0 asCharacter.
EToyPeerToPeer new
sendSomeData: {
EToyIncomingMessage typeMorph,null.
Preferences defaultAuthorName,null.
outData
}
to: (NetNameResolver stringFromAddress: connection remoteAddress)
for: self.
!
----- Method: NetworkTerminalMorph>>addScalingMenuItems:hand: (in category 'as yet unclassified') -----
addScalingMenuItems: menu hand: aHandMorph
"for comaptibility when in scaled frame"!
----- Method: NetworkTerminalMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
"I assume that we are opaque"
^ aRectangle areasOutside: self bounds!
----- Method: NetworkTerminalMorph>>commResult: (in category 'event handling') -----
commResult: anArrayOfAssociations
"ignore for now"!
----- Method: NetworkTerminalMorph>>connection: (in category 'initialization') -----
connection: aConnection
connection := aConnection.
decoder := CanvasDecoder connection: aConnection.
eventEncoder := MorphicEventEncoder on: aConnection.!
----- Method: NetworkTerminalMorph>>disconnect (in category 'shutting down') -----
disconnect
connection ifNotNil: [ connection destroy ].
eventEncoder := connection := decoder := nil.!
----- Method: NetworkTerminalMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
backgroundForm ifNotNil: [
aCanvas clipBy: bounds during: [ :c |
c drawImage: backgroundForm at: bounds topLeft
].
].
!
----- Method: NetworkTerminalMorph>>extent: (in category 'geometry') -----
extent: newExtent
super extent: newExtent.
eventEncoder sendViewExtent: self extent!
----- Method: NetworkTerminalMorph>>forceToFront: (in category 'drawing') -----
forceToFront: aRegion
| highQuality |
"force the given region from the drawing form onto the background form"
highQuality := false. "highQuality is slower"
self updateBackgroundForm.
backgroundForm
copy: aRegion
from: aRegion topLeft
in: decoder drawingForm
rule: Form over.
self invalidRect: (
highQuality ifTrue: [
bounds
] ifFalse: [
(aRegion expandBy: 4) translateBy: bounds topLeft "try to remove gribblys"
]
)
!
----- Method: NetworkTerminalMorph>>handleKeyDown: (in category 'events-processing') -----
handleKeyDown: anEvent
anEvent wasHandled ifTrue:[^self].
(self handlesKeyboard: anEvent) ifFalse:[^self].
anEvent wasHandled: true.
self sendEventAsIs: anEvent.!
----- Method: NetworkTerminalMorph>>handleKeyUp: (in category 'events-processing') -----
handleKeyUp: anEvent
anEvent wasHandled ifTrue:[^self].
(self handlesKeyboard: anEvent) ifFalse:[^self].
anEvent wasHandled: true.
self sendEventAsIs: anEvent.!
----- Method: NetworkTerminalMorph>>handleKeystroke: (in category 'events-processing') -----
handleKeystroke: anEvent
anEvent wasHandled ifTrue:[^self].
anEvent wasHandled: true.
self sendEventAsIs: anEvent.!
----- Method: NetworkTerminalMorph>>handleMouseDown: (in category 'events-processing') -----
handleMouseDown: anEvent
anEvent wasHandled ifTrue:[^self].
anEvent hand removePendingBalloonFor: self.
anEvent hand removePendingHaloFor: self.
anEvent wasHandled: true.
anEvent hand newMouseFocus: self event: anEvent.
anEvent hand removeHaloFromClick: anEvent on: self.
self sendEventAsIs: anEvent.!
----- Method: NetworkTerminalMorph>>handleMouseMove: (in category 'events-processing') -----
handleMouseMove: anEvent
anEvent wasHandled ifTrue:[^self]. "not interested"
(anEvent hand hasSubmorphs) ifTrue:[^self].
(anEvent anyButtonPressed and:[anEvent hand mouseFocus ~~ self]) ifTrue:[^self].
anEvent wasHandled: true.
self sendEventAsIs: anEvent.!
----- Method: NetworkTerminalMorph>>handleMouseUp: (in category 'events-processing') -----
handleMouseUp: anEvent
anEvent wasHandled ifTrue:[^self]. "not interested"
anEvent hand mouseFocus == self ifFalse:[^self]. "Not interested in other parties"
anEvent hand releaseMouseFocus: self.
anEvent wasHandled: true.
self sendEventAsIs: anEvent.!
----- Method: NetworkTerminalMorph>>handlerForMouseDown: (in category 'events-processing') -----
handlerForMouseDown: anEvent
^self!
----- Method: NetworkTerminalMorph>>handlesMouseOver: (in category 'event handling') -----
handlesMouseOver: evt
^true!
----- Method: NetworkTerminalMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
backgroundForm := (
(StringMorph contents: '......' font: (TextStyle default fontOfSize: 24))
color: Color white
) imageForm.
bounds := backgroundForm boundingBox.
!
----- Method: NetworkTerminalMorph>>mouseEnter: (in category 'event handling') -----
mouseEnter: evt
evt hand newKeyboardFocus: self.
evt hand needsToBeDrawn ifTrue:[Cursor blank show].!
----- Method: NetworkTerminalMorph>>mouseLeave: (in category 'event handling') -----
mouseLeave: evt
evt hand needsToBeDrawn ifTrue:[Cursor normal show].!
----- Method: NetworkTerminalMorph>>openInStyle: (in category 'initialization') -----
openInStyle: aSymbol
aSymbol == #naked ifTrue: [
self openInWorld.
].
aSymbol == #scaled ifTrue: [
self openScaled.
].
aSymbol == #bordered ifTrue: [
AlignmentMorph newColumn
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 8;
borderColor: Color blue;
addMorph: self;
openInWorld.
].
[
[self world isNil] whileFalse: [(Delay forSeconds: 2) wait].
self disconnect.
] fork.
!
----- Method: NetworkTerminalMorph>>openScaled (in category 'initialization') -----
openScaled
| window tm |
window := NetworkTerminalBorderMorph new
minWidth: 100;
minHeight: 100;
borderWidth: 8;
borderColor: Color orange;
bounds: (0@0 extent: Display extent * 3 // 4).
tm := BOBTransformationMorph new.
tm useRegularWarpBlt: true. "try to reduce memory used"
window addMorphBack: tm.
tm addMorph: self.
window openInWorld.
NebraskaNavigationMorph new
nebraskaBorder: window;
nebraskaTerminal: self;
openInWorld.!
----- Method: NetworkTerminalMorph>>requestBufferedConnection (in category 'shutting down') -----
requestBufferedConnection
eventEncoder ifNotNil: [eventEncoder requestBufferedConnection].
!
----- Method: NetworkTerminalMorph>>sendEvent: (in category 'event handling') -----
sendEvent: evt
self sendEventAsIs: (evt translatedBy: bounds topLeft negated).!
----- Method: NetworkTerminalMorph>>sendEventAsIs: (in category 'event handling') -----
sendEventAsIs: evt
eventEncoder ifNil: [ ^self ].
eventEncoder sendEvent: evt.!
----- Method: NetworkTerminalMorph>>step (in category 'stepping and presenter') -----
step
decoder ifNil: [ ^self ].
decoder processIOOnForce: [ :rectangle | self forceToFront: rectangle ].!
----- Method: NetworkTerminalMorph>>stepTime (in category 'testing') -----
stepTime
^10!
----- Method: NetworkTerminalMorph>>updateBackgroundForm (in category 'drawing') -----
updateBackgroundForm
"make sure that our background form matches what the server has most recently requested"
| drawingForm |
drawingForm := decoder drawingForm.
(drawingForm extent = backgroundForm extent and: [
drawingForm depth = backgroundForm depth ]) ifTrue: [
"they match just fine"
^self ].
backgroundForm := drawingForm deepCopy. "need copy to capture the moment"
self extent: backgroundForm extent.!
----- Method: NetworkTerminalMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
^true.!
NetworkTerminalMorph subclass: #NullTerminalMorph
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
----- Method: NullTerminalMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
aCanvas fillRectangle: self bounds fillStyle: Color orange.
aCanvas frameRectangle: self bounds color: Color black!
----- Method: NullTerminalMorph>>extent: (in category 'geometry') -----
extent: newExtent
| aPoint |
aPoint := 50@50.
bounds extent = aPoint ifFalse: [
self changed.
bounds := bounds topLeft extent: aPoint.
self layoutChanged.
self changed
].
eventEncoder sendViewExtent: newExtent!
----- Method: NullTerminalMorph>>forceToFront: (in category 'drawing') -----
forceToFront: aRegion
"force the given region from the drawing form onto the background form"
self updateBackgroundForm.
!
----- Method: GradientFillStyle>>encodeForRemoteCanvas (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvas
^(DataStream streamedRepresentationOf: self) asString
!
----- Method: Point>>encodeForRemoteCanvas (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvas
| encoded |
CanvasEncoder at: 3 count: 1.
encoded := String new: 8.
encoded putInteger32: x asInteger at: 1.
encoded putInteger32: y asInteger at: 5.
^encoded!
----- Method: ColorForm>>encodeForRemoteCanvas (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvas
"encode into a bitstream for use with RemoteCanvas."
| colorsToSend |
colorsToSend := self colors.
^String streamContents: [ :str |
str
nextPut: $C; "indicates color form"
nextPutAll: colorsToSend size printString;
nextPut: $,.
colorsToSend do: [ :each |
str nextPutAll: each encodeForRemoteCanvas
].
str nextPutAll: super encodeForRemoteCanvas
].
!
StringHolder subclass: #ChatNotes
instanceVariableNames: 'name notesIndex names notes recorder player sound isPlaying isRecording isSaving nameTextMorph'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Audio Chat'!
----- Method: ChatNotes class>>openAsMorph (in category 'instance creation') -----
openAsMorph
^self new openAsMorph!
----- Method: ChatNotes>>audioDirectory (in category 'file i/o') -----
audioDirectory
(FileDirectory default directoryExists: 'audio')
ifFalse: [FileDirectory default createDirectory: 'audio'].
^FileDirectory default directoryNamed: 'audio'!
----- Method: ChatNotes>>defaultBackgroundColor (in category 'morphic') -----
defaultBackgroundColor
"In a better design, this would be handled by preferences."
^Color r: 1.0 g: 0.7 b: 0.8!
----- Method: ChatNotes>>deleteSelection (in category 'file i/o') -----
deleteSelection
"Delete the selection in the list"
| dir |
notesIndex <= 0 ifTrue: [^self].
dir := self audioDirectory.
dir deleteFileNamed: ((notes at: notesIndex), 'name') ifAbsent: [].
dir deleteFileNamed: ((notes at: notesIndex), 'aiff') ifAbsent: [].
names removeAt: notesIndex.
notes removeAt: notesIndex.
self notesListIndex: 0.
self changed: #notesList.
self changed: #name.!
----- Method: ChatNotes>>getNextName (in category 'file i/o') -----
getNextName
"Return the next name available.
All names are of the form '#.name' and '#.aiff'."
| dir num |
dir := self audioDirectory.
num := 1.
[dir fileExists: (num asString, '.name')] whileTrue: [num := num + 1].
^(num asString, '.')!
----- Method: ChatNotes>>initialExtent (in category 'morphic') -----
initialExtent
"Nice and small--that was the idea.
It shouldn't take up much screen real estate."
^200@100!
----- Method: ChatNotes>>initialize (in category 'initialization') -----
initialize
self loadNotes.
notesIndex := 0.
recorder := ChatRecorder new.
recorder initialize.!
----- Method: ChatNotes>>isPlaying (in category 'testing') -----
isPlaying
^isPlaying ifNil: [isPlaying := false]!
----- Method: ChatNotes>>isPlaying: (in category 'testing') -----
isPlaying: aBoolean
isPlaying = aBoolean ifTrue: [^self].
isPlaying := aBoolean.
self changed: #isPlaying !
----- Method: ChatNotes>>isRecording (in category 'testing') -----
isRecording
^isRecording ifNil: [isRecording := false]!
----- Method: ChatNotes>>isRecording: (in category 'testing') -----
isRecording: aBoolean
isRecording = aBoolean ifTrue: [^self].
isRecording := aBoolean.
self changed: #isRecording !
----- Method: ChatNotes>>isSaving (in category 'testing') -----
isSaving
^isSaving ifNil: [isSaving := false]!
----- Method: ChatNotes>>isSaving: (in category 'testing') -----
isSaving: aBoolean
isSaving = aBoolean ifTrue: [^self].
isSaving := aBoolean.
self changed: #isSaving!
----- Method: ChatNotes>>isStopped (in category 'testing') -----
isStopped
^false!
----- Method: ChatNotes>>loadNotes (in category 'initialization') -----
loadNotes
"Load notes from the files"
| dir |
names := OrderedCollection new.
notes := OrderedCollection new.
(FileDirectory default directoryExists: 'audio')
ifFalse: [^self].
dir := self audioDirectory.
dir fileNames do: [:fname |
(fname endsWith: '.name') ifTrue: [
names add: ((dir fileNamed: fname) contentsOfEntireFile).
notes add: (fname copyFrom: 1 to: (fname size - 4))]].!
----- Method: ChatNotes>>name (in category 'accessing') -----
name
^name ifNil: [name := '']!
----- Method: ChatNotes>>name: (in category 'accessing') -----
name: aString
name := aString.
self changed: #name.!
----- Method: ChatNotes>>notesList (in category 'accessing') -----
notesList
self flag: #why.
^names copy asArray!
----- Method: ChatNotes>>notesListIndex (in category 'accessing') -----
notesListIndex
^notesIndex ifNil: [notesIndex := 0]!
----- Method: ChatNotes>>notesListIndex: (in category 'accessing') -----
notesListIndex: index
notesIndex := index = notesIndex ifTrue: [0] ifFalse: [index].
self name: (self notesList at: notesIndex ifAbsent: ['']).
self changed: #notesListIndex.!
----- Method: ChatNotes>>notesMenu: (in category 'morphic') -----
notesMenu: aMenu
"Simple menu to delete notes"
^(notesIndex = 0)
ifTrue: [aMenu labels: 'update notes' lines: #() selections: #(updateNotes)]
ifFalse: [aMenu labels: ('delete', String cr, 'update notes') lines: #() selections: #(deleteSelection updateNotes)]!
----- Method: ChatNotes>>openAsMorph (in category 'initialization') -----
openAsMorph
| window aColor recordButton stopButton playButton saveButton |
window := (SystemWindow labelled: 'Audio Notes') model: self.
window addMorph: (
(PluggableListMorph
on: self
list: #notesList
selected: #notesListIndex
changeSelected: #notesListIndex:
menu: #notesMenu:
) autoDeselect: false) frame: (0@0 corner: 0.5(a)1.0).
nameTextMorph := PluggableTextMorph on: self text: #name accept: nil.
nameTextMorph askBeforeDiscardingEdits: false.
window addMorph: nameTextMorph frame: (0.5@0 corner: 1.0(a)0.4).
aColor := Color colorFrom: self defaultBackgroundColor.
(recordButton := PluggableButtonMorph on: self getState: #isRecording action: #record)
label: 'record';
askBeforeChanging: true;
color: aColor;
onColor: aColor darker offColor: aColor.
window addMorph: recordButton frame: (0.5(a)0.4 corner: 0.75(a)0.7).
(stopButton := PluggableButtonMorph on: self getState: #isStopped action: #stop)
label: 'stop';
askBeforeChanging: true;
color: aColor;
onColor: aColor darker offColor: aColor.
window addMorph: stopButton frame: (0.75(a)0.4 corner: 1.0(a)0.7).
(playButton := PluggableButtonMorph on: self getState: #isPlaying action: #play)
label: 'play';
askBeforeChanging: true;
color: aColor;
onColor: aColor darker offColor: aColor.
window addMorph: playButton frame: (0.5(a)0.7 corner: 0.75(a)1.0).
(saveButton := PluggableButtonMorph on: self getState: #isSaving action: #save)
label: 'save';
askBeforeChanging: true;
color: aColor;
onColor: aColor darker offColor: aColor.
window addMorph: saveButton frame: (0.75(a)0.7 corner: 1.0(a)1.0).
window openInWorld.!
----- Method: ChatNotes>>play (in category 'file i/o') -----
play
| separator |
self isPlaying: true.
notesIndex = 0 ifTrue: [
recorder pause.
recorder playback.
self isPlaying: false.
^self
].
separator := FileDirectory pathNameDelimiter asString.
sound := (AIFFFileReader new readFromFile: (
FileDirectory default pathName,
separator, 'audio', separator, (notes at: notesIndex), 'aiff')) sound.
[
sound playAndWaitUntilDone.
self isPlaying: false
] fork!
----- Method: ChatNotes>>record (in category 'button commands') -----
record
self isRecording: true.
notesIndex = 0 ifFalse: [self notesListIndex: 0].
sound := nil.
recorder clearRecordedSound.
recorder resumeRecording.!
----- Method: ChatNotes>>recorder (in category 'accessing') -----
recorder
^recorder!
----- Method: ChatNotes>>save (in category 'button commands') -----
save
self isSaving: true.
notesIndex = 0
ifTrue: [self saveSound]
ifFalse: [self saveName].
self isSaving: false.!
----- Method: ChatNotes>>saveName (in category 'file i/o') -----
saveName
"Save the name to the '.name' file."
| dir file |
self name: self textMorphString.
dir := self audioDirectory.
file := (notes at: notesIndex), 'name'.
(dir fileExists: file) ifTrue: [dir deleteFileNamed: file].
file := dir newFileNamed: file.
file nextPutAll: name.
file close.
names at: notesIndex put: name.
self changed: #notesList.!
----- Method: ChatNotes>>saveSound (in category 'file i/o') -----
saveSound
"Move the sound from the recorder to the files."
| fname file |
recorder recordedSound ifNil: [^self].
self isSaving: true.
fname := self getNextName.
"Create .name file"
file := self audioDirectory newFileNamed: (fname, 'name').
file nextPutAll: self textMorphString.
file close.
"Create .aiff file"
file := (self audioDirectory newFileNamed: (fname, 'aiff')) binary.
self storeAIFFOnFile: file.
file close.
"Add to names and notes"
names add: self textMorphString.
notes add: fname.
self changed: #notesList.
self notesListIndex: (notes size).
"Clear Recorder"
recorder := SoundRecorder new.
"Stop Button"
self isSaving: false!
----- Method: ChatNotes>>stop (in category 'button commands') -----
stop
recorder pause.
self isRecording: false!
----- Method: ChatNotes>>storeAIFFOnFile: (in category 'file i/o') -----
storeAIFFOnFile: file
"In a better design, this would be handled by SequentialSound,
but I figure you will need a new primitive anyway, so it can
be implemented at that time."
| sampleCount s |
sampleCount := recorder recordedSound sounds inject: 0 into: [ :sum :rsound |
sum + rsound samples monoSampleCount
].
file nextPutAll: 'FORM' asByteArray.
file nextInt32Put: (2 * sampleCount) + 46.
file nextPutAll: 'AIFF' asByteArray.
file nextPutAll: 'COMM' asByteArray.
file nextInt32Put: 18.
file nextNumber: 2 put: 1. "channels"
file nextInt32Put: sampleCount.
file nextNumber: 2 put: 16. "bits/sample"
(AbstractSound new) storeExtendedFloat: (recorder samplingRate) on: file.
file nextPutAll: 'SSND' asByteArray.
file nextInt32Put: (2 * sampleCount) + 8.
file nextInt32Put: 0.
file nextInt32Put: 0.
(recorder recordedSound sounds) do: [:rsound |
1 to: (rsound samples monoSampleCount) do: [:i |
s := rsound samples at: i.
file nextPut: ((s bitShift: -8) bitAnd: 16rFF).
file nextPut: (s bitAnd: 16rFF)]].!
----- Method: ChatNotes>>textMorphString (in category 'morphic') -----
textMorphString
^nameTextMorph text string!
----- Method: ChatNotes>>updateNotes (in category 'file i/o') -----
updateNotes
"Probably not necessary unless several audio notes are
open at the same time"
"Clear Notes"
self loadNotes.
self changed: #notesList.
self notesListIndex: 0.
self name: ''.!
SoundRecorder subclass: #ChatRecorder
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Audio Chat'!
----- Method: ChatRecorder>>initialize (in category 'as yet unclassified') -----
initialize
"setting a higher desired recording rate seemed to fix certain powerbook problems.
I'm still trying to understand it all, but there it is for now"
super initialize.
samplingRate := 44100.
!
----- Method: ChatRecorder>>pause (in category 'as yet unclassified') -----
pause
"Go into pause mode. The record level continues to be updated, but no sound is recorded."
paused := true.
((currentBuffer ~~ nil) and: [nextIndex > 1])
ifTrue: [self emitPartialBuffer.
self allocateBuffer].
soundPlaying ifNotNil: [
soundPlaying pause.
soundPlaying := nil].
self stopRecording.
"Preferences canRecordWhilePlaying ifFalse: [self stopRecording]."
!
----- Method: ChatRecorder>>playback (in category 'as yet unclassified') -----
playback
"Playback the sound that has been recorded."
self pause.
soundPlaying := self recordedSound ifNil: [^self].
soundPlaying play.
!
----- Method: ChatRecorder>>recordedSound: (in category 'accessing') -----
recordedSound: aSound
self clearRecordedSound.
recordedSound := aSound.!
----- Method: ChatRecorder>>resumeRecording (in category 'as yet unclassified') -----
resumeRecording
"Continue recording from the point at which it was last paused."
self startRecording.
paused := false.
!
----- Method: TTCFont>>encodedForRemoteCanvas (in category '*nebraska-file in/out') -----
encodedForRemoteCanvas
^ self familyName, ' ', self pointSize printString, ' ', self emphasis printString.
!
EToyCommunicatorMorph subclass: #AudioChatGUI
instanceVariableNames: 'mycodec myrecorder mytargetip myalert playOnArrival theConnectButton soundBlockNumber soundMessageID queueForMultipleSends transmitWhileRecording theTalkButton handsFreeTalking handsFreeTalkingFlashTime'
classVariableNames: 'PlayOnArrival LiveMessages DebugLog NewAudioMessages'
poolDictionaries: ''
category: 'Nebraska-Morphic-Collaborative'!
----- Method: AudioChatGUI class>>debugLog: (in category 'as yet unclassified') -----
debugLog: x
"
AudioChatGUI debugLog: nil
AudioChatGUI debugLog: OrderedCollection new
DebugLog LiveMessages NewAudioMessages PlayOnArrival
"
DebugLog := x.
!
----- Method: AudioChatGUI class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
"Answer a description of the receiver for use in a parts bin"
^ self partName: 'Audio chat'
categories: #('Collaborative')
documentation: 'A tool for talking to other Squeak users'
sampleImageForm: (Form
extent: 110@70
depth: 8
fromArray: #( 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193845248 4193909241 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33159673 4193845248 4193909241 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843257 4193845248 4193908993 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 4193845248 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33095680 4193845505 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 33095680 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 378967702!
5 378967
7025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642629 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466465 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2239817189 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 2246173153 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857024481 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857013729 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783321061 3842048257 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 31843813 31843813 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857048965 3789619457 16842752 4177592!
577 3158
0641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783321061 31843813 3857048833 16901605 3842106625 31843813 3842106625 31843813 3842048257 3857049061 16901605 16843237 3857048960 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 31843813 3856990693 3856990693 16843237 3842106853 16843237 3842106853 31843813 31843585 3856990693 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3777505320 673720360 673720360 685891880 673720360 673720360 673720545 3777505320 673720360 673720360 685892065 3783321061 31843813 3856990693 3856990693 3842106853 3842106853 3842106853 3842106853 16843009 31785445 3857049061 3842106853 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783648741 31843813 3856990693 3856990693 3842106853 3842106853 3842106853 3842106853 31843813 3856990693 3857049061 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783321061 31843813 31785445 3856990693 3842106853 3842106853 3842106853 3842106853 31843813 31843585 3856990693 3842106853 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783648741 3842048257 3857048833 16901605 16843237 16843237 16843237 16843237 3842048257 3857049061 16901605 3856990693 3857048965 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783321061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 3789619457 1684!
2752 417
7592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857013729 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789653477 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857024481 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 2239817189 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 2246173153 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 3789642629 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466465 3789677025 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 3789677025 3789677025 3789676928 2239792512 2239792512 2239792512 2239792512 2239792512 2239816161 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3777505320 673720360 673720360 685891880 673720360 673720360 673720545 3777505320 673720360 673720360 685892065 3789677025 3789677025 3789677025 3783613413 3857049061 3857049061 3857049061 3857049061 3857049061!
3857013
637 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 16843009 16843009 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3842048257 16901605 16901605 3857049061 3857049061 3857049061 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789619457 16843009 16843009 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3856990693 3842106853 3857049061 3857049061 3857049061 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 16843009 1888776340 1888776340 1879113985 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990693 3856990693 3842106853 3842048257 3857048833 16901377 16901605 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789676801 16880752 2490406000 2490406000 2490405889 16900577 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3!
85699069
3 3842106853 31843813 31843813 31843813 31843813 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 26505364 1888776340 1888776340 1888776340 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990465 16901605 3842106853 3842048257 31843813 3842106625 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 2490406000 2490406000 2490406000 2490406000 2483093985 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3857049061 3842106853 31843813 31843813 3842106625 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939540 1888776340 1888776340 1888776340 1888776340 1888747777 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990693 3857049061 3842106853 31843813 31843813 3856990693 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939504 2490406000 2490406000 2490406000 2490406000 2490368257 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3842048257 3857049061 16843237 3842048257 3842106853 3856990693 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3774939393 3789677025 16871572 1888776340 1895825407 1888776340 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025!
3789677
025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3783613413 3857049061 3857049061 3857049061 3857049061 3857049061 3857013637 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 2239792512 2239792512 2239792512 2239792512 2239792512 2239816161 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1535466373 1535466373 1535466373 1535466373 1535466373 1541530081 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3774939393 3789677025 16880752 2490406000 2499805183 2490406000 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789653376 3857049061 3857049061 3857049061 3857049061 3857049061 3850405345 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 16871572 1888776340 1888776340 1888776340 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 3857049061 3857049061 3857049061 3857049061 3857049061 3857048965 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939504 2490406000 2490406000 2490406000 2490406000 2490368257 37!
89677025
3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939540 1888776340 1888776340 1888776340 1888776340 1888747777 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1541793253 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 1541530081 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 2490406000 2490406000 2490406000 2490406000 2483093985 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3856990465 16843237 3857049061 3857048833 31843813 31843813 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 26505364 1888776340 1888776340 1888776340 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3856990693 31785445 3857049061 3857049061 31843585 31843813 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789676801 16880752 2490406000 2490406000 2490405889 16900577 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 3842048257 3857049061 31843813 31843585 31843813 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 16843009 1888776340 1888776340 1879113985 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 31843813 31843813 31843813 31843813 31785445 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789619457 16843009 16843009 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 3842048257 31843813 31843813 16901605 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 16843009 16843009 315!
80641 37
89677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 31843813 31843813 31843813 31843813 31785445 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 31843813 31843813 31843813 31843585 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857048833 16901605 3842048257 3842106625 16901377 16901377 31843813 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1541793253 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 1541530081 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 3857049061 3857049061 3857049061 3857049061 3857049061 3857048965 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677!
025 3789
677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653376 3857049061 3857049061 3857049061 3857049061 3857049061 3850405345 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1535466373 1535466373 1535466373 1535466373 1535466373 1541530081 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 16842752 4193845505 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 33095680 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33095680 4193908993 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 4193845248 4193909241 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843257 4193845248 4193909241 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 !
16843009
16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33159673 4193845248)
offset: 0@0)!
----- Method: AudioChatGUI class>>handleNewAudioChat2From:sentBy:ipAddress: (in category 'as yet unclassified') -----
handleNewAudioChat2From: dataStream sentBy: senderName ipAddress: ipAddressString
| newSound seqSound compressed |
compressed := self newCompressedSoundFrom: dataStream.
newSound := compressed asSound.
"-------an experiment to try
newSound adjustVolumeTo: 7.0 overMSecs: 10
--------"
DebugLog ifNotNil: [
DebugLog add: {compressed. newSound}.
].
LiveMessages ifNil: [LiveMessages := Dictionary new].
seqSound := LiveMessages at: ipAddressString ifAbsentPut: [SequentialSound new].
seqSound isPlaying ifTrue: [
seqSound
add: newSound;
pruneFinishedSounds.
] ifFalse: [
seqSound
initialize;
add: newSound.
].
seqSound isPlaying ifFalse: [seqSound play].!
----- Method: AudioChatGUI class>>handleNewAudioChatFrom:sentBy:ipAddress: (in category 'as yet unclassified') -----
handleNewAudioChatFrom: dataStream sentBy: senderName ipAddress: ipAddressString
| compressed |
compressed := self newCompressedSoundFrom: dataStream.
DebugLog ifNotNil: [
DebugLog add: {compressed}.
].
self newAudioMessages nextPut: compressed.
self playOnArrival ifTrue: [self playNextAudioMessage].
!
----- Method: AudioChatGUI class>>initialize (in category 'class initialization') -----
initialize
EToyIncomingMessage
forType: EToyIncomingMessage typeAudioChat
send: #handleNewAudioChatFrom:sentBy:ipAddress:
to: self.
EToyIncomingMessage
forType: EToyIncomingMessage typeAudioChatContinuous
send: #handleNewAudioChat2From:sentBy:ipAddress:
to: self.
!
----- Method: AudioChatGUI class>>newAudioMessages (in category 'as yet unclassified') -----
newAudioMessages
^NewAudioMessages ifNil: [NewAudioMessages := SharedQueue new].!
----- Method: AudioChatGUI class>>newCompressedSoundFrom: (in category 'as yet unclassified') -----
newCompressedSoundFrom: dataStream
| samplingRate |
samplingRate := (dataStream upTo: 0 asCharacter) asNumber.
^CompressedSoundData new
withEToySound: dataStream upToEnd
samplingRate: samplingRate.
!
----- Method: AudioChatGUI class>>numberOfNewMessages (in category 'as yet unclassified') -----
numberOfNewMessages
^self newAudioMessages size!
----- Method: AudioChatGUI class>>openAsMorph (in category 'creation') -----
openAsMorph
AudioChatGUI new openInWorld. "old syswindow version in #start"
!
----- Method: AudioChatGUI class>>playNextAudioMessage (in category 'as yet unclassified') -----
playNextAudioMessage
(self newAudioMessages nextOrNil ifNil: [^self]) asSound play.!
----- Method: AudioChatGUI class>>playOnArrival (in category 'as yet unclassified') -----
playOnArrival
^PlayOnArrival ifNil: [PlayOnArrival := false]!
----- Method: AudioChatGUI>>buttonColor (in category 'initialization') -----
buttonColor
^Color lightBrown!
----- Method: AudioChatGUI>>changeTalkButtonLabel (in category 'stuff') -----
changeTalkButtonLabel
| bText |
self transmitWhileRecording.
handsFreeTalking
ifTrue:
[theTalkButton
labelUp: 'Talk';
labelDown: 'Release';
label: 'Talk'.
bText := 'Click once to begin a message. Click again to end the message.']
ifFalse:
[theTalkButton
labelUp: 'Talk';
labelDown: (transmitWhileRecording
ifTrue: ['TALKING']
ifFalse: ['RECORDING']);
label: 'Talk'.
bText := 'Press and hold to record a message.'].
bText := transmitWhileRecording
ifTrue: [bText , ' The message will be sent while you are speaking.']
ifFalse: [bText , ' The message will be sent when you are finished.'].
theTalkButton setBalloonText: bText!
----- Method: AudioChatGUI>>connect (in category 'stuff') -----
connect
mytargetip := FillInTheBlank
request: 'Connect to?'
initialAnswer: (mytargetip ifNil: ['']).
mytargetip := NetNameResolver stringFromAddress: (
(NetNameResolver addressFromString: mytargetip) ifNil: [^mytargetip := '']
)
!
----- Method: AudioChatGUI>>connectButton (in category 'initialization') -----
connectButton
^SimpleButtonMorph new
label: 'Connect';
color: self buttonColor;
target: self;
actWhen: #buttonUp;
actionSelector: #connect;
setBalloonText: 'Press to connect to another audio chat user.'
!
----- Method: AudioChatGUI>>currentConnectionStateString (in category 'stuff') -----
currentConnectionStateString
^'?'
!
----- Method: AudioChatGUI>>defaultBackgroundColor (in category 'user interface') -----
defaultBackgroundColor
"In a better design, this would be handled by preferences."
^Color yellow."r: 1.0 g: 0.7 b: 0.8"!
----- Method: AudioChatGUI>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 4!
----- Method: AudioChatGUI>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color yellow!
----- Method: AudioChatGUI>>getChoice: (in category 'stuff') -----
getChoice: aSymbol
aSymbol == #playOnArrival ifTrue: [^self class playOnArrival].
aSymbol == #transmitWhileRecording ifTrue: [^self transmitWhileRecording].
aSymbol == #handsFreeTalking ifTrue: [^self handsFreeTalking].
!
----- Method: AudioChatGUI>>handsFreeTalking (in category 'sending') -----
handsFreeTalking
^handsFreeTalking ifNil: [handsFreeTalking := false].!
----- Method: AudioChatGUI>>initialExtent (in category 'user interface') -----
initialExtent
"Nice and small--that was the idea.
It shouldn't take up much screen real estate."
^200@100!
----- Method: AudioChatGUI>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
transmitWhileRecording := false.
handsFreeTalking := false.
mycodec := GSMCodec new.
myrecorder := ChatNotes new.
mytargetip := ''.
self start2.
self changeTalkButtonLabel!
----- Method: AudioChatGUI>>ipAddress: (in category 'initialization') -----
ipAddress: aString
mytargetip := aString!
----- Method: AudioChatGUI>>messageWaitingAlertIndicator (in category 'initialization') -----
messageWaitingAlertIndicator
| messageCounter |
myalert := AlertMorph new socketOwner: self.
messageCounter := UpdatingStringMorph on: self selector: #objectsInQueue.
myalert addMorph: messageCounter.
messageCounter contents: '0'; color: Color white.
messageCounter align: messageCounter center with: myalert center.
myalert setBalloonText: 'New messages indicator. This will flash and show the number of messages when there are messages that you haven''t listened to. You can click here to play the next message.'.
myalert on: #mouseUp send: #playNextMessage to: self.
^myalert!
----- Method: AudioChatGUI>>objectsInQueue (in category 'stuff') -----
objectsInQueue
^self class numberOfNewMessages!
----- Method: AudioChatGUI>>playButton (in category 'initialization') -----
playButton
^SimpleButtonMorph new
label: 'Play';
color: self buttonColor;
target: self;
actWhen: #buttonUp;
actionSelector: #playNextMessage;
setBalloonText: 'Play the next new message.'
!
----- Method: AudioChatGUI>>playNextMessage (in category 'stuff') -----
playNextMessage
self class playNextAudioMessage.
!
----- Method: AudioChatGUI>>record (in category 'sending') -----
record
queueForMultipleSends := nil.
myrecorder record.!
----- Method: AudioChatGUI>>recordAndStopButton (in category 'initialization') -----
recordAndStopButton
^ChatButtonMorph new
labelUp: 'Record';
labelDown: 'RECORDING';
label: 'Record';
color: self buttonColor;
target: self;
actionUpSelector: #stop;
actionDownSelector: #record;
setBalloonText: 'Press and hold to record a message. It will be sent when you release the mouse.'
!
----- Method: AudioChatGUI>>removeConnectButton (in category 'stuff') -----
removeConnectButton
theConnectButton ifNotNil: [
theConnectButton delete.
theConnectButton := nil.
].!
----- Method: AudioChatGUI>>samplingRateForTransmission (in category 'sending') -----
samplingRateForTransmission
^11025 "try to cut down on amount of data sent for live chats"!
----- Method: AudioChatGUI>>send (in category 'sending') -----
send
| null rawSound aSampledSound |
mytargetip isEmpty ifTrue: [
^self inform: 'You must connect with someone first.'.
].
rawSound := myrecorder recorder recordedSound ifNil: [^self].
aSampledSound := rawSound asSampledSound.
"Smalltalk at: #Q3 put: {rawSound. rawSound asSampledSound. aCompressedSound}."
self transmitWhileRecording ifTrue: [
self sendOneOfMany: rawSound asSampledSound.
queueForMultipleSends ifNotNil: [queueForMultipleSends nextPut: nil].
queueForMultipleSends := nil.
^self
].
null := String with: 0 asCharacter.
EToyPeerToPeer new
sendSomeData: {
EToyIncomingMessage typeAudioChat,null.
Preferences defaultAuthorName,null.
aSampledSound originalSamplingRate asInteger printString,null.
(mycodec compressSound: aSampledSound) channels first.
}
to: mytargetip
for: self.
!
----- Method: AudioChatGUI>>sendAnyCompletedSounds (in category 'sending') -----
sendAnyCompletedSounds
| soundsSoFar firstCompleteSound |
myrecorder isRecording ifFalse: [^self].
mytargetip isEmpty ifTrue: [^self].
soundsSoFar := myrecorder recorder recordedSound ifNil: [^self].
firstCompleteSound := soundsSoFar removeFirstCompleteSoundOrNil ifNil: [^self].
self sendOneOfMany: firstCompleteSound.!
----- Method: AudioChatGUI>>sendOneOfMany: (in category 'sending') -----
sendOneOfMany: aSampledSound
| null message aCompressedSound ratio resultBuf oldSamples newCount t fromIndex val maxVal |
self samplingRateForTransmission = aSampledSound originalSamplingRate ifTrue: [
aCompressedSound := mycodec compressSound: aSampledSound.
] ifFalse: [
t := [
ratio := aSampledSound originalSamplingRate // self samplingRateForTransmission.
oldSamples := aSampledSound samples.
newCount := oldSamples monoSampleCount // ratio.
resultBuf := SoundBuffer newMonoSampleCount: newCount.
fromIndex := 1.
maxVal := 0.
1 to: newCount do: [ :i |
maxVal := maxVal max: (val := oldSamples at: fromIndex).
resultBuf at: i put: val.
fromIndex := fromIndex + ratio.
].
] timeToRun.
NebraskaDebug at: #soundReductionTime add: {t. maxVal}.
maxVal < 400 ifTrue: [
NebraskaDebug at: #soundReductionTime add: {'---dropped---'}.
^self
]. "awfully quiet"
aCompressedSound := mycodec compressSound: (
SampledSound new
setSamples: resultBuf
samplingRate: aSampledSound originalSamplingRate // ratio
).
].
null := String with: 0 asCharacter.
message := {
EToyIncomingMessage typeAudioChatContinuous,null.
Preferences defaultAuthorName,null.
aCompressedSound samplingRate asInteger printString,null.
aCompressedSound channels first.
}.
queueForMultipleSends ifNil: [
queueForMultipleSends := EToyPeerToPeer new
sendSomeData: message
to: mytargetip
for: self
multiple: true.
] ifNotNil: [
queueForMultipleSends nextPut: message
].
!
----- Method: AudioChatGUI>>start (in category 'stepping and presenter') -----
start
| myUpdatingText playButton myOpenConnectionButton myStopButton window |
"
--- old system window version ---
"
Socket initializeNetwork.
myrecorder initialize.
window := (SystemWindow labelled: 'iSCREAM') model: self.
myalert := AlertMorph new.
myalert socketOwner: self.
window addMorph: myalert frame: (0.35(a)0.4 corner: 0.5(a)0.7).
(playButton := self playButton) center: 200@300.
window addMorph: playButton frame: (0.5(a)0.4 corner: 1.0(a)0.7).
(myOpenConnectionButton := self connectButton) center: 250@300.
window addMorph: myOpenConnectionButton frame: (0.5@0 corner: 1.0(a)0.4).
(myStopButton := self recordAndStopButton) center: 300@300.
window addMorph: myStopButton frame: (0.5(a)0.7 corner: 1.0(a)1.0).
myUpdatingText := UpdatingStringMorph on: self selector: #objectsInQueue.
window addMorph: myUpdatingText frame: (0.41(a)0.75 corner: 0.45(a)0.95).
"myUserList init."!
----- Method: AudioChatGUI>>start2 (in category 'initialization') -----
start2
Socket initializeNetwork.
myrecorder initialize.
self addARow: {
self inAColumn: {
(
self inARow: {
self inAColumn: {self toggleForSendWhileTalking}.
self inAColumn: {self toggleForHandsFreeTalking}.
self inAColumn: {self toggleForPlayOnArrival}.
}
) hResizing: #shrinkWrap.
self inARow: {
self talkBacklogIndicator.
self messageWaitingAlertIndicator.
}.
}.
self inAColumn: {
theConnectButton := self connectButton.
self playButton.
theTalkButton := self talkButton.
}.
}.
!
----- Method: AudioChatGUI>>step (in category 'stepping and presenter') -----
step
| now |
super step.
self transmitWhileRecording ifTrue: [self sendAnyCompletedSounds].
self handsFreeTalking & myrecorder isRecording ifTrue: [
now := Time millisecondClockValue.
((handsFreeTalkingFlashTime ifNil: [0]) - now) abs > 200 ifTrue: [
theTalkButton color: (
theTalkButton color = self buttonColor
ifTrue: [Color white]
ifFalse: [self buttonColor]
).
handsFreeTalkingFlashTime := now.
].
].
self class playOnArrival ifTrue: [self playNextMessage].
"myrecorder ifNotNil: [
myrecorder recorder samplingRate printString ,' ',
SoundPlayer samplingRate printString,' '
displayAt: 0@0
]."!
----- Method: AudioChatGUI>>stepTime (in category 'testing') -----
stepTime
myrecorder ifNil: [^200].
myrecorder isRecording ifFalse: [^200].
^20!
----- Method: AudioChatGUI>>stepTimeIn: (in category 'testing') -----
stepTimeIn: aSystemWindow
^self stepTime
!
----- Method: AudioChatGUI>>stop (in category 'stepping and presenter') -----
stop
myrecorder stop.
self send.!
----- Method: AudioChatGUI>>talkBacklog (in category 'sending') -----
talkBacklog
^(queueForMultipleSends ifNil: [^0]) size // 2!
----- Method: AudioChatGUI>>talkBacklogIndicator (in category 'initialization') -----
talkBacklogIndicator
^(UpdatingStringMorph on: self selector: #talkBacklog)
setBalloonText: 'Approximate number of seconds of delay in your messages getting to the other end.'!
----- Method: AudioChatGUI>>talkButton (in category 'initialization') -----
talkButton
^ChatButtonMorph new
labelUp: 'xxx';
labelDown: 'xxx';
label: 'xxx';
color: self buttonColor;
target: self;
actionUpSelector: #talkButtonUp;
actionDownSelector: #talkButtonDown;
setBalloonText: 'xxx'
!
----- Method: AudioChatGUI>>talkButtonDown (in category 'sending') -----
talkButtonDown
EToyListenerMorph confirmListening.
self handsFreeTalking ifFalse: [^self record].
theTalkButton label: 'Release'.
!
----- Method: AudioChatGUI>>talkButtonUp (in category 'sending') -----
talkButtonUp
theTalkButton recolor: self buttonColor.
self handsFreeTalking ifFalse: [^self stop].
myrecorder isRecording ifTrue: [
theTalkButton label: 'Talk'.
^self stop.
].
self record.
theTalkButton label: 'TALKING'.
!
----- Method: AudioChatGUI>>toggleChoice: (in category 'stuff') -----
toggleChoice: aSymbol
aSymbol == #playOnArrival ifTrue: [
^PlayOnArrival := self class playOnArrival not
].
aSymbol == #transmitWhileRecording ifTrue: [
transmitWhileRecording := self transmitWhileRecording not.
self changeTalkButtonLabel.
^transmitWhileRecording
].
aSymbol == #handsFreeTalking ifTrue: [
handsFreeTalking := self handsFreeTalking not.
self changeTalkButtonLabel.
^handsFreeTalking
].
!
----- Method: AudioChatGUI>>toggleForHandsFreeTalking (in category 'initialization') -----
toggleForHandsFreeTalking
^self
simpleToggleButtonFor: self
attribute: #handsFreeTalking
help: 'Whether you want to talk without holding the mouse down.'!
----- Method: AudioChatGUI>>toggleForPlayOnArrival (in category 'initialization') -----
toggleForPlayOnArrival
^self
simpleToggleButtonFor: self
attribute: #playOnArrival
help: 'Whether you want to play messages automatically on arrival.'!
----- Method: AudioChatGUI>>toggleForSendWhileTalking (in category 'initialization') -----
toggleForSendWhileTalking
^self
simpleToggleButtonFor: self
attribute: #transmitWhileRecording
help: 'Whether you want to send messages while recording.'!
----- Method: AudioChatGUI>>transmitWhileRecording (in category 'sending') -----
transmitWhileRecording
^transmitWhileRecording ifNil: [transmitWhileRecording := false]!
EToyCommunicatorMorph subclass: #EToyChatOrBadgeMorph
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Experimental'!
EToyChatOrBadgeMorph subclass: #EToyChatMorph
instanceVariableNames: 'listener receivingPane myForm recipientForm acceptOnCR sendingPane'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Collaborative'!
!EToyChatMorph commentStamp: '<historical>' prior: 0!
EToyChatMorph new open setIPAddress: '1.2.3.4'
"
EToyChatMorph represents a chat session with another person. Type your message in the top text pane and press cmd-S.
"!
----- Method: EToyChatMorph class>>chatFrom:name:text: (in category 'as yet unclassified') -----
chatFrom: ipAddress name: senderName text: text
| chatWindow |
chatWindow := self
chatWindowForIP: ipAddress
name: senderName
picture: (EToySenderMorph pictureForIPAddress: ipAddress)
inWorld: self currentWorld.
chatWindow
chatFrom: ipAddress
name: senderName
text: text
!
----- Method: EToyChatMorph class>>chatWindowForIP:name:picture:inWorld: (in category 'as yet unclassified') -----
chatWindowForIP: ipAddress name: senderName picture: aForm inWorld: aWorld
| makeANewOne aSenderBadge existing |
existing := self instanceForIP: ipAddress inWorld: aWorld.
existing ifNotNil: [^existing].
makeANewOne := [
self new
recipientForm: aForm;
open;
setIPAddress: ipAddress
].
EToyCommunicatorMorph playArrivalSound.
self doChatsInternalToBadge ifTrue: [
aSenderBadge := EToySenderMorph instanceForIP: ipAddress inWorld: aWorld.
aSenderBadge ifNotNil: [
aSenderBadge startChat: false.
^aSenderBadge
findDeepSubmorphThat: [ :x | x isKindOf: EToyChatMorph]
ifAbsent: makeANewOne
].
aSenderBadge := EToySenderMorph instanceForIP: ipAddress.
aSenderBadge ifNotNil: [
aSenderBadge := aSenderBadge veryDeepCopy.
aSenderBadge
killExistingChat;
openInWorld: aWorld;
startChat: false.
^aSenderBadge
findDeepSubmorphThat: [ :x | x isKindOf: EToyChatMorph]
ifAbsent: makeANewOne
].
(aSenderBadge := EToySenderMorph new)
userName: senderName
userPicture: aForm
userEmail: 'unknown'
userIPAddress: ipAddress;
position: 200@200;
openInWorld: aWorld;
startChat: false.
^aSenderBadge
findDeepSubmorphThat: [ :x | x isKindOf: EToyChatMorph]
ifAbsent: makeANewOne
].
^makeANewOne value.
!
----- Method: EToyChatMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Text chat'
categories: #('Collaborative')
documentation: 'A tool for sending messages to other Squeak users'!
----- Method: EToyChatMorph class>>doChatsInternalToBadge (in category 'as yet unclassified') -----
doChatsInternalToBadge
^true!
----- Method: EToyChatMorph class>>instanceForIP:inWorld: (in category 'as yet unclassified') -----
instanceForIP: ipAddress inWorld: aWorld
^self allInstances detect: [ :x |
x world == aWorld and: [x ipAddress = ipAddress]
] ifNone: [nil]
!
----- Method: EToyChatMorph>>acceptTo:forMorph: (in category 'as yet unclassified') -----
acceptTo: someText forMorph: aMorph
| betterText |
betterText := self improveText: someText forMorph: aMorph.
self
transmitStreamedObject: (betterText eToyStreamedRepresentationNotifying: self)
to: self ipAddress.
aMorph setText: '' asText.
self appendMessage:
self startOfMessageFromMe,
' - ',
betterText,
String cr.
^true!
----- Method: EToyChatMorph>>appendMessage: (in category 'as yet unclassified') -----
appendMessage: aText
receivingPane appendTextEtoy: aText.!
----- Method: EToyChatMorph>>chatFrom:name:text: (in category 'as yet unclassified') -----
chatFrom: ipAddress name: senderName text: text
| initialText attrib |
recipientForm ifNil: [
initialText := senderName asText allBold.
] ifNotNil: [
attrib := TextAnchor new anchoredMorph: recipientForm "asMorph".
initialText := (String value: 1) asText.
initialText addAttribute: attrib from: 1 to: 1.
].
self appendMessage: initialText,' - ',text,String cr.
EToyCommunicatorMorph playArrivalSound.
!
----- Method: EToyChatMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
^ self standardBorderColor!
----- Method: EToyChatMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 8!
----- Method: EToyChatMorph>>defaultBounds (in category 'initialization') -----
defaultBounds
"answer the default bounds for the receiver"
^ 400 @ 100 extent: 200 @ 150!
----- Method: EToyChatMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color paleYellow!
----- Method: EToyChatMorph>>getChoice: (in category 'as yet unclassified') -----
getChoice: aSymbol
aSymbol == #acceptOnCR ifTrue: [^acceptOnCR ifNil: [true]].
^false.
!
----- Method: EToyChatMorph>>improveText:forMorph: (in category 'as yet unclassified') -----
improveText: someText forMorph: aMorph
| betterText conversions newAttr fontForAll |
fontForAll := aMorph eToyGetMainFont.
betterText := someText veryDeepCopy.
conversions := OrderedCollection new.
betterText runs withStartStopAndValueDo: [:start :stop :attributes |
attributes do: [:att |
(att isMemberOf: TextFontChange) ifTrue: [
conversions add: {att. start. stop}
]
]
].
conversions do: [ :old |
betterText removeAttribute: old first from: old second to: old third.
newAttr := TextFontReference toFont: (fontForAll fontAt: old first fontNumber).
newAttr fontNumber: old first fontNumber.
betterText addAttribute: newAttr from: old second to: old third.
].
^betterText!
----- Method: EToyChatMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
acceptOnCR := true.
self listDirection: #topToBottom;
layoutInset: 0;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
rubberBandCells: false;
minWidth: 200;
minHeight: 200;
rebuild !
----- Method: EToyChatMorph>>insetTheScrollbars (in category 'as yet unclassified') -----
insetTheScrollbars
self allMorphsDo: [ :each |
(each isKindOf: PluggableTextMorph) ifTrue: [each retractable: false]
].!
----- Method: EToyChatMorph>>ipAddress (in category 'as yet unclassified') -----
ipAddress
^(fields at: #ipAddress) contents!
----- Method: EToyChatMorph>>open (in category 'as yet unclassified') -----
open
^self openIn: self currentWorld!
----- Method: EToyChatMorph>>openIn: (in category 'as yet unclassified') -----
openIn: aWorld
"open an a chat window"
aWorld ifNil: [^self].
self
position: 400@100;
extent: 200@150;
openInWorld: aWorld.!
----- Method: EToyChatMorph>>rebuild (in category 'as yet unclassified') -----
rebuild
| r1 r2 |
r1 := self addARow: {
self simpleToggleButtonFor: self attribute: #acceptOnCR help: 'Send with Return?'.
self inAColumn: {StringMorph new contents: 'Your message to:'; lock}.
self textEntryFieldNamed: #ipAddress with: ''
help: 'IP address for chat partner'.
}.
recipientForm ifNotNil: [
r1 addMorphBack: recipientForm asMorph lock
].
sendingPane := PluggableTextMorph
on: self
text: nil
accept: #acceptTo:forMorph:.
sendingPane hResizing: #spaceFill; vResizing: #spaceFill.
self
addMorphBack: sendingPane.
r2 := self addARow: {self inAColumn: {StringMorph new contents: 'Replies'; lock}}.
receivingPane := PluggableTextMorph
on: self
text: nil
accept: nil.
receivingPane hResizing: #spaceFill; vResizing: #spaceFill.
self
addMorphBack: receivingPane.
receivingPane spaceFillWeight: 3.
{r1. r2} do: [ :each |
each
vResizing: #shrinkWrap; minHeight: 18;
color: Color veryLightGray.
].
sendingPane acceptOnCR: (acceptOnCR ifNil: [acceptOnCR := true])!
----- Method: EToyChatMorph>>recipientForm: (in category 'as yet unclassified') -----
recipientForm: aForm
recipientForm := aForm.
recipientForm ifNotNil: [recipientForm := recipientForm scaledToSize: 20@20].!
----- Method: EToyChatMorph>>reportError: (in category 'as yet unclassified') -----
reportError: aString
receivingPane appendTextEtoy: (aString asText addAttribute: TextColor red), String cr.!
----- Method: EToyChatMorph>>setIPAddress: (in category 'as yet unclassified') -----
setIPAddress: aString
(fields at: #ipAddress) contents: aString!
----- Method: EToyChatMorph>>standardBorderColor (in category 'as yet unclassified') -----
standardBorderColor
^Color darkGray!
----- Method: EToyChatMorph>>startOfMessageFromMe (in category 'as yet unclassified') -----
startOfMessageFromMe
myForm ifNil: [
myForm := EToySenderMorph pictureForIPAddress: NetNameResolver localAddressString.
myForm ifNotNil: [
myForm := myForm scaledToSize: 20@20
].
].
myForm ifNil: [
^(Preferences defaultAuthorName asText allBold addAttribute: TextColor blue)
].
^(String value: 1) asText
addAttribute: (TextAnchor new anchoredMorph: myForm);
yourself
!
----- Method: EToyChatMorph>>toggleChoice: (in category 'as yet unclassified') -----
toggleChoice: aSymbol
aSymbol == #acceptOnCR ifTrue: [
acceptOnCR := (acceptOnCR ifNil: [true]) not.
sendingPane ifNotNil: [sendingPane acceptOnCR: acceptOnCR].
^self
].
!
----- Method: EToyChatMorph>>transmittedObjectCategory (in category 'as yet unclassified') -----
transmittedObjectCategory
^EToyIncomingMessage typeKeyboardChat!
EToyChatMorph subclass: #EToyMultiChatMorph
instanceVariableNames: 'targetIPAddresses'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Collaborative'!
----- Method: EToyMultiChatMorph class>>chatWindowForIP:name:picture:inWorld: (in category 'as yet unclassified') -----
chatWindowForIP: ipAddress name: senderName picture: aForm inWorld: aWorld
^self allInstances
detect: [ :x | x world == aWorld]
ifNone: [
EToyCommunicatorMorph playArrivalSound.
self new open
].
!
----- Method: EToyMultiChatMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Text chat+'
categories: #('Collaborative')
documentation: 'A tool for sending messages to several Squeak users at once'
sampleImageForm: (Form
extent: 25@25
depth: 16
fromArray: #( 1177640695 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593245696 1593263665 1593270007 1593270007 1593270007 1177634353 1177628012 1177628012 1177640695 1593270007 1593270007 1593278463 2147450879 1316159488 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593274233 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1731723264 1593257324 762064236 762064236 762064236 762064236 762057894 762057894 762064236 762064236 762064236 762064236 762064236 1177616384 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 !
21471887
31 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593274233 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1731723264)
offset: 0@0)!
----- Method: EToyMultiChatMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
(morphToDrop isKindOf: EToySenderMorph) ifFalse: [
^morphToDrop rejectDropMorphEvent: evt.
].
self eToyRejectDropMorph: morphToDrop event: evt. "we don't really want it"
self updateIPAddressField: targetIPAddresses,{morphToDrop ipAddress}.
!
----- Method: EToyMultiChatMorph>>acceptTo:forMorph: (in category 'as yet unclassified') -----
acceptTo: someText forMorph: aMorph
| streamedMessage betterText |
betterText := self improveText: someText forMorph: aMorph.
streamedMessage := {targetIPAddresses. betterText} eToyStreamedRepresentationNotifying: self.
targetIPAddresses do: [ :each |
self
transmitStreamedObject: streamedMessage
to: each.
].
aMorph setText: '' asText.
self appendMessage:
self startOfMessageFromMe,
' - ',
betterText,
String cr.
^true!
----- Method: EToyMultiChatMorph>>chatFrom:name:text: (in category 'as yet unclassified') -----
chatFrom: ipAddress name: senderName text: textPackage
super chatFrom: ipAddress name: senderName text: textPackage second.
self updateIPAddressField: (
targetIPAddresses,textPackage first,{ipAddress}
copyWithout: NetNameResolver localAddressString
).
!
----- Method: EToyMultiChatMorph>>editEvent:for: (in category 'as yet unclassified') -----
editEvent: anEvent for: aMorph
| answer initialText aFillInTheBlankMorph |
(aMorph bounds containsPoint: anEvent cursorPoint) ifFalse: [^self].
initialText := String streamContents: [ :strm |
targetIPAddresses do: [ :each | strm nextPutAll: each; cr].
].
aFillInTheBlankMorph := FillInTheBlankMorph new
setQuery: 'Who are you chatting with?'
initialAnswer: initialText
answerHeight: 250
acceptOnCR: false.
aFillInTheBlankMorph responseUponCancel: nil.
self world addMorph: aFillInTheBlankMorph centeredNear: anEvent cursorPoint.
answer := aFillInTheBlankMorph getUserResponse.
answer ifNil: [^self].
self updateIPAddressField: (answer findTokens: ' ',String cr).
!
----- Method: EToyMultiChatMorph>>initialize (in category 'initialization') -----
initialize
targetIPAddresses := OrderedCollection new.
super initialize.
bounds := 0@0 extent: 350@350.!
----- Method: EToyMultiChatMorph>>rebuild (in category 'as yet unclassified') -----
rebuild
| r1 r2 |
r1 := self addARow: {
self simpleToggleButtonFor: self attribute: #acceptOnCR help: 'Send with Return?'.
self inAColumn: {StringMorph new contents: 'Multi chat with:'; lock}.
self textEntryFieldNamed: #ipAddress with: ''
help: 'Click to edit participant list'.
}.
sendingPane := PluggableTextMorph
on: self
text: nil
accept: #acceptTo:forMorph:.
sendingPane hResizing: #spaceFill; vResizing: #spaceFill.
self
addMorphBack: sendingPane.
r2 := self addARow: {self inAColumn: {StringMorph new contents: 'Replies'; lock}}.
receivingPane := PluggableTextMorph
on: self
text: nil
accept: nil.
receivingPane hResizing: #spaceFill; vResizing: #spaceFill.
self
addMorphBack: receivingPane.
receivingPane spaceFillWeight: 3.
{r1. r2} do: [ :each |
each
vResizing: #shrinkWrap; minHeight: 18;
color: Color veryLightGray.
].
self updateIPAddressField: targetIPAddresses.
sendingPane acceptOnCR: (acceptOnCR ifNil: [acceptOnCR := true]).!
----- Method: EToyMultiChatMorph>>standardBorderColor (in category 'as yet unclassified') -----
standardBorderColor
^Color veryLightGray!
----- Method: EToyMultiChatMorph>>transmittedObjectCategory (in category 'as yet unclassified') -----
transmittedObjectCategory
^EToyIncomingMessage typeMultiChat!
----- Method: EToyMultiChatMorph>>updateIPAddressField: (in category 'as yet unclassified') -----
updateIPAddressField: newAddresses
targetIPAddresses := (
newAddresses copyWithout: NetNameResolver localAddressString
)
asSet
asSortedCollection
asArray.
(fields at: #ipAddress) contents: targetIPAddresses size printString,' people'.!
----- Method: EToyMultiChatMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
(aMorph isKindOf: EToySenderMorph) ifFalse: [^false].
(bounds containsPoint: evt cursorPoint) ifFalse: [^false].
^true.!
----- Method: EToyChatOrBadgeMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
includeInNewMorphMenu
"Not to be instantiated from the menu"
^ self ~~ EToyChatOrBadgeMorph!
EToyChatOrBadgeMorph subclass: #EToySenderMorph
instanceVariableNames: 'userPicture'
classVariableNames: 'DEBUG'
poolDictionaries: ''
category: 'Nebraska-Morphic-Collaborative'!
!EToySenderMorph commentStamp: '<historical>' prior: 0!
EToySenderMorph
new
userName: 'Bob Arning'
userPicture: nil
userEmail: 'arning(a)charm.net'
userIPAddress: '1.2.3.4';
position: 200@200;
open
"
EToySenderMorph represents another person to whom you wish to send things. Drop a morph on an EToySenderMorph and a copy of that morph is sent to the person represented. Currently only peer-to-peer communications are supported, but other options are planned.
"!
----- Method: EToySenderMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Badge'
categories: #('Collaborative')
documentation: 'A tool for collaborating with other Squeak users'
sampleImageForm: (Form
extent: 66@72
depth: 16
fromArray: #( 7175 1545042975 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082429975 470220800 470252575 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082413575 1545042975 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082429975 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 21348677!
75 21348
67775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1582767304 1032871511 2134867775 2134842568 2134867775 2134867775 2134867775 1032879935 2134867775 2134867775 2134867775 2134867775 1582792511 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134842568 1032871511 1032863120 1582775696 1032871511 2134867775 2134867775 1032871511 2134842568 1032863120 482885008 1032879935 482901823 482885008 1032879935 1032863120 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 2134850960 1032879935 1032863120 2134850960 2134867775 2134859351 482876616 2134850960 2134867775 1032879935 1032879935 1032879935 1032879935 1032879935 1032863120 1582792511 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1582767304 1032871511 1032863120 1582775696 1032871511 2134867775 2134842568 1582767304 1582767304 1582792511 482893399 482893399 482893399 482893399 482893399 1032863120 1582792511 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1032863120 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867!
775 2134
867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 65537 65537 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2!
13486777
5 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 65537 1032863120 1032863120 98111 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 81296 2134867775 2134867775 1032847361 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 1032879935 2134867775 2134867775 2134835201 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 81296 2134867775 2134867775 21348!
67775 21
34867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 98111 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 65537 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 81296 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 81296 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 21348677!
75 21348
67775 2134867775 2134835201 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 98111 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 213!
4867775
2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134!
867775 2
134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 1039171583 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 1039171583 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141142512 1039154672 1593270007 1039163127 1593278463 1593261552 2147442423 1039154672 2147433968 1039154672 1593270007 1039163127 1593278463 1593261552 2147442423 1593270007 1593261552 2147450879 2147442423 1593270007 2147442423 1039171583 484990711 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141150967 1039163127 1039171583 1039163127 1039171583 1039171583 1039154672 1039154672 1039163127 1039163127 1039171583 1039163127 1039171583 484982256 1039146216 1593270007 484982256 1039171583 2147425512 1593261552 2147425512 1039154672 1039171583 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 1039154672 1593278463 1039171583 1039171583 1039171583 1039154672 1039146216 15932784!
63 10391
54672 1593278463 1039171583 1039171583 1039171583 1593261552 2147450879 1039171583 1593270007 2147433968 2147433968 2147433968 2147442423 1039171583 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 1593270007 2147450879 1039163127 1039163127 1593261552 2147442423 1039163127 2147450879 1593270007 2147450879 1039163127 1039163127 1593261552 2147433968 1593278463 1593261552 2147442423 2147433968 1593261552 1593270007 1039171583 2147442423 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141150967 1039171583 1593261552 2147442423 1039171583 2147450879 2147442423 2147450879 1593278463 1593261552 2147450879 2147442423 1039171583 2147442423 2147450879 2147442423 1039171583 2147442423 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 213486777!
5 208243
8175 2082438175 2134867775 2141150967 2147433968 1039171583 1039154672 2147433968 2147450879 1593261552 2147442423 1039171583 1593278463 1039171583 2147433968 2147433968 1593261552 2147450879 2147442423 2147433968 1593261552 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 1039171583 1039171583 1039154672 1039154672 2147450879 2147433968 2147425512 484990711 2147433968 1593278463 2147433968 1039154672 2147433968 2147450879 2147450879 1039163127 484973800 1593278367 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141142512 2147442423 1039171583 1039171583 1593270007 1593278463 2147433968 2147450879 1039171583 2147450879 1039163127 2147450879 1593270007 2147433968 2147442423 2147450879 2147433968 2147433968 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141142512 1039163127 1593261552 2147442423 1593278463 1593278463 1593261552 2147450879 1039163127 1593261552 2147442423 2147442423 1593278463 1593261552 2147442423 2147442423 1039171583 2147433968 1593278367 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2!
13486777
5 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134861595 1391951679 2134867775 2134867775 2134856439 1729855295 2134867775 2134867775 1729849115 2134867775 2134867775 2134861595 1729855295 2134867775 2134867775 1729843959 1391951679 2134867775 2134867775 2134856439 1729855295 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1326930843 1879001943 1729855295 2134861595 1398112251 1738035990 2134867775 2134855446 1536646039 1326874431 2134867775 1387357800 1718112945 2134867775 2134856463 1736736736 2145407816 1729855295 2134861595 1398243327 1738232599 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 1032863120 1032879935 2134867775 1032863120 1032879935 2134856439 1879011327 1879011327 1264025407 2134856533 2147188731 2147188731 1391951679 1391947770 1878683642 1878676215 2134856439 2120646246 2120646246 1391951679 1391951840 2145419232 2145419232 1397260095 2134856535 2147450879 2147450879 1391951679 2134867775 2082438175 2082438175 2134867775 2134842568 1507359 1514696 2134842568 48235488 48241864 2134854487 1391932912 904949759 1879003895 1391951867 484908263 1039040507 1398112063 1263890426 904753146 1878674261 2134856331 2120629539 1025736294 1384873791 1397260256 2145402336 2145419232 2145407735 1391951871 1039154672 1039171583 1398243135 2134867775 2082438175 2082438175 2134867775 2134835216 2031647 2031632 2134835680 65012704 65012192 2134854487 904949759 1879011327 1879003895 1391951867 2147171822 2147188731 1398112063 1263890426 904753146 1878674261 2134856331 2120646246 1025736294 1384873791 1397260256 1591754208 2145419232 2145407735 1391951871 1039163127 2147450879 1398243135 2134867775 2082438175 2082438175 2134867775 2134835216 2031647 2031632 2134835680 65012704 65012192 2134854487 904949759 1879011327 18790!
03895 13
91951867 2147171822 2147188731 1398112063 1263890426 904753146 1878674261 2134856331 2120629539 2120646246 1384873791 1397260256 484449504 1591771104 2145407735 1391951871 2147442423 1593278463 1398243135 2134867775 2082438175 2082438175 2134867775 2134842568 1507359 1514696 2134842568 48235488 48241864 2134854487 1391932912 904949759 1879003895 1391951867 1593056487 2147188731 1398112063 1263890426 1391685626 1878674261 2134856331 2120637892 2120646246 1384873791 1397251808 484466400 484474848 2145407735 1391951871 484982256 1593278463 1398243135 2134867775 2082438175 2082438175 2134867775 2134867775 1032863120 1032879935 2134867775 1032863120 1032879935 2134855447 1879011327 1879011327 1536911131 1729849240 2147188731 2147188731 1393983295 1326870522 1878683642 1878675222 2134856369 2120646246 2120646246 1387364159 1393524704 2145419232 2145419232 1736730395 1729849243 2147450879 2147450879 1394048831 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134861595 1536913407 1879011327 1326939967 2134856470 2147188731 2147182488 1729855295 1729846167 1878683642 1536648987 2134861595 1718124134 2120640104 1729855295 1729849220 2145419232 2145419232 1393524543 2134856471 2147450879 2147444635 1729855295 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1729842967 1264014071 2134867775 2134867775 1391940437 1393977115 2134867775 2134861595 1326862102 1729855295 2134867775 1729843889 1387357979 2134867775 2134861595 1393513288 1397248759 2134867775 2134867775 1391940439 1394042651 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 !
21348677
75 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 1545042975 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082429975 470252575 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082413575 7175 1545042975 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082429975 470220800)
offset: 0@0)!
----- Method: EToySenderMorph class>>instanceForIP: (in category 'as yet unclassified') -----
instanceForIP: ipAddress
^self allInstances detect: [ :x |
x ipAddress = ipAddress
] ifNone: [nil]
!
----- Method: EToySenderMorph class>>instanceForIP:inWorld: (in category 'as yet unclassified') -----
instanceForIP: ipAddress inWorld: aWorld
^self allInstances detect: [ :x |
x world == aWorld and: [x ipAddress = ipAddress]
] ifNone: [nil]
!
----- Method: EToySenderMorph class>>nameForIPAddress: (in category 'as yet unclassified') -----
nameForIPAddress: ipString
| senderMorphs |
senderMorphs := EToySenderMorph allInstances select: [ :x |
x userName notNil and: [x ipAddress = ipString]
].
senderMorphs isEmpty ifTrue: [^nil].
^senderMorphs first userName
!
----- Method: EToySenderMorph class>>pictureForIPAddress: (in category 'as yet unclassified') -----
pictureForIPAddress: ipString
| senderMorphs |
senderMorphs := EToySenderMorph allInstances select: [ :x |
x userPicture notNil and: [x ipAddress = ipString]
].
senderMorphs isEmpty ifTrue: [^nil].
^senderMorphs first userPicture
!
----- Method: EToySenderMorph>>aboutToBeGrabbedBy: (in category 'dropping/grabbing') -----
aboutToBeGrabbedBy: aHand
| aFridge |
super aboutToBeGrabbedBy: aHand.
aFridge := self ownerThatIsA: EToyFridgeMorph.
aFridge ifNil: [^self].
aFridge noteRemovalOf: self.!
----- Method: EToySenderMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
| myCopy outData |
(morphToDrop isKindOf: NewHandleMorph) ifTrue: [ "don't send these"
^morphToDrop rejectDropMorphEvent: evt.
].
self eToyRejectDropMorph: morphToDrop event: evt. "we don't really want it"
"7 mar 2001 - remove #veryDeepCopy"
myCopy := morphToDrop. "gradient fills require doing this second"
myCopy setProperty: #positionInOriginatingWorld toValue: morphToDrop position.
self stopFlashing.
outData := myCopy eToyStreamedRepresentationNotifying: self.
self resetIndicator: #working.
self transmitStreamedObject: outData to: self ipAddress.
!
----- Method: EToySenderMorph>>checkOnAFriend (in category 'as yet unclassified') -----
checkOnAFriend
| gateKeeperEntry caption choices resp |
gateKeeperEntry := EToyGateKeeperMorph entryForIPAddress: self ipAddress.
caption :=
'Last name: ',gateKeeperEntry latestUserName,
'\Last message in: ',gateKeeperEntry lastIncomingMessageTimeString,
'\Last status check at: ',gateKeeperEntry lastTimeCheckedString,
'\Last status in: ',gateKeeperEntry statusReplyReceivedString.
choices := 'Get his status now\Send my status now' .
resp := (PopUpMenu labels: choices withCRs) startUpWithCaption: caption withCRs.
resp = 1 ifTrue: [
gateKeeperEntry lastTimeChecked: Time totalSeconds.
self sendStatusCheck.
].
resp = 2 ifTrue: [
self sendStatusReply.
].
!
----- Method: EToySenderMorph>>currentBadgeVersion (in category 'as yet unclassified') -----
currentBadgeVersion
"enables on-the-fly updating of older morphs"
^10!
----- Method: EToySenderMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
^ Color magenta!
----- Method: EToySenderMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 4!
----- Method: EToySenderMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color lightMagenta!
----- Method: EToySenderMorph>>establishDropZone: (in category 'as yet unclassified') -----
establishDropZone: aMorph
self setProperty: #specialDropZone toValue: aMorph.
aMorph
on: #mouseEnterDragging send: #mouseEnteredDZ to: self;
on: #mouseLeaveDragging send: #mouseLeftDZ to: self;
on: #mouseLeave send: #mouseLeftDZ to: self.
!
----- Method: EToySenderMorph>>fixOldVersion (in category 'as yet unclassified') -----
fixOldVersion
| uName uForm uEmail uIP |
uName := self userName.
uForm := userPicture ifNil: [
(self
findDeepSubmorphThat: [ :x | (x isKindOf: ImageMorph) or: [x isSketchMorph]]
ifAbsent: [self halt]) form.
].
uEmail := (fields at: #emailAddress) contents.
uIP := self ipAddress.
self
userName: uName
userPicture: (uForm scaledToSize: 61@53)
userEmail: uEmail
userIPAddress: uIP
!
----- Method: EToySenderMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
Socket initializeNetwork.
"we may want our IP address"
Preferences defaultAuthorName.
"seems like a good place to insure we have a name"
super initialize.
""
self listDirection: #topToBottom;
layoutInset: 4;
setProperty: #normalBorderColor toValue: self borderColor;
setProperty: #flashingColors toValue: {Color red. Color yellow}!
----- Method: EToySenderMorph>>initializeToStandAlone (in category 'parts bin') -----
initializeToStandAlone
super initializeToStandAlone.
self installModelIn: ActiveWorld.
!
----- Method: EToySenderMorph>>installModelIn: (in category 'debug and other') -----
installModelIn: myWorld
"if we get this far and nothing exists, make it up"
userPicture ifNotNil: [^self].
self
userName: Preferences defaultAuthorName
userPicture: nil
userEmail: 'who(a)where.net'
userIPAddress: NetNameResolver localAddressString
!
----- Method: EToySenderMorph>>ipAddress (in category 'as yet unclassified') -----
ipAddress
^(fields at: #ipAddress) contents!
----- Method: EToySenderMorph>>ipAddress: (in category 'as yet unclassified') -----
ipAddress: aString
^(fields at: #ipAddress) contents: aString!
----- Method: EToySenderMorph>>killExistingChat (in category 'as yet unclassified') -----
killExistingChat
| oldOne |
self rubberBandCells: true. "disable growing"
(oldOne := self valueOfProperty: #embeddedChatHolder) ifNotNil: [
oldOne delete.
self removeProperty: #embeddedChatHolder
].
(oldOne := self valueOfProperty: #embeddedAudioChatHolder) ifNotNil: [
oldOne delete.
self removeProperty: #embeddedAudioChatHolder
].
!
----- Method: EToySenderMorph>>mouseEnteredDZ (in category 'as yet unclassified') -----
mouseEnteredDZ
| dz |
dz := self valueOfProperty: #specialDropZone ifAbsent: [^self].
dz color: Color blue.!
----- Method: EToySenderMorph>>mouseLeftDZ (in category 'as yet unclassified') -----
mouseLeftDZ
| dz |
dz := self valueOfProperty: #specialDropZone ifAbsent: [^self].
dz color: Color transparent.!
----- Method: EToySenderMorph>>sendStatusCheck (in category 'as yet unclassified') -----
sendStatusCheck
| null |
null := String with: 0 asCharacter.
EToyPeerToPeer new
sendSomeData: {
EToyIncomingMessage typeStatusRequest,null.
Preferences defaultAuthorName,null.
}
to: self ipAddress
for: self.
!
----- Method: EToySenderMorph>>sendStatusReply (in category 'as yet unclassified') -----
sendStatusReply
| null |
null := String with: 0 asCharacter.
EToyPeerToPeer new
sendSomeData: {
EToyIncomingMessage typeStatusReply,null.
Preferences defaultAuthorName,null.
((EToyGateKeeperMorph acceptableTypesFor: self ipAddress)
eToyStreamedRepresentationNotifying: self).
}
to: self ipAddress
for: self.
!
----- Method: EToySenderMorph>>startAudioChat (in category 'as yet unclassified') -----
startAudioChat
self startAudioChat: true
!
----- Method: EToySenderMorph>>startAudioChat: (in category 'as yet unclassified') -----
startAudioChat: toggleMode
| chat r |
(self valueOfProperty: #embeddedAudioChatHolder) ifNotNil:
[toggleMode ifFalse: [^self].
^self killExistingChat].
chat := AudioChatGUI new ipAddress: self ipAddress.
(self ownerThatIsA: EToyFridgeMorph) isNil
ifTrue:
[chat
removeConnectButton;
vResizing: #shrinkWrap;
hResizing: #shrinkWrap;
borderWidth: 2. "we already know the connectee"
r := (self addARow: {
chat}) vResizing: #shrinkWrap.
self world startSteppingSubmorphsOf: chat.
self setProperty: #embeddedAudioChatHolder toValue: r.
self
hResizing: #shrinkWrap;
vResizing: #shrinkWrap]
ifFalse:
[chat openInWorld: self world]!
----- Method: EToySenderMorph>>startChat (in category 'as yet unclassified') -----
startChat
self startChat: true
!
----- Method: EToySenderMorph>>startChat: (in category 'as yet unclassified') -----
startChat: toggleMode
| chat r |
(self valueOfProperty: #embeddedChatHolder) ifNotNil: [
toggleMode ifFalse: [^self].
^self killExistingChat
].
(EToyChatMorph doChatsInternalToBadge and:
[(self ownerThatIsA: EToyFridgeMorph) isNil]) ifTrue: [
chat := EToyChatMorph basicNew
recipientForm: userPicture;
initialize;
setIPAddress: self ipAddress.
chat
vResizing: #spaceFill;
hResizing: #spaceFill;
borderWidth: 2;
insetTheScrollbars.
r := (self addARow: {chat}) vResizing: #spaceFill.
self rubberBandCells: false. "enable growing"
self height: 350. "an estimated guess for allowing shrinking as well as growing"
self world startSteppingSubmorphsOf: chat.
self setProperty: #embeddedChatHolder toValue: r.
] ifFalse: [
chat := EToyChatMorph
chatWindowForIP: self ipAddress
name: self userName
picture: userPicture
inWorld: self world.
chat owner addMorphFront: chat.
]
!
----- Method: EToySenderMorph>>startNebraskaClient (in category 'as yet unclassified') -----
startNebraskaClient
| newMorph |
[
[
newMorph := NetworkTerminalMorph connectTo: self ipAddress.
WorldState addDeferredUIMessage: [newMorph openInStyle: #scaled] fixTemps.
]
on: Error
do: [ :ex |
WorldState addDeferredUIMessage: [
self inform: 'No connection to: '. self ipAddress,' (',ex printString,')'
] fixTemps
].
] fork
!
----- Method: EToySenderMorph>>startTelemorphic (in category 'as yet unclassified') -----
startTelemorphic
self world
connectRemoteUserWithName: self userName
picture: (userPicture ifNotNil: [userPicture scaledToSize: 16@20])
andIPAddress: self ipAddress
!
----- Method: EToySenderMorph>>step (in category 'stepping and presenter') -----
step
(self valueOfProperty: #currentBadgeVersion) = self currentBadgeVersion ifFalse: [
self setProperty: #currentBadgeVersion toValue: self currentBadgeVersion.
self fixOldVersion.
Preferences defaultAuthorName. "seems like a good place to insure we have a name"
].
super step.!
----- Method: EToySenderMorph>>tellAFriend (in category 'as yet unclassified') -----
tellAFriend
self world project tellAFriend: (fields at: #emailAddress) contents
!
----- Method: EToySenderMorph>>transmitStreamedObject: (in category 'as yet unclassified') -----
transmitStreamedObject: outData
self transmitStreamedObject: outData to: self ipAddress
!
----- Method: EToySenderMorph>>transmittedObjectCategory (in category 'as yet unclassified') -----
transmittedObjectCategory
^EToyIncomingMessage typeMorph!
----- Method: EToySenderMorph>>userName (in category 'as yet unclassified') -----
userName
^ (self
findDeepSubmorphThat: [ :x | x isKindOf: StringMorph]
ifAbsent: [^nil]) contents
!
----- Method: EToySenderMorph>>userName:userPicture:userEmail:userIPAddress: (in category 'as yet unclassified') -----
userName: aString userPicture: aFormOrNil userEmail: emailString userIPAddress: ipString
| dropZoneRow |
self setProperty: #currentBadgeVersion toValue: self currentBadgeVersion.
userPicture := aFormOrNil ifNil: [
(TextStyle default fontOfSize: 26) emphasized: 1; characterFormAt: $?
].
userPicture := userPicture scaledToSize: 61@53.
self killExistingChat.
self removeAllMorphs.
self useRoundedCorners.
self
addARow: {
self inAColumn: {(StringMorph contents: aString) lock}
}.
dropZoneRow := self
addARow: {
self inAColumn: {userPicture asMorph lock}
}.
self establishDropZone: dropZoneRow.
self
addARow: {
self textEntryFieldNamed: #emailAddress with: emailString
help: 'Email address for this person'
};
addARow: {
self textEntryFieldNamed: #ipAddress with: ipString
help: 'IP address for this person'
};
addARow: {
self indicatorFieldNamed: #working color: Color blue help: 'working'.
self indicatorFieldNamed: #communicating color: Color green help: 'sending'.
self buttonNamed: 'C' action: #startChat color: Color paleBlue
help: 'Open a written chat with this person'.
self buttonNamed: 'T' action: #startTelemorphic color: Color paleYellow
help: 'Start telemorphic with this person'.
self buttonNamed: '!!' action: #tellAFriend color: Color paleGreen
help: 'Tell this person about the current project'.
self buttonNamed: '?' action: #checkOnAFriend color: Color lightBrown
help: 'See if this person is available'.
self buttonNamed: 'A' action: #startAudioChat color: Color yellow
help: 'Open an audio chat with this person'.
self buttonNamed: 'S' action: #startNebraskaClient color: Color white
help: 'See this person''s world (if he allows that)'.
}.
!
----- Method: EToySenderMorph>>userPicture (in category 'as yet unclassified') -----
userPicture
^userPicture!
----- Method: EToySenderMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
| dz |
dz := self valueOfProperty: #specialDropZone ifAbsent: [^false].
(dz bounds containsPoint: (evt cursorPoint)) ifFalse: [^false].
^true.!
----- Method: EToyCommunicatorMorph>>addGateKeeperMorphs (in category '*nebraska-*nebraska-Morphic-Collaborative') -----
addGateKeeperMorphs
| list currentTime choices age row |
self setProperty: #gateKeeperCounterValue toValue: EToyGateKeeperMorph updateCounter.
choices := #(
(60 'm' 'in the last minute')
(3600 'h' 'in the last hour')
(86400 'd' 'in the last day')
).
currentTime := Time totalSeconds.
list := EToyGateKeeperMorph knownIPAddresses.
list do: [ :each |
age := each timeBetweenLastAccessAnd: currentTime.
age := choices
detect: [ :x | age <= x first]
ifNone: [{0. '-'. (age // 86400) printString,'days ago'}].
row := self addARow:
(EToyIncomingMessage allTypes collect: [ :type |
self toggleButtonFor: each attribute: type]
),
{
(self inAColumn: {
(StringMorph contents: age second) lock.
}) layoutInset: 2; hResizing: #shrinkWrap; setBalloonText: 'Last attempt was ',age third.
(self inAColumn: {
(StringMorph contents: each ipAddress) lock.
}) layoutInset: 2; hResizing: #shrinkWrap.
(self inAColumn: {
(StringMorph contents: each latestUserName) lock.
}) layoutInset: 2.
}.
row
color: (Color r: 0.6 g: 0.8 b: 1.0);
borderWidth: 1;
borderColor: #raised;
vResizing: #spaceFill;
"on: #mouseUp send: #mouseUp:in: to: self;"
setBalloonText: each fullInfoString
].!
----- Method: EToyCommunicatorMorph>>transmitStreamedObject:as:to: (in category '*nebraska-*nebraska-Morphic-Collaborative') -----
transmitStreamedObject: outData as: objectCategory to: anIPAddress
EToyPeerToPeer transmitStreamedObject: outData as: objectCategory to: anIPAddress for: self!
----- Method: EToyCommunicatorMorph>>transmitStreamedObject:to: (in category '*nebraska-*nebraska-Morphic-Collaborative') -----
transmitStreamedObject: outData to: anIPAddress
self transmitStreamedObject: outData as: self transmittedObjectCategory to: anIPAddress
!
EToyCommunicatorMorph subclass: #EToyFridgeMorph
instanceVariableNames: 'recipients incomingRow recipientRow updateCounter groupMode'
classVariableNames: 'UpdateCounter TheFridgeForm FridgeRecipients NewItems'
poolDictionaries: ''
category: 'Nebraska-Morphic-Collaborative'!
!EToyFridgeMorph commentStamp: '<historical>' prior: 0!
EToyFridgeMorph new openInWorld!
----- Method: EToyFridgeMorph class>>addRecipient: (in category 'as yet unclassified') -----
addRecipient: aSenderMorph
self fridgeRecipients do: [ :each |
aSenderMorph ipAddress = each ipAddress ifTrue: [^self]
].
self fridgeRecipients add: aSenderMorph.
UpdateCounter := self updateCounter + 1
!
----- Method: EToyFridgeMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Fridge'
categories: #('Collaborative')
documentation: 'A tool for sending objects to other Squeak users'!
----- Method: EToyFridgeMorph class>>fridgeForm (in category 'as yet unclassified') -----
fridgeForm
| fridgeFileName |
fridgeFileName := 'fridge.form'.
TheFridgeForm ifNotNil: [^TheFridgeForm].
(FileDirectory default fileExists: fridgeFileName) ifFalse: [^nil].
^TheFridgeForm := Form fromFileNamed: fridgeFileName.!
----- Method: EToyFridgeMorph class>>fridgeRecipients (in category 'as yet unclassified') -----
fridgeRecipients
^FridgeRecipients ifNil: [FridgeRecipients := OrderedCollection new]!
----- Method: EToyFridgeMorph class>>newItem: (in category 'as yet unclassified') -----
newItem: newMorph
| theFridge fridgeWorld trialRect |
theFridge := Project named: 'Fridge'.
theFridge ifNil: [^self newItems add: newMorph].
fridgeWorld := theFridge world.
trialRect := fridgeWorld randomBoundsFor: newMorph.
fridgeWorld
addMorphFront: (newMorph position: trialRect topLeft);
startSteppingSubmorphsOf: newMorph
!
----- Method: EToyFridgeMorph class>>newItems (in category 'as yet unclassified') -----
newItems
^NewItems ifNil: [NewItems := OrderedCollection new]!
----- Method: EToyFridgeMorph class>>removeRecipientWithIPAddress: (in category 'as yet unclassified') -----
removeRecipientWithIPAddress: ipString
FridgeRecipients := self fridgeRecipients reject: [ :each |
ipString = each ipAddress
].
UpdateCounter := self updateCounter + 1
!
----- Method: EToyFridgeMorph class>>updateCounter (in category 'as yet unclassified') -----
updateCounter
^UpdateCounter ifNil: [0]!
----- Method: EToyFridgeMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
| outData |
(morphToDrop isKindOf: NewHandleMorph) ifTrue: [ "don't send these"
^morphToDrop rejectDropMorphEvent: evt
].
self eToyRejectDropMorph: morphToDrop event: evt. "we will keep a copy"
(morphToDrop isKindOf: EToySenderMorph) ifTrue: [
self class addRecipient: morphToDrop.
^self rebuild
].
self stopFlashing.
"7 mar 2001 - remove #veryDeepCopy"
outData := morphToDrop eToyStreamedRepresentationNotifying: self.
self resetIndicator: #working.
self class fridgeRecipients do: [ :each |
self transmitStreamedObject: outData to: each ipAddress
].
!
----- Method: EToyFridgeMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
^ #raised!
----- Method: EToyFridgeMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 4!
----- Method: EToyFridgeMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color paleRed!
----- Method: EToyFridgeMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| f cache |
f := self class fridgeForm ifNil: [^super drawOn: aCanvas].
cache := Form extent: bounds extent depth: aCanvas depth.
f
displayInterpolatedIn: cache boundingBox truncated
on: cache.
cache replaceColor: Color black withColor: Color transparent.
aCanvas
translucentImage: cache
at: bounds origin.
!
----- Method: EToyFridgeMorph>>getChoice: (in category 'as yet unclassified') -----
getChoice: aString
aString = 'group' ifTrue: [^groupMode ifNil: [true]].!
----- Method: EToyFridgeMorph>>groupToggleButton (in category 'as yet unclassified') -----
groupToggleButton
^(self inAColumn: {
(EtoyUpdatingThreePhaseButtonMorph checkBox)
target: self;
actionSelector: #toggleChoice:;
arguments: {'group'};
getSelector: #getChoice:;
setBalloonText: 'Changes between group mode and individuals';
step
}) hResizing: #shrinkWrap
!
----- Method: EToyFridgeMorph>>handlesMouseDown: (in category 'event handling') -----
handlesMouseDown: globalEvt
| localCursorPoint |
localCursorPoint := self globalPointToLocal: globalEvt cursorPoint.
groupMode ifFalse: [
self allMorphsDo: [ :each |
(each isKindOf: EToySenderMorph) ifTrue: [
(each bounds containsPoint: localCursorPoint) ifTrue: [^false].
].
].
].
^true!
----- Method: EToyFridgeMorph>>handlesMouseOver: (in category 'event handling') -----
handlesMouseOver: globalEvt
^true!
----- Method: EToyFridgeMorph>>handlesMouseOverDragging: (in category 'event handling') -----
handlesMouseOverDragging: globalEvt
^true!
----- Method: EToyFridgeMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
groupMode := true.
self listDirection: #topToBottom;
layoutInset: 10;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
setProperty: #normalBorderColor toValue: self borderColor;
setProperty: #flashingColors toValue: {Color red. Color yellow};
rebuild!
----- Method: EToyFridgeMorph>>mouseDown: (in category 'event handling') -----
mouseDown: localEvt
self addMouseActionIndicatorsWidth: 15 color: (Color blue alpha: 0.7).
!
----- Method: EToyFridgeMorph>>mouseEnter: (in category 'event handling') -----
mouseEnter: evt
^self mouseEnterEither: evt
!
----- Method: EToyFridgeMorph>>mouseEnterDragging: (in category 'event handling') -----
mouseEnterDragging: evt
^self mouseEnterEither: evt
!
----- Method: EToyFridgeMorph>>mouseEnterEither: (in category 'as yet unclassified') -----
mouseEnterEither: evt
evt hand hasSubmorphs ifFalse: [
^self addMouseActionIndicatorsWidth: 10 color: (Color blue alpha: 0.3).
].
(evt hand firstSubmorph isKindOf: EToySenderMorph) ifTrue: [
^self addMouseActionIndicatorsWidth: 10 color: (Color magenta alpha: 0.3).
].
self addMouseActionIndicatorsWidth: 10 color: (Color green alpha: 0.3).
!
----- Method: EToyFridgeMorph>>mouseLeave: (in category 'event handling') -----
mouseLeave: evt
^self mouseLeaveEither: evt
!
----- Method: EToyFridgeMorph>>mouseLeaveDragging: (in category 'event handling') -----
mouseLeaveDragging: evt
^self mouseLeaveEither: evt
!
----- Method: EToyFridgeMorph>>mouseLeaveEither: (in category 'as yet unclassified') -----
mouseLeaveEither: evt
self deleteAnyMouseActionIndicators.
!
----- Method: EToyFridgeMorph>>mouseUp: (in category 'event handling') -----
mouseUp: localEvt
(self containsPoint: localEvt cursorPoint) ifFalse: [^self].
Project enterIfThereOrFind: 'Fridge'!
----- Method: EToyFridgeMorph>>noteRemovalOf: (in category 'as yet unclassified') -----
noteRemovalOf: aSenderMorph
self class removeRecipientWithIPAddress: aSenderMorph ipAddress!
----- Method: EToyFridgeMorph>>rebuild (in category 'as yet unclassified') -----
rebuild
| row filler fudge people maxPerRow insetY |
updateCounter := self class updateCounter.
self removeAllMorphs.
(self addARow: {
filler := Morph new color: Color transparent; extent: 4@4.
}) vResizing: #shrinkWrap.
self addARow: {
(StringMorph contents: 'the Fridge') lock.
self groupToggleButton.
}.
row := self addARow: {}.
people := self class fridgeRecipients.
maxPerRow := people size < 7 ifTrue: [2] ifFalse: [3].
"how big can this get before we need a different approach?"
people do: [ :each |
row submorphCount >= maxPerRow ifTrue: [row := self addARow: {}].
row addMorphBack: (
groupMode ifTrue: [
(each userPicture scaledToSize: 35@35) asMorph lock
] ifFalse: [
each veryDeepCopy killExistingChat
]
)
].
fullBounds := nil.
self fullBounds.
"htsBefore := submorphs collect: [ :each | each height]."
fudge := 20.
insetY := self layoutInset.
insetY isPoint ifTrue: [insetY := insetY y].
filler extent:
4 @ (self height - filler height * 0.37 - insetY - borderWidth - fudge) truncated.
"self fixLayout.
htsAfter := submorphs collect: [ :each | each height].
{htsBefore. htsAfter} explore."
!
----- Method: EToyFridgeMorph>>step (in category 'stepping and presenter') -----
step
super step.
updateCounter = self class updateCounter ifFalse: [self rebuild].
!
----- Method: EToyFridgeMorph>>toggleChoice: (in category 'as yet unclassified') -----
toggleChoice: aString
updateCounter := nil. "force rebuild"
aString = 'group' ifTrue: [^groupMode := (groupMode ifNil: [true]) not].
!
----- Method: EToyFridgeMorph>>transmittedObjectCategory (in category 'as yet unclassified') -----
transmittedObjectCategory
^EToyIncomingMessage typeFridge!
----- Method: EToyFridgeMorph>>trulyFlashIndicator: (in category 'as yet unclassified') -----
trulyFlashIndicator: aSymbol
| state |
state := (self
valueOfProperty: #fridgeFlashingState
ifAbsent: [false]) not.
self setProperty: #fridgeFlashingState toValue: state.
self
addMouseActionIndicatorsWidth: 15
color: (Color green alpha: (state ifTrue: [0.3] ifFalse: [0.7])). Beeper beep.
"self world displayWorldSafely."!
----- Method: EToyFridgeMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
^true!
EToyCommunicatorMorph subclass: #EToyGateKeeperMorph
instanceVariableNames: 'counter'
classVariableNames: 'UpdateCounter KnownIPAddresses'
poolDictionaries: ''
category: 'Nebraska-Morphic-Experimental'!
!EToyGateKeeperMorph commentStamp: '<historical>' prior: 0!
EToyGateKeeperMorph new open
"
I am used to control the types of connections a user is willing to allow.
"!
----- Method: EToyGateKeeperMorph class>>acceptRequest:from:at: (in category 'as yet unclassified') -----
acceptRequest: requestType from: senderName at: ipAddressString
| entry |
UpdateCounter := self updateCounter + 1.
entry := self entryForIPAddress: ipAddressString.
senderName isEmpty ifFalse: [entry latestUserName: senderName].
^entry requestAccessOfType: requestType!
----- Method: EToyGateKeeperMorph class>>acceptableTypesFor: (in category 'as yet unclassified') -----
acceptableTypesFor: ipAddressString
^(self knownIPAddresses at: ipAddressString ifAbsent: [^#()]) acceptableTypes!
----- Method: EToyGateKeeperMorph class>>entryForIPAddress: (in category 'as yet unclassified') -----
entryForIPAddress: ipAddressString
| known entry |
UpdateCounter := self updateCounter + 1.
known := self knownIPAddresses.
entry := known at: ipAddressString ifAbsentPut: [
entry := EToyGateKeeperEntry new.
entry ipAddress: ipAddressString.
entry
].
^entry!
----- Method: EToyGateKeeperMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
includeInNewMorphMenu
"Not to be instantiated from the menu"
^ false!
----- Method: EToyGateKeeperMorph class>>knownIPAddresses (in category 'as yet unclassified') -----
knownIPAddresses
^KnownIPAddresses ifNil: [KnownIPAddresses := Dictionary new]!
----- Method: EToyGateKeeperMorph class>>updateCounter (in category 'as yet unclassified') -----
updateCounter
^UpdateCounter ifNil: [UpdateCounter := 0]!
----- Method: EToyGateKeeperMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
^ #raised!
----- Method: EToyGateKeeperMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 4!
----- Method: EToyGateKeeperMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color lightGray!
----- Method: EToyGateKeeperMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self listDirection: #topToBottom;
layoutInset: 4;
hResizing: #spaceFill;
vResizing: #spaceFill;
useRoundedCorners;
rebuild !
----- Method: EToyGateKeeperMorph>>open (in category 'as yet unclassified') -----
open
self rebuild.
self openInWorld.!
----- Method: EToyGateKeeperMorph>>rebuild (in category 'as yet unclassified') -----
rebuild
self removeAllMorphs.
self addGateKeeperMorphs.
!
----- Method: EToyGateKeeperMorph>>step (in category 'stepping and presenter') -----
step
(self valueOfProperty: #gateKeeperCounterValue) =
EToyGateKeeperMorph updateCounter ifTrue: [^self].
self rebuild.
!
EToyCommunicatorMorph subclass: #EToyListenerMorph
instanceVariableNames: 'listener updateCounter'
classVariableNames: 'QueueSemaphore GlobalIncomingQueue UpdateCounter GlobalListener WasListeningAtShutdown'
poolDictionaries: ''
category: 'Nebraska-Morphic-Collaborative'!
!EToyListenerMorph commentStamp: '<historical>' prior: 0!
EToyListenerMorph new open
EToyListenerMorph startListening.
EToyListenerMorph stopListening.
"
EToyListenerMorph listens for messgaes from other EToy communicators. You need one of these open to receive messages from elsewhere.
- Received Morphs are shown in a list. Items can be grabbed (a copy) or deleted.
- Chat messages are sent to an appropriate EToyChatMorph (created if necessary)
"
!
----- Method: EToyListenerMorph class>>addToGlobalIncomingQueue: (in category 'as yet unclassified') -----
addToGlobalIncomingQueue: aMorphTuple
self critical: [
self globalIncomingQueue add: aMorphTuple.
self bumpUpdateCounter.
].!
----- Method: EToyListenerMorph class>>bumpUpdateCounter (in category 'as yet unclassified') -----
bumpUpdateCounter
UpdateCounter := (UpdateCounter ifNil: [0]) + 1.
!
----- Method: EToyListenerMorph class>>commResult: (in category 'as yet unclassified') -----
commResult: anArrayOfAssociations
WorldState addDeferredUIMessage: [self commResultDeferred: anArrayOfAssociations].!
----- Method: EToyListenerMorph class>>commResultDeferred: (in category 'as yet unclassified') -----
commResultDeferred: anArrayOfAssociations
| m ipAddress aDictionary |
"to be run as part of the UI process in case user interaction is required"
aDictionary := Dictionary new.
anArrayOfAssociations do: [ :each | aDictionary add: each].
aDictionary at: #commFlash ifPresent: [ :ignore | ^self].
m := aDictionary at: #message ifAbsent: [^self].
m = 'OK' ifFalse: [^self].
ipAddress := NetNameResolver stringFromAddress: (aDictionary at: #ipAddress).
EToyIncomingMessage new
incomingMessgage: (ReadStream on: (aDictionary at: #data))
fromIPAddress: ipAddress
!
----- Method: EToyListenerMorph class>>confirmListening (in category 'as yet unclassified') -----
confirmListening
self isListening ifFalse: [
(self confirm: 'You currently are not listening and will not hear a reply.
Shall I start listening for you?') ifTrue: [
self startListening
].
].
!
----- Method: EToyListenerMorph class>>critical: (in category 'as yet unclassified') -----
critical: aBlock
QueueSemaphore ifNil: [QueueSemaphore := Semaphore forMutualExclusion].
^QueueSemaphore critical: aBlock
!
----- Method: EToyListenerMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Listener'
categories: #('Collaborative')
documentation: 'A tool for receiving things from other Squeak users'!
----- Method: EToyListenerMorph class>>ensureListenerInCurrentWorld (in category 'as yet unclassified') -----
ensureListenerInCurrentWorld
| w |
w := self currentWorld.
EToyListenerMorph allInstances
detect: [ :each | each world == w]
ifNone: [EToyListenerMorph new open]!
----- Method: EToyListenerMorph class>>flashIndicator: (in category 'as yet unclassified') -----
flashIndicator: ignoredForNow!
----- Method: EToyListenerMorph class>>globalIncomingQueue (in category 'as yet unclassified') -----
globalIncomingQueue
^GlobalIncomingQueue ifNil: [GlobalIncomingQueue := OrderedCollection new].!
----- Method: EToyListenerMorph class>>globalIncomingQueueCopy (in category 'as yet unclassified') -----
globalIncomingQueueCopy
^self critical: [self globalIncomingQueue copy].
!
----- Method: EToyListenerMorph class>>initialize (in category 'class initialization') -----
initialize
"
EToyListenerMorph initialize
"
Smalltalk addToStartUpList: self.
Smalltalk addToShutDownList: self.
!
----- Method: EToyListenerMorph class>>isListening (in category 'as yet unclassified') -----
isListening
^GlobalListener notNil
!
----- Method: EToyListenerMorph class>>makeListeningToggle: (in category 'as yet unclassified') -----
makeListeningToggle: withEars
| background c capExtent bgExtent earExtent earDeltaX earDeltaY botCent factor parts |
factor := 2.
bgExtent := (50@25) * factor.
capExtent := (30@30) * factor.
earExtent := (15@15) * factor.
earDeltaX := capExtent x // 2.
earDeltaY := capExtent y // 2.
background := Form extent: bgExtent depth: 8.
botCent := background boundingBox bottomCenter.
c := background getCanvas.
"c fillColor: Color white."
parts := {
(botCent - (capExtent // 2)) extent: capExtent.
}.
withEars ifTrue: [
parts := parts , {
(botCent - (earDeltaX @ earDeltaY) - (earExtent // 2)) extent: earExtent.
(botCent - (earDeltaX negated @ earDeltaY) - (earExtent // 2)) extent: earExtent.
}
].
parts do: [ :each |
c
fillOval: each
color: Color black
borderWidth: 0
borderColor: Color black.
].
^background
"=====
f2 := Form extent: 30@15 depth: 8.
background displayInterpolatedOn: f2.
f2 replaceColor: Color white withColor: Color transparent.
^f2
====="
!
----- Method: EToyListenerMorph class>>makeListeningToggleNew: (in category 'as yet unclassified') -----
makeListeningToggleNew: activeMode
| background c baseExtent bgExtent botCent factor len endPts base |
factor := 2.
bgExtent := (50@25) * factor.
baseExtent := (15@15) * factor.
background := Form extent: bgExtent depth: 8.
botCent := background boundingBox bottomCenter.
c := background getCanvas.
"c fillColor: Color white."
base := (botCent - (baseExtent // 2)) extent: baseExtent.
c
fillOval: base
color: Color black
borderWidth: 0
borderColor: Color black.
activeMode ifTrue: [
len := background boundingBox height - 15.
endPts := {botCent - (len@len). botCent - (len negated@len)}.
endPts do: [ :each |
c line: botCent to: each width: 2 color: Color black.
].
endPts do: [ :each |
#(4 8 12) do: [ :offset |
c frameOval: (each - offset corner: each + offset) color: Color red
].
].
].
"background asMorph openInWorld."
^background
!
----- Method: EToyListenerMorph class>>removeFromGlobalIncomingQueue: (in category 'as yet unclassified') -----
removeFromGlobalIncomingQueue: theActualObject
self critical: [
GlobalIncomingQueue := self globalIncomingQueue reject: [ :each |
each second == theActualObject
].
self bumpUpdateCounter.
].!
----- Method: EToyListenerMorph class>>resetIndicator: (in category 'as yet unclassified') -----
resetIndicator: ignoredForNow!
----- Method: EToyListenerMorph class>>shutDown: (in category 'system startup') -----
shutDown: quitting
WasListeningAtShutdown := GlobalListener notNil.
self stopListening.
!
----- Method: EToyListenerMorph class>>startListening (in category 'as yet unclassified') -----
startListening
self stopListening.
GlobalListener := EToyPeerToPeer new awaitDataFor: self.
self bumpUpdateCounter.
!
----- Method: EToyListenerMorph class>>startUp: (in category 'system startup') -----
startUp: resuming
WasListeningAtShutdown == true ifTrue: [
self startListening.
].
!
----- Method: EToyListenerMorph class>>stopListening (in category 'as yet unclassified') -----
stopListening
GlobalListener ifNotNil:
[GlobalListener stopListening.
GlobalListener := nil.
self bumpUpdateCounter]
"EToyListenerMorph stopListening"!
----- Method: EToyListenerMorph class>>unload (in category 'class initialization') -----
unload
Smalltalk removeFromStartUpList: self.
Smalltalk removeFromShutDownList: self.
!
----- Method: EToyListenerMorph>>addNewObject:thumbForm:sentBy:ipAddress: (in category 'as yet unclassified') -----
addNewObject: newObject thumbForm: aForm sentBy: senderName ipAddress: ipAddressString
| thumb row |
thumb := aForm asMorph.
thumb setProperty: #depictedObject toValue: newObject.
row := self addARow: {
thumb.
self inAColumn: {
StringMorph new contents: senderName; lock.
StringMorph new contents: ipAddressString; lock.
}
}.
true ifTrue: [ "simpler protocol"
row on: #mouseUp send: #mouseUpEvent:for: to: self.
] ifFalse: [
row on: #mouseDown send: #mouseDownEvent:for: to: self.
].
!
----- Method: EToyListenerMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
^ Color blue!
----- Method: EToyListenerMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 4!
----- Method: EToyListenerMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color lightBlue!
----- Method: EToyListenerMorph>>delete (in category 'submorphs-add/remove') -----
delete
listener ifNotNil: [listener stopListening. listener := nil].
"for old instances that were locally listening"
super delete.!
----- Method: EToyListenerMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self listDirection: #topToBottom;
layoutInset: 4;
rebuild !
----- Method: EToyListenerMorph>>mouseDownEvent:for: (in category 'as yet unclassified') -----
mouseDownEvent: event for: aMorph
| menu selection depictedObject |
depictedObject := aMorph firstSubmorph valueOfProperty: #depictedObject.
menu := CustomMenu new.
menu
add: 'Grab' action: [event hand attachMorph: depictedObject veryDeepCopy];
add: 'Delete'
action:
[self class removeFromGlobalIncomingQueue: depictedObject.
self rebuild].
selection := menu build startUpCenteredWithCaption: 'Morph from '
, (aMorph submorphs second) firstSubmorph contents.
selection ifNil: [^self].
selection value!
----- Method: EToyListenerMorph>>mouseUpEvent:for: (in category 'as yet unclassified') -----
mouseUpEvent: event for: aMorph
| depictedObject |
depictedObject := aMorph firstSubmorph valueOfProperty: #depictedObject.
event hand attachMorph: depictedObject.
self class removeFromGlobalIncomingQueue: depictedObject.
self rebuild.
!
----- Method: EToyListenerMorph>>rebuild (in category 'as yet unclassified') -----
rebuild
| earMorph |
updateCounter := UpdateCounter.
self removeAllMorphs.
self addGateKeeperMorphs.
GlobalListener ifNil: [
earMorph := (self class makeListeningToggleNew: false) asMorph.
earMorph setBalloonText: 'Click to START listening for messages'.
earMorph on: #mouseUp send: #startListening to: self.
] ifNotNil: [
earMorph := (self class makeListeningToggleNew: true) asMorph.
earMorph setBalloonText: 'Click to STOP listening for messages'.
earMorph on: #mouseUp send: #stopListening to: self.
].
self addARow: {self inAColumn: {earMorph}}.
self
addARow: {
self inAColumn: {(StringMorph contents: 'Incoming communications') lock}.
self indicatorFieldNamed: #working color: Color blue help: 'working'.
self indicatorFieldNamed: #communicating color: Color green help: 'receiving'.
}.
"{thumbForm. newObject. senderName. ipAddressString}"
self class globalIncomingQueueCopy do: [ :each |
self
addNewObject: each second
thumbForm: each first
sentBy: each third
ipAddress: each fourth.
].!
----- Method: EToyListenerMorph>>startListening (in category 'as yet unclassified') -----
startListening
self class startListening!
----- Method: EToyListenerMorph>>step (in category 'stepping and presenter') -----
step
| needRebuild |
super step.
needRebuild := false.
(self valueOfProperty: #gateKeeperCounterValue) =
EToyGateKeeperMorph updateCounter ifFalse: [needRebuild := true].
updateCounter = UpdateCounter ifFalse: [
needRebuild := true.
].
needRebuild ifTrue: [self rebuild].
!
----- Method: EToyListenerMorph>>stopListening (in category 'as yet unclassified') -----
stopListening
self class stopListening!
EToyCommunicatorMorph subclass: #EToyMorphsWelcomeMorph
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Collaborative'!
!EToyMorphsWelcomeMorph commentStamp: '<historical>' prior: 0!
EToyMorphsWelcomeMorph new openInWorld!
----- Method: EToyMorphsWelcomeMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Welcome'
categories: #('Collaborative')
documentation: 'A sign that you accept morphs dropped directly into your world'!
----- Method: EToyMorphsWelcomeMorph class>>morphsWelcomeInWorld: (in category 'as yet unclassified') -----
morphsWelcomeInWorld: aWorld
^self allInstances anySatisfy: [ :each | each world == aWorld]!
----- Method: EToyMorphsWelcomeMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color yellow!
----- Method: EToyMorphsWelcomeMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
| earMorph |
super initialize.
""
self layoutInset: 8 @ 8.
"earMorph := (EToyListenerMorph makeListeningToggle: true)
asMorph."
earMorph := TextMorph new contents: 'Morphs
welcome
here';
fontName: Preferences standardEToysFont familyName size: 18;
centered;
lock.
self addARow: {earMorph}.
self setBalloonText: 'My presence in this world means received morphs may appear automatically'!
EToyCommunicatorMorph subclass: #EToyProjectHistoryMorph
instanceVariableNames: 'changeCounter'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Refactoring'!
!EToyProjectHistoryMorph commentStamp: '<historical>' prior: 0!
EToyProjectHistoryMorph new openInWorld
EToyProjectHistoryMorph provides a quick reference of the most recent projects. Click on one to go there.!
----- Method: EToyProjectHistoryMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'ProjectHistory'
categories: #('Navigation')
documentation: 'A tool that lets you navigate back to recently-visited projects'!
----- Method: EToyProjectHistoryMorph>>closeMyFlapIfAny (in category 'as yet unclassified') -----
closeMyFlapIfAny
| myFlap allTabs myTab myWorld |
myWorld := self world.
myFlap := self nearestOwnerThat: [ :each | each isFlap].
myFlap ifNil: [^self].
allTabs := myWorld submorphs select: [ :each | each isFlapTab].
myTab := allTabs detect: [ :each | each referent == myFlap] ifNone: [^self].
myTab hideFlap.
myWorld displayWorldSafely.
!
----- Method: EToyProjectHistoryMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
^ #raised!
----- Method: EToyProjectHistoryMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 4!
----- Method: EToyProjectHistoryMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color lightBrown!
----- Method: EToyProjectHistoryMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self listDirection: #topToBottom;
layoutInset: 4;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
useRoundedCorners;
rebuild !
----- Method: EToyProjectHistoryMorph>>jumpToProject (in category 'as yet unclassified') -----
jumpToProject
| selection |
selection := (Project buildJumpToMenu: CustomMenu new) startUp.
self closeMyFlapIfAny.
Project jumpToSelection: selection
!
----- Method: EToyProjectHistoryMorph>>mouseDown:in: (in category 'as yet unclassified') -----
mouseDown: evt in: aMorph
aMorph setProperty: #mouseDownPoint toValue: evt cursorPoint.
!
----- Method: EToyProjectHistoryMorph>>mouseLeave:in: (in category 'as yet unclassified') -----
mouseLeave: evt in: aMorph
aMorph removeProperty: #mouseDownPoint.!
----- Method: EToyProjectHistoryMorph>>mouseMove:in: (in category 'as yet unclassified') -----
mouseMove: evt in: aMorph
| start tuple project url pvm |
start := aMorph valueOfProperty: #mouseDownPoint ifAbsent: [^self].
(start dist: evt cursorPoint) abs < 5 ifTrue: [^self].
aMorph removeProperty: #mouseDownPoint.
evt hand hasSubmorphs ifTrue: [^self].
tuple := aMorph valueOfProperty: #projectParametersTuple ifAbsent: [^self].
project := tuple fourth first.
(project notNil and: [project world notNil]) ifTrue: [
^evt hand attachMorph: (ProjectViewMorph on: project).
].
url := tuple third.
url isEmptyOrNil ifTrue: [^self].
pvm := ProjectViewMorph new.
pvm
project: (DiskProxy global: #Project selector: #namedUrl: args: {url});
lastProjectThumbnail: tuple second.
evt hand attachMorph: pvm.
!
----- Method: EToyProjectHistoryMorph>>mouseUp:in: (in category 'as yet unclassified') -----
mouseUp: evt in: aMorph
| tuple project url |
(aMorph boundsInWorld containsPoint: evt cursorPoint) ifFalse: [^self].
tuple := aMorph valueOfProperty: #projectParametersTuple ifAbsent: [^Beeper beep].
project := tuple fourth first.
(project notNil and: [project world notNil]) ifTrue: [self closeMyFlapIfAny. ^project enter].
url := tuple third.
url isEmptyOrNil ifTrue: [^Beeper beep].
self closeMyFlapIfAny.
ProjectLoading thumbnailFromUrl: url.
"---
newTuple := {
aProject name.
aProject thumbnail.
aProject url.
WeakArray with: aProject.
}.
---"!
----- Method: EToyProjectHistoryMorph>>rebuild (in category 'as yet unclassified') -----
rebuild
| history r1 |
history := ProjectHistory currentHistory mostRecentCopy.
changeCounter := ProjectHistory changeCounter.
self removeAllMorphs.
self rubberBandCells: false. "enable growing"
r1 := self addARow: {
self inAColumn: {
StringMorph new contents: 'Jump...' translated; lock.
}.
}.
r1 on: #mouseUp send: #jumpToProject to: self.
history do: [ :each |
(
self addARow: {
(self inAColumn: {
StretchyImageMorph new form: each second; minWidth: 35; minHeight: 35; lock
}) vResizing: #spaceFill.
self inAColumn: {
StringMorph new contents: each first; lock.
"StringMorph new contents: each third; lock."
}.
}
)
color: Color paleYellow;
borderWidth: 1;
borderColor: #raised;
vResizing: #spaceFill;
on: #mouseUp send: #mouseUp:in: to: self;
on: #mouseDown send: #mouseDown:in: to: self;
on: #mouseMove send: #mouseMove:in: to: self;
on: #mouseLeave send: #mouseLeave:in: to: self;
setProperty: #projectParametersTuple toValue: each;
setBalloonText: (each third isEmptyOrNil ifTrue: ['not saved'] ifFalse: [each third])
].
"---
newTuple := {
aProject name.
aProject thumbnail.
aProject url.
WeakArray with: aProject.
}.
---"!
----- Method: EToyProjectHistoryMorph>>step (in category 'stepping and presenter') -----
step
changeCounter = ProjectHistory changeCounter ifTrue: [^self].
self rebuild.
!
EllipseMorph subclass: #AlertMorph
instanceVariableNames: 'onColor offColor myObjSock socketOwner'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Audio Chat'!
----- Method: AlertMorph>>canHaveFillStyles (in category 'visual properties') -----
canHaveFillStyles
^false!
----- Method: AlertMorph>>color: (in category 'accessing') -----
color: aColor
super color: aColor.
onColor := aColor.!
----- Method: AlertMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 2!
----- Method: AlertMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color red!
----- Method: AlertMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self extent: 25 @ 25.
!
----- Method: AlertMorph>>onColor (in category 'accessing') -----
onColor
^onColor ifNil: [onColor := Color green]!
----- Method: AlertMorph>>socketOwner: (in category 'as yet unclassified') -----
socketOwner: aChatGUI
socketOwner := aChatGUI.!
----- Method: AlertMorph>>step (in category 'stepping and presenter') -----
step
super step.
offColor ifNil: [offColor := self onColor mixed: 0.5 with: Color black].
socketOwner objectsInQueue = 0 ifTrue: [
color = offColor ifFalse: [super color: offColor].
] ifFalse: [
super color: (color = onColor ifTrue: [offColor] ifFalse: [onColor]).
].
!
----- Method: AlertMorph>>stepTime (in category 'testing') -----
stepTime
"Answer the desired time between steps in milliseconds."
^ 500!
----- Method: MouseButtonEvent>>decodeFromStringArray: (in category '*nebraska-*nebraska-Morphic-Remote') -----
decodeFromStringArray: array
"decode the receiver from an array of strings"
type := array first asSymbol.
position := CanvasDecoder decodePoint: (array second).
buttons := CanvasDecoder decodeInteger: (array third).
whichButton := CanvasDecoder decodeInteger: (array fourth)!
----- Method: MouseButtonEvent>>encodedAsStringArray (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodedAsStringArray
"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
^{
type.
CanvasEncoder encodePoint: position.
CanvasEncoder encodeInteger: buttons.
CanvasEncoder encodeInteger: whichButton.
}!
SimpleButtonMorph subclass: #ChatButtonMorph
instanceVariableNames: 'actionDownSelector actionUpSelector labelDown labelUp'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Audio Chat'!
----- Method: ChatButtonMorph>>actionDownSelector: (in category 'accessing') -----
actionDownSelector: aSymbolOrString
(nil = aSymbolOrString or:
['nil' = aSymbolOrString or:
[aSymbolOrString isEmpty]])
ifTrue: [^actionDownSelector := nil].
actionDownSelector := aSymbolOrString asSymbol.!
----- Method: ChatButtonMorph>>actionUpSelector: (in category 'accessing') -----
actionUpSelector: aSymbolOrString
(nil = aSymbolOrString or:
['nil' = aSymbolOrString or:
[aSymbolOrString isEmpty]])
ifTrue: [^ actionUpSelector := nil].
actionUpSelector := aSymbolOrString asSymbol.!
----- Method: ChatButtonMorph>>doButtonDownAction (in category 'events') -----
doButtonDownAction
(target notNil and: [actionDownSelector notNil])
ifTrue: [Cursor normal showWhile: [target perform: actionDownSelector]]!
----- Method: ChatButtonMorph>>doButtonUpAction (in category 'events') -----
doButtonUpAction
(target notNil and: [actionUpSelector notNil])
ifTrue: [Cursor normal showWhile: [target perform: actionUpSelector]]!
----- Method: ChatButtonMorph>>labelDown: (in category 'accessing') -----
labelDown: aString
labelDown := aString.!
----- Method: ChatButtonMorph>>labelUp: (in category 'accessing') -----
labelUp: aString
labelUp := aString!
----- Method: ChatButtonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
oldColor := self fillStyle.
self label: labelDown.
self doButtonDownAction.
!
----- Method: ChatButtonMorph>>mouseUp: (in category 'event handling') -----
mouseUp: evt
"if oldColor nil, it signals that mouse had not gone DOWN inside me, e.g. because of a cmd-drag; in this case we want to avoid triggering the action!!"
oldColor ifNil: [^self].
self color: oldColor.
(self containsPoint: evt cursorPoint) ifTrue: [
self label: labelUp.
self doButtonUpAction.
].
!
----- Method: UserInputEvent>>encodedAsStringArray (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodedAsStringArray
"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
^{
type.
CanvasEncoder encodePoint: position.
CanvasEncoder encodeInteger: buttons.
}!
----- Method: InfiniteForm>>encodeForRemoteCanvas (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvas
^patternForm encodeForRemoteCanvas
!
HandMorph subclass: #RemoteControlledHandMorph
instanceVariableNames: 'eventDecoder viewExtent nebraskaClient'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!RemoteControlledHandMorph commentStamp: '<historical>' prior: 0!
Used as part of the Nebraska system. It is controlled by commands sent through a socket. The encoding is interpreted via a MorphicEventDecoder.!
----- Method: RemoteControlledHandMorph class>>on: (in category 'instance creation') -----
on: aDecoder
^self new decoder: aDecoder!
----- Method: RemoteControlledHandMorph>>convertRemoteClientToBuffered (in category 'events') -----
convertRemoteClientToBuffered
self world convertRemoteClientToBuffered: nebraskaClient!
----- Method: RemoteControlledHandMorph>>decoder: (in category 'initialization') -----
decoder: aDecoder
eventDecoder := aDecoder!
----- Method: RemoteControlledHandMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
viewExtent := 100@100.!
----- Method: RemoteControlledHandMorph>>nebraskaClient: (in category 'initialization') -----
nebraskaClient: aNebraskaClient
nebraskaClient := aNebraskaClient!
----- Method: RemoteControlledHandMorph>>needsToBeDrawn (in category 'drawing') -----
needsToBeDrawn
^true!
----- Method: RemoteControlledHandMorph>>processEvents (in category 'event handling') -----
processEvents
| |
eventDecoder processIO.
eventDecoder applyMessagesTo: self.
!
----- Method: RemoteControlledHandMorph>>queueEvent: (in category 'events') -----
queueEvent: anEvent
"add an event to be handled"
anEvent setHand: self.
self handleEvent: anEvent resetHandlerFields.!
----- Method: RemoteControlledHandMorph>>setViewExtent: (in category 'events') -----
setViewExtent: newExtent
"set the extent of this hand's view of the world"
viewExtent := newExtent!
----- Method: RemoteControlledHandMorph>>worldBounds (in category 'geometry') -----
worldBounds
^0@0 extent: viewExtent!
EmbeddedWorldBorderMorph subclass: #NetworkTerminalBorderMorph
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
----- Method: NetworkTerminalBorderMorph>>boxesAndColorsAndSelectors (in category 'boxes') -----
boxesAndColorsAndSelectors
^#()!
----- Method: NetworkTerminalBorderMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
self setBalloonText: nil. "'I am a view on another Squeak'."
self layoutInset: 0.
!
----- Method: NetworkTerminalBorderMorph>>toggleFullView (in category 'as yet unclassified') -----
toggleFullView
"Toggle the full view for network terminal"
| fullExtent priorExtent |
fullExtent := self worldIEnclose extent + (2 * self borderWidth).
priorExtent := self valueOfProperty: #priorExtent.
priorExtent ifNil:[
self setProperty: #priorExtent toValue: self extent.
self extent: fullExtent.
self position: self position + self borderWidth asPoint negated.
] ifNotNil:[
self removeProperty: #priorExtent.
self extent: priorExtent.
self position: (self position max: 0@0).
].!
----- Method: MorphicEvent class>>fromStringArray: (in category '*nebraska-*nebraska-Morphic-Remote') -----
fromStringArray: array
"decode an event that was encoded with encodedAsStringArray"
| type |
type := (array at: 1).
(type = 'mouseMove')
ifTrue:[^MouseMoveEvent new decodeFromStringArray: array].
(type = 'mouseDown' or:[type = 'mouseUp'])
ifTrue:[^MouseButtonEvent new decodeFromStringArray: array].
(type = 'keystroke' or:[type = 'keyDown' or:[type = 'keyUp']])
ifTrue:[^KeyboardEvent new decodeFromStringArray: array].
^nil!
----- Method: StrikeFontSet>>encodedForRemoteCanvas (in category '*nebraska-as yet unclassified') -----
encodedForRemoteCanvas
| stream |
stream := RWBinaryOrTextStream on: ''.
stream nextPutAll: self familyName.
stream nextPut: Character space.
stream nextPutAll: self pointSize asString.
stream nextPut: Character space.
stream nextPutAll: self emphasis asString.
^ stream contents asString.
!
----- Method: MatrixTransform2x3 class>>fromRemoteCanvasEncoding: (in category '*nebraska-instance creation') -----
fromRemoteCanvasEncoding: encoded
"DisplayTransform fromRemoteCanvasEncoding: 'Matrix,1065353216,0,1137541120,0,1065353216,1131610112,'"
| nums transform encodedNums |
"split the numbers up"
encodedNums := encoded findTokens: ','.
"remove the initial 'Matrix' specification"
encodedNums := encodedNums asOrderedCollection.
encodedNums removeFirst.
"parse the numbers"
nums := encodedNums collect: [ :enum |
Integer readFromString: enum ].
"create an instance"
transform := self new.
"plug in the numbers"
nums doWithIndex: [ :num :i |
transform basicAt: i put: num ].
^transform!
----- Method: MatrixTransform2x3>>encodeForRemoteCanvas (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvas
"encode this transform into a string for use by a RemoteCanvas"
^String streamContents: [ :str |
str nextPutAll: 'Matrix,'.
1 to: 6 do: [ :i |
str print: (self basicAt: i).
str nextPut: $, ].
]!
PluggableCanvas subclass: #BufferedCanvas
instanceVariableNames: 'remote previousVersion lastTick dirtyRect mirrorOfScreen'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
----- Method: BufferedCanvas>>asBufferedCanvas (in category 'as yet unclassified') -----
asBufferedCanvas
^self!
----- Method: BufferedCanvas>>checkIfTimeToDisplay (in category 'as yet unclassified') -----
checkIfTimeToDisplay
remote backlog > 0 ifTrue: [^self]. "why bother if network full?"
dirtyRect ifNil: [^self].
self sendDeltas.
lastTick := Time millisecondClockValue.
!
----- Method: BufferedCanvas>>clipBy:during: (in category 'drawing-support') -----
clipBy: aRectangle during: aBlock
!
----- Method: BufferedCanvas>>clipRect (in category 'accessing') -----
clipRect
^0@0 extent: 99999@99999
!
----- Method: BufferedCanvas>>connection:clipRect:transform:remoteCanvas: (in category 'as yet unclassified') -----
connection: connection clipRect: newClipRect transform: transform remoteCanvas: remoteCanvas
remote := remoteCanvas.
lastTick := 0.
!
----- Method: BufferedCanvas>>displayIsFullyUpdated (in category 'Nebraska/embeddedWorlds') -----
displayIsFullyUpdated
self checkIfTimeToDisplay!
----- Method: BufferedCanvas>>drawMorph: (in category 'drawing-general') -----
drawMorph: x
!
----- Method: BufferedCanvas>>extent (in category 'accessing') -----
extent
^Display extent!
----- Method: BufferedCanvas>>forceToScreen: (in category 'other') -----
forceToScreen: rect
mirrorOfScreen ifNil: [
mirrorOfScreen := (previousVersion ifNil: [Display]) deepCopy.
].
mirrorOfScreen copy: rect from: rect origin in: Display rule: Form over.
dirtyRect := dirtyRect ifNil: [rect] ifNotNil: [dirtyRect merge: rect].
!
----- Method: BufferedCanvas>>origin (in category 'accessing') -----
origin
^0@0!
----- Method: BufferedCanvas>>purgeOutputQueue (in category 'as yet unclassified') -----
purgeOutputQueue!
----- Method: BufferedCanvas>>sendDeltas (in category 'as yet unclassified') -----
sendDeltas
"
NebraskaDebug showStats: #sendDeltas
"
| t deltas dirtyFraction |
previousVersion ifNil: [
previousVersion := Display deepCopy.
remote
image: previousVersion
at: 0@0
sourceRect: previousVersion boundingBox
rule: Form paint.
^remote forceToScreen: previousVersion boundingBox.
].
dirtyRect ifNil: [^self].
t := Time millisecondClockValue.
dirtyFraction := dirtyRect area / previousVersion boundingBox area roundTo: 0.0001.
deltas := mirrorOfScreen deltaFrom: (previousVersion copy: dirtyRect) at: dirtyRect origin.
previousVersion := mirrorOfScreen.
mirrorOfScreen := nil.
remote
image: deltas at: dirtyRect origin sourceRect: deltas boundingBox rule: Form reverse;
forceToScreen: dirtyRect.
t := Time millisecondClockValue - t.
NebraskaDebug at: #sendDeltas add: {t. dirtyFraction. deltas boundingBox}.
dirtyRect := nil.
!
----- Method: CompositeTransform class>>fromRemoteCanvasEncoding: (in category '*nebraska-instance creation') -----
fromRemoteCanvasEncoding: encoding
| firstStart firstEnd firstEncoding firstTransform secondStart secondEnd secondEncoding secondTransform |
"format: Composite,(enc1)(enc2)"
"decode the first encoding"
firstStart := encoding indexOf: $(.
firstStart = 0 ifTrue: [ self error: 'invalid encoding' ].
firstEnd := encoding findCloseParenthesisFor: firstStart.
firstEncoding := encoding copyFrom: firstStart+1 to: firstEnd-1.
firstTransform := DisplayTransform fromRemoteCanvasEncoding: firstEncoding.
"decode the second encoding"
secondStart := firstEnd + 1.
(encoding at: secondStart) = $( ifFalse: [ ^self error: 'invalid encoding' ].
secondEnd := encoding findCloseParenthesisFor: secondStart.
secondEncoding := encoding copyFrom: secondStart+1 to: secondEnd-1.
secondTransform := DisplayTransform fromRemoteCanvasEncoding: secondEncoding.
"put it together"
^self globalTransform: firstTransform localTransform: secondTransform!
----- Method: CompositeTransform>>encodeForRemoteCanvas (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvas
^String streamContents: [ :str |
str
nextPutAll: 'Composite,';
nextPutAll: '(';
nextPutAll: globalTransform encodeForRemoteCanvas;
nextPutAll: ')(';
nextPutAll: localTransform encodeForRemoteCanvas;
nextPutAll: ')' ]!
----- Method: Form>>addDeltasFrom: (in category '*nebraska-encoding') -----
addDeltasFrom: previousForm
(BitBlt
destForm: self
sourceForm: previousForm
fillColor: nil
combinationRule: Form reverse
destOrigin: 0@0
sourceOrigin: 0@0
extent: self extent
clipRect: self boundingBox) copyBits.
^self!
----- Method: Form>>deltaFrom: (in category '*nebraska-encoding') -----
deltaFrom: previousForm
| newForm |
newForm := previousForm deepCopy.
(BitBlt
destForm: newForm
sourceForm: self
fillColor: nil
combinationRule: Form reverse
destOrigin: 0@0
sourceOrigin: 0@0
extent: self extent
clipRect: self boundingBox) copyBits.
^newForm!
----- Method: Form>>deltaFrom:at: (in category '*nebraska-encoding') -----
deltaFrom: smallerForm at: offsetInMe
| newForm |
newForm := smallerForm deepCopy.
(BitBlt
destForm: newForm
sourceForm: self
fillColor: nil
combinationRule: Form reverse
destOrigin: 0@0
sourceOrigin: offsetInMe
extent: smallerForm extent
clipRect: newForm boundingBox) copyBits.
^newForm!
----- Method: Form>>encodeForRemoteCanvas (in category '*nebraska-encoding') -----
encodeForRemoteCanvas
| header binaryForm |
"encode into a bitstream for use with RemoteCanvas. The format does not require invoking the Compiler"
header := String streamContents: [ :str |
str "nextPutAll: 'F|';"
nextPutAll: self depth printString;
nextPut: $,;
nextPutAll: self width printString;
nextPut: $,;
nextPutAll: self height printString;
nextPut: $|. ].
binaryForm := ByteArray streamContents: [ :str |
self unhibernate.
bits writeOn: str. ].
^header, binaryForm asString
!
----- Method: StrikeFont class>>decodedFromRemoteCanvas: (in category '*nebraska-instance creation') -----
decodedFromRemoteCanvas: aString
| array style base |
array _ aString findTokens: #($ ).
style _ TextStyle named: (array at: 1) asSymbol.
style ifNil: [^ TextStyle defaultFont].
(style fontArray first name = style fontArray first name withoutTrailingDigits) ifTrue: [
^ self familyName: (array at: 1) size: (array at: 3) asNumber emphasized: (array at: 4) asNumber].
base _ style fontArray detect: [:f | (array at: 2) beginsWith: f name].
^ base emphasized: (array at: 4) asNumber.
"^ self familyName: (array at: 1) size: (array at: 2) asNumber emphasized: (array at: 3) asNumber."
!
----- Method: StrikeFont>>encodedForRemoteCanvas (in category '*nebraska-file in/out') -----
encodedForRemoteCanvas
| stream |
stream := RWBinaryOrTextStream on: ''.
stream nextPutAll: self familyName.
stream nextPut: Character space.
stream nextPutAll: self name.
stream nextPut: Character space.
stream nextPutAll: self height.
stream nextPut: Character space.
stream nextPutAll: self emphasis asString.
^ stream contents asString.
!
Canvas subclass: #RemoteCanvas
instanceVariableNames: 'innerClipRect outerClipRect transform connection shadowColor'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!RemoteCanvas commentStamp: '<historical>' prior: 0!
A canvas which draws to a terminal across the network. Note that multiple RemoteCanvas's might exist for a single MREncoder, each having different transformations and clipping rectangles.!
----- Method: RemoteCanvas class>>connection:clipRect:transform: (in category 'instance creation') -----
connection: connection clipRect: clipRect transform: transform
^self new connection: connection clipRect: clipRect transform: transform!
----- Method: RemoteCanvas>>apply: (in category 'as yet unclassified') -----
apply: ignored
"added for the convenience of BufferedCanvas"!
----- Method: RemoteCanvas>>asBufferedCanvas (in category 'initialization') -----
asBufferedCanvas
| bufferedCanvas |
bufferedCanvas := BufferedCanvas new.
connection cachingEnabled: false.
bufferedCanvas
connection: connection
clipRect: NebraskaServer extremelyBigRectangle
transform: MorphicTransform identity
remoteCanvas: self.
^bufferedCanvas!
----- Method: RemoteCanvas>>backlog (in category 'nil') -----
backlog
^connection backlog!
----- Method: RemoteCanvas>>balloonFillOval:fillStyle:borderWidth:borderColor: (in category 'drawing') -----
balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
self drawCommand: [ :executor |
executor balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
].!
----- Method: RemoteCanvas>>balloonFillRectangle:fillStyle: (in category 'drawing') -----
balloonFillRectangle: aRectangle fillStyle: aFillStyle
self drawCommand: [ :executor |
executor balloonFillRectangle: aRectangle fillStyle: aFillStyle
].!
----- Method: RemoteCanvas>>clipBy:during: (in category 'drawing-support') -----
clipBy: aRectangle during: aBlock
| newCanvas newR |
"Set a clipping rectangle active only during the execution of aBlock."
newR := transform localBoundsToGlobal: aRectangle.
newCanvas := RemoteCanvas
connection: connection
clipRect: (outerClipRect intersect: newR)
transform: transform.
newCanvas privateShadowColor: shadowColor.
aBlock value: newCanvas.
connection shadowColor: shadowColor.!
----- Method: RemoteCanvas>>clipRect (in category 'accessing') -----
clipRect
^innerClipRect!
----- Method: RemoteCanvas>>connection:clipRect:transform: (in category 'initialization') -----
connection: connection0 clipRect: clipRect0 transform: transform0
connection := connection0.
outerClipRect := clipRect0.
transform := transform0.
innerClipRect := transform globalBoundsToLocal: outerClipRect. !
----- Method: RemoteCanvas>>contentsOfArea:into: (in category 'accessing') -----
contentsOfArea: aRectangle into: aForm
"this should never be called; normally, RemoteCanvas's are used in conjunction with a CachingCanvas"
self flag: #roundedRudeness.
"aForm fillWhite.
^aForm"
^Display getCanvas contentsOfArea: aRectangle into: aForm!
----- Method: RemoteCanvas>>drawCommand: (in category 'private') -----
drawCommand: aBlock
"set up the connection for a drawing command, and then execute aBlock with the connection as an argument"
connection updateTransform: transform andClipRect: outerClipRect.
aBlock value: connection!
----- Method: RemoteCanvas>>drawPolygon:color:borderWidth:borderColor: (in category 'drawing-polygons') -----
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
self drawCommand: [ :c |
c drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc ]!
----- Method: RemoteCanvas>>drawString:from:to:in:font:color: (in category 'drawing-text') -----
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
"Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used."
"(innerClipRect intersects: (transform transformBoundsRect: boundsRect)) ifFalse: [ ^self ]."
"clip rectangles seem to be all screwed up...."
s isAllSeparators ifTrue: [ ^self ]. "is this correct?? it sure does speed things up!!"
self drawCommand: [ :executor |
executor drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: (self isShadowDrawing ifTrue: [self shadowColor] ifFalse: [c])]!
----- Method: RemoteCanvas>>extent (in category 'accessing') -----
extent
self flag: #hack.
^1500@1500!
----- Method: RemoteCanvas>>fillOval:color:borderWidth:borderColor: (in category 'drawing-ovals') -----
fillOval: bounds color: color borderWidth: borderWidth borderColor: borderColor
"Fill the given oval."
self drawCommand: [ :executor |
executor fillOval: bounds color: color borderWidth: borderWidth borderColor: borderColor
].!
----- Method: RemoteCanvas>>fillOval:fillStyle:borderWidth:borderColor: (in category 'drawing-ovals') -----
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
"Fill the given oval."
self shadowColor ifNotNil: [
^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc
].
(aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
self flag: #fixThis.
^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc
].
(aFillStyle isSolidFill) ifTrue:[
^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc
].
"Use a BalloonCanvas instead"
self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc!
----- Method: RemoteCanvas>>fillRectangle:fillStyle: (in category 'drawing-rectangles') -----
fillRectangle: aRectangle fillStyle: aFillStyle
"Fill the given rectangle."
| pattern |
(self isShadowDrawing not and: [self shadowColor notNil]) ifTrue:
[^self fillRectangle: aRectangle color: self shadowColor].
(aFillStyle isKindOf: InfiniteForm) ifTrue: [
^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
].
(aFillStyle isSolidFill)
ifTrue:[^self fillRectangle: aRectangle color: aFillStyle asColor].
"We have a very special case for filling with infinite forms"
(aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[
pattern _ aFillStyle form.
(aFillStyle direction = (pattern width @ 0)
and:[aFillStyle normal = (0@pattern height)]) ifTrue:[
"Can use an InfiniteForm"
^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
].
"Use a BalloonCanvas instead"
self balloonFillRectangle: aRectangle fillStyle: aFillStyle.!
----- Method: RemoteCanvas>>flush (in category 'initialization') -----
flush
connection ifNotNil: [ connection flush ]!
----- Method: RemoteCanvas>>forceToScreen: (in category 'other') -----
forceToScreen: rect
self drawCommand: [ :exec |
exec forceToScreen: rect ]!
----- Method: RemoteCanvas>>frameAndFillRectangle:fillColor:borderWidth:borderColor: (in category 'drawing-rectangles') -----
frameAndFillRectangle: bounds fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
"Draw the rectangle using the given attributes"
self drawCommand: [ :executor |
executor
frameAndFillRectangle: bounds
fillColor: fillColor
borderWidth: borderWidth
borderColor: borderColor
].!
----- Method: RemoteCanvas>>image:at:sourceRect:rule: (in category 'private') -----
image: aForm at: aPoint sourceRect: sourceRect rule: rule
"Draw the given form."
self drawCommand: [ :executor |
executor image: aForm at: aPoint sourceRect: sourceRect rule: rule
].!
----- Method: RemoteCanvas>>infiniteFillRectangle:fillStyle: (in category 'drawing') -----
infiniteFillRectangle: aRectangle fillStyle: aFillStyle
self drawCommand: [ :c |
c infiniteFillRectangle: aRectangle fillStyle: aFillStyle
]!
----- Method: RemoteCanvas>>isShadowDrawing (in category 'accessing') -----
isShadowDrawing
^ self shadowColor notNil!
----- Method: RemoteCanvas>>line:to:width:color: (in category 'drawing') -----
line: point1 to: point2 width: width color: color
"Draw a line using the given width and color"
self drawCommand: [ :executor |
executor line: point1 to: point2 width: width color: color ]!
----- Method: RemoteCanvas>>origin (in category 'accessing') -----
origin
^0@0!
----- Method: RemoteCanvas>>paragraph:bounds:color: (in category 'drawing') -----
paragraph: paragraph bounds: bounds color: c
| scanner |
scanner := CanvasCharacterScanner new.
scanner
canvas: self;
text: paragraph text textStyle: paragraph textStyle;
textColor: c; defaultTextColor: c.
paragraph displayOn: self using: scanner at: bounds topLeft.
!
----- Method: RemoteCanvas>>privateShadowColor: (in category 'drawing-support') -----
privateShadowColor: x
shadowColor := x.
!
----- Method: RemoteCanvas>>processIO (in category 'misc') -----
processIO
connection processIO!
----- Method: RemoteCanvas>>purgeOutputQueue (in category 'initialization') -----
purgeOutputQueue
connection purgeOutputQueue.!
----- Method: RemoteCanvas>>roundCornersOf:in:during: (in category 'drawing-general') -----
roundCornersOf: aMorph in: bounds during: aBlock
self flag: #roundedRudeness.
aMorph wantsRoundedCorners ifFalse:[^aBlock value].
(self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds))
ifTrue: ["Don't bother with corner logic if the region is inside them"
^ aBlock value].
CornerRounder roundCornersOf: aMorph on: self in: bounds
displayBlock: aBlock
borderWidth: aMorph borderWidthForRounding
corners: aMorph roundedCorners!
----- Method: RemoteCanvas>>shadowColor (in category 'accessing') -----
shadowColor
^shadowColor!
----- Method: RemoteCanvas>>shadowColor: (in category 'accessing') -----
shadowColor: x
connection shadowColor: (shadowColor := x).
!
----- Method: RemoteCanvas>>showAt:invalidRects: (in category 'drawing-support') -----
showAt: pt invalidRects: updateRects
updateRects do: [ :rect |
self drawCommand: [ :exec |
exec forceToScreen: rect ] ]!
----- Method: RemoteCanvas>>stencil:at:sourceRect:color: (in category 'drawing-images') -----
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
self drawCommand: [ :executor |
executor stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor ]!
----- Method: RemoteCanvas>>transform2By:clippingTo:during:smoothing: (in category 'Nebraska/embeddedWorlds') -----
transform2By: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
(aDisplayTransform isPureTranslation) ifTrue: [
^self
transformBy: aDisplayTransform
clippingTo: aClipRect
during: aBlock
smoothing: cellSize
].
^super
transform2By: aDisplayTransform
clippingTo: aClipRect
during: aBlock
smoothing: cellSize
!
----- Method: RemoteCanvas>>transformBy:clippingTo:during:smoothing: (in category 'drawing-support') -----
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
| newCanvas |
self flag: #bob. "do tranform and clip work together properly?"
newCanvas := RemoteCanvas
connection: connection
clipRect: (aClipRect intersect: outerClipRect)
transform: (transform composedWith: aDisplayTransform).
newCanvas privateShadowColor: shadowColor.
aBlock value: newCanvas.
connection shadowColor: shadowColor.!
----- Method: RemoteCanvas>>translateBy:during: (in category 'drawing-support') -----
translateBy: delta during: aBlock
self transformBy: (MorphicTransform offset: delta negated) clippingTo: outerClipRect during: aBlock smoothing: 1!
UpdatingThreePhaseButtonMorph subclass: #EtoyUpdatingThreePhaseButtonMorph
instanceVariableNames: ''
classVariableNames: 'CheckedForm UncheckedForm MouseDownForm'
poolDictionaries: ''
category: 'Nebraska-Refactoring'!
!EtoyUpdatingThreePhaseButtonMorph commentStamp: '<historical>' prior: 0!
A slight variation wherein the actionSelector and getSelector both take argument(s).!
----- Method: EtoyUpdatingThreePhaseButtonMorph class>>checkBox (in category 'instance creation') -----
checkBox
"Answer a button pre-initialized with checkbox images."
"(Form extent: 12@12 depth: 32) morphEdit"
CheckedForm ifNil: [
self setForms
].
^self new
onImage: CheckedForm;
pressedImage: MouseDownForm;
offImage: UncheckedForm;
extent: CheckedForm extent;
yourself
!
----- Method: EtoyUpdatingThreePhaseButtonMorph class>>setForms (in category 'as yet unclassified') -----
setForms
CheckedForm := (Form
extent: 12@12
depth: 32
fromArray: #( 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 4278190081 4278190081 4278190081 0 0 0 0 0 0 0 0 4278190081 2003331177 4278190081 4278190081 0 0 0 0 0 0 0 4278190081 2003331177 0 4278190081 4278190081 0 0 0 0 0 0 4278190081 2003331177 0 0 4278190081 4278190081 0 4278190081 0 0 0 4278190081 2003331177 0 0 0 4278190081 4278190081 0 2003331177 4278190081 0 4278190081 2003331177 0 0 0 0 4278190081 4278190081 0 0 2003331177 4278190081 2003331177 0 0 0 0 0 4278190081 4278190081 0 0 0 2003331177 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081)
offset: 0@0).
MouseDownForm := UncheckedForm := (Form
extent: 12@12
depth: 32
fromArray: #( 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081)
offset: 0@0)!
----- Method: EtoyUpdatingThreePhaseButtonMorph>>step (in category 'stepping and presenter') -----
step
| newBoolean |
state == #pressed ifTrue: [^ self].
newBoolean := target perform: getSelector withArguments: arguments.
newBoolean == self isOn
ifFalse:
[self state: (newBoolean ifTrue: [#on] ifFalse: [#off])]
!
ProjectNavigationMorph subclass: #NebraskaNavigationMorph
instanceVariableNames: 'nebraskaBorder nebraskaTerminal'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
----- Method: NebraskaNavigationMorph>>addButtons (in category 'as yet unclassified') -----
addButtons
self addARow: {
self inAColumn: {self buttonScale}.
self inAColumn: {self buttonQuit}.
self inAColumn: {self buttonBuffered}.
}.
!
----- Method: NebraskaNavigationMorph>>bufferNebraska (in category 'as yet unclassified') -----
bufferNebraska
nebraskaTerminal requestBufferedConnection
!
----- Method: NebraskaNavigationMorph>>buttonBuffered (in category 'as yet unclassified') -----
buttonBuffered
^self makeButton: 'B' balloonText: 'Request buffered Nebraska session' for: #bufferNebraska
!
----- Method: NebraskaNavigationMorph>>buttonQuit (in category 'the buttons') -----
buttonQuit
^self makeButton: 'Quit' balloonText: 'Quit this Nebraska session' for: #quitNebraska
!
----- Method: NebraskaNavigationMorph>>buttonScale (in category 'as yet unclassified') -----
buttonScale
^self makeButton: '1x1' balloonText: 'Switch between 1x1 and scaled view' for: #toggleFullView
!
----- Method: NebraskaNavigationMorph>>currentNavigatorVersion (in category 'as yet unclassified') -----
currentNavigatorVersion
^1 "not particularly relevant here"!
----- Method: NebraskaNavigationMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color yellow !
----- Method: NebraskaNavigationMorph>>fontForButtons (in category 'as yet unclassified') -----
fontForButtons
^ TextStyle defaultFont.
"^Preferences standardButtonFont"!
----- Method: NebraskaNavigationMorph>>nebraskaBorder: (in category 'as yet unclassified') -----
nebraskaBorder: aNebraskaBorder
nebraskaBorder := aNebraskaBorder!
----- Method: NebraskaNavigationMorph>>nebraskaTerminal: (in category 'as yet unclassified') -----
nebraskaTerminal: aNebraskaTerminal
nebraskaTerminal := aNebraskaTerminal!
----- Method: NebraskaNavigationMorph>>positionVertically (in category 'as yet unclassified') -----
positionVertically
| w |
w := self world ifNil: [^self].
self top < w top ifTrue: [self top: w top].
self bottom > w bottom ifTrue: [self bottom: w bottom].!
----- Method: NebraskaNavigationMorph>>quitNebraska (in category 'as yet unclassified') -----
quitNebraska
nebraskaBorder ifNotNil: [nebraskaBorder delete].
self delete.!
----- Method: NebraskaNavigationMorph>>step (in category 'stepping and presenter') -----
step
super step.
(nebraskaBorder isNil or: [nebraskaBorder world isNil]) ifTrue: [self delete].!
----- Method: NebraskaNavigationMorph>>toggleFullView (in category 'as yet unclassified') -----
toggleFullView
nebraskaBorder ifNotNil: [nebraskaBorder toggleFullView]!
----- Method: NebraskaNavigationMorph>>wantsToBeDroppedInto: (in category 'dropping/grabbing') -----
wantsToBeDroppedInto: aMorph
"avoid difficulties in placement"
^(aMorph isKindOf: NetworkTerminalMorph) not!
----- Method: ProjectNavigationMorph>>buttonShare (in category '*nebraska-*nebraska-Morphic-Remote') -----
buttonShare
^self makeButton: 'Share'
balloonText: 'Share this project so that others can explore it with you.'
for: #shareThisWorld
!
----- Method: ProjectNavigationMorph>>shareThisWorld (in category '*nebraska-*nebraska-Morphic-Remote') -----
shareThisWorld
NebraskaServerMorph serveWorld: self world!
----- Method: KeyboardEvent>>decodeFromStringArray: (in category '*nebraska-*nebraska-Morphic-Remote') -----
decodeFromStringArray: array
"decode the receiver from an array of strings"
type := array first asSymbol.
position := CanvasDecoder decodePoint: (array second).
buttons := CanvasDecoder decodeInteger: (array third).
keyValue := CanvasDecoder decodeInteger: array fourth!
----- Method: KeyboardEvent>>encodedAsStringArray (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodedAsStringArray
"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
^{
type.
CanvasEncoder encodePoint: position.
CanvasEncoder encodeInteger: buttons.
CanvasEncoder encodeInteger: keyValue asInteger
}!
----- Method: Rectangle>>encodeForRemoteCanvas (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvas
| encoded |
CanvasEncoder at: 2 count: 1.
encoded := String new: 16.
encoded putInteger32: origin x asInteger at: 1.
encoded putInteger32: origin y asInteger at: 5.
encoded putInteger32: corner x asInteger at: 9.
encoded putInteger32: corner y asInteger at: 13.
^encoded!
----- Method: Rectangle>>encodeForRemoteCanvasB (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvasB
| encoded |
encoded := Bitmap new: 4.
encoded at: 1 put: origin x asInteger.
encoded at: 2 put: origin y asInteger.
encoded at: 3 put: corner x asInteger.
encoded at: 4 put: corner y asInteger.
^encoded!
----- Method: DisplayTransform class>>fromRemoteCanvasEncoding: (in category '*nebraska-instance creation') -----
fromRemoteCanvasEncoding: encoded
| type |
"decode a transform from the given encoded string"
type := (ReadStream on: encoded) upTo: $,.
type = 'Morphic' ifTrue: [
^MorphicTransform fromRemoteCanvasEncoding: encoded ].
type = 'Matrix' ifTrue: [
^MatrixTransform2x3 fromRemoteCanvasEncoding: encoded ].
type = 'Composite' ifTrue: [
^CompositeTransform fromRemoteCanvasEncoding: encoded ].
^self error: 'invalid transform encoding'!
----- Method: DisplayTransform>>encodeForRemoteCanvas (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvas
"encode this transform into a string for use by a RemoteCanvas"
^self subclassResponsibility!
MorphicModel subclass: #EToyGateKeeperEntry
instanceVariableNames: 'ipAddress accessAttempts lastTimes acceptableTypes latestUserName attempsDenied lastRequests'
classVariableNames: 'KnownIPAddresses'
poolDictionaries: ''
category: 'Nebraska-Morphic-Experimental'!
----- Method: EToyGateKeeperEntry class>>includeInNewMorphMenu (in category 'new-morph participation') -----
includeInNewMorphMenu
"Not to be instantiated from the menu"
^ false!
----- Method: EToyGateKeeperEntry>>acceptableTypes (in category 'as yet unclassified') -----
acceptableTypes
^acceptableTypes!
----- Method: EToyGateKeeperEntry>>dateAndTimeStringFrom: (in category 'as yet unclassified') -----
dateAndTimeStringFrom: totalSeconds
| dateAndTime |
dateAndTime := Time dateAndTimeFromSeconds: totalSeconds.
^dateAndTime first printString,' ',dateAndTime second printString!
----- Method: EToyGateKeeperEntry>>fullInfoString (in category 'as yet unclassified') -----
fullInfoString
^self latestUserName,
' at ',
ipAddress ,
' attempts: ',
accessAttempts printString,
'/',
attempsDenied printString,
' last: ',
(self lastIncomingMessageTimeString)
"acceptableTypes"
!
----- Method: EToyGateKeeperEntry>>getChoice: (in category 'as yet unclassified') -----
getChoice: aString
^acceptableTypes includes: aString!
----- Method: EToyGateKeeperEntry>>initialize (in category 'initialization') -----
initialize
self flag: #bob. "need to decide better initial types"
super initialize.
ipAddress := '???'.
accessAttempts := attempsDenied := 0.
lastRequests := OrderedCollection new.
acceptableTypes := Set withAll: EToyIncomingMessage allTypes.
!
----- Method: EToyGateKeeperEntry>>ipAddress (in category 'as yet unclassified') -----
ipAddress
^ipAddress!
----- Method: EToyGateKeeperEntry>>ipAddress: (in category 'as yet unclassified') -----
ipAddress: aString
ipAddress := aString!
----- Method: EToyGateKeeperEntry>>lastIncomingMessageTimeString (in category 'as yet unclassified') -----
lastIncomingMessageTimeString
lastRequests isEmpty ifTrue: [^'never'].
^self dateAndTimeStringFrom: lastRequests first first
!
----- Method: EToyGateKeeperEntry>>lastTimeChecked (in category 'as yet unclassified') -----
lastTimeChecked
^self valueOfProperty: #lastTimeChecked
!
----- Method: EToyGateKeeperEntry>>lastTimeChecked: (in category 'as yet unclassified') -----
lastTimeChecked: aDateAndTimeInSeconds
self setProperty: #lastTimeChecked toValue: aDateAndTimeInSeconds
!
----- Method: EToyGateKeeperEntry>>lastTimeCheckedString (in category 'as yet unclassified') -----
lastTimeCheckedString
| statusTime |
statusTime := self valueOfProperty: #lastTimeChecked ifAbsent: [^'none'].
^(self dateAndTimeStringFrom: statusTime)!
----- Method: EToyGateKeeperEntry>>latestUserName (in category 'as yet unclassified') -----
latestUserName
^latestUserName ifNil: ['???']!
----- Method: EToyGateKeeperEntry>>latestUserName: (in category 'as yet unclassified') -----
latestUserName: aString
latestUserName := aString!
----- Method: EToyGateKeeperEntry>>requestAccessOfType: (in category 'as yet unclassified') -----
requestAccessOfType: aString
| ok |
accessAttempts := accessAttempts + 1.
lastRequests addFirst: {Time totalSeconds. aString}.
lastRequests size > 10 ifTrue: [
lastRequests := lastRequests copyFrom: 1 to: 10.
].
ok := (acceptableTypes includes: aString) or: [acceptableTypes includes: 'all'].
ok ifFalse: [attempsDenied := attempsDenied + 1].
^ok!
----- Method: EToyGateKeeperEntry>>statusReplyReceived: (in category 'as yet unclassified') -----
statusReplyReceived: anArray
self setProperty: #lastStatusReplyTime toValue: Time totalSeconds.
self setProperty: #lastStatusReply toValue: anArray.!
----- Method: EToyGateKeeperEntry>>statusReplyReceivedString (in category 'as yet unclassified') -----
statusReplyReceivedString
| statusTime |
statusTime := self valueOfProperty: #lastStatusReplyTime ifAbsent: [^'none'].
^(self dateAndTimeStringFrom: statusTime),' accepts:
', (self valueOfProperty: #lastStatusReply) asArray printString!
----- Method: EToyGateKeeperEntry>>timeBetweenLastAccessAnd: (in category 'as yet unclassified') -----
timeBetweenLastAccessAnd: currentTime
lastRequests isEmpty ifTrue: [^0].
^currentTime - lastRequests first first
!
----- Method: EToyGateKeeperEntry>>toggleChoice: (in category 'as yet unclassified') -----
toggleChoice: aString
(acceptableTypes includes: aString) ifTrue: [
acceptableTypes remove: aString ifAbsent: []
] ifFalse: [
acceptableTypes add: aString
].!
Model subclass: #NebraskaServer
instanceVariableNames: 'worldDepth world clients listenQueue'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!NebraskaServer commentStamp: '<historical>' prior: 0!
A Nebraska server has a private world and some collection of clients. It associates a RemoteControlledHand for each client. Redraw events in the world are broadcasted to all connected clients. A Nebraska server can listen on a TCP/IP port and accept new clients. Current version has been modified so that the server serves the world in which it was launched. Other variations are certainly possible.
To start a server, execute the following code:
NebraskaServerMorph serveWorld: World
To start a client, run the following in another image:
NetworkTerminalMorph openAndConnectTo: 'servername'
Fill in your server's hostname for 'servername'. At this point, everything should be working!!
Before starting a server, you can tweak these:
BufferedCanvas enabled: false.
BufferedCanvas enabled: true.
At any time you can do these:
NebraskaDebug beginStats
NebraskaDebug showStats
NebraskaDebug showStats: #delays
NebraskaDebug showStats: #bigImage
NebraskaDebug showStats: #FormEncodeTimes
NebraskaDebug killStats
NOTE: if you want to have a local view of the server, you shouldn't use the TCP connections. The problem is that the server will occasionally do a #flush, and it won't work due to single threading. The better solution is to use a LoopBackStringSocket instead of a regular StringSocket, but there is no handy method for that right now....
!
----- Method: NebraskaServer class>>defaultPort (in category 'as yet unclassified') -----
defaultPort
^9091!
----- Method: NebraskaServer class>>extremelyBigRectangle (in category 'as yet unclassified') -----
extremelyBigRectangle
^(0@0 extent: 5000@5000)!
----- Method: NebraskaServer class>>newForWorld: (in category 'instance creation') -----
newForWorld: aWorld
^self basicNew initializeForWorld: aWorld!
----- Method: NebraskaServer class>>serveWorld: (in category 'instance creation') -----
serveWorld: aWorld
^self serveWorld: aWorld onPort: self defaultPort!
----- Method: NebraskaServer class>>serveWorld:onPort: (in category 'instance creation') -----
serveWorld: aWorld onPort: aPortNumber
| server |
Utilities authorName. "since we will need it later"
server := self newForWorld: aWorld.
server startListeningOnPort: aPortNumber.
^server
"server acceptNullConnection" "server acceptPhonyConnection."
!
----- Method: NebraskaServer>>acceptNewConnections (in category 'networking') -----
acceptNewConnections
| connection |
listenQueue ifNil: [ ^self ].
[ clients size > 20 ifTrue: [ "too many connections!!" ^self ].
connection := listenQueue getConnectionOrNil.
connection isNil ]
whileFalse: [
self addClientFromConnection: (StringSocket on: connection) ].!
----- Method: NebraskaServer>>acceptNullConnection (in category 'networking') -----
acceptNullConnection
| twins |
twins := LoopbackStringSocket newPair.
self addClientFromConnection: twins first.
(NullTerminalMorph new connection: twins second) openInWorld.
!
----- Method: NebraskaServer>>acceptPhonyConnection (in category 'networking') -----
acceptPhonyConnection
| twins |
twins := LoopbackStringSocket newPair.
self addClientFromConnection: twins first.
(NetworkTerminalMorph new connection: twins second) inspect "openInWorld".
!
----- Method: NebraskaServer>>addClientFromConnection: (in category 'networking') -----
addClientFromConnection: connection
| client |
client := NebraskaClient onConnection: connection.
clients add: client.
client extent: world extent depth: worldDepth.
world addRemoteClient: client.
self changed: #numClients.!
----- Method: NebraskaServer>>backlog (in category 'networking') -----
backlog
^clients inject: 0 into: [ :max :each | max max: each backlog]!
----- Method: NebraskaServer>>clients (in category 'accessing') -----
clients
^clients ifNil:[#()].!
----- Method: NebraskaServer>>destroy (in category 'initialization') -----
destroy
self stopListening.
clients do:[:each| each destroy].
self breakDependents.!
----- Method: NebraskaServer>>extent:depth: (in category 'attributes') -----
extent: newExtent depth: newDepth
"modify the extent and/or depth of the shared world"
clients do: [ :client |
client extent: newExtent depth: newDepth ].
world extent: newExtent.
worldDepth := newDepth.!
----- Method: NebraskaServer>>initialize (in category 'initialization') -----
initialize
clients := IdentitySet new.
self extent: 800@600 depth: 16.!
----- Method: NebraskaServer>>initializeForWorld: (in category 'initialization') -----
initializeForWorld: aWorld
world := aWorld.
clients := IdentitySet new.
self extent: world extent depth: Display depth.
aWorld remoteServer: self.!
----- Method: NebraskaServer>>numClients (in category 'attributes') -----
numClients
"return the number of connected clients"
^clients size!
----- Method: NebraskaServer>>processIO (in category 'networking') -----
processIO
self pruneDeadConnections.
self acceptNewConnections.!
----- Method: NebraskaServer>>pruneDeadConnections (in category 'networking') -----
pruneDeadConnections
| deadConnections |
deadConnections := clients select: [ :client | client isConnected not ].
deadConnections do: [ :client |
world removeRemoteClient: client].
deadConnections isEmpty ifTrue:[ ^self ].
clients removeAll: deadConnections.
self changed: #numClients.!
----- Method: NebraskaServer>>sharedWorld (in category 'attributes') -----
sharedWorld
^world!
----- Method: NebraskaServer>>startListeningOnPort: (in category 'networking') -----
startListeningOnPort: portNumber
Socket initializeNetwork.
self stopListening.
listenQueue := ConnectionQueue portNumber: portNumber queueLength: 5.!
----- Method: NebraskaServer>>step (in category 'menus') -----
step
self processIO.
"savedWorld := Processor activeProcess world.
Processor activeProcess setWorld: world."
self flag: #bob. "in this version, world is THE WORLD, so it steps itself"
"world doOneCycle."
"Processor activeProcess setWorld: savedWorld."
clients do: [ :each | each canvas apply: [ :ignore | ]]. "for modes that need a little push"
!
----- Method: NebraskaServer>>stopListening (in category 'networking') -----
stopListening
listenQueue ifNil: [ ^self ].
listenQueue destroy.
listenQueue := nil.!
AlignmentMorphBob1 subclass: #EToyGenericDialogMorph
instanceVariableNames: 'namedFields'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Refactoring'!
----- Method: EToyGenericDialogMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
^ ColorTheme current dialogBorderColor!
----- Method: EToyGenericDialogMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ ColorTheme current dialogBorderWidth!
----- Method: EToyGenericDialogMorph>>genericTextFieldNamed: (in category 'as yet unclassified') -----
genericTextFieldNamed: aString
| newField |
newField := ShowEmptyTextMorph new beAllFont: self myFont;
extent: 400 @ 20;
contentsWrapped: ''.
namedFields at: aString put: newField.
^ newField!
----- Method: EToyGenericDialogMorph>>inAColumnForText: (in category 'as yet unclassified') -----
inAColumnForText: someMorphs
^ (self inAColumn: someMorphs) hResizing: #shrinkWrap;
color: ColorTheme current dialogTextBoxColor;
borderColor: ColorTheme current dialogTextBoxBorderColor;
borderWidth: ColorTheme current dialogButtonBorderWidth;
useRoundedCorners!
----- Method: EToyGenericDialogMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
namedFields := Dictionary new.
self rebuild!
----- Method: EToyGenericDialogMorph>>lockedString: (in category 'as yet unclassified') -----
lockedString: aString
^ self lockedString: aString font: self myFont!
----- Method: EToyGenericDialogMorph>>lockedString:font: (in category 'as yet unclassified') -----
lockedString: aString font: aFont
^ self inAColumn: {(StringMorph contents: aString font: aFont) lock}!
----- Method: EToyGenericDialogMorph>>myFont (in category 'as yet unclassified') -----
myFont
^ Preferences standardEToysFont!
----- Method: EToyGenericDialogMorph>>rebuild (in category 'initialization') -----
rebuild
"rebuilds the receiver"
^ self!
----- Method: EToyGenericDialogMorph>>rightLockedString: (in category 'as yet unclassified') -----
rightLockedString: aString
^ self rightLockedString: aString font: self myFont!
----- Method: EToyGenericDialogMorph>>rightLockedString:font: (in category 'as yet unclassified') -----
rightLockedString: aString font: aFont
^ self inARightColumn: {(StringMorph contents: aString font: aFont) lock}!
EToyGenericDialogMorph subclass: #EToyProjectRenamerMorph
instanceVariableNames: 'actionBlock theProject'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Refactoring'!
EToyProjectRenamerMorph subclass: #EToyProjectDetailsMorph
instanceVariableNames: 'projectDetails'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Refactoring'!
----- Method: EToyProjectDetailsMorph class>>getFullInfoFor:ifValid:expandedFormat: (in category 'as yet unclassified') -----
getFullInfoFor: aProject ifValid: aBlock expandedFormat: expandedFormat
| me |
(me := self basicNew)
expandedFormat: expandedFormat;
project: aProject
actionBlock: [ :x |
aProject world setProperty: #ProjectDetails toValue: x.
x at: 'projectname' ifPresent: [ :newName |
aProject renameTo: newName.
].
me delete.
aBlock value.
];
initialize;
becomeModal;
openCenteredInWorld!
----- Method: EToyProjectDetailsMorph class>>test1: (in category 'as yet unclassified') -----
test1: aProject
"EToyProjectDetailsMorph test1: Project current"
(self basicNew)
project: aProject
actionBlock: [ :x |
aProject world setProperty: #ProjectDetails toValue: x.
x at: 'projectname' ifPresent: [ :newName |
aProject renameTo: newName.
]
];
initialize;
openCenteredInWorld!
----- Method: EToyProjectDetailsMorph>>copyOutDetails (in category 'as yet unclassified') -----
copyOutDetails
| newDetails |
newDetails := Dictionary new.
self fieldToDetailsMappings do: [ :each |
namedFields at: each first ifPresent: [ :field |
newDetails at: each second put: field contents string
].
].
namedFields at: 'projectname' ifPresent: [ :field |
newDetails at: 'projectname' put: field contents string withBlanksTrimmed.
].
^newDetails!
----- Method: EToyProjectDetailsMorph>>doExpand (in category 'as yet unclassified') -----
doExpand
self expandedFormat: true.
self copyOutDetails.
self rebuild.
!
----- Method: EToyProjectDetailsMorph>>doOK (in category 'as yet unclassified') -----
doOK
self validateTheProjectName ifFalse: [^false].
actionBlock value: self copyOutDetails.
self delete.!
----- Method: EToyProjectDetailsMorph>>expandButton (in category 'as yet unclassified') -----
expandButton
^self
buttonNamed: 'More' translated
action: #doExpand
color: self buttonColor
help: 'Show more info on this project.' translated.
!
----- Method: EToyProjectDetailsMorph>>expandedFormat (in category 'as yet unclassified') -----
expandedFormat
^ Preferences expandedPublishing
or: [self valueOfProperty: #expandedFormat ifAbsent: [false]]
!
----- Method: EToyProjectDetailsMorph>>expandedFormat: (in category 'as yet unclassified') -----
expandedFormat: aBoolean
self setProperty: #expandedFormat toValue: aBoolean!
----- Method: EToyProjectDetailsMorph>>fieldToDetailsMappings (in category 'as yet unclassified') -----
fieldToDetailsMappings
^#(
(#description 'projectdescription' 'Description:' 100)
(#author 'projectauthor' 'Author:' 20)
(#category 'projectcategory' 'Category:' 20)
(#subCategory 'projectsubcategory' 'Sub-category:' 20)
(#keywords 'projectkeywords' 'Key words:' 20)
)
!
----- Method: EToyProjectDetailsMorph>>fillInDetails (in category 'as yet unclassified') -----
fillInDetails
theProject ifNotNil: [
namedFields at: 'projectname' ifPresent: [ :field |
field contentsWrapped: theProject name
].
].
projectDetails ifNotNil: [
self fieldToDetailsMappings do: [ :each |
namedFields at: each first ifPresent: [ :field |
projectDetails at: each second ifPresent: [ :data |
field contentsWrapped: data
].
].
].
].!
----- Method: EToyProjectDetailsMorph>>project:actionBlock: (in category 'as yet unclassified') -----
project: aProject actionBlock: aBlock
theProject := aProject.
actionBlock := aBlock.
projectDetails := theProject world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new]!
----- Method: EToyProjectDetailsMorph>>projectDetails: (in category 'as yet unclassified') -----
projectDetails: aDictionary
projectDetails := aDictionary.!
----- Method: EToyProjectDetailsMorph>>rebuild (in category 'initialization') -----
rebuild
| bottomButtons |
self removeAllMorphs.
self addARow: {
self
lockedString: 'Please describe this project' translated
font: Preferences standardEToysTitleFont.
}.
self addARow: {self space }.
self addARow: {
self rightLockedString: 'Name:' translated.
self inAColumnForText: {self fieldForProjectName}
}.
self expandedFormat ifTrue: [
self fieldToDetailsMappings do: [ :each |
self addARow: {
self rightLockedString: each third translated.
self inAColumnForText: {(self genericTextFieldNamed: each first) height: each fourth}
}.
].
].
self addARow: {self space }.
bottomButtons := self expandedFormat
ifTrue: [ { self okButton. self cancelButton } ]
ifFalse: [ { self okButton. self expandButton. self cancelButton } ].
self addARow: bottomButtons.
self fillInDetails.!
----- Method: EToyProjectDetailsMorph>>space (in category 'initialization') -----
space
^ RectangleMorph new extent: 5 @ 5;
color: Color transparent;
borderWidth: 0 !
EToyProjectDetailsMorph subclass: #EToyProjectQueryMorph
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Refactoring'!
----- Method: EToyProjectQueryMorph class>>onServer: (in category 'as yet unclassified') -----
onServer: aProjectServer
"EToyProjectQueryMorph onServer: SuperSwikiServer testOnlySuperSwiki"
| criteria clean |
(self basicNew)
project: nil
actionBlock: [ :x |
criteria := OrderedCollection new.
x keysAndValuesDo: [ :k :v |
(clean := v withBlanksTrimmed) isEmpty
ifFalse: [criteria add: k,': *',clean,'*']].
aProjectServer queryProjectsAndShow: criteria];
initialize;
becomeModal;
openCenteredInWorld!
----- Method: EToyProjectQueryMorph class>>test1: (in category 'as yet unclassified') -----
test1: aProject
"EToyProjectQueryMorph test1: nil"
| criteria clean |
(self basicNew)
project: aProject
actionBlock: [ :x |
criteria := OrderedCollection new.
x keysAndValuesDo: [ :k :v |
(clean := v withBlanksTrimmed) isEmpty ifFalse: [
criteria add: k,': *',clean,'*'
].
].
SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow: criteria
];
initialize;
openCenteredInWorld!
----- Method: EToyProjectQueryMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color
r: 0.545
g: 0.47
b: 0.621!
----- Method: EToyProjectQueryMorph>>doOK (in category 'as yet unclassified') -----
doOK
actionBlock value: self copyOutDetails.
self delete.!
----- Method: EToyProjectQueryMorph>>fillInDetails (in category 'as yet unclassified') -----
fillInDetails
"leave them blank for now"!
----- Method: EToyProjectQueryMorph>>project:actionBlock: (in category 'as yet unclassified') -----
project: ignored actionBlock: aBlock
actionBlock := aBlock.
projectDetails := Dictionary new.!
----- Method: EToyProjectQueryMorph>>rebuild (in category 'as yet unclassified') -----
rebuild
self removeAllMorphs.
self addARow: {
self lockedString: 'Enter things to search for'.
}.
self addARow: {
self lockedString: 'Name:'.
self inAColumnForText: {self fieldForProjectName}
}.
self fieldToDetailsMappings do: [ :each |
self addARow: {
self lockedString: each third.
self inAColumnForText: {(self genericTextFieldNamed: each first) height: each fourth}
}.
].
self addARow: {
self okButton.
self cancelButton.
}.
self fillInDetails.!
----- Method: EToyProjectRenamerMorph class>>validate:andDo: (in category 'as yet unclassified') -----
validate: aProject andDo: aBlock
(self new)
project: aProject actionBlock: aBlock;
openCenteredInWorld!
----- Method: EToyProjectRenamerMorph>>buttonColor (in category 'as yet unclassified') -----
buttonColor
^color darker!
----- Method: EToyProjectRenamerMorph>>buttonNamed:action:color:help: (in category 'as yet unclassified') -----
buttonNamed: aString action: aSymbol color: aColor help: helpString
| f col |
f := SimpleButtonMorph new
target: self;
label: aString translated font: self myFont;
color: aColor;
borderColor: aColor muchDarker;
actionSelector: aSymbol;
setBalloonText: helpString translated.
col := (self inAColumn: {f}) hResizing: #spaceFill.
^col!
----- Method: EToyProjectRenamerMorph>>cancelButton (in category 'as yet unclassified') -----
cancelButton
^ self
buttonNamed: 'Cancel'
action: #doCancel
color: ColorTheme current cancelColor
help: 'Cancel this Publish operation.'!
----- Method: EToyProjectRenamerMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ ColorTheme current dialogColor!
----- Method: EToyProjectRenamerMorph>>doCancel (in category 'as yet unclassified') -----
doCancel
self delete.!
----- Method: EToyProjectRenamerMorph>>doOK (in category 'as yet unclassified') -----
doOK
self validateTheProjectName ifFalse: [^self].
self delete.
actionBlock value: (namedFields at: 'projectname') contents string withBlanksTrimmed.!
----- Method: EToyProjectRenamerMorph>>fieldForProjectName (in category 'as yet unclassified') -----
fieldForProjectName
| tm |
tm := self genericTextFieldNamed: 'projectname'.
tm crAction: (MessageSend receiver: self selector: #doOK).
tm setBalloonText: 'Pick a name 24 characters or less and avoid the following characters:
: < > | / \ ? * " .' translated.
^tm
!
----- Method: EToyProjectRenamerMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self vResizing: #shrinkWrap;
hResizing: #shrinkWrap;
layoutInset: 4;
useRoundedCorners;
rebuild!
----- Method: EToyProjectRenamerMorph>>okButton (in category 'as yet unclassified') -----
okButton
^ self
buttonNamed: 'OK'
action: #doOK
color: ColorTheme current okColor
help: 'Change my name and continue publishing.'!
----- Method: EToyProjectRenamerMorph>>project:actionBlock: (in category 'as yet unclassified') -----
project: aProject actionBlock: aBlock
theProject := aProject.
actionBlock := aBlock.
(namedFields at: 'projectname') contentsWrapped: theProject name.!
----- Method: EToyProjectRenamerMorph>>rebuild (in category 'as yet unclassified') -----
rebuild
self removeAllMorphs.
self addARow: {
self lockedString: 'Please name this project'.
}.
self addARow: {
self inAColumnForText: {self fieldForProjectName}
}.
self addARow: {
self okButton.
self cancelButton.
}.
!
----- Method: EToyProjectRenamerMorph>>validateTheProjectName (in category 'as yet unclassified') -----
validateTheProjectName
| proposed |
proposed _ (namedFields at: 'projectname') contents string withBlanksTrimmed.
proposed isEmpty ifTrue: [
self inform: 'I do need a name for the project' translated.
^false
].
proposed size > 24 ifTrue: [
self inform: 'Please make the name 24 characters or less' translated.
^false
].
(Project isBadNameForStoring: proposed) ifTrue: [
self inform: 'Please remove any funny characters from the name' translated.
^false
].
proposed = theProject name ifTrue: [^true].
(ChangesOrganizer changeSetNamed: proposed) ifNotNil: [
Utilities inform: 'Sorry that name is already used' translated.
^false
].
^true!
AlignmentMorphBob1 subclass: #NebraskaServerMorph
instanceVariableNames: 'server slowCounter previousBacklog lastFullUpdateTime currentStatusString fullDisplay previousClients currentBacklogString'
classVariableNames: ''
poolDictionaries: ''
category: 'Nebraska-Morphic-Remote'!
!NebraskaServerMorph commentStamp: '<historical>' prior: 0!
A cheezy morph that simply steps a Nebraska server instance over and over.!
----- Method: NebraskaServerMorph class>>killOldServers (in category 'as yet unclassified') -----
killOldServers
NebraskaServerMorph allInstances do: [ :each |
each delete.
].
NebraskaServer allInstances do: [ :each |
each stopListening.
DependentsFields removeKey: each ifAbsent: [].
].
!
----- Method: NebraskaServerMorph class>>serveWorld (in category 'as yet unclassified') -----
serveWorld
^ self serveWorld: ActiveWorld.
!
----- Method: NebraskaServerMorph class>>serveWorld: (in category 'as yet unclassified') -----
serveWorld: aWorld
"Check to make sure things won't crash. See Mantis #0000519"
aWorld isSafeToServe ifTrue:[
^self serveWorld: aWorld onPort: NebraskaServer defaultPort]
!
----- Method: NebraskaServerMorph class>>serveWorld:onPort: (in category 'as yet unclassified') -----
serveWorld: aWorld onPort: aPortNumber
| server |
server := NebraskaServer serveWorld: aWorld onPort: aPortNumber.
(self new) openInWorld: aWorld.
"server acceptNullConnection" "server acceptPhonyConnection."
!
----- Method: NebraskaServerMorph class>>serveWorldButton (in category 'as yet unclassified') -----
serveWorldButton
| button |
button _ ScriptableButton new.
button target: NebraskaServerMorph.
button actionSelector: #serveWorld.
button arguments: #().
button label: 'Share'.
button color: Color yellow.
^ button.
!
----- Method: NebraskaServerMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') -----
supplementaryPartsDescriptions
^ {DescriptionForPartsBin
formalName: 'NebraskaServer'
categoryList: #('Collaborative')
documentation: 'A button to start the Nebraska desktop sharing server' translated
globalReceiverSymbol: #NebraskaServerMorph
nativitySelector: #serveWorldButton
}!
----- Method: NebraskaServerMorph>>currentBacklogString (in category 'accessing') -----
currentBacklogString
^currentBacklogString!
----- Method: NebraskaServerMorph>>currentStatusString (in category 'accessing') -----
currentStatusString
^currentStatusString!
----- Method: NebraskaServerMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color white!
----- Method: NebraskaServerMorph>>delete (in category 'submorphs-add/remove') -----
delete
self server ifNotNil:[
(self confirm:'Shutdown the server?')
ifTrue:[self world remoteServer: nil]].
super delete.!
----- Method: NebraskaServerMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
fullDisplay := false.
lastFullUpdateTime := 0.
self listDirection: #topToBottom;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap!
----- Method: NebraskaServerMorph>>rebuild (in category 'initialization') -----
rebuild
| myServer toggle closeBox font |
font := StrikeFont familyName: #Palatino size: 14.
self removeAllMorphs.
self setColorsAndBorder.
self updateCurrentStatusString.
toggle := SimpleHierarchicalListMorph new perform: (
fullDisplay ifTrue: [#expandedForm] ifFalse: [#notExpandedForm]
).
closeBox := SimpleButtonMorph new borderWidth: 0;
label: 'X' font: Preferences standardButtonFont; color: Color transparent;
actionSelector: #delete; target: self; extent: 14@14;
setBalloonText: 'End Nebrasks session'.
self addARow: {
self inAColumn: {closeBox}.
self inAColumn: {
UpdatingStringMorph new
useStringFormat;
target: self;
font: font;
getSelector: #currentStatusString;
contents: self currentStatusString;
stepTime: 2000;
lock.
}.
self inAColumn: {
toggle asMorph
on: #mouseUp send: #toggleFull to: self;
setBalloonText: 'Show more or less of Nebraska Status'
}.
}.
myServer := self server.
(myServer isNil or: [fullDisplay not]) ifTrue: [
^World startSteppingSubmorphsOf: self
].
"--- the expanded display ---"
self addARow: {
self inAColumn: {
UpdatingStringMorph new
useStringFormat;
target: self;
font: font;
getSelector: #currentBacklogString;
contents: self currentBacklogString;
stepTime: 2000;
lock.
}.
}.
self addARow: {
self inAColumn: {
(StringMorph contents: '--clients--' translated) lock; font: font.
}.
}.
myServer clients do: [ :each |
self addARow: {
UpdatingStringMorph new
useStringFormat;
target: each;
font: font;
getSelector: #currentStatusString;
contents: each currentStatusString;
stepTime: 2000;
lock.
}
].
World startSteppingSubmorphsOf: self.!
----- Method: NebraskaServerMorph>>server (in category 'accessing') -----
server
^self world remoteServer!
----- Method: NebraskaServerMorph>>setColorsAndBorder (in category 'initialization') -----
setColorsAndBorder
| worldColor c |
c := ((Preferences menuColorFromWorld and: [Display depth > 4])
and: [(worldColor := self currentWorld color) isColor])
ifTrue:
[worldColor luminance > 0.7
ifTrue: [worldColor mixed: 0.8 with: Color black]
ifFalse: [worldColor mixed: 0.4 with: Color white]]
ifFalse: [Preferences menuColor].
self color: c.
self borderColor: #raised.
self borderWidth: Preferences menuBorderWidth.
self useRoundedCorners!
----- Method: NebraskaServerMorph>>step (in category 'stepping and presenter') -----
step
| now |
self server ifNil: [ ^self ].
self server step.
now := Time millisecondClockValue.
(now - lastFullUpdateTime) abs > 5000 ifTrue: [
lastFullUpdateTime := now.
(previousBacklog = self server backlog and: [self server clients = previousClients]) ifFalse: [
previousClients := self server clients copy.
self rebuild
]
].
!
----- Method: NebraskaServerMorph>>stepTime (in category 'testing') -----
stepTime
^10!
----- Method: NebraskaServerMorph>>toggleFull (in category 'initialization') -----
toggleFull
fullDisplay := fullDisplay not.
self rebuild.
!
----- Method: NebraskaServerMorph>>update: (in category 'updating') -----
update: aSymbol
self rebuild.!
----- Method: NebraskaServerMorph>>updateCurrentStatusString (in category 'drawing') -----
updateCurrentStatusString
self server ifNil:[
currentStatusString := '<Nebraska not active>' translated.
currentBacklogString := ''.
] ifNotNil:[
currentStatusString :=
' Nebraska: ' translated,
self server numClients printString,
' clients' translated.
currentBacklogString := 'backlog: ' translated,
((previousBacklog := self server backlog) // 1024) printString,'k'
].
!
----- Method: MorphicTransform class>>fromRemoteCanvasEncoding: (in category '*nebraska-instance creation') -----
fromRemoteCanvasEncoding: encoded
"DisplayTransform fromRemoteCanvasEncoding: 'Morphic,-88,-128,1.345165663873898,0.1352584843149221'"
| type offsetXEnc offsetYEnc scaleEnc angleEnc offsetX offsetY angle scale rs |
"separate the numbers"
rs := ReadStream on: encoded.
type := rs upTo: $,.
offsetXEnc := rs upTo: $,.
offsetYEnc := rs upTo: $,.
scaleEnc := rs upTo: $,.
angleEnc := rs upToEnd.
"decode the numbers"
offsetX := Integer readFromString: offsetXEnc.
offsetY := Integer readFromString: offsetYEnc.
scale := Number readFromString: scaleEnc.
angle := Number readFromString: angleEnc.
"create an instance"
^self offset: offsetX@offsetY angle: angle scale: scale!
----- Method: MorphicTransform>>encodeForRemoteCanvas (in category '*nebraska-*nebraska-Morphic-Remote') -----
encodeForRemoteCanvas
"encode this transform into a string for use by a RemoteCanvas"
^String streamContents: [ :str |
str nextPutAll: 'Morphic,';
print: offset x truncated;
nextPut: $,;
print: offset y truncated;
nextPut: $,;
print: scale;
nextPut: $,;
print: angle
]!
1
0
13 Jan '09
A new version of Packages-Library was added to project Packages:
http://www.squeaksource.com/Packages/Packages-Library-kph.25.mcz
==================== Summary ====================
Name: Packages-Library-kph.25
Author: test
Time: 13 January 2009, 4:20:49 pm
UUID: dd71be16-6785-45e5-bbc9-1ba1d69eac2e
Ancestors: Packages-Library-kph.24
updated
=============== Diff against Packages-Library-kph.24 ===============
Item was added:
+ ----- Method: PackagesDevU>>OmniBrowserSUnitGUI (in category 'Development') -----
+ OmniBrowserSUnitGUI
+
+ self name: 'OmniBrowser-SUnit-GUI'.
+ self version: '0.47'.
+ info category: 'Development'.
+ info description:
+ 'OmniBrowser-based implementation of TestRunner. Expects SUnit to be already loaded'.
+ info maintainer: 'Dale Henrichs'.
+ info homepage: 'http://seaside.gemstone.com/ss/obsunit.html'.
+ info squeakMapID: ''.
+ info url: 'http://seaside.gemstone.com/ss/obsunit/OB-SUnitGUI-dkh.47.mcz'.
+ self provides: #('OmniBrowser-SUnit-GUI').
+
+ self dependsOn: #('OmniBrowser' 'OmniBrowser-Morphic' 'OmniBrowser-Standard').
+
+ !
Item was changed:
----- Method: PackagesDevU>>OmniBrowserStandard (in category 'Code Browsing') -----
OmniBrowserStandard
self name: 'OmniBrowser-Standard'.
+ self version: '0.384'.
- self version: '0.377'.
info category: 'Code Browsing'.
info description:
'OB-Standard represents the classical system browser implemented with the OmniBrowser framework.'.
info maintainer: 'Colin Putney'.
info homepage: 'http://source.wiresong.ca/ob/'.
info squeakMapID: ''.
+ info url: 'http://source.wiresong.ca/ob/OB-Standard-dr.384.mcz'.
- info url: 'http://source.wiresong.ca/ob/OB-Standard-dr.377.mcz'.
self provides: #().
self dependsOn: #('OmniBrowser').
!
Item was changed:
----- Method: PackagesDevU>>OmniBrowser (in category 'Code Browsing') -----
OmniBrowser
self name: 'OmniBrowser'.
+ self version: '0.434'.
- self version: '0.432'.
info category: 'Code Browsing'.
info description:
'OmniBrowser is a ground up rewrite of the classical system browsers provided
in Smalltalk. It''s designed to be flexible and extensible, so as to encourage
experimentation with new types of development tools, language extensions,
and runtime environments. In fact it''s a framework to build browsers. Install OmniBrowser-Standard to get the new browser using this framework.'.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://source.wiresong.ca/ob/'.
info squeakMapID: '81451b19-7df8-4fc7-8652-b26cc55dd291'.
+ info url: 'http://source.wiresong.ca/ob/OmniBrowser-dr.434.mcz'.
- info url: 'http://source.wiresong.ca/ob/OmniBrowser-dr.432.mcz'.
self provides: #().
self dependsOn: #().
!
Item was changed:
----- Method: PackagesDevU>>Pharopackages (in category 'Distributions') -----
Pharopackages
self name: 'Pharo packages'.
+ self version: '0.11'.
- self version: '0.9'.
info category: 'Distributions'.
info description:
'This package generates a Pharo image prepared for end-users from a Pharo core.'.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://code.google.com/p/pharo/'.
info squeakMapID: ''.
info url: 'http://www.squeaksource.com/ImageForDevelopers/ImageForDevelopers-pharo-dam…'.
self provides: #().
self dependsOn: #('Installer' 'Nile' 'OB-Enhancements' 'OmniBrowser-Refactory' 'OmniBrowser-Regex' 'OmniBrowser-Tools' 'Shout' 'ShoutWorkspace' 'Universes' 'Universes OmniBrowser' 'eCompletion' 'eCompletion-Traits' 'eCompletionOmniBrowser').
!
Item was changed:
----- Method: PackagesDevU>>FileTest (in category 'Model Extension') -----
FileTest
self name: 'File-Test'.
+ self version: '7'.
- self version: '5'.
info category: 'Model Extension'.
info description:
'File-Tests '.
info maintainer: 'keith_hodges(a)yahoo.co.uk'.
info homepage: 'http://wiki.squeak.org/squeak/5929'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Rio/File-Test-test.7.mcz'.
- info url: 'http://www.squeaksource.com/Rio/File-Test-kph.5.mcz'.
self provides: #().
self dependsOn: #('File-Base').
!
Item was changed:
----- Method: PackagesDevU>>Nile (in category 'Model Extension') -----
Nile
self name: 'Nile'.
+ self version: '1.0.124'.
- self version: '1.0.122'.
info category: 'Model Extension'.
info description:
'Nile is a complete reimplementation of the squeak stream hierarchy. It provides:
* traits for code reuse.
* lots of tests: same tests are used for the squeak stream hierarchy and Nile (they are implemented in traits).
* lots of clients to verify the reusability.
* a diagram of the implementation: http://damien.cassou.free.fr/documents/internship_2007/nile/complete_hierar… '.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://www.squeaksource.com/Nile/'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Nile/Nile-All-damiencassou.124.mcz'.
- info url: 'http://www.squeaksource.com/Nile/Nile-All-dc.122.mcz'.
self provides: #().
self dependsOn: #('Nile-Base' 'Nile-Clients' 'Nile-Tests').
!
Item was added:
+ ----- Method: PackagesDev>>SystemLocalization (in category 'Translation') -----
+ SystemLocalization
+
+ self name: 'System-Localization'.
+ self version: '0.2'.
+ info category: 'Translation'.
+ info description:
+ 'gettext support'.
+ info maintainer: 'm.rueger(a)acm.org'.
+ info homepage: ''.
+ info url: 'http://source.impara.de/aida/System-Localization-be.3.mcz'.
+
+ self dependsOn: #('Multilingual-Editor').
+
+ !
Item was added:
+ ----- Method: PackagesDevU>>CassandraClient (in category 'Persistence') -----
+ CassandraClient
+
+ self name: 'CassandraClient'.
+ self version: '1.0'.
+ info category: 'Persistence'.
+ info description:
+ ''.
+ info maintainer: 'shute'.
+ info homepage: 'http://www.squeaksource.com/CassandraClient.html'.
+ info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/CassandraClient/CassandraClient-shute.2.mcz'.
+ self provides: #('CassandraClient').
+
+ self dependsOn: #('Thrift').
+
+ !
Item was added:
+ ----- Method: PackagesDevU>>GemToolsClient (in category 'Network') -----
+ GemToolsClient
+
+ self name: 'GemTools-Client'.
+ self version: '0.345'.
+ info category: 'Network'.
+ info description:
+ 'Installs GLASS client software. Provides development environment UI for OmniBrowser-based tools running in a GemStone server.
+
+ This new version depends upon OSTestRunner, an OmniBrowser-based version of TestRunner
+
+ Note that this package is not only dependent upon certain packages, but it is dependent upon specific versions of those packages in the client image. Here is the list of versions that the client has been tested with:
+ OmniBrowser version 0.432
+ ShoutOmniBrowser version tween.6
+ FFI version 3.9.1
+ OmniBrowser-Morphic version 0.62
+
+ If you experience problems, you should make sure that you have the above versions loaded.
+
+ This version is also dependent upon GLASS.230-dkh.182 (or later) on the GemStone side.'.
+ info maintainer: 'Dale Henrichs'.
+ info homepage: 'http://seaside.gemstone.com/'.
+ info squeakMapID: ''.
+ info url: 'http://seaside.gemstone.com/ss/GLASSClient/GemStone-obi.345.mcz'.
+ self provides: #('GemTools-Client').
+
+ self dependsOn: #('FFI' 'OmniBrowser' 'OmniBrowser-Morphic' 'OmniBrowser-SUnit-GUI' 'ShoutOmniBrowser').
+
+ !
Item was changed:
----- Method: PackagesDevU>>NileBase (in category 'Model Extension') -----
NileBase
self name: 'Nile-Base'.
+ self version: '1.0.59'.
- self version: '1.0.58'.
info category: 'Model Extension'.
info description:
'Nile is a complete reimplementation of the squeak stream hierarchy. It provides:
* traits for code reuse.
* lots of tests: same tests are used for the squeak stream hierarchy and Nile (they are implemented in traits).
* lots of clients to verify the reusability.
* a diagram of the implementation: http://damien.cassou.free.fr/documents/internship_2007/nile/complete_hierar… '.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://www.squeaksource.com/Nile/'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Nile/Nile-Base-damiencassou.59.mcz'.
- info url: 'http://www.squeaksource.com/Nile/Nile-Base-dc.58.mcz'.
self provides: #().
self dependsOn: #().
!
Item was changed:
----- Method: PackagesDevU>>OmniBrowserMorphic (in category 'Code Browsing') -----
OmniBrowserMorphic
self name: 'OmniBrowser-Morphic'.
+ self version: '0.68'.
- self version: '0.63'.
info category: 'Code Browsing'.
info description:
'OB-Standard represents the classical system browser implemented with the OmniBrowser framework.'.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://source.wiresong.ca/ob/'.
info squeakMapID: ''.
+ info url: 'http://source.wiresong.ca/ob/OB-Morphic-dkh.68.mcz'.
- info url: 'http://source.wiresong.ca/ob/OB-Morphic-dr.63.mcz'.
self provides: #().
self dependsOn: #('OmniBrowser' 'OmniBrowser-Standard').
!
Item was added:
+ ----- Method: PackagesDevU>>Thrift (in category 'Persistence') -----
+ Thrift
+
+ self name: 'Thrift'.
+ self version: '1.0'.
+ info category: 'Persistence'.
+ info description:
+ ''.
+ info maintainer: 'shute'.
+ info homepage: 'http://www.squeaksource.com/CassandraClient.html'.
+ info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/CassandraClient/Thrift-shute.1.mcz'.
+ self provides: #('Thrift').
+
+ self dependsOn: #().
+
+ !
Item was changed:
----- Method: PackagesDevU>>OmniBrowserTools (in category 'Development') -----
OmniBrowserTools
self name: 'OmniBrowser-Tools'.
+ self version: '0.52'.
- self version: '0.35'.
info category: 'Development'.
info description:
'Set of tools (debugger, inspector...) rewritten on top of the OmniBrowser framework.'.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: ''.
info squeakMapID: ''.
+ info url: 'http://source.lukas-renggli.ch/omnibrowser/OB-Tools-dkh.52.mcz'.
- info url: 'http://source.lukas-renggli.ch/omnibrowser/OB-Tools-lr.35.mcz'.
self provides: #().
self dependsOn: #('OmniBrowser-Standard').
!
Item was changed:
----- Method: PackagesDevU>>eCompletion (in category 'Code Browsing') -----
eCompletion
self name: 'eCompletion'.
+ self version: '0.102'.
- self version: '0.93'.
info category: 'Code Browsing'.
info description:
'Complete variables, selectors, class names in your browser, workspace, debugger and other code holders.'.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://www.squeaksource.com/eCompletion'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/eCompletion/ECompletion-damiencassou.102.mcz'.
- info url: 'http://www.squeaksource.com/eCompletion/ECompletion-rjl.93.mcz'.
self provides: #().
self dependsOn: #('RoelTyper' 'Shout').
!
Item was added:
+ ----- Method: PackagesDevU>>StreamsReadability (in category 'Kernel') -----
+ StreamsReadability
+
+ self name: 'StreamsReadability'.
+ self version: '0.1'.
+ info category: 'Kernel'.
+ info description:
+ 'Provides Stream-#<< , used by Logging'.
+ info maintainer: 'kph'.
+ info homepage: ''.
+ info squeakMapID: ''.
+ info url: 'http://bugs.squeak.org/file_download.php?file_id=3565&type=bug&e=.st'.
+ self provides: #().
+
+ self dependsOn: #().
+
+ !
Item was changed:
----- Method: PackagesDevU>>NileClients (in category 'Model Extension') -----
NileClients
self name: 'Nile-Clients'.
+ self version: '1.0.94'.
- self version: '1.0.93'.
info category: 'Model Extension'.
info description:
'Nile is a complete reimplementation of the squeak stream hierarchy. It provides:
* traits for code reuse.
* lots of tests: same tests are used for the squeak stream hierarchy and Nile (they are implemented in traits).
* lots of clients to verify the reusability.
* a diagram of the implementation: http://damien.cassou.free.fr/documents/internship_2007/nile/complete_hierar… '.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://www.squeaksource.com/Nile/'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Nile/Nile-Clients-damiencassou.94.mcz'.
- info url: 'http://www.squeaksource.com/Nile/Nile-Clients-dc.93.mcz'.
self provides: #().
self dependsOn: #('Nile-Base' 'Nile-Tests').
!
Item was added:
+ ----- Method: PackagesDev>>MultilingualEditor (in category 'Translation') -----
+ MultilingualEditor
+
+ self name: 'Multilingual-Editor'.
+ self version: '0.2'.
+ info category: 'Translation'.
+ info description:
+ 'gettext support'.
+ info maintainer: 'm.rueger(a)acm.org'.
+ info homepage: ''.
+ info url: 'http://source.impara.de/aida/Multilingual-Editor-be.2.mcz'.
+
+ self dependsOn: #().
+
+ !
Item was changed:
----- Method: PackagesDevU>>FileBase (in category 'Model Extension') -----
FileBase
self name: 'File-Base'.
+ self version: '10'.
- self version: '8'.
info category: 'Model Extension'.
info description:
'A file IO interface inspired by http://rio.rubyforge.org , potentially replaces FileDirectory/FileMan.
Transparently supports archives and ftp filesystems'.
info maintainer: 'keith_hodges(a)yahoo.co.uk'.
info homepage: 'http://wiki.squeak.org/squeak/5929'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Rio/File-Base-test.10.mcz'.
- info url: 'http://www.squeaksource.com/Rio/File-Base-kph.8.mcz'.
self provides: #().
self dependsOn: #('File-Kernel').
!
Item was changed:
----- Method: PackagesDevU>>OBEnhancements (in category 'Code Browsing') -----
OBEnhancements
self name: 'OB-Enhancements'.
+ self version: '0.284'.
- self version: '0.265'.
info category: 'Code Browsing'.
info description:
'OB-Enhancements extend the OmniBrowser framework with new features such as multiple selection of elements in columns, a package-based view on the image instead of using just class categories, or smart groups to categorize source artifacts.
This package requires the latest version of the OmniBrowser framework.'.
info maintainer: 'David Röthlisberger'.
info homepage: 'http://source.wiresong.ca/ob/'.
info squeakMapID: ''.
+ info url: 'http://source.wiresong.ca/ob/OB-Enhancements-dr.284.mcz'.
- info url: 'http://source.wiresong.ca/ob/OB-Enhancements-dr.265.mcz'.
self provides: #().
self dependsOn: #('OmniBrowser' 'OmniBrowser-Morphic' 'OmniBrowser-Standard').
!
Item was changed:
----- Method: PackagesDevU>>SqueakDBX (in category 'Persistence') -----
SqueakDBX
self name: 'SqueakDBX'.
+ self version: '0.8'.
- self version: '0.7.1'.
info category: 'Persistence'.
info description:
'OpenDBX plugin, provides db connection to free and commercial databases.
+ Currently supports: PostgreSQL, mySQL, Oracle, sqlite3 and MSSQL.
- Currently supports: PostgreSQL, mySQL and Oracle (MSSQL and others should work, but not tested yet).
Use FFI to talk to OpenDBX.
It works in Unix, OSX and (through MinGW) Windows. '.
info maintainer: 'EL'.
info homepage: 'http://wiki.squeak.org/squeak/6052'.
+ info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/SqueakDBX/OpenDBX-Core-MMP.117.mcz'.
- info squeakMapID: 'cef1978a-9b8a-4804-8071-016512b97e64'.
- info url: 'http://www.squeaksource.com/SqueakDBX/OpenDBX-Core-EL.62.mcz'.
self provides: #().
self dependsOn: #('FFI').
!
Item was changed:
----- Method: PackagesDevU>>ProcessSpecific (in category 'System') -----
ProcessSpecific
self name: 'ProcessSpecific'.
+ self version: '1.0.18'.
- self version: '1.0.15'.
info category: 'System'.
info description:
'My subclasses (not instances of them) keep state specific to the current process.
There are two kinds of process-specific variables: process-local (state available
for read and write in all methods inside the process), and dynamic variables
(implementing dynamic scope).
Includes tests and example: DateAndTimeWarp
Includes extension (if not loaded ignore) for seaside for debugging.'.
info maintainer: 'keith_hodges(a)yahoo.co.uk'.
info homepage: ''.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Logging/ProcessSpecific-kph.18.mcz'.
- info url: 'http://www.squeaksource.com/Logging/ProcessSpecific-kph.15.mcz'.
self provides: #('ProcessSpecific').
self dependsOn: #().
!
Item was changed:
----- Method: PackagesDevU>>FileKernel (in category 'Model Extension') -----
FileKernel
self name: 'File-Kernel'.
+ self version: '10'.
- self version: '8'.
info category: 'Model Extension'.
info description:
'A file IO interface inspired by http://rio.rubyforge.org , potentially replaces FileDirectory.
This package contains only the kernel of Rio. See the package File-Base to get the full distribution.'.
info maintainer: 'keith_hodges(a)yahoo.co.uk'.
info homepage: 'http://wiki.squeak.org/squeak/5929'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Rio/File-Kernel-test.10.mcz'.
- info url: 'http://www.squeaksource.com/Rio/File-Kernel-kph.8.mcz'.
self provides: #().
self dependsOn: #().
!
Item was changed:
----- Method: PackagesDevU>>NileTests (in category 'Model Extension') -----
NileTests
self name: 'Nile-Tests'.
+ self version: '1.0.67'.
- self version: '1.0.65'.
info category: 'Model Extension'.
info description:
'Nile is a complete reimplementation of the squeak stream hierarchy. It provides:
* traits for code reuse.
* lots of tests: same tests are used for the squeak stream hierarchy and Nile (they are implemented in traits).
* lots of clients to verify the reusability.
* a diagram of the implementation: http://damien.cassou.free.fr/documents/internship_2007/nile/complete_hierar… '.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://www.squeaksource.com/Nile/'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Nile/Nile-Tests-damiencassou.67.mcz'.
- info url: 'http://www.squeaksource.com/Nile/Nile-Tests-damiencassou.65.mcz'.
self provides: #().
self dependsOn: #('Nile-Base').
!
Item was changed:
----- Method: PackagesDevU>>Pier (in category 'Web Development') -----
Pier
self name: 'Pier'.
+ self version: 'currentnew'.
- self version: 'current'.
info category: 'Web Development'.
info description:
'Pier with some common plugins. A good package to get started with Pier development or deployment.'.
info maintainer: 'lr'.
info homepage: 'http://www.lukas-renggli.ch/smalltalk/pier'.
info squeakMapID: ''.
info url: nil.
self provides: #().
+ self dependsOn: #('Magritte-Tests' 'Pier-Blog' 'Pier-Documents' 'Pier-EditorEnh' 'Pier-Seaside' 'Pier-Security' 'Pier-Tests').
- self dependsOn: #('Magritte-Tests' 'Pier-Blog' 'Pier-Documents' 'Pier-EditorEnh' 'Pier-OmniBrowser' 'Pier-Seaside' 'Pier-Security' 'Pier-Tests').
!
Item was changed:
----- Method: PackagesDevU>>Logging (in category 'Development') -----
Logging
self name: 'Logging'.
+ self version: '3.42'.
- self version: '3.27'.
info category: 'Development'.
info description:
'Logging for squeak, a front end to Toothpick OR SimpleLog (apologies to LogEngine)
usage:
self log this.
self log x: 10 y: 20.
and much more...
'.
info maintainer: 'Keith Hodges <keith_hodges(a)yahoo.co.uk>'.
info homepage: 'http://wiki.squeak.org/squeak/3706'.
info squeakMapID: '6c1b03cd-6c37-4acf-b971-72ff132c03f0'.
+ info url: 'http://www.squeaksource.com/Logging/Logging-kph.42.mcz'.
- info url: 'http://www.squeaksource.com/Logging/Logging-kph.27.mcz'.
self provides: #('Logging').
+ self dependsOn: #('ProcessSpecific' 'StreamsReadability').
- self dependsOn: #('KernelExt-kph' 'ProcessSpecific').
!
Item was removed:
- ----- Method: PackagesDevU>>GLASSClient (in category 'Network') -----
- GLASSClient
-
- self name: 'GLASS Client'.
- self version: '0.312'.
- info category: 'Network'.
- info description:
- 'Installs GLASS client software. Provides development environment UI for OmniBrowser-based tools running in a GemStone server.
-
- Note that this package is not only dependent upon certain packages, but it is dependent upon specific versions of those packages in the client image. Here is the list of versions that the client has been tested with:
- OmniBrowser version 0.432
- ShoutOmniBrowser version tween.6
- FFI version 3.9.1
- OmniBrowser-Morphic version 0.62
-
- If you experience problems, you should make sure that you have the above versions loaded.
-
- This version is also dependent upon GLASS.230-dkh.182 (or later) on the GemStone side.'.
- info maintainer: 'Dale Henrichs'.
- info homepage: 'http://seaside.gemstone.com/'.
- info squeakMapID: ''.
- info url: 'http://seaside.gemstone.com/ss/GLASSClient/GemStone-dkh.312.mcz'.
- self provides: #('GemStone').
-
- self dependsOn: #('FFI' 'OmniBrowser' 'OmniBrowser-Morphic' 'ShoutOmniBrowser').
-
- !
1
0
A new version of Sake-Core was added to project Sake :
http://www.squeaksource.com/Sake/Sake-Core-kph.95.mcz
==================== Summary ====================
Name: Sake-Core-kph.95
Author: test
Time: 13 January 2009, 3:56:24 pm
UUID: bfddf117-651e-48be-bf9a-8248de37b113
Ancestors: Sake-Core-kph.94
saving a documentation method now returns boolean indicating whether or not a change occurred
=============== Diff against Sake-Core-kph.94 ===============
Item was changed:
----- Method: SakeTask class>>at:category:putMethod:doc: (in category 'as yet unclassified') -----
at: selector category: cat putMethod: code doc: content
+ "only replace the method source if it has changed, return true/false to indicate whether a change occurred"
+
+ | s source changed |
- | s source |
source := (s := selector asLegalSelector asSymbol) , String cr, code ,String cr, '""""""', String cr, content.
+ (changed := (self sourceCodeAt: s ifAbsent: nil) ~= source) ifTrue: [
+ self compile: source classified: cat notifying: nil.
+ ].
+
+ ^ changed!
- (self sourceCodeAt: s ifAbsent: nil) ~= source ifTrue: [
-
- self compile: source classified: cat notifying: nil
- ]
- !
1
0
Packages: Packages-Library-damiencassou.25.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 13 Jan '09
by squeak-dev-noreply＠lists.squeakfoundation.org 13 Jan '09
13 Jan '09
Damien Cassou uploaded a new version of Packages-Library to project Packages:
http://www.squeaksource.com/Packages/Packages-Library-damiencassou.25.mcz
==================== Summary ====================
Name: Packages-Library-damiencassou.25
Author: damiencassou
Time: 13 January 2009, 2:46:40 pm
UUID: ce624608-de90-4c43-932b-225516ddfe56
Ancestors: Packages-Library-kph.24
- Updates Universe packages
=============== Diff against Packages-Library-kph.24 ===============
Item was added:
+ ----- Method: PackagesDevU>>OmniBrowserSUnitGUI (in category 'Development') -----
+ OmniBrowserSUnitGUI
+
+ self name: 'OmniBrowser-SUnit-GUI'.
+ self version: '0.47'.
+ info category: 'Development'.
+ info description:
+ 'OmniBrowser-based implementation of TestRunner. Expects SUnit to be already loaded'.
+ info maintainer: 'Dale Henrichs'.
+ info homepage: 'http://seaside.gemstone.com/ss/obsunit.html'.
+ info squeakMapID: ''.
+ info url: 'http://seaside.gemstone.com/ss/obsunit/OB-SUnitGUI-dkh.47.mcz'.
+ self provides: #('OmniBrowser-SUnit-GUI').
+
+ self dependsOn: #('OmniBrowser' 'OmniBrowser-Morphic' 'OmniBrowser-Standard').
+
+ !
Item was changed:
----- Method: PackagesDevU>>OmniBrowserStandard (in category 'Code Browsing') -----
OmniBrowserStandard
self name: 'OmniBrowser-Standard'.
+ self version: '0.384'.
- self version: '0.377'.
info category: 'Code Browsing'.
info description:
'OB-Standard represents the classical system browser implemented with the OmniBrowser framework.'.
info maintainer: 'Colin Putney'.
info homepage: 'http://source.wiresong.ca/ob/'.
info squeakMapID: ''.
+ info url: 'http://source.wiresong.ca/ob/OB-Standard-dr.384.mcz'.
- info url: 'http://source.wiresong.ca/ob/OB-Standard-dr.377.mcz'.
self provides: #().
self dependsOn: #('OmniBrowser').
!
Item was changed:
----- Method: PackagesDevU>>OmniBrowser (in category 'Code Browsing') -----
OmniBrowser
self name: 'OmniBrowser'.
+ self version: '0.434'.
- self version: '0.432'.
info category: 'Code Browsing'.
info description:
'OmniBrowser is a ground up rewrite of the classical system browsers provided
in Smalltalk. It''s designed to be flexible and extensible, so as to encourage
experimentation with new types of development tools, language extensions,
and runtime environments. In fact it''s a framework to build browsers. Install OmniBrowser-Standard to get the new browser using this framework.'.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://source.wiresong.ca/ob/'.
info squeakMapID: '81451b19-7df8-4fc7-8652-b26cc55dd291'.
+ info url: 'http://source.wiresong.ca/ob/OmniBrowser-dr.434.mcz'.
- info url: 'http://source.wiresong.ca/ob/OmniBrowser-dr.432.mcz'.
self provides: #().
self dependsOn: #().
!
Item was changed:
----- Method: PackagesDevU>>Pharopackages (in category 'Distributions') -----
Pharopackages
self name: 'Pharo packages'.
+ self version: '0.11'.
- self version: '0.9'.
info category: 'Distributions'.
info description:
'This package generates a Pharo image prepared for end-users from a Pharo core.'.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://code.google.com/p/pharo/'.
info squeakMapID: ''.
info url: 'http://www.squeaksource.com/ImageForDevelopers/ImageForDevelopers-pharo-dam…'.
self provides: #().
self dependsOn: #('Installer' 'Nile' 'OB-Enhancements' 'OmniBrowser-Refactory' 'OmniBrowser-Regex' 'OmniBrowser-Tools' 'Shout' 'ShoutWorkspace' 'Universes' 'Universes OmniBrowser' 'eCompletion' 'eCompletion-Traits' 'eCompletionOmniBrowser').
!
Item was changed:
----- Method: PackagesDevU>>FileTest (in category 'Model Extension') -----
FileTest
self name: 'File-Test'.
+ self version: '7'.
- self version: '5'.
info category: 'Model Extension'.
info description:
'File-Tests '.
info maintainer: 'keith_hodges(a)yahoo.co.uk'.
info homepage: 'http://wiki.squeak.org/squeak/5929'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Rio/File-Test-test.7.mcz'.
- info url: 'http://www.squeaksource.com/Rio/File-Test-kph.5.mcz'.
self provides: #().
self dependsOn: #('File-Base').
!
Item was changed:
----- Method: PackagesDevU>>Nile (in category 'Model Extension') -----
Nile
self name: 'Nile'.
+ self version: '1.0.124'.
- self version: '1.0.122'.
info category: 'Model Extension'.
info description:
'Nile is a complete reimplementation of the squeak stream hierarchy. It provides:
* traits for code reuse.
* lots of tests: same tests are used for the squeak stream hierarchy and Nile (they are implemented in traits).
* lots of clients to verify the reusability.
* a diagram of the implementation: http://damien.cassou.free.fr/documents/internship_2007/nile/complete_hierar… '.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://www.squeaksource.com/Nile/'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Nile/Nile-All-damiencassou.124.mcz'.
- info url: 'http://www.squeaksource.com/Nile/Nile-All-dc.122.mcz'.
self provides: #().
self dependsOn: #('Nile-Base' 'Nile-Clients' 'Nile-Tests').
!
Item was added:
+ ----- Method: PackagesDevU>>CassandraClient (in category 'Persistence') -----
+ CassandraClient
+
+ self name: 'CassandraClient'.
+ self version: '1.0'.
+ info category: 'Persistence'.
+ info description:
+ ''.
+ info maintainer: 'shute'.
+ info homepage: 'http://www.squeaksource.com/CassandraClient.html'.
+ info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/CassandraClient/CassandraClient-shute.2.mcz'.
+ self provides: #('CassandraClient').
+
+ self dependsOn: #('Thrift').
+
+ !
Item was added:
+ ----- Method: PackagesDevU>>GemToolsClient (in category 'Network') -----
+ GemToolsClient
+
+ self name: 'GemTools-Client'.
+ self version: '0.345'.
+ info category: 'Network'.
+ info description:
+ 'Installs GLASS client software. Provides development environment UI for OmniBrowser-based tools running in a GemStone server.
+
+ This new version depends upon OSTestRunner, an OmniBrowser-based version of TestRunner
+
+ Note that this package is not only dependent upon certain packages, but it is dependent upon specific versions of those packages in the client image. Here is the list of versions that the client has been tested with:
+ OmniBrowser version 0.432
+ ShoutOmniBrowser version tween.6
+ FFI version 3.9.1
+ OmniBrowser-Morphic version 0.62
+
+ If you experience problems, you should make sure that you have the above versions loaded.
+
+ This version is also dependent upon GLASS.230-dkh.182 (or later) on the GemStone side.'.
+ info maintainer: 'Dale Henrichs'.
+ info homepage: 'http://seaside.gemstone.com/'.
+ info squeakMapID: ''.
+ info url: 'http://seaside.gemstone.com/ss/GLASSClient/GemStone-obi.345.mcz'.
+ self provides: #('GemTools-Client').
+
+ self dependsOn: #('FFI' 'OmniBrowser' 'OmniBrowser-Morphic' 'OmniBrowser-SUnit-GUI' 'ShoutOmniBrowser').
+
+ !
Item was changed:
----- Method: PackagesDevU>>NileBase (in category 'Model Extension') -----
NileBase
self name: 'Nile-Base'.
+ self version: '1.0.59'.
- self version: '1.0.58'.
info category: 'Model Extension'.
info description:
'Nile is a complete reimplementation of the squeak stream hierarchy. It provides:
* traits for code reuse.
* lots of tests: same tests are used for the squeak stream hierarchy and Nile (they are implemented in traits).
* lots of clients to verify the reusability.
* a diagram of the implementation: http://damien.cassou.free.fr/documents/internship_2007/nile/complete_hierar… '.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://www.squeaksource.com/Nile/'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Nile/Nile-Base-damiencassou.59.mcz'.
- info url: 'http://www.squeaksource.com/Nile/Nile-Base-dc.58.mcz'.
self provides: #().
self dependsOn: #().
!
Item was changed:
----- Method: PackagesDevU>>OmniBrowserMorphic (in category 'Code Browsing') -----
OmniBrowserMorphic
self name: 'OmniBrowser-Morphic'.
+ self version: '0.68'.
- self version: '0.63'.
info category: 'Code Browsing'.
info description:
'OB-Standard represents the classical system browser implemented with the OmniBrowser framework.'.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://source.wiresong.ca/ob/'.
info squeakMapID: ''.
+ info url: 'http://source.wiresong.ca/ob/OB-Morphic-dkh.68.mcz'.
- info url: 'http://source.wiresong.ca/ob/OB-Morphic-dr.63.mcz'.
self provides: #().
self dependsOn: #('OmniBrowser' 'OmniBrowser-Standard').
!
Item was added:
+ ----- Method: PackagesDevU>>Thrift (in category 'Persistence') -----
+ Thrift
+
+ self name: 'Thrift'.
+ self version: '1.0'.
+ info category: 'Persistence'.
+ info description:
+ ''.
+ info maintainer: 'shute'.
+ info homepage: 'http://www.squeaksource.com/CassandraClient.html'.
+ info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/CassandraClient/Thrift-shute.1.mcz'.
+ self provides: #('Thrift').
+
+ self dependsOn: #().
+
+ !
Item was changed:
----- Method: PackagesDevU>>OmniBrowserTools (in category 'Development') -----
OmniBrowserTools
self name: 'OmniBrowser-Tools'.
+ self version: '0.52'.
- self version: '0.35'.
info category: 'Development'.
info description:
'Set of tools (debugger, inspector...) rewritten on top of the OmniBrowser framework.'.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: ''.
info squeakMapID: ''.
+ info url: 'http://source.lukas-renggli.ch/omnibrowser/OB-Tools-dkh.52.mcz'.
- info url: 'http://source.lukas-renggli.ch/omnibrowser/OB-Tools-lr.35.mcz'.
self provides: #().
self dependsOn: #('OmniBrowser-Standard').
!
Item was changed:
----- Method: PackagesDevU>>eCompletion (in category 'Code Browsing') -----
eCompletion
self name: 'eCompletion'.
+ self version: '0.102'.
- self version: '0.93'.
info category: 'Code Browsing'.
info description:
'Complete variables, selectors, class names in your browser, workspace, debugger and other code holders.'.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://www.squeaksource.com/eCompletion'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/eCompletion/ECompletion-damiencassou.102.mcz'.
- info url: 'http://www.squeaksource.com/eCompletion/ECompletion-rjl.93.mcz'.
self provides: #().
self dependsOn: #('RoelTyper' 'Shout').
!
Item was added:
+ ----- Method: PackagesDevU>>StreamsReadability (in category 'Kernel') -----
+ StreamsReadability
+
+ self name: 'StreamsReadability'.
+ self version: '0.1'.
+ info category: 'Kernel'.
+ info description:
+ 'Provides Stream-#<< , used by Logging'.
+ info maintainer: 'kph'.
+ info homepage: ''.
+ info squeakMapID: ''.
+ info url: 'http://bugs.squeak.org/file_download.php?file_id=3565&type=bug&e=.st'.
+ self provides: #().
+
+ self dependsOn: #().
+
+ !
Item was changed:
----- Method: PackagesDevU>>NileClients (in category 'Model Extension') -----
NileClients
self name: 'Nile-Clients'.
+ self version: '1.0.94'.
- self version: '1.0.93'.
info category: 'Model Extension'.
info description:
'Nile is a complete reimplementation of the squeak stream hierarchy. It provides:
* traits for code reuse.
* lots of tests: same tests are used for the squeak stream hierarchy and Nile (they are implemented in traits).
* lots of clients to verify the reusability.
* a diagram of the implementation: http://damien.cassou.free.fr/documents/internship_2007/nile/complete_hierar… '.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://www.squeaksource.com/Nile/'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Nile/Nile-Clients-damiencassou.94.mcz'.
- info url: 'http://www.squeaksource.com/Nile/Nile-Clients-dc.93.mcz'.
self provides: #().
self dependsOn: #('Nile-Base' 'Nile-Tests').
!
Item was changed:
----- Method: PackagesDevU>>FileBase (in category 'Model Extension') -----
FileBase
self name: 'File-Base'.
+ self version: '10'.
- self version: '8'.
info category: 'Model Extension'.
info description:
'A file IO interface inspired by http://rio.rubyforge.org , potentially replaces FileDirectory/FileMan.
Transparently supports archives and ftp filesystems'.
info maintainer: 'keith_hodges(a)yahoo.co.uk'.
info homepage: 'http://wiki.squeak.org/squeak/5929'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Rio/File-Base-test.10.mcz'.
- info url: 'http://www.squeaksource.com/Rio/File-Base-kph.8.mcz'.
self provides: #().
self dependsOn: #('File-Kernel').
!
Item was changed:
----- Method: PackagesDevU>>OBEnhancements (in category 'Code Browsing') -----
OBEnhancements
self name: 'OB-Enhancements'.
+ self version: '0.284'.
- self version: '0.265'.
info category: 'Code Browsing'.
info description:
'OB-Enhancements extend the OmniBrowser framework with new features such as multiple selection of elements in columns, a package-based view on the image instead of using just class categories, or smart groups to categorize source artifacts.
This package requires the latest version of the OmniBrowser framework.'.
info maintainer: 'David Röthlisberger'.
info homepage: 'http://source.wiresong.ca/ob/'.
info squeakMapID: ''.
+ info url: 'http://source.wiresong.ca/ob/OB-Enhancements-dr.284.mcz'.
- info url: 'http://source.wiresong.ca/ob/OB-Enhancements-dr.265.mcz'.
self provides: #().
self dependsOn: #('OmniBrowser' 'OmniBrowser-Morphic' 'OmniBrowser-Standard').
!
Item was changed:
----- Method: PackagesDevU>>SqueakDBX (in category 'Persistence') -----
SqueakDBX
self name: 'SqueakDBX'.
+ self version: '0.8'.
- self version: '0.7.1'.
info category: 'Persistence'.
info description:
'OpenDBX plugin, provides db connection to free and commercial databases.
+ Currently supports: PostgreSQL, mySQL, Oracle, sqlite3 and MSSQL.
- Currently supports: PostgreSQL, mySQL and Oracle (MSSQL and others should work, but not tested yet).
Use FFI to talk to OpenDBX.
It works in Unix, OSX and (through MinGW) Windows. '.
info maintainer: 'EL'.
info homepage: 'http://wiki.squeak.org/squeak/6052'.
+ info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/SqueakDBX/OpenDBX-Core-MMP.117.mcz'.
- info squeakMapID: 'cef1978a-9b8a-4804-8071-016512b97e64'.
- info url: 'http://www.squeaksource.com/SqueakDBX/OpenDBX-Core-EL.62.mcz'.
self provides: #().
self dependsOn: #('FFI').
!
Item was changed:
----- Method: PackagesDevU>>ProcessSpecific (in category 'System') -----
ProcessSpecific
self name: 'ProcessSpecific'.
+ self version: '1.0.18'.
- self version: '1.0.15'.
info category: 'System'.
info description:
'My subclasses (not instances of them) keep state specific to the current process.
There are two kinds of process-specific variables: process-local (state available
for read and write in all methods inside the process), and dynamic variables
(implementing dynamic scope).
Includes tests and example: DateAndTimeWarp
Includes extension (if not loaded ignore) for seaside for debugging.'.
info maintainer: 'keith_hodges(a)yahoo.co.uk'.
info homepage: ''.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Logging/ProcessSpecific-kph.18.mcz'.
- info url: 'http://www.squeaksource.com/Logging/ProcessSpecific-kph.15.mcz'.
self provides: #('ProcessSpecific').
self dependsOn: #().
!
Item was changed:
----- Method: PackagesDevU>>FileKernel (in category 'Model Extension') -----
FileKernel
self name: 'File-Kernel'.
+ self version: '10'.
- self version: '8'.
info category: 'Model Extension'.
info description:
'A file IO interface inspired by http://rio.rubyforge.org , potentially replaces FileDirectory.
This package contains only the kernel of Rio. See the package File-Base to get the full distribution.'.
info maintainer: 'keith_hodges(a)yahoo.co.uk'.
info homepage: 'http://wiki.squeak.org/squeak/5929'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Rio/File-Kernel-test.10.mcz'.
- info url: 'http://www.squeaksource.com/Rio/File-Kernel-kph.8.mcz'.
self provides: #().
self dependsOn: #().
!
Item was changed:
----- Method: PackagesDevU>>NileTests (in category 'Model Extension') -----
NileTests
self name: 'Nile-Tests'.
+ self version: '1.0.67'.
- self version: '1.0.65'.
info category: 'Model Extension'.
info description:
'Nile is a complete reimplementation of the squeak stream hierarchy. It provides:
* traits for code reuse.
* lots of tests: same tests are used for the squeak stream hierarchy and Nile (they are implemented in traits).
* lots of clients to verify the reusability.
* a diagram of the implementation: http://damien.cassou.free.fr/documents/internship_2007/nile/complete_hierar… '.
info maintainer: 'Damien Cassou <damien.cassou(a)gmail.com>'.
info homepage: 'http://www.squeaksource.com/Nile/'.
info squeakMapID: ''.
+ info url: 'http://www.squeaksource.com/Nile/Nile-Tests-damiencassou.67.mcz'.
- info url: 'http://www.squeaksource.com/Nile/Nile-Tests-damiencassou.65.mcz'.
self provides: #().
self dependsOn: #('Nile-Base').
!
Item was changed:
----- Method: PackagesDevU>>Pier (in category 'Web Development') -----
Pier
self name: 'Pier'.
+ self version: 'currentnew'.
- self version: 'current'.
info category: 'Web Development'.
info description:
'Pier with some common plugins. A good package to get started with Pier development or deployment.'.
info maintainer: 'lr'.
info homepage: 'http://www.lukas-renggli.ch/smalltalk/pier'.
info squeakMapID: ''.
info url: nil.
self provides: #().
+ self dependsOn: #('Magritte-Tests' 'Pier-Blog' 'Pier-Documents' 'Pier-EditorEnh' 'Pier-Seaside' 'Pier-Security' 'Pier-Tests').
- self dependsOn: #('Magritte-Tests' 'Pier-Blog' 'Pier-Documents' 'Pier-EditorEnh' 'Pier-OmniBrowser' 'Pier-Seaside' 'Pier-Security' 'Pier-Tests').
!
Item was changed:
----- Method: PackagesDevU>>Logging (in category 'Development') -----
Logging
self name: 'Logging'.
+ self version: '3.42'.
- self version: '3.27'.
info category: 'Development'.
info description:
'Logging for squeak, a front end to Toothpick OR SimpleLog (apologies to LogEngine)
usage:
self log this.
self log x: 10 y: 20.
and much more...
'.
info maintainer: 'Keith Hodges <keith_hodges(a)yahoo.co.uk>'.
info homepage: 'http://wiki.squeak.org/squeak/3706'.
info squeakMapID: '6c1b03cd-6c37-4acf-b971-72ff132c03f0'.
+ info url: 'http://www.squeaksource.com/Logging/Logging-kph.42.mcz'.
- info url: 'http://www.squeaksource.com/Logging/Logging-kph.27.mcz'.
self provides: #('Logging').
+ self dependsOn: #('ProcessSpecific' 'StreamsReadability').
- self dependsOn: #('KernelExt-kph' 'ProcessSpecific').
!
Item was removed:
- ----- Method: PackagesDevU>>GLASSClient (in category 'Network') -----
- GLASSClient
-
- self name: 'GLASS Client'.
- self version: '0.312'.
- info category: 'Network'.
- info description:
- 'Installs GLASS client software. Provides development environment UI for OmniBrowser-based tools running in a GemStone server.
-
- Note that this package is not only dependent upon certain packages, but it is dependent upon specific versions of those packages in the client image. Here is the list of versions that the client has been tested with:
- OmniBrowser version 0.432
- ShoutOmniBrowser version tween.6
- FFI version 3.9.1
- OmniBrowser-Morphic version 0.62
-
- If you experience problems, you should make sure that you have the above versions loaded.
-
- This version is also dependent upon GLASS.230-dkh.182 (or later) on the GemStone side.'.
- info maintainer: 'Dale Henrichs'.
- info homepage: 'http://seaside.gemstone.com/'.
- info squeakMapID: ''.
- info url: 'http://seaside.gemstone.com/ss/GLASSClient/GemStone-dkh.312.mcz'.
- self provides: #('GemStone').
-
- self dependsOn: #('FFI' 'OmniBrowser' 'OmniBrowser-Morphic' 'ShoutOmniBrowser').
-
- !
1
0