[Pkg] Squeak3.11 Contributions: Nebraska-kph.14.mcz
squeak-dev-noreply at lists.squeakfoundation.org
squeak-dev-noreply at lists.squeakfoundation.org
Tue Jan 13 20:19:22 UTC 2009
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 at height depth: depth bits: bits
].
^(ColorForm extent: width at 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 at 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 at y corner: cornerX at 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 at 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 at 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 at 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 at 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 at 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 at 100 extent: 300 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 0 corner: 0.5 at 1.0).
nameTextMorph := PluggableTextMorph on: self text: #name accept: nil.
nameTextMorph askBeforeDiscardingEdits: false.
window addMorph: nameTextMorph frame: (0.5 at 0 corner: 1.0 at 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 at 0.4 corner: 0.75 at 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 at 0.4 corner: 1.0 at 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 at 0.7 corner: 0.75 at 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 at 0.7 corner: 1.0 at 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 at 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 at 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 at 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 at 0.4 corner: 0.5 at 0.7).
(playButton := self playButton) center: 200 at 300.
window addMorph: playButton frame: (0.5 at 0.4 corner: 1.0 at 0.7).
(myOpenConnectionButton := self connectButton) center: 250 at 300.
window addMorph: myOpenConnectionButton frame: (0.5 at 0 corner: 1.0 at 0.4).
(myStopButton := self recordAndStopButton) center: 300 at 300.
window addMorph: myStopButton frame: (0.5 at 0.7 corner: 1.0 at 1.0).
myUpdatingText := UpdatingStringMorph on: self selector: #objectsInQueue.
window addMorph: myUpdatingText frame: (0.41 at 0.75 corner: 0.45 at 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 at 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 at 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 at 100;
extent: 200 at 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 at 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 at 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 at 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 at 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 at 0 extent: 350 at 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 at charm.net'
userIPAddress: '1.2.3.4';
position: 200 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 25) * factor.
capExtent := (30 at 30) * factor.
earExtent := (15 at 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 at 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 at 25) * factor.
baseExtent := (15 at 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 at len). botCent - (len negated at 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 at 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 at 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 at 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 at 0 extent: 99999 at 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 at 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 at 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 at 0
sourceOrigin: 0 at 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 at 0
sourceOrigin: 0 at 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 at 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 at 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 at 0)]) ifTrue:[
pattern _ aFillStyle form.
(aFillStyle direction = (pattern width @ 0)
and:[aFillStyle normal = (0 at 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 at 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 at 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 at 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 at 0).
MouseDownForm := UncheckedForm := (Form
extent: 12 at 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 at 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 at 0 extent: 5000 at 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 at 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 at 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 at 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
]!
More information about the Packages
mailing list