tim Rowledge uploaded a new version of SMLoader to project The Trunk:
http://source.squeak.org/trunk/SMLoader-tpr.101.mcz
==================== Summary ====================
Name: SMLoader-tpr.101
Author: tpr
Time: 7 November 2023, 4:09:38.903981 pm
UUID: 0728d977-6079-4877-8491-52ad519499a9
Ancestors: SMLoader-mt.100
If for some reason there is no WebClient class installed when the SMClient wants to start up we can load the package; but it's quite important to load the latest version as oposed to one from the distant days of circa 2015
=============== Diff against SMLoader-mt.100 ===============
Item was changed:
----- Method: SMClient class>>installWebClient (in category 'private') -----
installWebClient
Installer ss
project: 'WebClient';
+ install: 'WebClient'!
- install: 'WebClient-Core-ar.92.mcz'!
1
0
tim Rowledge uploaded a new version of WebClient-Tests to project The Trunk:
http://source.squeak.org/trunk/WebClient-Tests-tpr.64.mcz
==================== Summary ====================
Name: WebClient-Tests-tpr.64
Author: tpr
Time: 29 October 2023, 6:00:45.760151 pm
UUID: 0cd122d2-a7b8-443a-b449-77f0da833bc4
Ancestors: WebClient-Tests-mt.63
Update json related WebClient tests.
Some are simply redundant if we have changed to use Json instead of the older internal code. Some still require a little thought.
Some of the number tests might be good to move to the JsonTests class since they extend the testing in #testAtomNumber.
There's still some possible debate about when and how wide character containing String should be dealt with. What about those \u escaped non-ascii chars?
=============== Diff against WebClient-Tests-mt.63 ===============
Item was removed:
- ----- Method: WebClientServerTest>>testArrays (in category 'tests - json') -----
- testArrays
- "Test array encodings"
-
- self assert: (self decode: '[]') = #().
- self assert: (self decode: '[[]]') = #(#()).
- self assert: (self decode: '[[], []]') = #(#() #()).
- self assert: (self decode: '["hello", "world", 123]') = #('hello' 'world' 123).
- self assert: (self decode: '[["true", false, null]]') = #(('true' false nil)).
-
- self assert: (self encode: #()) = '[]'.
- self assert: (self encode: #(#())) = '[[]]'.
- self assert: (self encode: #(#() #()) ) = '[[], []]'.
- self assert: (self encode: #('hello' 'world' 123)) = '["hello", "world", 123]'.
- self assert: (self encode: #(('true' false nil))) = '[["true", false, null]]'.
-
- self should: [self decode: '['] raise: Error.
- self should: [self decode: '[}'] raise: Error.
- self should: [self decode: '{[}'] raise: Error.
- self should: [self decode: '[[[]]'] raise: Error.
- !
Item was removed:
- ----- Method: WebClientServerTest>>testDictionaries (in category 'tests - json') -----
- testDictionaries
- "Test dictionary encodings"
-
- self assert: (self decode: '{}') = (Dictionary new).
-
- self assert: (self decode: '{"foo" : "bar"}')
- equals: (Dictionary newFromPairs: {
- 'foo'. 'bar'
- }).
-
- self assert: (self decode: '{"stuff" : [[], 42, "hello"]}')
- equals: (Dictionary newFromPairs: {
- 'stuff'. #(() 42 'hello')
- }).
-
- self assert: (self decode: '{"x" : 42, "y": "77", "z": 0.1}')
- equals: (Dictionary newFromPairs: {
- 'x'. 42.
- 'y'. '77'.
- 'z'. 0.1
- }).
-
-
- self assert: (self encode: Dictionary new) = '{}'.
-
- self assert: (self encode: (Dictionary newFromPairs: {
- 'foo'. 'bar'
- })) equals: '{"foo": "bar"}'.
-
- self assert: (self encode: (Dictionary newFromPairs: {
- 'stuff'. #(() 42 'hello')
- })) equals: '{"stuff": [[], 42, "hello"]}'.
-
- self assert: (self encode: (Dictionary newFromPairs: {
- 'x'. 42.
- 'y'. '77'.
- 'z'. 0.1
- })) equals: '{"x": 42, "y": "77", "z": 0.1}'.
-
- self should: [self decode: '{'] raise: Error.
- self should: [self decode: '{]'] raise: Error.
- self should: [self decode: '[{]'] raise: Error.
- self should: [self decode: '{"a"}'] raise: Error.
- self should: [self decode: '{42: "hello"}'] raise: Error.
- self should: [self decode: '{"a" : 42,}'] raise: Error.
- self should: [self decode: '{"a" : 42 "b": 33}'] raise: Error.
-
- self should: [self encode: (Dictionary newFromPairs: {1. 1})] raise: Error.!
Item was removed:
- ----- Method: WebClientServerTest>>testNilTrueFalse (in category 'tests - json') -----
- testNilTrueFalse
- "Test encodings of nil, true, false"
-
- self assert: (self decode: 'true') = true.
- self assert: (self decode: 'false') = false.
- self assert: (self decode: 'null') = nil.
-
- self assert: (self encode: true) = 'true'.
- self assert: (self encode: false) = 'false'.
- self assert: (self encode: nil) = 'null'.
-
- self should: [self decode: 'nul'] raise: Error.
- self should: [self decode: 'nullll'] raise: Error.
- self should: [self decode: 'tru'] raise: Error.
- self should: [self decode: 'falsef'] raise: Error.
- self should: [self decode: 'truefalse'] raise: Error.
- !
Item was changed:
----- Method: WebClientServerTest>>testNumbers (in category 'tests - json') -----
testNumbers
"Test the encodings of numbers"
self assert: 42 classAndValueEquals: (self decode: '42').
+ self assert: -123 classAndValueEquals: (self decode: '-123').
- self assert: -123 classAndValueEquals: (self decode: '-0123').
self assert: 42.3 classAndValueEquals: (self decode: '42.3').
self assert: -42.9e44 classAndValueEquals: (self decode: '-42.9e44').
self assert: -42.95e-44 classAndValueEquals: (self decode: '-42.95e-44').
+ self assert: 0 classAndValueEquals: (self decode: '-0.0e0'). "Looks like the standard is to return plain zero"
- self assert: -0.0 classAndValueEquals: (self decode: '-0.0e0').
+ self assert: 100 classAndValueEquals: (self decode: '1.0e+2'). "Standard appears to be produce integer"
- self assert: 1.0 classAndValueEquals: (self decode: '1.').
- self assert: 100.0 classAndValueEquals: (self decode: '1.e+2').
self assert: 1000 classAndValueEquals: (self decode: '1e3'). "This remains an Integer like in Squeak, though questionable"
self assert: 0.01 classAndValueEquals: (self decode: '1e-2').
self assert: '42' equals: (self encode: 42).
self assert: '-123' equals: (self encode: -123).
self assert: '42.3' equals: (self encode: 42.3).
self assert: '-4.29e45' equals: (self encode: -42.9e44).
self assert: '-4.295e-43' equals: (self encode: -42.95e-44).
self assert: '-0.0' equals: (self encode: -0.0e0).
+ self should: [self decode: '0x123'] raise: JsonSyntaxError.
+ self should: [self decode: '0123'] raise: JsonSyntaxError.
+ self should: [self decode: '1.'] raise: JsonSyntaxError.
+ self should: [self decode: '1.e2'] raise: JsonSyntaxError.
+ self should: [self decode: '-.e'] raise: JsonSyntaxError.
- self should: [self decode: '0x123'] raise: Error.
- self should: [self decode: '-.e'] raise: Error.
!
Item was changed:
----- Method: WebClientServerTest>>testStrings (in category 'tests - json') -----
testStrings
+ "Test string encodings.
+ These ones are still contentious"
- "Test string encodings"
- self assert: (self decode: '"Hello World"') = 'Hello World'.
- self assert: (self decode: '"\"Hello World\""') = '"Hello World"'.
- self assert: (self decode: '"foo\\bar\/baz"') = 'foo\bar/baz'.
- self assert: (self decode: '""') = ''.
- self assert: (self decode: '"foo \u0026 bar"') = 'foo & bar'.
- self assert: (self decode: '"\r\n"') = String crlf.
self assert: (self decode: '"\u041F\u0440\u0430\u0432\u0434\u0430"')
equals: #[208 159 209 128 208 176 208 178 208 180 208 176] asString utf8ToSqueak.
-
- self assert: (self encode: 'Hello World') = '"Hello World"'.
- self assert: (self encode: '"Hello World"') = '"\"Hello World\""'.
- self assert: (self encode: 'foo\bar/baz') = '"foo\\bar\/baz"'.
- self assert: (self encode: '') = '""'.
self assert: (self encode: 'foo ', (Character value: 257),' bar') = '"foo \u0101 bar"'.
- self assert: (self encode: String crlf) = '"\r\n"'.
-
self assert: (self encode: #[208 159 209 128 208 176 208 178 208 180 208 176] asString utf8ToSqueak)
equals: '"\u041F\u0440\u0430\u0432\u0434\u0430"'.
+ !
-
- self should: [self decode: '"hello'] raise: Error.
- self should: [self decode: '"\'] raise: Error.
- self should: [self decode: '"\"'] raise: Error.!
1
0
tim Rowledge uploaded a new version of WebClient-Core to project The Trunk:
http://source.squeak.org/trunk/WebClient-Core-tpr.135.mcz
==================== Summary ====================
Name: WebClient-Core-tpr.135
Author: tpr
Time: 29 October 2023, 5:55:50.903884 pm
UUID: 04c4b5e6-fe5a-4d04-b6d1-1b3e25a0d85c
Ancestors: WebClient-Core-tpr.134
A proposal to convert WebUtils to use Json instead of the older internal code.
- divert #jsonEncode: to use Json render:
- divert #jsonDecode: to use Json readFrom and check at the end for potential single-atom issue
- divert #jsonFromString to String parseAsJson
- remove all the theoretically now-unused methods.
Relies upon JSON-ul.57
NB: we also seem to have some json related code deep in monticello classes. Maybe they should be looked at.
=============== Diff against WebClient-Core-tpr.134 ===============
Item was removed:
- ----- Method: WebUtils class>>jsonArray:on: (in category 'json-encode') -----
- jsonArray: anArray on: stream
- "Encodes an array"
-
- stream nextPut: $[.
- anArray
- do:[:each| self jsonObj: each on: stream]
- separatedBy:[stream nextPutAll:', '].
- stream nextPut:$].
- !
Item was removed:
- ----- Method: WebUtils class>>jsonArrayFrom: (in category 'json-decode') -----
- jsonArrayFrom: stream
- "Decodes a JSON [value, *] array from the stream"
-
- | ch result |
- (ch := stream next) = $[ ifFalse:[^self error: 'JSON Array expected'].
- stream skipSeparators.
- stream peek = $] ifTrue:[stream next. ^#()].
- result := WriteStream on: (Array new: 10).
- ["Decode the next value"
- stream skipSeparators.
- result nextPut: (self jsonDecode: stream).
- stream skipSeparators.
- (ch := stream next) = $]] whileFalse:[
- ch = $, ifFalse:[^self error: 'Comma expected'].
- ].
-
- ^result contents!
Item was removed:
- ----- Method: WebUtils class>>jsonChar:on: (in category 'json-encode') -----
- jsonChar: aCharacter on: stream
- "Writes a single encoded character"
-
- | ascii |
- ascii := aCharacter asciiValue.
-
- ascii < 32 ifTrue:["Control character"
- ascii caseOf: {
- [13] -> [^stream nextPutAll: '\r'].
- [12] -> [^stream nextPutAll: '\f'].
- [10] -> [^stream nextPutAll: '\n'].
- [9] -> [^stream nextPutAll: '\t'].
- [8] -> [^stream nextPutAll: '\b'].
- } otherwise:[
- ^stream nextPutAll: '\u'; nextPutAll:
- ((ascii printStringBase: 16) padded: #left to: 4 with: $0)
- ].
- ].
-
- (ascii >= 32 and:[ascii <=127]) ifTrue:["Ascii character"
- (ascii = 34 or:[ascii = 92 or:[ascii = 47]]) ifTrue:[stream nextPut: $\].
- ^stream nextPut: aCharacter
- ].
-
- "Encode other characters (control chars, accents, umlauts, unicode)"
- stream nextPutAll:
- '\u', (((ascii bitAnd: 16rFFFF) printStringBase: 16) padded: #left to: 4 with: $0).
- !
Item was removed:
- ----- Method: WebUtils class>>jsonCharFrom: (in category 'json-decode') -----
- jsonCharFrom: stream
- "Decodes a backslash-escaped character"
-
- | ch |
- ^(ch := stream next) caseOf: {
- [$u] -> [Unicode value:
- (Integer readFrom: (stream next: 4) readStream base: 16)].
- [$r] -> [Character cr].
- [$n] -> [Character lf].
- [$t] -> [Character tab].
- [$b] -> [Character backspace].
- [$f] -> [Character newPage].
- } otherwise:[ch].
- !
Item was changed:
----- Method: WebUtils class>>jsonDecode: (in category 'json-decode') -----
jsonDecode: stream
+ "Decodes an arbitrary JSON encoded value from the given stream.
+ Checks the stream atEnd in order to catch some mildly obscure single-atom input errors"
- "Decodes an arbitrary JSON encoded value from the given stream"
+ | parser result |
+ parser := Json new.
+ result := parser readFrom: stream.
+ stream atEnd ifFalse: [ parser invalid: 'Unexpected data at end of input' ].
+ ^result!
- stream skipSeparators.
- ^stream peek caseOf: {
- [$"] -> [self jsonStringFrom: stream].
- [$t] -> [self jsonTrueFrom: stream].
- [$f] -> [self jsonFalseFrom: stream].
- [$n] -> [self jsonNullFrom: stream].
- [${] -> [self jsonMapFrom: stream].
- [$[] -> [self jsonArrayFrom: stream].
- } otherwise:[self jsonNumberFrom: stream].
- !
Item was changed:
----- Method: WebUtils class>>jsonEncode: (in category 'json-encode') -----
jsonEncode: anObject
"Encode the given object as JSON"
+ ^Json render: anObject!
- ^String streamContents:[:s| self jsonObj: anObject on: s]!
Item was removed:
- ----- Method: WebUtils class>>jsonFalseFrom: (in category 'json-decode') -----
- jsonFalseFrom: stream
- "Decodes 'false' from aStream"
-
- ((stream next: 5) = 'false'
- and:[stream atEnd or:[stream peek isAlphaNumeric not]])
- ifFalse:[^self error: 'Expected ''false'''].
- ^false!
Item was removed:
- ----- Method: WebUtils class>>jsonFloatSignificand:exp10: (in category 'json-decode') -----
- jsonFloatSignificand: value exp10: exponent
- "Take care to convert to nearest Float"
- ^self jsonFloatSignificand: value exp10: exponent scale: (10 raisedTo: exponent abs)!
Item was removed:
- ----- Method: WebUtils class>>jsonFloatSignificand:exp10:scale: (in category 'json-decode') -----
- jsonFloatSignificand: value exp10: exponent scale: scale
- "Take care to convert to nearest Float"
- "self assert: scale = (10 raisedTo: exponent abs)."
- ^(value isAnExactFloat and: ["scale isAnExactFloat"
- exponent between: -22 and: 22
- "(1 to: 100) detect: [:i | (10 raisedTo: i) isAnExactFloat not]"])
- ifTrue: [exponent >= 0
- ifTrue: [value asExactFloat * scale asExactFloat]
- ifFalse: [value asExactFloat / scale asExactFloat]]
- ifFalse: [exponent >= 0
- ifTrue: [(value * scale) asFloat]
- ifFalse: [(Fraction numerator: value denominator: scale) asFloat]]!
Item was changed:
----- Method: WebUtils class>>jsonFromString: (in category 'json-decode') -----
jsonFromString: aString
+ ^aString parseAsJson!
- ^ self jsonDecode: aString readStream!
Item was removed:
- ----- Method: WebUtils class>>jsonMap:on: (in category 'json-encode') -----
- jsonMap: aDictionary on: stream
- "Encodes a dictionary"
-
- stream nextPut: ${.
- "Sorting keys ensures deterministic order"
- aDictionary keys asArray sort do:[:key|
- self jsonString: key on: stream.
- stream nextPutAll:': '.
- self jsonObj: (aDictionary at: key) on: stream.
- ] separatedBy:[stream nextPutAll: ', '].
- stream nextPut: $}.!
Item was removed:
- ----- Method: WebUtils class>>jsonMapFrom: (in category 'json-decode') -----
- jsonMapFrom: stream
- "Decodes a JSON {key:value, *} object from the stream"
-
- | map ch key value |
- map := Dictionary new.
- (ch := stream next) = ${ ifFalse:[^self error: 'JSON Object expected'].
- stream skipSeparators.
- stream peek = $} ifTrue:[^map].
-
- ["Decode the next key:value pair"
- stream skipSeparators.
- key := self jsonStringFrom: stream.
- stream skipSeparators.
- stream next = $: ifFalse:[^self error: 'Key-value pair expected'].
- value := self jsonDecode: stream.
- map at: key put: value.
- stream skipSeparators.
- (ch := stream next) = $}] whileFalse:[
- ch = $, ifFalse:[^self error: 'Comma expected'].
- ].
-
- ^map!
Item was removed:
- ----- Method: WebUtils class>>jsonNullFrom: (in category 'json-decode') -----
- jsonNullFrom: stream
- "Decodes 'null' from aStream"
-
- ((stream next: 4) = 'null'
- and:[stream atEnd or:[stream peek isAlphaNumeric not]])
- ifFalse:[^self error: 'Expected ''null'''].
- ^nil!
Item was removed:
- ----- Method: WebUtils class>>jsonNumber:on: (in category 'json-encode') -----
- jsonNumber: aNumber on: stream
- "Encodes a number"
-
- | value |
- value := aNumber.
- value isInteger ifFalse:[value := aNumber asFloat].
- stream print: aNumber.
- !
Item was removed:
- ----- Method: WebUtils class>>jsonNumberFrom: (in category 'json-decode') -----
- jsonNumberFrom: stream
- "Decodes a JSON number from the stream"
-
- | ascii ch integer fraction scale sign expSign exponent exp value beFloat |
- integer := fraction := exponent := exp := 0. sign := scale := expSign := 1.
- ascii := stream next asciiValue.
- ascii = 45 "$- asciiValue" ifTrue:[
- sign := -1.
- ascii := stream next asciiValue.
- ].
- "JSON requires at least one digit"
- (ascii >= 48 and:[ascii <= 57]) ifFalse:[^self error: 'Digit expected'].
-
- "Read the integer part"
- integer := ascii - 48.
- [ch := stream next ifNil:[^integer * sign].
- ascii := ch asciiValue.
- ascii >= 48 and:[ascii <= 57]] whileTrue:[
- integer := (integer * 10) + (ascii - 48).
- ].
-
- (beFloat := ascii = 46) "$. asciiValue" ifTrue:[
- "Read the fraction part"
- [ch := stream next ifNil:
- [value := integer * scale + fraction * sign.
- ^self jsonFloatSignificand: value exp10: exponent scale: scale].
- ascii := ch asciiValue.
- ascii >= 48 and:[ascii <= 57]] whileTrue:[
- fraction := (fraction * 10) + (ascii - 48).
- exponent := exponent - 1.
- scale := scale * 10.
- ].
- value := integer * scale + fraction * sign.
- ] ifFalse:[value := integer * sign].
- (ascii = 69 "$E asciiValue" or:[ascii = 101 "$e asciiValue"]) ifTrue:[
- "Read exponent"
- ascii := stream next asciiValue.
- ascii = 45 "$- asciiValue" ifTrue:[
- expSign := -1.
- ascii := stream next asciiValue.
- ] ifFalse:[ascii = 43 "$+ asciiValue" ifTrue:[ascii := stream next asciiValue]].
- exp := ascii - 48.
- [ch := stream next ifNil:
- [exponent := exp * expSign + exponent.
- (beFloat or: [expSign = -1]) ifTrue: [^self jsonFloatSignificand: value exp10: exponent].
- ^value * (10 raisedTo: exponent)].
- ascii := ch asciiValue.
- ascii >= 48 and:[ascii <= 57]] whileTrue:[
- exp := (exp * 10) + (ascii - 48).
- ].
- exponent := exp * expSign + exponent
- ].
-
- "Skip back before last character since number might be part of a sequence
- like 1, 2, 3, 4, etc (which would eat the trailing comma)"
- ch isAlphaNumeric ifTrue:[^self error: 'Delimiter expected'].
- stream skip: -1.
-
- (beFloat or: [expSign = -1]) ifTrue: [^self jsonFloatSignificand: value exp10: exponent].
- ^value * (10 raisedTo: exponent)!
Item was removed:
- ----- Method: WebUtils class>>jsonObj:on: (in category 'json-encode') -----
- jsonObj: anObject on: stream
- "Encode a generic object"
-
- anObject isString ifTrue:[^self jsonString: anObject on: stream].
- anObject isNumber ifTrue:[^self jsonNumber: anObject on: stream].
- anObject == nil ifTrue:[^stream nextPutAll: 'null'].
- anObject == true ifTrue:[^stream nextPutAll: 'true'].
- anObject == false ifTrue:[^stream nextPutAll: 'false'].
- anObject isArray ifTrue:[^self jsonArray: anObject on: stream].
- anObject isDictionary ifTrue:[^self jsonMap: anObject on: stream].
-
- self error: 'Cannot encode: ', anObject!
Item was removed:
- ----- Method: WebUtils class>>jsonString:on: (in category 'json-encode') -----
- jsonString: aString on: stream
- "Encodes a string"
-
- stream nextPut: $".
- aString do:[:ch| self jsonChar: ch on: stream].
- stream nextPut: $".
- !
Item was removed:
- ----- Method: WebUtils class>>jsonStringFrom: (in category 'json-decode') -----
- jsonStringFrom: stream
- "Decodes a JSON encoded string"
-
- | ch result |
- (ch := stream next) = $"
- ifFalse:[^self error: 'String expected'].
- result := WriteStream on: (String new: 20).
- [(ch := stream next) == nil] whileFalse:[
- ch = $" ifTrue:[^result contents].
- ch = $\ ifTrue:[ch := self jsonCharFrom: stream].
- result nextPut: ch.
- ].
- ^self error: 'Unterminated string'!
Item was removed:
- ----- Method: WebUtils class>>jsonTrueFrom: (in category 'json-decode') -----
- jsonTrueFrom: stream
- "Decodes 'true' from aStream"
-
- ((stream next: 4) = 'true'
- and:[stream atEnd or:[stream peek isAlphaNumeric not]])
- ifFalse:[^self error: 'Expected ''true'''].
- ^true!
1
0
tim Rowledge uploaded a new version of JSON to project The Trunk:
http://source.squeak.org/trunk/JSON-ul.57.mcz
==================== Summary ====================
Name: JSON-ul.57
Author: ul
Time: 29 October 2023, 6:42:54.166011 pm
UUID: c4b6cadf-54b3-40b2-8099-2ec44c498bc8
Ancestors: JSON-ul.56
- parse negative zero as negative zero with any exponent
- the convenience methods String >> #parseAsJson and #parseAsOrderedJson will raise an error unless all the bytes of the input string have been consumed during parsing
=============== Diff against JSON-ul.56 ===============
Item was changed:
----- Method: JsonNumberParser>>nextNumber: (in category 'parsing-public') -----
nextNumber: negative
| numberOfTrailingZeroInIntegerPart oldLeadingZeroesAllowed numberOfTrailingZeroInFractionPart numberOfNonZeroFractionDigits mantissa value |
integerPart := self nextUnsignedIntegerOrNil ifNil: [ ^self error: 'Missing integer part!!' ].
numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero.
(sourceStream peekFor: $.) ifFalse: [ "No fraction part"
negative ifTrue: [ integerPart := integerPart negated ].
self readExponent ifFalse: [ ^integerPart ].
exponent > 0 ifTrue: [ ^integerPart * (self fiveRaisedTo: exponent) bitShift: exponent ].
^self makeFloatFromMantissa: integerPart exponent: exponent ].
oldLeadingZeroesAllowed := leadingZeroesAllowed.
leadingZeroesAllowed := true.
fractionPart := self nextUnsignedIntegerOrNil.
leadingZeroesAllowed := oldLeadingZeroesAllowed.
fractionPart ifNil: [ self error: 'Missing fraction part!!' ].
fractionPart isZero ifTrue: [
+ value := self readExponent
+ ifFalse: [ integerPart ]
+ ifTrue: [
+ exponent >= 0
+ ifTrue: [ integerPart * (self fiveRaisedTo: exponent) bitShift: exponent ]
+ ifFalse: [ self makeFloatFromMantissa: integerPart exponent: exponent ] ].
+ negative ifFalse: [ ^value ].
+ value isZero ifTrue: [ ^Float negativeZero ].
+ ^value negated ].
- self readExponent ifFalse: [
- negative ifTrue: [
- integerPart isZero ifTrue: [ ^Float negativeZero ].
- ^integerPart negated ].
- ^integerPart ].
- exponent >= 0 ifTrue: [
- negative ifTrue: [ integerPart := integerPart negated ].
- ^integerPart * (self fiveRaisedTo: exponent) bitShift: exponent ].
- value := self makeFloatFromMantissa: integerPart exponent: exponent.
- negative ifTrue: [ ^value negated ].
- ^value ].
numberOfTrailingZeroInFractionPart := nDigits - lastNonZero.
numberOfNonZeroFractionDigits := lastNonZero.
self readExponent.
exponent := exponent - numberOfNonZeroFractionDigits.
mantissa := (integerPart * (self fiveRaisedTo: numberOfNonZeroFractionDigits) bitShift: numberOfNonZeroFractionDigits) + (fractionPart // (self fiveRaisedTo: numberOfTrailingZeroInFractionPart) bitShift: 0 - numberOfTrailingZeroInFractionPart).
value := self makeFloatFromMantissa: mantissa exponent: exponent.
negative ifTrue: [ ^value negated ].
^value!
Item was changed:
----- Method: String>>parseAsJson (in category '*JSON') -----
parseAsJson
"Convenience"
+ ^self parseAsJsonWithDictionaryClass: nil!
- ^Json readFrom: self readStream!
Item was added:
+ ----- Method: String>>parseAsJsonWithDictionaryClass: (in category '*JSON') -----
+ parseAsJsonWithDictionaryClass: aClassOrNil
+ "Convenience"
+
+ | input parser result |
+ parser := Json new.
+ aClassOrNil ifNotNil: [ parser dictionaryClass: aClassOrNil ].
+ input := self readStream.
+ result := parser readFrom: input.
+ input atEnd ifFalse: [ parser invalid: 'Unexpected data at end of input' ].
+ ^result!
Item was changed:
----- Method: String>>parseAsOrderedJson (in category '*JSON') -----
parseAsOrderedJson
"Convenience"
+ ^self parseAsJsonWithDictionaryClass: OrderedJsonObject!
- ^Json new
- dictionaryClass: OrderedJsonObject;
- readFrom: self readStream!
1
0
Marcel Taeumel uploaded a new version of Tests to project The Trunk:
http://source.squeak.org/trunk/Tests-mt.501.mcz
==================== Summary ====================
Name: Tests-mt.501
Author: mt
Time: 7 November 2023, 11:34:39.524949 am
UUID: abcc3d86-5baf-9d4b-bf0c-f3734c8f4072
Ancestors: Tests-mt.500
Let Monticello tests not spill new change sets all over the place. And don't let them add things to the current change set.
=============== Diff against Tests-mt.500 ===============
Item was changed:
----- Method: MCClassDefinitionTest>>tearDown (in category 'running') -----
tearDown
+ Smalltalk at: 'MCMockClassC' ifPresent: [:c | c removeFromSystemUnlogged].
+ super tearDown.!
- Smalltalk at: 'MCMockClassC' ifPresent: [:c | c removeFromSystem].
-
- ^ super tearDown!
Item was changed:
----- Method: MCEnvironmentLoadTest>>tearDown (in category 'running') -----
tearDown
(environment allClassesAndTraits sorted: [:a :b |
(a allSuperclasses includes: b) or: [a name < b name]])
+ do: [:each | each removeFromSystemUnlogged].
- do: [:each | each removeFromSystem].
+ super tearDown.!
- ^ super tearDown!
Item was changed:
----- Method: MCMethodDefinitionTest>>tearDown (in category 'running') -----
tearDown
self restoreMocks.
extensionPackage unregister.
extensionPackage := nil.
MCMockPackageInfo new mcPackage workingCopy unregister.
+ SystemChangeNotifier uniqueInstance doSilently: [
+ self class
+ compile: 'override ^ 1'
+ classified: 'mocks'
+ withStamp: overrideTimestamp
+ notifying: nil].
- self class
- compile: 'override ^ 1'
- classified: 'mocks'
- withStamp: overrideTimestamp
- notifying: nil.
SystemOrganizer default removeEmptyCategories.
+ MCMethodDefinitionTest organization removeEmptyCategories.
self ownPackage modified: isModified.
+ super tearDown.!
- ^ super tearDown!
Item was changed:
TestCase subclass: #MCTestCase
+ instanceVariableNames: 'priorChangeSetNames'
- instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Monticello'!
!MCTestCase commentStamp: 'nice 12/7/2017 00:11' prior: 0!
Abstract superclass for Monticello tests
Monticello is the distributed source code management system.!
Item was added:
+ ----- Method: MCTestCase>>deleteChangeSets (in category 'running') -----
+ deleteChangeSets
+ "Some tests create extra change sets because of, for example, MCPackageLoader>>load. Remove those change sets."
+
+ | toDelete |
+ toDelete := ChangeSet allChangeSetNames copyWithoutAll: priorChangeSetNames.
+ ChangeSet removeChangeSetsNamedSuchThat: [:nm | toDelete includes: nm].!
Item was changed:
----- Method: MCTestCase>>performTest (in category 'private') -----
performTest
Utilities
useAuthorInitials: self className
+ during: [ MCPackageLoader new "TODO: Extract utility method into base system?"
+ useNewChangeSetNamedLike: self className
+ during: [ super performTest ]]!
- during: [ super performTest ]!
Item was changed:
----- Method: MCTestCase>>setUp (in category 'running') -----
setUp
super setUp.
+ priorChangeSetNames := ChangeSet allChangeSetNames.
MCMockPackageInfo new register.!
Item was changed:
----- Method: MCTestCase>>tearDown (in category 'running') -----
tearDown
self clearPackageCache.
+ self deleteChangeSets.
+
+ self flag: #todo. "Unfortunately breaks the tests"
"Environment current packageOrganizer unregisterPackageNamed:
MCSnapshotResource mockPackageName."
- self flag: #todo. "Unfortunately breaks the tests"
+ super tearDown.!
- ^ super tearDown!
1
0
06 Nov '23
Hello to all Squeakers, Smalltalkers, and OO-enthusiasts out there! :-)
Last Saturday, the German Squeakers Assoc. ("Squeak Deutschland e.V." [1]) had a small workshop and club meeting [2]. There were many interesting demos and discussions around Squeak, applied in many different domains:
Christoph Thiede (https://github.com/LinqLover)
"How to make use of ChatGPT in Squeak?"
-> https://github.com/LinqLover/Squeak-SemanticText
Jens Lincke (https://github.com/JensLincke)
"How small can a Squeak image be to run in the cloud?"
-> https://github.com/hpi-swa-lab/cloud-squeak
Marius Dörbandt (https://github.com/MariusDoe)
"A simple Git GUI that handles merge conflicts and assets"
-> https://github.com/hpi-swa/Squot/tree/mapper
Jens Mönig (https://github.com/jmoenig)
"Snap! Blocks all the way down"
-> https://github.com/jmoenig/Snap
Leon Matthes (https://github.com/LeonMatthes)
"Programming the OpenSmalltalk VM is fun! :)"
-> https://github.com/OpenSmalltalk/opensmalltalk-vm
-> https://github.com/hpi-swa-teaching/PowerSqueak
Vanessa Freudenberg (https://github.com/codefrau)
"Saving Etoys projects in SqueakJS"
-> https://squeak.js.org/etoys/#fullscreen
-> https://github.com/codefrau/SqueakJS/
Eva Krebs (https://github.com/ekrebs5)
"Exploratory Babylonian programming in Squeak"
-> https://github.com/hpi-swa-lab/babylonian-programming-smalltalk
Joana Bergsiek (https://github.com/JoeAtHPI)
"Exploring code variations in babylonian-style block-based editors"
-> https://github.com/hpi-swa/Sandblocks
Have fun checking out these projects! :-)
Best,
MarcelÂ
[1] https://squeak.de/squeakev/
[2] https://squeak.de/news/2023/10/02/squeak_treffen/
3
3
Marcel Taeumel uploaded a new version of Tests to project The Trunk:
http://source.squeak.org/trunk/Tests-mt.500.mcz
==================== Summary ====================
Name: Tests-mt.500
Author: mt
Time: 6 November 2023, 9:21:48.067059 am
UUID: e8af30ab-12cc-0244-b4be-0d07ae13d2e2
Ancestors: Tests-ct.499
Clean up two Monticello repository tests. While this change should not have changed anything meaningful, it made 2 failing tests pass again. Note that this clean-up addresses a mixture of instvar access and accessor methods, which is now harmonized in #setUp. The #addVersion: helpers accessed instvars directly anyway.
=============== Diff against Tests-ct.499 ===============
Item was removed:
- ----- Method: MCDictionaryRepositoryTest>>dictionary (in category 'accessing') -----
- dictionary
- ^ dict ifNil: [dict := Dictionary new]!
Item was changed:
----- Method: MCDictionaryRepositoryTest>>setUp (in category 'running') -----
setUp
super setUp.
+ dict := Dictionary new.
+ repository := MCDictionaryRepository new dictionary: dict.!
- repository := MCDictionaryRepository new dictionary: self dictionary!
Item was removed:
- ----- Method: MCDirectoryRepositoryTest>>directory (in category 'accessing') -----
- directory
- directory ifNil:
- [directory := FileDirectory default directoryNamed: 'mctest'.
- directory assureExistence].
- ^ directory!
Item was changed:
----- Method: MCDirectoryRepositoryTest>>setUp (in category 'running') -----
setUp
super setUp.
+ directory := FileDirectory default directoryNamed: 'mctest'.
+ directory assureExistence.
+
+ repository := MCDirectoryRepository directory: directory.!
- repository := MCDirectoryRepository directory: self directory!
Item was changed:
----- Method: MCDirectoryRepositoryTest>>tearDown (in category 'running') -----
tearDown
+ directory recursiveDelete.
+ super tearDown.!
- self directory recursiveDelete.
-
- ^ super tearDown!
1
0
David T. Lewis uploaded a new version of EToys to project The Trunk:
http://source.squeak.org/trunk/EToys-dtl.506.mcz
==================== Summary ====================
Name: EToys-dtl.506
Author: dtl
Time: 4 November 2023, 9:47:21.01997 pm
UUID: 46b0a449-7904-4c43-951d-fae34550da29
Ancestors: EToys-dtl.505
Retain some Etoys classes and methods in the base image, based on Marcel's unload-etoys.33.cs Etoys removal script.
Reference squeak-dev 29-Aug-2023 Let's discuss the future of Etoys in Squeak 6.1 (and beyond)
=============== Diff against EToys-dtl.505 ===============
Item was removed:
- Morph subclass: #CalendarMorph
- instanceVariableNames: 'date stepTime shouldUpdate'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Etoys-Calendar'!
-
- !CalendarMorph commentStamp: 'sw 1/25/2012 21:09' prior: 0!
- CalendarMorph, by Ricardo Moran, 2011, with some changes by Scott Wallace, January 2012.
-
- A CalendarMorph is single-month calendar that is scriptable using tiles in its viewer. It always has a 'selected' date, for which the correct month and year are shown; the actual day corresponding to the selected date is highlighted on the calendar.
- !
Item was removed:
- ----- Method: CalendarMorph class>>additionsToViewerCategories (in category 'viewer categories') -----
- additionsToViewerCategories
- "Answer definitions for viewer categories of a Calendar."
-
- ^ #(
-
- (#'calendar' (
- (slot date 'Shows the selected date' String readOnly Player getDate Player unused )
- (slot day 'Shows the selected day and lets you modify it' Number readWrite Player getDay Player setDay: )
- (slot month 'Shows the selected month and lets you modify it' Number readWrite Player getMonth Player setMonth: )
- (slot year 'Shows the selected year and lets you modify it' Number readWrite Player getYear Player setYear: )
-
- (slot dayName 'Shows the name of the selected day' String readOnly Player getDayName Player unused )
- (slot monthName 'Shows the name of the selected month' String readOnly Player getMonthName Player unused )
- (slot dateFormat 'Lets you choose a format for displaying the date' DateFormat readWrite Player getDateFormat Player setDateFormat: )
-
- (command goToToday 'Show the current month and highlight the current day on it')
- (slot julianDay 'The Julian day of the selected date' Number readWrite Player getJulianDay Player setJulianDay:)
- )))!
Item was removed:
- ----- Method: CalendarMorph class>>assureDateFormatEstablished (in category 'class initialization') -----
- assureDateFormatEstablished
- "Make certain that there is a DateFormat vocabulary in the system's list."
-
- Vocabulary addStandardVocabulary: (SymbolListType new vocabularyName: #DateFormat;
- symbols: #(#'dd/mm/yyyy' #'yyyy/mm/dd' #'mm/dd/yyyy')).!
Item was removed:
- ----- Method: CalendarMorph class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- "Answer a description for use in parts bins"
-
- ^ self partName: 'Calendar' translatedNoop
- categories: {'Just for Fun' translatedNoop}
- documentation: 'A scriptable calendar' translatedNoop!
Item was removed:
- ----- Method: CalendarMorph class>>initialize (in category 'class initialization') -----
- initialize
- "Class initialization."
-
- self assureDateFormatEstablished!
Item was removed:
- ----- Method: CalendarMorph>>addDays: (in category 'actions') -----
- addDays: aNumber
- [self date: (date addDays: aNumber)]
- on: Error
- do: ["Nothing"]!
Item was removed:
- ----- Method: CalendarMorph>>addMonths: (in category 'actions') -----
- addMonths: aNumber
- [self date: (date addMonths: aNumber)]
- on: Error
- do: ["Nothing"]!
Item was removed:
- ----- Method: CalendarMorph>>buildMonthRow (in category 'building') -----
- buildMonthRow
- ^ self newRow
- addMorphBack: ((self newButtonWithContents: '<-') actionSelector: #previousMonth; target: self);
- addMorphBack: AlignmentMorph newVariableTransparentSpacer;
- addMorphBack: (date month name translated asMorph color: self labelsDefaultColor);
- addMorphBack: AlignmentMorph newVariableTransparentSpacer;
- addMorphBack: ((self newButtonWithContents: '->') actionSelector: #nextMonth; target: self)!
Item was removed:
- ----- Method: CalendarMorph>>buildYearRow (in category 'building') -----
- buildYearRow
- ^ self newRow
- addMorphBack: ((self newButtonWithContents: '<-') actionSelector: #previousYear; target: self);
- addMorphBack: AlignmentMorph newVariableTransparentSpacer;
- addMorphBack: (date year name asMorph color: self labelsDefaultColor);
- addMorphBack: AlignmentMorph newVariableTransparentSpacer;
- addMorphBack: ((self newButtonWithContents: '->') actionSelector: #nextYear; target: self)!
Item was removed:
- ----- Method: CalendarMorph>>color: (in category 'accessing') -----
- color: aColor
- super color: aColor.
- shouldUpdate := true!
Item was removed:
- ----- Method: CalendarMorph>>date (in category 'accessing') -----
- date
- ^ date!
Item was removed:
- ----- Method: CalendarMorph>>date: (in category 'accessing') -----
- date: aDate
- date := aDate.
- shouldUpdate := true!
Item was removed:
- ----- Method: CalendarMorph>>dayInitialsRow (in category 'building') -----
- dayInitialsRow
- | newRow |
- newRow := self newRow.
- Week dayNames
- do: [:dayName|
- newRow addMorphBack: (TextMorph new
- contentsWrapped: dayName translated first asString;
- textColor: self labelsDefaultColor;
- autoFit: false;
- width: 30 px;
- centered;
- lock)]
- separatedBy: [newRow addMorphBack: AlignmentMorph newVariableTransparentSpacer].
- ^newRow !
Item was removed:
- ----- Method: CalendarMorph>>fillStyle: (in category 'accessing') -----
- fillStyle: aFillStyle
- super fillStyle: aFillStyle.
- shouldUpdate := true!
Item was removed:
- ----- Method: CalendarMorph>>incrementStepTime (in category 'stepping') -----
- incrementStepTime
- stepTime := (stepTime + 1) min: self maximumStepTime!
Item was removed:
- ----- Method: CalendarMorph>>initialColor (in category 'initialize') -----
- initialColor
- "Answer the color to use for a new Calendar."
-
- ^ Color r: 0.516 g: 0.677 b: 1.0
-
- "Note: Richo's initial implementation was to use a randomly-chosen color for each new Calendar, for which the code in this method would be:
-
- ^ Color random
-
- ... but in this version, a standard, sedate color is used for each new calendar. The user can of course change the color using the standard halo recolor tool"!
Item was removed:
- ----- Method: CalendarMorph>>initialize (in category 'initialize') -----
- initialize
- "One-time initialization of a new calendar."
-
- super initialize.
- date := Date today.
- stepTime := self minimumStepTime.
- shouldUpdate := false.
- self layoutPolicy: TableLayout new;
- listDirection: #topToBottom;
- hResizing: #shrinkWrap;
- vResizing: #shrinkWrap;
- color: self initialColor;
- cornerStyle: #rounded;
- initializeSubmorphs!
Item was removed:
- ----- Method: CalendarMorph>>initializeSubmorphs (in category 'initialize') -----
- initializeSubmorphs
- | weekRow dateButton |
- self addMorphBack: self buildYearRow;
- addMorphBack: self buildMonthRow;
- addMorphBack: self dayInitialsRow.
- date month weeks
- do: [:week |
- weekRow := self newRow.
- week dates
- do: [:aDate |
- dateButton := self newDateButtonWithContents: aDate dayOfMonth asString.
- dateButton actionSelector: #date:;
- target: self;
- arguments: {aDate}.
- date = aDate
- ifTrue: [dateButton
- color: (self color
- mixed: 0.5
- with: (self color adjustSaturation: 1 brightness: 1))].
- date month ~= aDate month
- ifTrue: [dateButton color: self color.
- (dateButton findA: StringMorph)
- color: Color gray].
- weekRow addMorphBack: dateButton]
- separatedBy: [weekRow addMorphBack: AlignmentMorph newVariableTransparentSpacer].
- self addMorphBack: weekRow]!
Item was removed:
- ----- Method: CalendarMorph>>labelsDefaultColor (in category 'building') -----
- labelsDefaultColor
- ^ self color makeForegroundColor !
Item was removed:
- ----- Method: CalendarMorph>>localeChanged (in category 'update') -----
- localeChanged
- self update!
Item was removed:
- ----- Method: CalendarMorph>>maximumStepTime (in category 'stepping') -----
- maximumStepTime
- ^ 200!
Item was removed:
- ----- Method: CalendarMorph>>minimumStepTime (in category 'stepping') -----
- minimumStepTime
- ^ 20!
Item was removed:
- ----- Method: CalendarMorph>>newButtonWithContents: (in category 'building') -----
- newButtonWithContents: aString
-
- ^ SimpleButtonMorph new
- label: aString;
- color: (self color mixed: 0.5 with: Color gray);
- borderStyle: (BorderStyle raised width: 2 px);
- yourself!
Item was removed:
- ----- Method: CalendarMorph>>newDateButtonWithContents: (in category 'building') -----
- newDateButtonWithContents: aString
-
- ^ SimpleButtonMorph new
- label: aString;
- cornerStyle: #square;
- color: self color muchLighter;
- borderStyle: (BorderStyle raised width: 2 px);
- width: 30 px;
- yourself!
Item was removed:
- ----- Method: CalendarMorph>>newRow (in category 'building') -----
- newRow
- ^ AlignmentMorph newRow
- vResizing: #shrinkWrap;
- color: Color transparent!
Item was removed:
- ----- Method: CalendarMorph>>nextMonth (in category 'actions') -----
- nextMonth
- self addMonths: 1!
Item was removed:
- ----- Method: CalendarMorph>>nextYear (in category 'actions') -----
- nextYear
- self addMonths: 12!
Item was removed:
- ----- Method: CalendarMorph>>previousMonth (in category 'actions') -----
- previousMonth
- self addMonths: -1!
Item was removed:
- ----- Method: CalendarMorph>>previousYear (in category 'actions') -----
- previousYear
- self addMonths: -12!
Item was removed:
- ----- Method: CalendarMorph>>step (in category 'stepping') -----
- step
- shouldUpdate
- ifTrue: [self update.
- stepTime := self minimumStepTime.
- shouldUpdate := false]
- ifFalse: [self incrementStepTime]!
Item was removed:
- ----- Method: CalendarMorph>>stepTime (in category 'stepping') -----
- stepTime
- ^ stepTime !
Item was removed:
- ----- Method: CalendarMorph>>update (in category 'update') -----
- update
- self submorphsDo: [:m | m delete].
- self initializeSubmorphs !
Item was removed:
- ChessBoard subclass: #Chess960Board
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess960'!
-
- !Chess960Board commentStamp: 'spfa 6/2/2020 15:13' prior: 0!
- Chess960Board can handle Fisher-style random starting positions in home ranks!
Item was removed:
- ----- Method: Chess960Board>>initialize (in category 'initialize') -----
- initialize
- generator ifNil:[generator := Chess960MoveGenerator new initialize].
- searchAgent ifNil:[searchAgent := ChessPlayerAI new initialize].
- self resetGame.
- !
Item was removed:
- ----- Method: Chess960Board>>initializeNewBoard (in category 'initialize') -----
- initializeNewBoard
-
- | conf |
-
- self resetGame.
- conf := Chess960Configuration new.
- whitePlayer addWhitePieces: conf.
- blackPlayer addBlackPieces: conf.
- !
Item was removed:
- ----- Method: Chess960Board>>resetGame (in category 'initialize') -----
- resetGame
- hashKey := hashLock := 0.
- whitePlayer := Chess960Player new initialize.
- blackPlayer := Chess960Player new initialize.
- whitePlayer opponent: blackPlayer.
- whitePlayer board: self.
- blackPlayer opponent: whitePlayer.
- blackPlayer board: self.
- activePlayer := whitePlayer.
- searchAgent reset: self.
- userAgent ifNotNil:[userAgent gameReset].!
Item was removed:
- Object subclass: #Chess960Configuration
- instanceVariableNames: 'positions king leftRook rightRook'
- classVariableNames: ''
- poolDictionaries: 'ChessConstants'
- category: 'Etoys-Squeakland-Morphic-Games-Chess960'!
-
- !Chess960Configuration commentStamp: 'spfa 6/2/2020 15:13' prior: 0!
- A Chess960Configuration is a Fisher-style random starting arrangement of pieces in the home ranks!
Item was removed:
- ----- Method: Chess960Configuration class>>new (in category 'as yet unclassified') -----
- new
-
- | rand positions k |
-
- rand := Random new.
- positions := Array new: 8.
- positions at: (rand nextInt: 4) * 2 - 1 put: Bishop.
- positions at: (rand nextInt: 4) * 2 put: Bishop.
- positions at: (k := (((1 to: 8) select: [:n | (positions at: n) isNil]) copyFrom: 2 to: 5) atRandom: rand) put: King.
- positions at: (((1 to: k-1) select: [:n | (positions at: n) isNil]) atRandom: rand) put: Rook.
- positions at: (((k+1 to: 8) select: [:n | (positions at: n) isNil]) atRandom: rand) put: Rook.
- positions at: (((1 to: 8) select: [:n | (positions at: n) isNil]) atRandom: rand) put: Queen.
- positions at: ((1 to: 8) detect: [:n | (positions at: n) isNil]) put: Knight.
- positions at: ((1 to: 8) detect: [:n | (positions at: n) isNil]) put: Knight.
-
- ^ self basicNew positions: positions
- !
Item was removed:
- ----- Method: Chess960Configuration>>initialKingPosition (in category 'positions') -----
- initialKingPosition
-
- ^ king ifNil: [king := positions indexOf: King]!
Item was removed:
- ----- Method: Chess960Configuration>>initialLeftRookPosition (in category 'positions') -----
- initialLeftRookPosition
-
- ^ leftRook ifNil: [leftRook := positions indexOf: Rook]!
Item was removed:
- ----- Method: Chess960Configuration>>initialRightRookPosition (in category 'positions') -----
- initialRightRookPosition
-
- ^ rightRook ifNil: [rightRook := positions indexOf: Rook startingAt: self initialKingPosition]!
Item was removed:
- ----- Method: Chess960Configuration>>positions (in category 'positions') -----
- positions
-
- ^ positions!
Item was removed:
- ----- Method: Chess960Configuration>>positions: (in category 'positions') -----
- positions: anArray
-
- positions := anArray.
- king := leftRook := rightRook := nil!
Item was removed:
- ChessMorph subclass: #Chess960Morph
- instanceVariableNames: 'images message squareSize'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess960'!
-
- !Chess960Morph commentStamp: 'spfa 6/2/2020 15:10' prior: 0!
- Chess960Morph is a nicer, scalable, skin for ChessMorph.
- It also can play Fischer random chess (use the '960' button)
-
- Chess960Morph new openInWorld
-
- (Chess960Morph new squareSize: 100) openInWorld
- !
Item was removed:
- ----- Method: Chess960Morph class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'Chess 960' translatedNoop
- categories: {'Games' translatedNoop}
- documentation: 'A fine game of chess. Revised by Stéphane Rollandin (spfa).' translatedNoop!
Item was removed:
- ----- Method: Chess960Morph>>addButtonRow (in category 'initialize') -----
- addButtonRow
-
- | r m |
- r := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color transparent.
- r cellInset: 2.
- r addMorphBack: (self buttonName: ' New ' translated action: #newGame).
- r addMorphBack: (self buttonName: ' 960 ' translated action: #new960Game).
- r addMorphBack: (self buttonName: ' Help ' translated action: #findBestMove).
- r addMorphBack: (self buttonName: ' Play ' translated action: #thinkAndMove).
- r addMorphBack: (self buttonName: ' Auto ' translated action: #autoPlay).
- r addMorphBack: (self buttonName: ' Undo ' translated action: #undoMove).
- r addMorphBack: (self buttonName: ' Redo ' translated action: #redoMove).
- r addMorphBack: (self buttonName: ' Quit ' translated action: #delete).
- r disableLayout: true.
- r align: r bounds topLeft with: self layoutBounds topLeft.
- self addMorphFront: r.
- m := UpdatingStringMorph on: self selector: #statusString.
- m useStringFormat.
- m disableTableLayout: true.
- m stepTime: 50.
- m align: m bounds topLeft with: r fullBounds bottomLeft.
- self addMorphFront: m.
- m
- font: self textFont;
- color: self statusColor;
- maximumWidth: self width - self squareSize;
- position: self position + (self squareSize @ self squareSize * 0.6)!
Item was removed:
- ----- Method: Chess960Morph>>addSquares (in category 'initialize') -----
- addSquares
- | white black border square index |
- white := self whiteColor.
- black := self blackColor.
- border := self highColor.
- index := 0.
- #(
- ( ' ' 'a' 'b' 'c' 'd' 'e' 'f' 'g' 'h' ' ')
- ( '1' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
- ( '2' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
- ( '3' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
- ( '4' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
- ( '5' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
- ( '6' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
- ( '7' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
- ( '8' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
- ( ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ')
- ) do:[:file|
- file do:[:sq|
- square := self newSquare.
- square borderWidth: 0.
- (sq = 'W' or:[sq = 'B']) ifTrue:[
- square color: (sq = 'W' ifTrue:[white] ifFalse:[black]).
- square borderColor: border.
- square setProperty: #squarePosition toValue: (index := index + 1).
- square setNameTo:
- (String with: ($a asInteger + (index - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (index -1 bitShift: -3)) asCharacter).
- square on: #mouseEnter send: #showMoves:from: to: self.
- square on: #mouseEnterDragging send: #dragSquareEnter:from: to: self.
- square on: #mouseLeaveDragging send: #dragSquareLeave:from: to: self.
- ] ifFalse:["decoration"
- square color: Color transparent.
- sq = ' ' ifFalse:[
- square addMorph: ((StringMorph contents: sq font: self textFont)
- color: self labelsColor).
- ].
- ].
- square extent: self squareSize @ self squareSize.
- self addMorphBack: square.
- square submorphs ifNotEmpty: [square submorphs first center: square center]
- ]].
- !
Item was removed:
- ----- Method: Chess960Morph>>blackColor (in category 'theme') -----
- blackColor
-
- " Color earth paler duller."
- "^ Color grass duller"
- ^ Color r: 0.343 g: 0.576 b: 0.207!
Item was removed:
- ----- Method: Chess960Morph>>buttonColor (in category 'theme') -----
- buttonColor
-
- " ^ Color lightBlue3 whiter "
- ^ Color r: 0.667 g: 0.792 b: 0.833!
Item was removed:
- ----- Method: Chess960Morph>>buttonName:action: (in category 'initialize') -----
- buttonName: aString action: aSymbol
-
- ^ SimpleButtonMorph new
- target: self;
- label: aString;
- actionSelector: aSymbol;
- color: self buttonColor;
- borderWidth: 1;
- borderRaised.
- !
Item was removed:
- ----- Method: Chess960Morph>>defaultBounds (in category 'initialization') -----
- defaultBounds
- "answer the default bounds for the receiver"
- ^ 0 @ 0 corner: (self squareSize * 10 + 10) @ (self squareSize * 10 + 10)!
Item was removed:
- ----- Method: Chess960Morph>>defaultColor (in category 'theme') -----
- defaultColor
-
- "^ Color paleTeal duller duller"
- ^ Color r: 0.467 g: 0.631 b: 0.71!
Item was removed:
- ----- Method: Chess960Morph>>findBestMove (in category 'playing') -----
- findBestMove
- | move |
- board ifNil: [^ self].
- board searchAgent isThinking ifTrue:[^self].
-
- "tmp - board should be nil when the game is over"
- ((1 to: 64) allSatisfy: [:n |
- (board activePlayer pieces at: n) isZero
- or: [(board activePlayer findValidMovesAt: n) isEmpty]])
- ifTrue: [message := (board activePlayer isWhitePlayer
- ifTrue: ['white'] ifFalse: ['black']), ' lost'.
- ^ self].
-
- Cursor wait showWhile:[move := board searchAgent think].
- message := 'I suggest ' translated, move moveString.
- ^move
- !
Item was removed:
- ----- Method: Chess960Morph>>finishedGame: (in category 'as yet unclassified') -----
- finishedGame: result
-
- super finishedGame: result.
- message := #('black won' 'draw' 'white won') at: result * 2 + 1!
Item was removed:
- ----- Method: Chess960Morph>>highColor (in category 'theme') -----
- highColor
-
- " ^ Color lightGold"
- ^ Color r: 0.992 g: 0.863 b: 0.361!
Item was removed:
- ----- Method: Chess960Morph>>images (in category 'theme') -----
- images
-
- ^ images ifNil: [images := ChessPieceMorphWC piecesWithHeight: self squareSize - 5]!
Item was removed:
- ----- Method: Chess960Morph>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- self bounds: self defaultBounds.
- self beSticky!
Item was removed:
- ----- Method: Chess960Morph>>labelsColor (in category 'theme') -----
- labelsColor
-
- " ^ Color armyGreen"
- ^ Color r: 0.294 g: 0.365 b: 0.086!
Item was removed:
- ----- Method: Chess960Morph>>movedPiece:from:to: (in category 'game callbacks') -----
- movedPiece: piece from: sourceSquare to: destSquare
- | sourceMorph destMorph sourcePos destPos w startTime nowTime deltaTime |
- sourceMorph := (self atSquare: sourceSquare) firstSubmorph.
- destMorph := self atSquare: destSquare.
- animateMove ifTrue:[
- sourcePos := sourceMorph boundsInWorld center.
- destPos := destMorph boundsInWorld center.
- (w := self world) ifNotNil:[
- w addMorphFront: sourceMorph.
- deltaTime := (sourcePos dist: destPos) * 3 asInteger.
- startTime := Time millisecondClockValue.
- [nowTime := Time millisecondClockValue.
- nowTime - startTime < deltaTime] whileTrue:[
- sourceMorph center: sourcePos + (destPos - sourcePos * (nowTime - startTime) // deltaTime) asIntegerPoint.
- w displayWorldSafely].
- sourceMorph removeDropShadow.
- ].
- ].
- destMorph removeAllMorphs.
- destMorph addMorphCentered: sourceMorph.
- animateMove := false.
- message := nil.!
Item was removed:
- ----- Method: Chess960Morph>>new960Game (in category 'initialize') -----
- new960Game
- board := Chess960Board new.
- board initialize.
- board userAgent: self.
- board initializeNewBoard.
- history := OrderedCollection new.
- redoList := OrderedCollection new.
- message := nil
- !
Item was removed:
- ----- Method: Chess960Morph>>newPiece:white: (in category 'initialize') -----
- newPiece: piece white: isWhite
-
- | index selector m |
- index := piece.
- isWhite ifFalse:[index := index + 6].
- selector := #(
- whitePawn
- whiteKnight
- whiteBishop
- whiteRook
- whiteQueen
- whiteKing
-
- blackPawn
- blackKnight
- blackBishop
- blackRook
- blackQueen
- blackKing) at: index.
- m := ChessPieceMorph new image: (self images at: selector).
- m setProperty: #isWhite toValue: isWhite.
- m setProperty: #piece toValue: piece.
- ^m!
Item was removed:
- ----- Method: Chess960Morph>>reinstallPieces (in category 'resizing') -----
- reinstallPieces
-
- board whitePlayer pieces withIndexDo: [:pc :n |
- pc isZero ifFalse: [
- self addedPiece: pc at: n white: true]].
-
- board blackPlayer pieces withIndexDo: [:pc :n |
- pc isZero ifFalse: [
- self addedPiece: pc at: n white: false]].!
Item was removed:
- ----- Method: Chess960Morph>>setExtentFromHalo: (in category 'miscellaneous') -----
- setExtentFromHalo: anExtent
-
- self squareSize: (anExtent x - 10) //10.!
Item was removed:
- ----- Method: Chess960Morph>>showMovesAt: (in category 'events') -----
- showMovesAt: square
- | list |
- board ifNil:[^self].
- board searchAgent isThinking ifTrue:[^self].
- self squaresDo:[:m| m borderWidth: 0].
- list := board activePlayer findValidMovesAt: square.
- list isEmpty ifTrue:[^self].
- (self atSquare: square) borderWidth: 2.
- list do:[:move|
- (self atSquare: (move triggerSquareIn: board)) borderWidth: 5.
- ].!
Item was removed:
- ----- Method: Chess960Morph>>squareSize (in category 'resizing') -----
- squareSize
-
- ^ squareSize ifNil: [70]!
Item was removed:
- ----- Method: Chess960Morph>>squareSize: (in category 'resizing') -----
- squareSize: anInteger
-
- | ss |
-
- ss := anInteger max: 48.
-
- squareSize := ss.
- images := nil.
- submorphs do: #delete.
- self extent: (ss * 10 + 10) @ (ss * 10 + 10) .
- self addSquares.
- self addButtonRow.
- self reinstallPieces!
Item was removed:
- ----- Method: Chess960Morph>>statusColor (in category 'theme') -----
- statusColor
-
- " ^ Color reallyLightBlue "
- ^ Color r: 0.831 g: 1 b: 1!
Item was removed:
- ----- Method: Chess960Morph>>statusString (in category 'other stuff') -----
- statusString
-
- ^ message ifNil: [super statusString]!
Item was removed:
- ----- Method: Chess960Morph>>swappedPieceOn:withPieceOn: (in category 'game callbacks') -----
- swappedPieceOn: aSquare withPieceOn: bSquare
- | aMorph bMorph |
-
- aMorph := (self atSquare: aSquare) firstSubmorph.
- bMorph := (self atSquare: bSquare) firstSubmorph.
-
- (self atSquare: aSquare) removeAllMorphs.
- (self atSquare: aSquare) addMorphCentered: bMorph.
-
- (self atSquare: bSquare) removeAllMorphs.
- (self atSquare: bSquare) addMorphCentered: aMorph.
-
- message := nil.!
Item was removed:
- ----- Method: Chess960Morph>>textFont (in category 'theme') -----
- textFont
-
- | ps |
-
- ps := self squareSize < 80 ifTrue: [12] ifFalse: [15].
-
- ^ TTCFont familyName: 'BitstreamVeraSans' pointSize: ps emphasis: 1
- !
Item was removed:
- ----- Method: Chess960Morph>>whiteColor (in category 'theme') -----
- whiteColor
-
- " ^ Color ivory"
- ^ Color r: 1 g: 1 b: 0.94!
Item was removed:
- ChessMoveGenerator subclass: #Chess960MoveGenerator
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess960'!
-
- !Chess960MoveGenerator commentStamp: 'spfa 6/1/2020 14:56' prior: 0!
- Chess960MoveGenerator implements the specific castling checks and moves for Chess960!
Item was removed:
- ----- Method: Chess960MoveGenerator>>canCastleBlackKingSide (in category 'support') -----
- canCastleBlackKingSide
-
- (castlingStatus bitAnd: CastlingEnableKingSide) = 0 ifFalse:[^false].
-
- (myPlayer rightCastlingField inject: 0 into: [:sum :s|
- sum + (myPieces at: s) + (itsPieces at: s)]) = (King + Rook)
- ifFalse:[^false].
-
- myPlayer rightCastlingWalk in: [:w |
- (self checkRookMoversAttacksAlong: w) ifTrue: [^false].
- (self checkBishopMoversAttacksAlong: w) ifTrue: [^ false].
- (self checkKnightAttacksAlong: w) ifTrue: [^ false].
- (self checkPawnsAttacksAlong: w) ifTrue: [^ false].
- (self checkKingAttacksAlong: w) ifTrue: [^ false]].
-
- (self checkAttack: (myPlayer initialKingSquare - 1 to: A8 by: -1) fromPieces: RookMovers)
- ifTrue: [^false].
- (self checkAttack: {H8} fromPieces: RookMovers) ifTrue: [^false].
-
- ^true.
-
-
-
-
- !
Item was removed:
- ----- Method: Chess960MoveGenerator>>canCastleBlackQueenSide (in category 'support') -----
- canCastleBlackQueenSide
-
- (castlingStatus bitAnd: CastlingEnableQueenSide) = 0 ifFalse:[^false].
-
- (myPlayer leftCastlingField inject: 0 into: [:sum :s|
- sum + (myPieces at: s) + (itsPieces at: s)]) = (King + Rook)
- ifFalse:[^false].
-
- myPlayer leftCastlingWalk in: [:w |
- (self checkRookMoversAttacksAlong: w) ifTrue: [^false].
- (self checkBishopMoversAttacksAlong: w) ifTrue: [^ false].
- (self checkKnightAttacksAlong: w) ifTrue: [^ false].
- (self checkPawnsAttacksAlong: w) ifTrue: [^ false].
- (self checkKingAttacksAlong: w) ifTrue: [^ false]].
-
- (self checkAttack: (myPlayer initialKingSquare +1 to: H8) fromPieces: RookMovers)
- ifTrue: [^false].
- (self checkAttack: {B8 . A8} fromPieces: RookMovers) ifTrue: [^false].
-
-
- ^true.
-
-
-
-
- !
Item was removed:
- ----- Method: Chess960MoveGenerator>>canCastleWhiteKingSide (in category 'support') -----
- canCastleWhiteKingSide
-
- (castlingStatus bitAnd: CastlingEnableKingSide) = 0 ifFalse:[^false].
-
- (myPlayer rightCastlingField inject: 0 into: [:sum :s|
- sum + (myPieces at: s) + (itsPieces at: s)]) = (King + Rook)
- ifFalse:[^false].
-
- myPlayer rightCastlingWalk in: [:w |
- (self checkRookMoversAttacksAlong: w) ifTrue: [^false].
- (self checkBishopMoversAttacksAlong: w) ifTrue: [^ false].
- (self checkKnightAttacksAlong: w) ifTrue: [^ false].
- (self checkPawnsAttacksAlong: w) ifTrue: [^ false].
- (self checkKingAttacksAlong: w) ifTrue: [^ false]].
-
- (self checkAttack: (myPlayer initialKingSquare - 1 to: A1 by: -1) fromPieces: RookMovers)
- ifTrue: [^false].
- (self checkAttack: {H1} fromPieces: RookMovers) ifTrue: [^false].
-
- ^true.
-
-
-
-
- !
Item was removed:
- ----- Method: Chess960MoveGenerator>>canCastleWhiteQueenSide (in category 'support') -----
- canCastleWhiteQueenSide
-
- (castlingStatus bitAnd: CastlingEnableQueenSide) = 0 ifFalse:[^false].
-
- (myPlayer leftCastlingField inject: 0 into: [:sum :s|
- sum + (myPieces at: s) + (itsPieces at: s)]) = (King + Rook)
- ifFalse:[^false].
-
- myPlayer leftCastlingWalk in: [:w |
- (self checkRookMoversAttacksAlong: w) ifTrue: [^false].
- (self checkBishopMoversAttacksAlong: w) ifTrue: [^ false].
- (self checkKnightAttacksAlong: w) ifTrue: [^ false].
- (self checkPawnsAttacksAlong: w) ifTrue: [^ false].
- (self checkKingAttacksAlong: w) ifTrue: [^ false]].
-
- (self checkAttack: (myPlayer initialKingSquare + 1 to: H1) fromPieces: RookMovers)
- ifTrue: [^false].
- (self checkAttack: {B1 . A1} fromPieces: RookMovers) ifTrue: [^false].
-
- ^true.
-
-
-
-
- !
Item was removed:
- ----- Method: Chess960MoveGenerator>>checkBishopMoversAttacksAlong: (in category 'support') -----
- checkBishopMoversAttacksAlong: anArray
-
- "anArray contains consecutive, ordered squares that are all either in rank 8 or in rank 1"
-
- anArray do: [:s |
- (self checkBishopMoversAttacksOn: s) ifTrue: [^ true]].
-
- ^ false!
Item was removed:
- ----- Method: Chess960MoveGenerator>>checkBishopMoversAttacksOn: (in category 'support') -----
- checkBishopMoversAttacksOn: aSquare
-
- "aSquare is either in rank 8 or in rank 1"
-
- | leftDiagonal rightDiagonal |
-
- myPlayer isWhitePlayer ifFalse: [
- leftDiagonal := (1 to: aSquare - A8) collect: [:n | aSquare - (n * 7)].
- rightDiagonal := (1 to: H8 - aSquare) collect: [:n | aSquare - (n * 9)]
- ]
- ifTrue: [
- leftDiagonal := (1 to: aSquare - A1) collect: [:n | aSquare + (n * 7)].
- rightDiagonal := (1 to: H1 - aSquare) collect: [:n | aSquare + (n * 9)]
- ].
-
- ^ (self checkAttack: leftDiagonal fromPieces: BishopMovers)
- or: [self checkAttack: rightDiagonal fromPieces: BishopMovers]!
Item was removed:
- ----- Method: Chess960MoveGenerator>>checkKingAttacksAlong: (in category 'support') -----
- checkKingAttacksAlong: anArray
-
- "anArray contains consecutive, ordered squares that are all either in rank 8 or in rank 1"
-
- | kpos |
-
- "somewhat overkill because some positions can never be reached by opponent king"
- kpos := Array streamContents: [:str |
- str nextPut: anArray first - 1.
- str nextPutAll: anArray.
- str nextPut: anArray last + 1].
-
- ^ self checkUnprotectedAttack:
- (kpos + (myPlayer isWhitePlayer ifTrue: [8] ifFalse: [-8]))
- fromPiece: King!
Item was removed:
- ----- Method: Chess960MoveGenerator>>checkKnightAttacksAlong: (in category 'support') -----
- checkKnightAttacksAlong: anArray
-
- "anArray contains consecutive, ordered squares that are all either in rank 8 or in rank 1"
-
- | kpos1 kpos2 |
-
- "rank at distance 1"
- kpos1 := (anArray - 2) union: (anArray + 2).
-
- myPlayer isWhitePlayer ifTrue: [
- kpos1 min = 0 ifTrue: [kpos1 := kpos1 copyWithout: 0].
- kpos1 max = 9 ifTrue: [kpos1 := kpos1 copyWithout: 9]].
-
- (self checkUnprotectedAttack:
- (kpos1 + (myPlayer isWhitePlayer ifTrue: [8] ifFalse: [-8]))
- fromPiece: Knight) ifTrue: [^ true].
-
- "rank at distance 2 - same logic as for pawns at distance 1"
- kpos2 := Array streamContents: [:str |
- str nextPut: anArray min - 1.
- anArray size > 1 ifTrue: [str nextPutAll: anArray].
- str nextPut: anArray max + 1].
-
- ^ self checkUnprotectedAttack:
- (kpos2 + (myPlayer isWhitePlayer ifTrue: [16] ifFalse: [-16]))
- fromPiece: Knight!
Item was removed:
- ----- Method: Chess960MoveGenerator>>checkPawnsAttacksAlong: (in category 'support') -----
- checkPawnsAttacksAlong: anArray
-
- "anArray contains consecutive, ordered squares that are all either in rank 8 or in rank 1"
-
- | ppos |
-
- ppos := Array streamContents: [:str |
- str nextPut: anArray first - 1.
- "If the king does not move, castling is not prevented by a pawn in same file"
- anArray size > 1 ifTrue: [str nextPutAll: anArray].
- str nextPut: anArray last + 1].
-
- ^ self checkUnprotectedAttack:
- (ppos + (myPlayer isWhitePlayer ifTrue: [8] ifFalse: [-8]))
- fromPiece: Pawn!
Item was removed:
- ----- Method: Chess960MoveGenerator>>checkRookMoversAttacksAlong: (in category 'support') -----
- checkRookMoversAttacksAlong: anArray
-
- "anArray contains consecutive, ordered squares that are all either in rank 8 or in rank 1"
-
- anArray first > 8 ifTrue: [ "black"
- anArray do: [:s |
- (self checkAttack: {s-8. s-16. s-24. s-32. s-40. s-48. s-56} fromPieces: RookMovers)
- ifTrue: [^ true]].
- ^ false].
-
- "white"
- anArray do: [:s |
- (self checkAttack: {s+8. s+16. s+24. s+32. s+40. s+48. s+56} fromPieces: RookMovers)
- ifTrue: [^ true]].
- ^ false
- !
Item was removed:
- ----- Method: Chess960MoveGenerator>>moveBlackKingAt: (in category 'moves-general') -----
- moveBlackKingAt: square
- | capture |
- (KingMoves at: square) do:[:destSquare|
- (myPieces at: destSquare) = 0 ifTrue:[
- capture := itsPieces at: destSquare.
- (forceCaptures and:[capture = 0]) ifFalse:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- move: King from: square to: destSquare capture: capture.
- capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
- ].
- ].
- ].
- forceCaptures ifTrue:[^self].
- "now consider castling"
- self canCastleBlackKingSide ifTrue:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- moveCastlingKingSide: King from: square to: G8
- ].
- self canCastleBlackQueenSide ifTrue:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- moveCastlingQueenSide: King from: square to: C8
- ].!
Item was removed:
- ----- Method: Chess960MoveGenerator>>moveWhiteKingAt: (in category 'moves-general') -----
- moveWhiteKingAt: square
- | capture |
- (KingMoves at: square) do:[:destSquare|
- (myPieces at: destSquare) = 0 ifTrue:[
- capture := itsPieces at: destSquare.
- (forceCaptures and:[capture = 0]) ifFalse:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- move: King from: square to: destSquare capture: capture.
- capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
- ].
- ].
- ].
- forceCaptures ifTrue:[^self].
- "now consider castling"
- self canCastleWhiteKingSide ifTrue:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- moveCastlingKingSide: King from: square to: G1.
- ].
- self canCastleWhiteQueenSide ifTrue:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- moveCastlingQueenSide: King from: square to: C1.
- ].!
Item was removed:
- ChessPlayer subclass: #Chess960Player
- instanceVariableNames: 'configuration'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess960'!
-
- !Chess960Player commentStamp: 'spfa 6/2/2020 15:16' prior: 0!
- Chess960Player represents a Chess960 player (doh)!
Item was removed:
- ----- Method: Chess960Player>>addBlackPieces: (in category 'adding/removing') -----
- addBlackPieces: aChess960Configuration
-
- self configuration: aChess960Configuration.
-
- configuration positions withIndexDo: [:p :n | self addPiece: p at: 56+n].
- 49 to: 56 do:[:i| self addPiece: Pawn at: i].!
Item was removed:
- ----- Method: Chess960Player>>addWhitePieces: (in category 'adding/removing') -----
- addWhitePieces: aChess960Configuration
-
- self configuration: aChess960Configuration.
-
- configuration positions withIndexDo: [:p :n | self addPiece: p at: n].
- 9 to: 16 do:[:i| self addPiece: Pawn at: i].
- !
Item was removed:
- ----- Method: Chess960Player>>applyCastleKingSideMove: (in category 'moving') -----
- applyCastleKingSideMove: move
-
- (pieces at: move destinationSquare) isZero "rook" ifFalse: [
- castlingRookSquare := self isWhitePlayer ifTrue: [F1] ifFalse: [F8].
- move sourceSquare = castlingRookSquare
- ifTrue: [
- self swapPiecesIn: move sourceSquare and: move destinationSquare]
- ifFalse: [
- self movePiece: Rook from: self initialRightRookSquare to: castlingRookSquare.
- self movePiece: King from: move sourceSquare to: move destinationSquare].
- castlingStatus := castlingStatus bitOr: CastlingDone.
- ^ self].
-
- self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.
- self movePiece: Rook
- from: self initialRightRookSquare
- to: ((castlingRookSquare := self isWhitePlayer ifTrue: [F1] ifFalse: [F8])).
- pieces at: castlingRookSquare put: King.
- castlingStatus := castlingStatus bitOr: CastlingDone.!
Item was removed:
- ----- Method: Chess960Player>>applyCastleQueenSideMove: (in category 'moving') -----
- applyCastleQueenSideMove: move
-
- (pieces at: move destinationSquare) isZero "rook or king" ifFalse: [
- castlingRookSquare := self isWhitePlayer ifTrue: [D1] ifFalse: [D8].
- move sourceSquare = castlingRookSquare
- ifTrue: [
- self swapPiecesIn: move sourceSquare and: move destinationSquare]
- ifFalse: [
- self movePiece: Rook
- from: self initialLeftRookSquare to: castlingRookSquare.
- self movePiece: King from: move sourceSquare to: move destinationSquare].
- castlingStatus := castlingStatus bitOr: CastlingDone.
- ^ self].
-
- self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.
- self movePiece: Rook
- from: self initialLeftRookSquare
- to: (castlingRookSquare := self isWhitePlayer ifTrue: [D1] ifFalse: [D8]).
- pieces at: castlingRookSquare put: King.
- castlingStatus := castlingStatus bitOr: CastlingDone.!
Item was removed:
- ----- Method: Chess960Player>>configuration (in category 'configuration') -----
- configuration
-
- ^ configuration!
Item was removed:
- ----- Method: Chess960Player>>configuration: (in category 'configuration') -----
- configuration: aChess960Configuration
-
- configuration := aChess960Configuration!
Item was removed:
- ----- Method: Chess960Player>>copyPlayer: (in category 'copying') -----
- copyPlayer: aPlayer
-
- super copyPlayer: aPlayer.
- configuration := aPlayer configuration!
Item was removed:
- ----- Method: Chess960Player>>initialKingSquare (in category 'configuration') -----
- initialKingSquare
-
- ^ self isWhitePlayer ifTrue: [self configuration initialKingPosition]
- ifFalse: [self configuration initialKingPosition + 56]!
Item was removed:
- ----- Method: Chess960Player>>initialLeftRookSquare (in category 'configuration') -----
- initialLeftRookSquare
-
- ^ self isWhitePlayer ifTrue: [self configuration initialLeftRookPosition]
- ifFalse: [self configuration initialLeftRookPosition + 56]!
Item was removed:
- ----- Method: Chess960Player>>initialRightRookSquare (in category 'configuration') -----
- initialRightRookSquare
-
- ^ self isWhitePlayer ifTrue: [self configuration initialRightRookPosition]
- ifFalse: [self configuration initialRightRookPosition + 56]!
Item was removed:
- ----- Method: Chess960Player>>leftCastlingField (in category 'configuration') -----
- leftCastlingField
-
- "The squares walked by both the king and the left rook when castling to the left - they must be clear of other pieces"
-
- ^ self isWhitePlayer
- ifTrue: [(C1 to: self initialKingSquare) union: (self initialLeftRookSquare to: D1)]
- ifFalse: [(C8 to: self initialKingSquare) union: (self initialLeftRookSquare to: D8)]
- !
Item was removed:
- ----- Method: Chess960Player>>leftCastlingWalk (in category 'configuration') -----
- leftCastlingWalk
-
- "The squares walked by the king when castling to the left - they must not be under check"
-
- | ks |
-
- ks := self initialKingSquare.
-
- ^ self isWhitePlayer
- ifTrue: [ks > C1 ifTrue: [C1 to: ks] ifFalse: [ks to: C1]]
- ifFalse: [ks > C8 ifTrue: [C8 to: ks] ifFalse: [ks to: C8]] !
Item was removed:
- ----- Method: Chess960Player>>movePiece:from:to: (in category 'adding/removing') -----
- movePiece: piece from: sourceSquare to: destSquare
-
- sourceSquare = destSquare ifTrue: [^ self].
- super movePiece: piece from: sourceSquare to: destSquare!
Item was removed:
- ----- Method: Chess960Player>>rightCastlingField (in category 'configuration') -----
- rightCastlingField
-
- "The squares walked by both the king and the right rook when castling to the left - they must be clear of other pieces"
-
- ^ self isWhitePlayer
- ifTrue: [(self initialKingSquare to: G1) union: (F1 to: self initialRightRookSquare)]
- ifFalse: [(self initialKingSquare to: G8) union: (F8 to: self initialRightRookSquare)]!
Item was removed:
- ----- Method: Chess960Player>>rightCastlingWalk (in category 'configuration') -----
- rightCastlingWalk
-
- "The squares walked by the king when castling to the right - they must not be under check"
-
- | ks |
-
- ks := self initialKingSquare.
-
- ^ self isWhitePlayer
- ifTrue: [ks > G1 ifTrue: [G1 to: ks] ifFalse: [ks to: G1]]
- ifFalse: [ks > G8 ifTrue: [G8 to: ks] ifFalse: [ks to: G8]] !
Item was removed:
- ----- Method: Chess960Player>>swapPiecesIn:and: (in category 'adding/removing') -----
- swapPiecesIn: aSquare and: bSquare
-
- "Only applies to specific castling moves"
-
- | score pa pb |
-
- pa := pieces at: aSquare.
- pb := pieces at: bSquare.
-
- score := PieceCenterScores at: pa.
- positionalValue := positionalValue - (score at: aSquare).
- positionalValue := positionalValue + (score at: bSquare).
-
- score := PieceCenterScores at: pb.
- positionalValue := positionalValue - (score at: bSquare).
- positionalValue := positionalValue + (score at: aSquare).
-
- pieces at: aSquare put: pb.
- pieces at: bSquare put: pa.
- board updateHash: pa at: aSquare from: self.
- board updateHash: pa at: bSquare from: self.
- board updateHash: pb at: bSquare from: self.
- board updateHash: pb at: aSquare from: self.
-
- self userAgent ifNotNil:[self userAgent swappedPieceOn: aSquare withPieceOn: bSquare].!
Item was removed:
- ----- Method: Chess960Player>>undoCastleKingSideMove: (in category 'undo') -----
- undoCastleKingSideMove: move
- self prepareNextMove. "in other words, remove extra kings"
- self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
-
- self isWhitePlayer ifTrue: [
- self movePiece: Rook from: F1 to: self initialRightRookPosition.
- ] ifFalse: [
- self movePiece: Rook from: F8 to: self initialRightRookPosition + 56.
- ]
-
- !
Item was removed:
- ----- Method: Chess960Player>>undoCastleQueenSideMove: (in category 'undo') -----
- undoCastleQueenSideMove: move
- self prepareNextMove. "in other words, remove extra kings"
- self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
-
- self isWhitePlayer ifTrue: [
- self movePiece: Rook from: D1 to: self initialLeftRookPosition.
- ] ifFalse: [
- self movePiece: Rook from: D8 to: self initialLeftRookPosition + 56.
- ]
-
- !
Item was removed:
- ----- Method: Chess960Player>>updateCastlingStatus: (in category 'moving') -----
- updateCastlingStatus: move
-
- "Cannot castle when king has moved"
- (move movingPiece = King)
- ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableAll].
-
- "See if a rook has moved"
- (move movingPiece = Rook) ifFalse:[^self].
-
- (move sourceSquare = self initialLeftRookSquare)
- ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableQueenSide].
-
- (move sourceSquare = self initialRightRookSquare)
- ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableKingSide].!
Item was removed:
- Object subclass: #ChessBoard
- instanceVariableNames: 'whitePlayer blackPlayer activePlayer userAgent searchAgent generator hashKey hashLock'
- classVariableNames: 'HashKeys HashLocks'
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
-
- !ChessBoard commentStamp: '<historical>' prior: 0!
- This class represents the chess board itself.!
Item was removed:
- ----- Method: ChessBoard class>>initialize (in category 'class initialization') -----
- initialize
- "ChessGame initialize"
- self initializeHashKeys.
- !
Item was removed:
- ----- Method: ChessBoard class>>initializeHashKeys (in category 'class initialization') -----
- initializeHashKeys
- "ChessGame initialize"
- | random |
- HashKeys := Array new: 12.
- 1 to: HashKeys size do:[:i| HashKeys at: i put: (WordArray new: 64)].
- HashLocks := Array new: 12.
- 1 to: HashLocks size do:[:i| HashLocks at: i put: (WordArray new: 64)].
- random := Random seed: 23648646.
- 1 to: 12 do:[:i|
- 1 to: 64 do:[:j|
- (HashKeys at: i) at: j put: (random nextInt: 16r3FFFFFFF "SmallInteger maxVal on 32bits VM")- 1.
- (HashLocks at: i) at: j put: (random nextInt: 16r3FFFFFFF "SmallInteger maxVal on 32bits VM") - 1.
- ].
- ].
-
- !
Item was removed:
- ----- Method: ChessBoard>>activePlayer (in category 'accessing') -----
- activePlayer
- ^activePlayer!
Item was removed:
- ----- Method: ChessBoard>>blackPlayer (in category 'accessing') -----
- blackPlayer
- ^blackPlayer!
Item was removed:
- ----- Method: ChessBoard>>copyBoard: (in category 'copying') -----
- copyBoard: aBoard
- "Copy all volatile state from the given board"
-
- whitePlayer copyPlayer: aBoard whitePlayer.
- blackPlayer copyPlayer: aBoard blackPlayer.
- activePlayer := aBoard activePlayer isWhitePlayer
- ifTrue: [whitePlayer]
- ifFalse: [blackPlayer].
- hashKey := aBoard hashKey.
- hashLock := aBoard hashLock.
- userAgent := nil!
Item was removed:
- ----- Method: ChessBoard>>generator (in category 'accessing') -----
- generator
- ^generator!
Item was removed:
- ----- Method: ChessBoard>>hashKey (in category 'hashing') -----
- hashKey
- ^hashKey!
Item was removed:
- ----- Method: ChessBoard>>hashLock (in category 'hashing') -----
- hashLock
- ^hashLock!
Item was removed:
- ----- Method: ChessBoard>>initialize (in category 'initialize') -----
- initialize
- generator ifNil:[generator := ChessMoveGenerator new initialize].
- searchAgent ifNil:[searchAgent := ChessPlayerAI new initialize].
- self resetGame.
- !
Item was removed:
- ----- Method: ChessBoard>>initializeNewBoard (in category 'initialize') -----
- initializeNewBoard
- self resetGame.
- whitePlayer addWhitePieces.
- blackPlayer addBlackPieces.
- !
Item was removed:
- ----- Method: ChessBoard>>movePieceFrom:to: (in category 'moving') -----
- movePieceFrom: sourceSquare to: destSquare
- | move |
- searchAgent isThinking ifTrue:[^self].
- move := (activePlayer findPossibleMovesAt: sourceSquare) contents
- detect:[:any| any destinationSquare = destSquare
- or: [(any triggerSquareIn: self) = destSquare]].
- self nextMove: move.
- searchAgent activePlayer: activePlayer.!
Item was removed:
- ----- Method: ChessBoard>>nextMove: (in category 'moving') -----
- nextMove: aMove
- activePlayer applyMove: aMove.
- userAgent
- ifNotNil: [userAgent completedMove: aMove white: activePlayer isWhitePlayer].
- activePlayer := activePlayer == whitePlayer
- ifTrue: [blackPlayer]
- ifFalse: [whitePlayer].
- activePlayer prepareNextMove !
Item was removed:
- ----- Method: ChessBoard>>nullMove (in category 'moving') -----
- nullMove
- activePlayer := activePlayer == whitePlayer
- ifTrue: [blackPlayer]
- ifFalse: [whitePlayer].
- activePlayer prepareNextMove!
Item was removed:
- ----- Method: ChessBoard>>postCopy (in category 'copying') -----
- postCopy
- whitePlayer == activePlayer ifTrue:[
- whitePlayer := whitePlayer copy.
- blackPlayer := blackPlayer copy.
- activePlayer := whitePlayer.
- ] ifFalse:[
- whitePlayer := whitePlayer copy.
- blackPlayer := blackPlayer copy.
- activePlayer := blackPlayer.
- ].
- whitePlayer opponent: blackPlayer.
- blackPlayer opponent: whitePlayer.
- whitePlayer board: self.
- blackPlayer board: self.
- self userAgent: nil.!
Item was removed:
- ----- Method: ChessBoard>>printOn: (in category 'printing') -----
- printOn: aStream
- super printOn: aStream.
- aStream
- nextPut: $(;
- print: hashKey; space; print: hashLock;
- nextPut: $).!
Item was removed:
- ----- Method: ChessBoard>>resetGame (in category 'initialize') -----
- resetGame
- hashKey := hashLock := 0.
- whitePlayer := ChessPlayer new initialize.
- blackPlayer := ChessPlayer new initialize.
- whitePlayer opponent: blackPlayer.
- whitePlayer board: self.
- blackPlayer opponent: whitePlayer.
- blackPlayer board: self.
- activePlayer := whitePlayer.
- searchAgent reset: self.
- userAgent ifNotNil:[userAgent gameReset].!
Item was removed:
- ----- Method: ChessBoard>>searchAgent (in category 'accessing') -----
- searchAgent
- ^searchAgent!
Item was removed:
- ----- Method: ChessBoard>>searchAgent: (in category 'accessing') -----
- searchAgent: anAgent
- searchAgent := anAgent.!
Item was removed:
- ----- Method: ChessBoard>>statusString (in category 'accessing') -----
- statusString
- ^searchAgent statusString!
Item was removed:
- ----- Method: ChessBoard>>undoMove: (in category 'moving') -----
- undoMove: aMove
- activePlayer := activePlayer == whitePlayer
- ifTrue: [blackPlayer]
- ifFalse: [whitePlayer].
- activePlayer undoMove: aMove.
- userAgent
- ifNotNil: [userAgent undoMove: aMove white: activePlayer isWhitePlayer]!
Item was removed:
- ----- Method: ChessBoard>>updateHash:at:from: (in category 'hashing') -----
- updateHash: piece at: square from: player
- | index |
- index := player == whitePlayer ifTrue: [piece] ifFalse: [piece + 6].
- hashKey := hashKey bitXor: ((HashKeys at: index) at: square).
- hashLock := hashLock bitXor: ((HashLocks at: index) at: square)!
Item was removed:
- ----- Method: ChessBoard>>userAgent (in category 'accessing') -----
- userAgent
- ^userAgent!
Item was removed:
- ----- Method: ChessBoard>>userAgent: (in category 'accessing') -----
- userAgent: anObject
- userAgent := anObject.!
Item was removed:
- ----- Method: ChessBoard>>whitePlayer (in category 'accessing') -----
- whitePlayer
- ^whitePlayer!
Item was removed:
- SharedPool subclass: #ChessConstants
- instanceVariableNames: ''
- classVariableNames: 'A1 A2 A3 A4 A5 A6 A7 A8 B1 B2 B3 B4 B5 B6 B7 B8 Bishop BishopMovers BishopMoves C1 C2 C3 C4 C5 C6 C7 C8 CastlingDisableAll CastlingDisableKingSide CastlingDisableQueenSide CastlingDone CastlingEnableKingSide CastlingEnableQueenSide D1 D2 D3 D4 D5 D6 D7 D8 E1 E2 E3 E4 E5 E6 E7 E8 EmptySquare F1 F2 F3 F4 F5 F6 F7 F8 G1 G2 G3 G4 G5 G6 G7 G8 H1 H2 H3 H4 H5 H6 H7 H8 King KingMoves Knight KnightMoves Pawn PieceCenterScores PieceValues Queen Rook RookMovers RookMoves'
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
Item was removed:
- ----- Method: ChessConstants class>>initialize (in category 'pool initialization') -----
- initialize
- "ChessConstants initialize"
- self initializePieceConstants.
- self initializeCastlingConstants.
- self initializePieceValues.
- self initializeMoves.
- self initializeCenterScores.
- self initializeBishopMovers.
- self initializeRookMovers.
- self initializeSquareConstants.!
Item was removed:
- ----- Method: ChessConstants class>>initializeBishopMovers (in category 'pool initialization') -----
- initializeBishopMovers.
- BishopMovers := Set new.
- BishopMovers add:Bishop.
- BishopMovers add:Queen.!
Item was removed:
- ----- Method: ChessConstants class>>initializeBishopMoves (in category 'pool initialization') -----
- initializeBishopMoves
- "ChessPlayer initialize"
- | index moveList1 moveList2 moveList3 moveList4 px py |
- BishopMoves := Array new: 64 withAll: #().
- 0 to: 7 do:[:j|
- 0 to: 7 do:[:i|
- index := (j * 8) + i + 1.
- moveList1 := moveList2 := moveList3 := moveList4 := #().
- 1 to: 7 do:[:k|
- px := i + k. py := j - k.
- ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
- moveList1 := moveList1 copyWith: (py * 8) + px + 1].
- px := i - k. py := j - k.
- ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
- moveList2 := moveList2 copyWith: (py * 8) + px + 1].
- px := i + k. py := j + k.
- ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
- moveList3 := moveList3 copyWith: (py * 8) + px + 1].
- px := i - k. py := j + k.
- ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
- moveList4 := moveList4 copyWith: (py * 8) + px + 1].
- ].
- BishopMoves at: index put: {moveList1. moveList2. moveList3. moveList4}.
- ].
- ].!
Item was removed:
- ----- Method: ChessConstants class>>initializeCastlingConstants (in category 'pool initialization') -----
- initializeCastlingConstants
- CastlingDone := 1.
-
- CastlingDisableKingSide := 2.
- CastlingDisableQueenSide := 4.
- CastlingDisableAll := CastlingDisableQueenSide bitOr: CastlingDisableKingSide.
-
- CastlingEnableKingSide := CastlingDone bitOr: CastlingDisableKingSide.
- CastlingEnableQueenSide := CastlingDone bitOr: CastlingDisableQueenSide.
- !
Item was removed:
- ----- Method: ChessConstants class>>initializeCenterScores (in category 'pool initialization') -----
- initializeCenterScores
- "ChessPlayer initialize"
- PieceCenterScores := Array new: 6.
- 1 to: 6 do:[:i| PieceCenterScores at: i put: (ByteArray new: 64)].
- PieceCenterScores at: Knight put:
- #(
- -4 0 0 0 0 0 0 -4
- -4 0 2 2 2 2 0 -4
- -4 2 3 2 2 3 2 -4
- -4 1 2 5 5 2 2 -4
- -4 1 2 5 5 2 2 -4
- -4 2 3 2 2 3 2 -4
- -4 0 2 2 2 2 0 -4
- -4 0 0 0 0 0 0 -4
- ).
- PieceCenterScores at: Bishop put:
- #(
- -2 -2 -2 -2 -2 -2 -2 -2
- -2 0 0 0 0 0 0 -2
- -2 0 1 1 1 1 0 -2
- -2 0 1 2 2 1 0 -2
- -2 0 1 2 2 1 0 -2
- -2 0 1 1 1 1 0 -2
- -2 0 0 0 0 0 0 -2
- -2 -2 -2 -2 -2 -2 -2 -2
- ).
- PieceCenterScores at: Queen put:
- #(
- -3 0 0 0 0 0 0 -3
- -2 0 0 0 0 0 0 -2
- -2 0 1 1 1 1 0 -2
- -2 0 1 2 2 1 0 -2
- -2 0 1 2 2 1 0 -2
- -2 0 1 1 1 1 0 -2
- -2 0 0 0 0 0 0 -2
- -3 0 0 0 0 0 0 -3
- ).!
Item was removed:
- ----- Method: ChessConstants class>>initializeKingMoves (in category 'pool initialization') -----
- initializeKingMoves
- "ChessPlayer initialize"
- | index px py moveList |
- KingMoves := Array new: 64 withAll: #().
- 0 to: 7 do:[:j|
- 0 to: 7 do:[:i|
- index := (j * 8) + i + 1.
- moveList := #().
- #( (-1 -1) (0 -1) (1 -1) (-1 0) (1 0) (-1 1) (0 1) (1 1)) do:[:spec|
- px := i + spec first.
- py := j + spec last.
- ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
- moveList := moveList copyWith: (py * 8) + px + 1]].
- KingMoves at: index put: moveList
- ].
- ].!
Item was removed:
- ----- Method: ChessConstants class>>initializeKnightMoves (in category 'pool initialization') -----
- initializeKnightMoves
- "ChessPlayer initialize"
- | index px py moveList |
- KnightMoves := Array new: 64 withAll: #().
- 0 to: 7 do:[:j|
- 0 to: 7 do:[:i|
- index := (j * 8) + i + 1.
- moveList := #().
- #( (-2 -1) (-1 -2) (1 -2) (2 -1) (-2 1) (-1 2) (1 2) (2 1)) do:[:spec|
- px := i + spec first.
- py := j + spec last.
- ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
- moveList := moveList copyWith: (py * 8) + px + 1]].
- KnightMoves at: index put: moveList
- ].
- ].!
Item was removed:
- ----- Method: ChessConstants class>>initializeMoves (in category 'pool initialization') -----
- initializeMoves
- "ChessPlayer initialize"
- self initializeKnightMoves.
- self initializeRookMoves.
- self initializeBishopMoves.
- self initializeKingMoves.!
Item was removed:
- ----- Method: ChessConstants class>>initializePieceConstants (in category 'pool initialization') -----
- initializePieceConstants
- EmptySquare := 0.
- Pawn := 1.
- Knight := 2.
- Bishop := 3.
- Rook := 4.
- Queen := 5.
- King := 6.!
Item was removed:
- ----- Method: ChessConstants class>>initializePieceValues (in category 'pool initialization') -----
- initializePieceValues
- PieceValues := Array new: 6.
- PieceValues at: Pawn put: 100.
- PieceValues at: Knight put: 300.
- PieceValues at: Bishop put: 350.
- PieceValues at: Rook put: 500.
- PieceValues at: Queen put: 900.
- PieceValues at: King put: 2000.
- !
Item was removed:
- ----- Method: ChessConstants class>>initializeRookMovers (in category 'pool initialization') -----
- initializeRookMovers.
- RookMovers := Set new.
- RookMovers add:Rook.
- RookMovers add:Queen.!
Item was removed:
- ----- Method: ChessConstants class>>initializeRookMoves (in category 'pool initialization') -----
- initializeRookMoves
- "ChessPlayer initialize"
- | index moveList1 moveList2 moveList3 moveList4 px py |
- RookMoves := Array new: 64 withAll: #().
- 0 to: 7 do:[:j|
- 0 to: 7 do:[:i|
- index := (j * 8) + i + 1.
- moveList1 := moveList2 := moveList3 := moveList4 := #().
- 1 to: 7 do:[:k|
- px := i + k. py := j.
- ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
- moveList1 := moveList1 copyWith: (py * 8) + px + 1].
- px := i. py := j + k.
- ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
- moveList2 := moveList2 copyWith: (py * 8) + px + 1].
- px := i - k. py := j.
- ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
- moveList3 := moveList3 copyWith: (py * 8) + px + 1].
- px := i. py := j - k.
- ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
- moveList4 := moveList4 copyWith: (py * 8) + px + 1].
- ].
- RookMoves at: index put: {moveList1. moveList2. moveList3. moveList4}.
- ].
- ].!
Item was removed:
- ----- Method: ChessConstants class>>initializeSquareConstants (in category 'pool initialization') -----
- initializeSquareConstants
- A1:=1. B1:=2. C1:=3. D1:=4. E1:=5. F1:=6. G1:=7. H1:=8.
- A2:=9. B2:=10. C2:=11. D2:=12. E2:=13. F2:=14. G2:=15. H2:=16.
- A3:=17. B3:=18. C3:=19. D3:=20. E3:=21. F3:=22. G3:=23. H3:=24.
- A4:=25. B4:=26. C4:=27. D4:=28. E4:=29. F4:=30. G4:=31. H4:=32.
- A5:=33. B5:=34. C5:=35. D5:=36. E5:=37. F5:=38. G5:=39. H5:=40.
- A6:=41. B6:=42. C6:=43. D6:=44. E6:=45. F6:=46. G6:=47. H6:=48.
- A7:=49. B7:=50. C7:=51. D7:=52. E7:=53. F7:=54. G7:=55. H7:=56.
- A8:=57. B8:=58. C8:=59. D8:=60. E8:=61. F8:=62. G8:=63. H8:=64.!
Item was removed:
- Object variableWordSubclass: #ChessHistoryTable
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
-
- !ChessHistoryTable commentStamp: '<historical>' prior: 0!
- This class is a history table for our 'killer heuristic'. It remembers moves that have proven effective in the past and is later used to prioritize newly generated moves according to the effectiveness of the particular move in the past.!
Item was removed:
- ----- Method: ChessHistoryTable class>>new (in category 'instance creation') -----
- new
- ^self new: 4096+64!
Item was removed:
- ----- Method: ChessHistoryTable>>addMove: (in category 'accessing') -----
- addMove: aMove
- | index |
- index := (aMove sourceSquare bitShift: 6) + aMove destinationSquare.
- self at: index put: (self at: index + 1)!
Item was removed:
- ----- Method: ChessHistoryTable>>atAllPut: (in category 'initialize') -----
- atAllPut: aPositiveInteger
- "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays."
-
- <primitive: 145>
- self errorImproperStore.!
Item was removed:
- ----- Method: ChessHistoryTable>>clear (in category 'initialize') -----
- clear
- self atAllPut: 0.!
Item was removed:
- ----- Method: ChessHistoryTable>>sorts:before: (in category 'sorting') -----
- sorts: move1 before: move2
- ^(self at: (move1 sourceSquare bitShift: 6) + move1 destinationSquare) >
- (self at: (move2 sourceSquare bitShift: 6) + move2 destinationSquare)!
Item was removed:
- BorderedMorph subclass: #ChessMorph
- instanceVariableNames: 'board history redoList animateMove autoPlay'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
-
- !ChessMorph commentStamp: '<historical>' prior: 0!
- This class defines the user interface for a fine game of chess.!
Item was removed:
- ----- Method: ChessMorph class>>blackBishopImage (in category 'accessing') -----
- blackBishopImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 0 0 0 21053440 0 0 21053440 0 0 4538368 0 0 88489984 0 0 357978112 0 0 357994496 0 0 1431675904 0 1 1452647424 0 1 1452631040 0 5 1789487360 0 5 1789483264 0 5 1452628224 0 21 1452627200 0 21 1452626944 0 21 1431655424 0 21 1431655424 0 21 1431655424 0 21 1431654400 0 21 1431654400 0 5 1431654400 0 5 1431650304 0 1 1431650304 0 1 2863284224 0 1 2863284224 0 0 1431633920 0 0 445644800 0 1 1431650304 0 1 1789476864 0 1 1789476864 0 1 1431650304 0 0 20971520 0 0 89128960 0 0 357826560 0 21840 1414858069 0 349525 1410684245 1342177280 344085 1074091009 1342177280 262144 0 268435456 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph class>>blackKingImage (in category 'accessing') -----
- blackKingImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 0 0 0 0 0 0 4194304 0 0 22020096 0 0 4194304 0 0 89391104 0 0 111411200 0 1398016 107216981 1426063360 22369600 107218261 1430257664 22456660 107222362 2772434944 89740885 111416741 1498415104 90527125 1162892885 1448083456 93672805 1095850325 1448083456 362108249 1431656790 2522087424 362190169 1435854230 2522087424 362190422 1452643686 2522087424 362112598 1431672169 1448345600 362112597 2505463146 2522087424 93760085 2505463145 1448083456 93678165 2526434665 1448083456 93673045 1704351141 1498415104 90527317 1700353429 1498415104 23418261 1700353429 1497366528 22631829 1499027029 1497366528 22631829 1503221333 1698693120 5657957 1503222101 1694498816 1463653 1499026773 2483027968 1414485 1499026774 1409286144 354986 2841291433 1342177280 87381 1431655765 1073741824 21845 1431655765 0 5802 2863311508 0 6485 1431655780 0 6485 1521046884 0 6485 1431655780 0 6826 2863311524 0 5461 1431655764 0 0 0 0 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph class>>blackKnightImage (in category 'accessing') -----
- blackKnightImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 0 0 0 268435456 0 1 335544320 0 1 335544320 0 1 1430257664 0 0 1431568384 0 1 1431650304 0 21 1432704000 0 342 2774160704 0 1370 1767216464 0 5461 2505402708 0 21845 1431656021 0 87381 1431655829 0 349525 1431655781 1073741824 1398101 1431672149 1342177280 1398101 1431672153 1342177280 5592405 1431983446 1409286144 5592405 1343576406 1409286144 22369600 1402197 2483027968 26543360 5920085 2768240640 22287360 5593685 1694498816 22040576 23766357 1694498816 81920 89478485 1698693120 0 89478485 1698693120 0 357913941 1765801984 0 1431655765 1765801984 0 1431655765 1766850560 1 1431655765 1498415104 5 1431655765 1498415104 21 1431655765 1498415104 21 1431655765 1498415104 21 1431655765 1498415104 85 1431655765 1498415104 341 1431655765 1498415104 341 1431655765 1498415104 1365 1431655765 1498415104 1365 1431655765 1431306240 1365 1431655765 1431306240 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph class>>blackPawnImage (in category 'accessing') -----
- blackPawnImage
- ^((ColorForm
- extent: 40@40
- depth: 1
- fromArray: #( 0 0 15360 0 32256 0 32256 0 32256 0 32256 0 32256 0 15360 0 65280 0 262080 0 65280 0 32256 0 32256 0 65280 0 65280 0 65280 0 130944 0 262080 0 262080 0 524256 0 524256 0 524256 0 524256 0 524256 0 524256 0 524256 0 262080 0 262080 0 262080 0 130944 0 65280 0 65280 0 524256 0 4194300 0 8388606 0 16777215 0 33554431 2147483648 33554431 2147483648 33554431 2147483648 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) ))!
Item was removed:
- ----- Method: ChessMorph class>>blackQueenImage (in category 'accessing') -----
- blackQueenImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 0 0 0 0 0 0 5242880 0 0 5242880 0 0 1048576 0 320 4194324 0 320 5242900 0 64 5242896 0 64 5242896 0 64 5242896 0 80 5242960 0 83886160 5242960 0 83886160 5242960 1310720 16777300 5243216 1310720 4194388 22282576 1048576 4194388 22282576 4194304 5242964 22282576 4194304 5505109 22283600 20971520 1310805 22283600 88080384 1376341 22283600 88080384 1392725 1096029520 356515840 1392725 1096029520 356515840 1396821 1096029520 1430257664 1397845 1431655761 1426063360 349269 1431655761 1426063360 349525 1431655765 1426063360 349525 1431655765 1426063360 349525 1431655765 1426063360 349525 1521112405 1426063360 88746 2773854890 1409286144 91477 1453938005 2483027968 27285 1436898666 2415919104 23125 1521112410 1342177280 6826 2773854890 1073741824 5461 1431655765 1073741824 21845 1431655765 1342177280 21845 1431655765 1342177280 0 0 0 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph class>>blackRookImage (in category 'accessing') -----
- blackRookImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 357826560 0 349184 357826645 1073741824 349184 357826645 1073741824 349184 357826645 1073741824 349525 1431655765 1073741824 436906 2863311530 1073741824 349526 1431721301 1073741824 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1706 2863311504 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1706 2863311504 0 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1706 2863311504 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1706 2863311504 0 23210 2863311525 0 27306 2863311529 0 87381 1431655765 1073741824 436906 2863311530 2415919104 436906 2863311530 2415919104 349525 1431655765 1342177280 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'Chess' translatedNoop
- categories: {'Games' translatedNoop}
- documentation: 'A fine game of chess' translatedNoop!
Item was removed:
- ----- Method: ChessMorph class>>whiteBishopImage (in category 'accessing') -----
- whiteBishopImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 0 0 0 16842752 0 0 88424448 0 0 88424448 0 0 89473024 0 0 378966016 0 0 1520865280 0 1 1789240320 0 1 2842256384 0 5 2842321920 0 6 2505462784 0 22 2505479168 0 26 2842338304 0 26 2842338304 0 26 2842338304 0 26 2863309824 0 26 2863309824 0 26 2863309824 0 26 2863309824 0 26 2863305728 0 22 2863304704 0 6 2863288320 0 5 2863284224 0 1 1431650304 0 1 1431650304 0 1 1768505344 0 1 1768505344 0 1 1768505344 0 1 1431650304 0 5 2863284224 0 5 1431654400 0 0 104857600 0 0 374341632 0 0 1498677248 0 87381 1701139797 1073741824 1419946 2488969898 1409286144 349525 1343575381 1342177280 1310720 0 335544320 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph class>>whiteKingImage (in category 'accessing') -----
- whiteKingImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 0 0 0 22020096 0 0 93585408 0 0 111411200 0 0 93585408 0 0 362020864 0 1397760 447021077 1409286144 5940480 425263450 2768240640 23767376 429458858 2839543808 94721684 425268885 1448083456 110536037 426072410 2794455040 379234921 1499818410 2777939968 442149466 1431676586 2846097408 443198102 2526451305 1772355584 443116133 2842319449 1772355584 443111785 2841270937 2846097408 443193769 1785293465 2577661952 442866090 1789504149 1503920128 443110826 1785309845 2846097408 376083882 1499048598 2845048832 106603946 2573838938 2777677824 110799274 2594548330 2794455040 110799210 2594613610 2794455040 93760106 2523310506 2521825280 27699802 2774968746 2587885568 23440026 2795939242 1497366528 6908570 2795939497 1694498816 5925546 2795940521 2751463424 1463637 1453675861 2483027968 371301 2506447274 1342177280 87641 2590415189 1073741824 26261 1431655845 0 21850 2774182229 0 21930 2505484885 0 21866 2842339669 0 22165 1431655829 0 21850 2863311189 0 21845 143165576
5 0 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph class>>whiteKnightImage (in category 'accessing') -----
- whiteKnightImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 1073741824 0 16 1342177280 0 20 1342177280 0 5 1430257664 0 6 2857713664 0 6 2862956544 0 22 2863223808 0 346 2863306048 0 1445 1789569360 0 22166 1521134164 0 91813 1789569685 0 367274 2863245989 1073741824 1469098 2862983845 1342177280 1682090 2863049385 1342177280 5679786 2863048362 1409286144 22718890 2861996714 1409286144 27961706 2775210410 2499805184 95070809 1432708522 2499805184 111503701 22455978 2503999488 378889472 27957930 2773483520 374969344 94988970 2773483520 88428544 106343082 2773483520 84295680 359312042 2840592384 344064 1521134250 2840592384 1 1789569706 2840592384 1 2863311530 2840854528 5 2863311530 2857631744 22 2863311530 2857631744 26 2863311530 2857631744 90 2863311530 2857631744 106 2863311530 2857631744 362 2863311530 2857631744 1450 2863311530 2857631744 1706 2863311530 2857631744 5802 2863311530 2857631744 6826 2863311530 2857631744 23210 2863311530 2857631744 21845 1431655765 1431568384 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph class>>whitePawnImage (in category 'accessing') -----
- whitePawnImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 357826560 0 0 446955520 0 0 1520762880 0 0 1789460480 0 0 1520762880 0 0 378798080 0 0 1431633920 0 1 1789476864 0 21 2863289344 0 85 1431655680 0 0 446955520 0 0 1520762880 0 0 1789460480 0 0 1789460480 0 1 1789476864 0 5 2863288320 0 6 2863304704 0 22 2863305728 0 26 2863309824 0 90 2863310080 0 106 2863311104 0 106 2863311104 0 106 2863311104 0 90 2863310080 0 26 2863309824 0 26 2863309824 0 22 2863305728 0 6 2863304704 0 5 2863288320 0 1 1789476864 0 0 1789460480 0 341 1520784704 0 1450 2505484880 0 22186 2863311509 0 92842 2863311529 1073741824 109226 2863311530 1073741824 109226 2863311530 1073741824 87381 1431655765 1073741824 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph class>>whiteQueenImage (in category 'accessing') -----
- whiteQueenImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 0 0 0 5242880 0 0 22282240 0 0 5242880 0 64 5242896 0 336 5242964 0 336 5242964 0 64 5242896 0 64 5242896 0 80 5242960 0 80 22282320 0 83886160 27525200 1310720 352321620 27525456 1376256 88080484 27525520 1376256 20971620 27525520 5242880 5242981 27526544 5242880 5505129 27526800 22020096 6553705 27526800 93323264 6619241 1101272720 105906176 6881386 1168448144 373293056 5849194 1185487504 440401920 1724522 1453939344 1514143744 1740906 2527685265 1782579200 1741930 2527685265 2856321024 1746282 2863311509 2856321024 1747306 2863311510 2856321024 1485482 2863311530 2839543808 436906 2863311530 2835349504 436906 2505403050 2835349504 365909 1515869525 1694498816 87466 2773854885 1409286144 21850 2841029205 1342177280 21866 2505403029 1342177280 21845 1521112405 1342177280 27306 2863311530 2415919104 27306 2863311530 2415919104 92842 2863311530 2483027968 87381 1431655765 1409286144 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph class>>whiteRookImage (in category 'accessing') -----
- whiteRookImage
- ^((ColorForm
- extent: 40@40
- depth: 2
- fromArray: #( 0 0 0 0 357892096 0 87360 447283221 1409286144 109120 447283226 2751463424 109120 447283226 2751463424 109141 1521046874 2751463424 109226 2863311530 2751463424 87381 1431655765 1409286144 426 1789553316 0 426 1789553316 0 426 1789553316 0 426 1789553316 0 426 1789553316 0 341 1431655764 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 341 1431655764 0 426 1789553316 0 426 1789553316 0 426 1789553316 0 426 1789553316 0 426 1789553316 0 341 1431655764 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 5461 1431655765 0 23210 2863311529 1073741824 27306 2863311530 1073741824 87381 1431655765 1342177280 371370 2863311530 2483027968 436906 2863311530 2751463424 349525 1431655765 1409286144 0 0 0)
- offset: 0@0)
- colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was removed:
- ----- Method: ChessMorph>>acceptDroppingMorph:event: (in category 'layout') -----
- acceptDroppingMorph: aMorph event: anEvent
- | destSquare sourceSquare |
- sourceSquare := aMorph valueOfProperty: #chessBoardSourceSquare.
- aMorph removeProperty: #chessBoardSourceSquare.
- destSquare := self asSquare: aMorph center.
- "!!!!!! ACTUAL MOVE HAPPENS INDIRECTLY !!!!!!"
- (self atSquare: sourceSquare) addMorphCentered: aMorph.
- destSquare ifNil:[^self].
- self movePieceFrom: sourceSquare to: destSquare.
- self showMovesAt: destSquare.!
Item was removed:
- ----- Method: ChessMorph>>addButtonRow (in category 'initialize') -----
- addButtonRow
-
- | r m |
- r := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color transparent.
- r cellInset: 2.
- r addMorphBack: (self buttonName: ' New ' translated action: #newGame).
- r addMorphBack: (self buttonName: ' Help ' translated action: #findBestMove).
- r addMorphBack: (self buttonName: ' Play ' translated action: #thinkAndMove).
- r addMorphBack: (self buttonName: ' Auto ' translated action: #autoPlay).
- r addMorphBack: (self buttonName: ' Undo ' translated action: #undoMove).
- r addMorphBack: (self buttonName: ' Redo ' translated action: #redoMove).
- r addMorphBack: (self buttonName: ' Quit ' translated action: #delete).
- r disableLayout: true.
- r align: r bounds topLeft with: self layoutBounds topLeft.
- self addMorphFront: r.
- m := UpdatingStringMorph on: self selector: #statusString.
- m useStringFormat.
- m disableTableLayout: true.
- m align: m bounds topLeft with: r fullBounds bottomLeft.
- self addMorphFront: m.!
Item was removed:
- ----- Method: ChessMorph>>addSquares (in category 'initialize') -----
- addSquares
- | white black square index |
- white := Color white.
- black := Color lightGray.
- index := 0.
- #(
- ( ' ' 'a' 'b' 'c' 'd' 'e' 'f' 'g' 'h' ' ')
- ( '1' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
- ( '2' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
- ( '3' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
- ( '4' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
- ( '5' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
- ( '6' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
- ( '7' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
- ( '8' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
- ( ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ')
- ) do:[:file|
- file do:[:sq|
- square := self newSquare.
- square borderWidth: 0.
- (sq = 'W' or:[sq = 'B']) ifTrue:[
- square color: (sq = 'W' ifTrue:[white] ifFalse:[black]).
- square borderColor: Color red.
- square setProperty: #squarePosition toValue: (index := index + 1).
- square setNameTo:
- (String with: ($a asInteger + (index - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (index -1 bitShift: -3)) asCharacter).
- square on: #mouseEnter send: #showMoves:from: to: self.
- square on: #mouseEnterDragging send: #dragSquareEnter:from: to: self.
- square on: #mouseLeaveDragging send: #dragSquareLeave:from: to: self.
- ] ifFalse:["decoration"
- square color: Color transparent.
- sq = ' ' ifFalse:[
- square addMorphCentered: (StringMorph contents: sq asUppercase font: Preferences windowTitleFont emphasis: 1).
- ].
- ].
- square extent: 40@40.
- self addMorphBack: square.
- ]].
- !
Item was removed:
- ----- Method: ChessMorph>>addedPiece:at:white: (in category 'game callbacks') -----
- addedPiece: piece at: square white: isWhite
- | m |
- m := self newPiece: piece white: isWhite.
- m on: #mouseDown send: #dragPiece:from: to: self.
- m setProperty: #chessBoard toValue: self.
- (self atSquare: square) removeAllMorphs; addMorphCentered: m.!
Item was removed:
- ----- Method: ChessMorph>>areasRemainingToFill: (in category 'drawing') -----
- areasRemainingToFill: x
- ^x areasOutside: self bounds!
Item was removed:
- ----- Method: ChessMorph>>asSquare: (in category 'geometry') -----
- asSquare: aPoint
- self squaresDo:[:sq| (sq bounds containsPoint: aPoint) ifTrue:[^sq valueOfProperty: #squarePosition]].
- ^nil!
Item was removed:
- ----- Method: ChessMorph>>atSquare: (in category 'geometry') -----
- atSquare: square
- ^submorphs detect:[:any| (any valueOfProperty: #squarePosition) = square] ifNone:[nil]!
Item was removed:
- ----- Method: ChessMorph>>autoPlay (in category 'playing') -----
- autoPlay
- autoPlay := autoPlay not.
- autoPlay ifTrue:[self thinkAndMove].!
Item was removed:
- ----- Method: ChessMorph>>buttonFillStyle (in category 'initialize') -----
- buttonFillStyle
-
- | fill |
- fill := GradientFillStyle ramp: {
- 0.0 -> (Color r: 0.05 g: 0.5 b: 1.0).
- 1.0 -> (Color r: 0.85 g: 0.95 b: 1.0)}.
- fill origin: (0@0).
- fill direction: 40@10.
- fill radial: false.
- ^ fill
- !
Item was removed:
- ----- Method: ChessMorph>>buttonName:action: (in category 'initialize') -----
- buttonName: aString action: aSymbol
-
- ^ SimpleButtonMorph new
- target: self;
- label: aString;
- actionSelector: aSymbol;
- color: (Color gray: 0.8); "old color"
- fillStyle: self buttonFillStyle;
- borderWidth: 1;
- borderRaised.
- !
Item was removed:
- ----- Method: ChessMorph>>completedMove:white: (in category 'game callbacks') -----
- completedMove: aMove white: aBool
- board ifNil:[^self].
- history addLast: aMove.
- self validateGamePosition.!
Item was removed:
- ----- Method: ChessMorph>>defaultBorderColor (in category 'initialization') -----
- defaultBorderColor
- ^ Color transparent!
Item was removed:
- ----- Method: ChessMorph>>defaultBorderStyle (in category 'initialization') -----
- defaultBorderStyle
- ^ BorderStyle raised!
Item was removed:
- ----- Method: ChessMorph>>defaultBorderWidth (in category 'initialization') -----
- defaultBorderWidth
- "answer the default border width for the receiver"
- ^ 5!
Item was removed:
- ----- Method: ChessMorph>>defaultBounds (in category 'initialization') -----
- defaultBounds
- "answer the default bounds for the receiver"
- ^ 0 @ 0 corner: 410 @ 410!
Item was removed:
- ----- Method: ChessMorph>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the receiver's default color"
- | result |
- result := GradientFillStyle ramp: {0.0
- -> (Color
- r: 0.05
- g: 0.5
- b: 1.0). 1.0
- -> (Color
- r: 0.85
- g: 0.95
- b: 1.0)}.
- result origin: self bounds origin;
- direction: self extent.
- result radial: false.
- ^ result!
Item was removed:
- ----- Method: ChessMorph>>dragPiece:from: (in category 'drag and drop') -----
- dragPiece: evt from: aMorph
- board searchAgent isThinking ifTrue:[^self].
- self submorphsDo:[:m| m borderWidth: 0].
- aMorph setProperty: #chessBoardSourceSquare toValue: (aMorph owner valueOfProperty: #squarePosition).
- evt hand grabMorph: aMorph.!
Item was removed:
- ----- Method: ChessMorph>>dragSquareEnter:from: (in category 'drag and drop') -----
- dragSquareEnter: evt from: aMorph
- "Note: #wantsDroppedMorph: will validate move"
- board ifNil:[^self].
- evt hand hasSubmorphs ifFalse:[^self].
- (self wantsDroppedMorph: evt hand firstSubmorph event: evt) ifFalse:[^self].
- aMorph borderWidth: 1.!
Item was removed:
- ----- Method: ChessMorph>>dragSquareLeave:from: (in category 'drag and drop') -----
- dragSquareLeave: evt from: aMorph
- board ifNil:[^self].
- evt hand hasSubmorphs ifFalse:[^self].
- aMorph borderWidth: 0.!
Item was removed:
- ----- Method: ChessMorph>>findBestMove (in category 'playing') -----
- findBestMove
- | move |
- board searchAgent isThinking ifTrue:[^self].
- Cursor wait showWhile:[move := board searchAgent think].
- self inform: 'I suggest: ' translated, move printString.
- ^move!
Item was removed:
- ----- Method: ChessMorph>>finishedGame: (in category 'game callbacks') -----
- finishedGame: result
- "
- 0 - white lost
- 0.5 - draw
- 1 - white won
- "
- board := nil.!
Item was removed:
- ----- Method: ChessMorph>>gameReset (in category 'game callbacks') -----
- gameReset
- self squaresDo:[:m| m removeAllMorphs; borderWidth: 0]!
Item was removed:
- ----- Method: ChessMorph>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
- animateMove := false.
- autoPlay := false.
-
- self cornerStyle: #square.
- self layoutPolicy: TableLayout new.
- self listDirection: #leftToRight;
- wrapDirection: #bottomToTop.
- self addSquares.
- self addButtonRow.
- self newGame!
Item was removed:
- ----- Method: ChessMorph>>movePieceFrom:to: (in category 'playing') -----
- movePieceFrom: sourceSquare to: destSquare
- board ifNil:[^self].
- board searchAgent isThinking ifTrue:[^self].
- board movePieceFrom: sourceSquare to: destSquare.
- board searchAgent startThinking.!
Item was removed:
- ----- Method: ChessMorph>>movedPiece:from:to: (in category 'game callbacks') -----
- movedPiece: piece from: sourceSquare to: destSquare
- | sourceMorph destMorph sourcePos destPos w startTime nowTime deltaTime |
- sourceMorph := (self atSquare: sourceSquare) firstSubmorph.
- destMorph := self atSquare: destSquare.
- animateMove ifTrue:[
- sourcePos := sourceMorph boundsInWorld center.
- destPos := destMorph boundsInWorld center.
- (w := self world) ifNotNil:[
- w addMorphFront: sourceMorph.
- sourceMorph addDropShadow.
- sourceMorph shadowColor: (Color black alpha: 0.5).
- deltaTime := (sourcePos dist: destPos) * 10 asInteger.
- startTime := Time millisecondClockValue.
- [nowTime := Time millisecondClockValue.
- nowTime - startTime < deltaTime] whileTrue:[
- sourceMorph center: sourcePos + (destPos - sourcePos * (nowTime - startTime) // deltaTime) asIntegerPoint.
- w displayWorldSafely].
- sourceMorph removeDropShadow.
- ].
- ].
- destMorph removeAllMorphs.
- destMorph addMorphCentered: sourceMorph.
- animateMove := false.!
Item was removed:
- ----- Method: ChessMorph>>newGame (in category 'playing') -----
- newGame
- board ifNil:[board := ChessBoard new].
- board initialize.
- board userAgent: self.
- board initializeNewBoard.
- history := OrderedCollection new.
- redoList := OrderedCollection new.
- !
Item was removed:
- ----- Method: ChessMorph>>newPiece:white: (in category 'initialize') -----
- newPiece: piece white: isWhite
- | index selector m |
- index := piece.
- isWhite ifFalse:[index := index + 6].
- selector := #(
- whitePawnImage
- whiteKnightImage
- whiteBishopImage
- whiteRookImage
- whiteQueenImage
- whiteKingImage
-
- blackPawnImage
- blackKnightImage
- blackBishopImage
- blackRookImage
- blackQueenImage
- blackKingImage) at: index.
- m := ChessPieceMorph new image: (self class perform: selector).
- m setProperty: #isWhite toValue: isWhite.
- m setProperty: #piece toValue: piece.
- ^m!
Item was removed:
- ----- Method: ChessMorph>>newSquare (in category 'initialize') -----
- newSquare
- ^BorderedMorph new "or anyone alike"!
Item was removed:
- ----- Method: ChessMorph>>redoMove (in category 'playing') -----
- redoMove
- "Redo the last undone move"
- redoList isEmpty ifTrue:[^self].
- board nextMove: redoList removeLast.
- !
Item was removed:
- ----- Method: ChessMorph>>removedPiece:at: (in category 'game callbacks') -----
- removedPiece: piece at: square
- animateMove ifFalse:[
- (self atSquare: square) removeAllMorphs.
- ].!
Item was removed:
- ----- Method: ChessMorph>>replacedPiece:with:at:white: (in category 'game callbacks') -----
- replacedPiece: oldPiece with: newPiece at: square white: isWhite
- self removedPiece: oldPiece at: square.
- self addedPiece: newPiece at: square white: isWhite!
Item was removed:
- ----- Method: ChessMorph>>rotateBoard (in category 'other stuff') -----
- rotateBoard
- self listDirection = #leftToRight
- ifTrue:[^self listDirection: #topToBottom; wrapDirection: #leftToRight].
- self listDirection = #topToBottom
- ifTrue:[^self listDirection: #rightToLeft; wrapDirection: #topToBottom].
- self listDirection = #rightToLeft
- ifTrue:[^self listDirection: #bottomToTop; wrapDirection: #rightToLeft].
- self listDirection = #bottomToTop
- ifTrue:[^self listDirection: #leftToRight; wrapDirection: #bottomToTop].
- !
Item was removed:
- ----- Method: ChessMorph>>showMoves:from: (in category 'events') -----
- showMoves: evt from: aMorph
- | square |
- square := aMorph valueOfProperty: #squarePosition.
- square ifNotNil:[^self showMovesAt: square].!
Item was removed:
- ----- Method: ChessMorph>>showMovesAt: (in category 'events') -----
- showMovesAt: square
- | list |
- board ifNil:[^self].
- board searchAgent isThinking ifTrue:[^self].
- self squaresDo:[:m| m borderWidth: 0].
- list := board activePlayer findValidMovesAt: square.
- list isEmpty ifTrue:[^self].
- (self atSquare: square) borderWidth: 1.
- list do:[:move|
- (self atSquare: (move triggerSquareIn: board)) borderWidth: 1.
- ].!
Item was removed:
- ----- Method: ChessMorph>>squaresDo: (in category 'geometry') -----
- squaresDo: aBlock
- ^submorphs do:[:m| (m hasProperty: #squarePosition) ifTrue:[aBlock value: m]].!
Item was removed:
- ----- Method: ChessMorph>>statusString (in category 'other stuff') -----
- statusString
- board ifNil:[^''].
- ^board statusString!
Item was removed:
- ----- Method: ChessMorph>>step (in category 'stepping') -----
- step
- | move |
- board searchAgent isThinking ifTrue:[
- move := board searchAgent thinkStep.
- move ifNotNil:[
- animateMove := true.
- board movePieceFrom: move sourceSquare
- to: move destinationSquare].
- ] ifFalse:[
- autoPlay ifTrue:[board searchAgent startThinking].
- ].!
Item was removed:
- ----- Method: ChessMorph>>stepTime (in category 'testing') -----
- stepTime
- ^0!
Item was removed:
- ----- Method: ChessMorph>>thinkAndMove (in category 'playing') -----
- thinkAndMove
- board searchAgent isThinking ifTrue:[^self].
- board searchAgent startThinking.!
Item was removed:
- ----- Method: ChessMorph>>undoMove (in category 'playing') -----
- undoMove
- "Undo the last move"
- board ifNil:[^self].
- history isEmpty ifTrue:[^self].
- board undoMove: history removeLast.
- !
Item was removed:
- ----- Method: ChessMorph>>undoMove:white: (in category 'game callbacks') -----
- undoMove: aMove white: aBool
- board ifNil:[^self].
- redoList addLast: aMove.
- self validateGamePosition.!
Item was removed:
- ----- Method: ChessMorph>>validateGamePosition (in category 'game callbacks') -----
- validateGamePosition
- "This method does nothing but validating what you see (on screen) is what you get (from the board)."
- | square piece isWhite p |
- 1 to: 64 do:[:idx|
- square := self atSquare: idx.
- square hasSubmorphs
- ifTrue:[piece := square firstSubmorph valueOfProperty: #piece.
- isWhite := square firstSubmorph valueOfProperty: #isWhite]
- ifFalse:[piece := 0. isWhite := nil].
- p := board whitePlayer pieceAt: idx.
- idx = board whitePlayer castlingRookSquare ifTrue:[p := ChessPlayer rook].
- isWhite == true ifTrue:[
- p = piece ifFalse:[self error:'White broken'].
- ] ifFalse:[p = 0 ifFalse:[self error:'White broken']].
- p := board blackPlayer pieceAt: idx.
- idx = board blackPlayer castlingRookSquare ifTrue:[p := ChessPlayer rook].
- isWhite == false ifTrue:[
- p = piece ifFalse:[self error:'White broken'].
- ] ifFalse:[p = 0 ifFalse:[self error:'White broken']].
- ].!
Item was removed:
- ----- Method: ChessMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
- wantsDroppedMorph: aMorph event: anEvent
- | sourceSquare destSquare |
- (aMorph valueOfProperty: #chessBoard) == self ifFalse:[^false].
- board ifNil:[^true].
- sourceSquare := aMorph valueOfProperty: #chessBoardSourceSquare.
- destSquare := self asSquare: aMorph bounds center.
- destSquare ifNil:[^false].
- ^board activePlayer isValidMoveFrom: sourceSquare to: destSquare!
Item was removed:
- Object subclass: #ChessMove
- instanceVariableNames: 'movingPiece capturedPiece sourceSquare destinationSquare type value bestMove'
- classVariableNames: 'BasicMoveMask EvalTypeAccurate EvalTypeLowerBound EvalTypeUpperBound ExtractPromotionShift MoveCaptureEnPassant MoveCaptureOrdinary MoveCastlingKingSide MoveCastlingQueenSide MoveDoublePush MoveNormal MovePromotionBishop MovePromotionKnight MovePromotionQueen MovePromotionRook MoveResign MoveStaleMate NoPromotionMask NullMove PromotionMask PromotionShift'
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
-
- !ChessMove commentStamp: '<historical>' prior: 0!
- I represent a particular move in the chess game.!
Item was removed:
- ----- Method: ChessMove class>>basicMoveMask (in category 'accessing') -----
- basicMoveMask
- ^BasicMoveMask!
Item was removed:
- ----- Method: ChessMove class>>decodeFrom: (in category 'accessing') -----
- decodeFrom: encodedMove
- ^self new moveEncoded: encodedMove!
Item was removed:
- ----- Method: ChessMove class>>initialize (in category 'class initialization') -----
- initialize
- "ChessMove initialize"
- MoveNormal := 1.
- MoveDoublePush := 2.
- MoveCaptureEnPassant := 3.
- MoveCastlingKingSide := 4.
- MoveCastlingQueenSide := 5.
- MoveResign := 6.
- MoveStaleMate := 7.
-
- BasicMoveMask := 15.
- PromotionShift := 4.
- ExtractPromotionShift := 0 - PromotionShift.
-
- EvalTypeAccurate := 0.
- EvalTypeUpperBound := 1.
- EvalTypeLowerBound := 2.
-
- NullMove := 0.
-
- !
Item was removed:
- ----- Method: ChessMove>>= (in category 'comparing') -----
- = aMove
- movingPiece = aMove movingPiece ifFalse:[^false].
- capturedPiece = aMove capturedPiece ifFalse:[^false].
- type = aMove type ifFalse:[^false].
- sourceSquare = aMove sourceSquare ifFalse:[^false].
- destinationSquare = aMove destinationSquare ifFalse:[^false].
- ^true!
Item was removed:
- ----- Method: ChessMove>>bestMove (in category 'accessing') -----
- bestMove
- ^nil!
Item was removed:
- ----- Method: ChessMove>>captureEnPassant:from:to: (in category 'initialize') -----
- captureEnPassant: aPiece from: startSquare to: endSquare
- movingPiece := capturedPiece := aPiece.
- sourceSquare := startSquare.
- destinationSquare := endSquare.
- type := MoveCaptureEnPassant.!
Item was removed:
- ----- Method: ChessMove>>capturedPiece (in category 'accessing') -----
- capturedPiece
- ^capturedPiece!
Item was removed:
- ----- Method: ChessMove>>capturedPiece: (in category 'accessing') -----
- capturedPiece: aValue
- ^capturedPiece := aValue!
Item was removed:
- ----- Method: ChessMove>>checkMate: (in category 'initialize') -----
- checkMate: aPiece
- movingPiece := aPiece.
- sourceSquare := 0.
- destinationSquare := 0.
- type := MoveResign.
- capturedPiece := 0.!
Item was removed:
- ----- Method: ChessMove>>destinationSquare (in category 'accessing') -----
- destinationSquare
- ^destinationSquare!
Item was removed:
- ----- Method: ChessMove>>destinationSquare: (in category 'accessing') -----
- destinationSquare: aValue
- ^destinationSquare := aValue!
Item was removed:
- ----- Method: ChessMove>>doublePush:from:to: (in category 'initialize') -----
- doublePush: aPiece from: startSquare to: endSquare
- movingPiece := aPiece.
- sourceSquare := startSquare.
- destinationSquare := endSquare.
- type := MoveDoublePush.
- capturedPiece := 0.!
Item was removed:
- ----- Method: ChessMove>>encodedMove (in category 'accessing') -----
- encodedMove
- "Return an integer encoding enough of a move for printing"
- ^destinationSquare +
- (sourceSquare bitShift: 8) +
- (movingPiece bitShift: 16) +
- (capturedPiece bitShift: 24)!
Item was removed:
- ----- Method: ChessMove>>hash (in category 'comparing') -----
- hash
- ^((movingPiece hash bitXor: capturedPiece hash) bitXor:
- (sourceSquare hash bitXor: destinationSquare hash)) bitXor: type hash!
Item was removed:
- ----- Method: ChessMove>>init (in category 'initialize') -----
- init
- movingPiece := sourceSquare := destinationSquare := 1.
- type := MoveNormal.
- capturedPiece := 0.!
Item was removed:
- ----- Method: ChessMove>>move:from:to: (in category 'initialize') -----
- move: aPiece from: startSquare to: endSquare
- movingPiece := aPiece.
- sourceSquare := startSquare.
- destinationSquare := endSquare.
- type := MoveNormal.
- capturedPiece := 0.!
Item was removed:
- ----- Method: ChessMove>>move:from:to:capture: (in category 'initialize') -----
- move: aPiece from: startSquare to: endSquare capture: capture
- movingPiece := aPiece.
- sourceSquare := startSquare.
- destinationSquare := endSquare.
- capturedPiece := capture.
- type := MoveNormal.
- !
Item was removed:
- ----- Method: ChessMove>>moveCastlingKingSide:from:to: (in category 'initialize') -----
- moveCastlingKingSide: aPiece from: startSquare to: endSquare
- movingPiece := aPiece.
- sourceSquare := startSquare.
- destinationSquare := endSquare.
- type := MoveCastlingKingSide.
- capturedPiece := 0.!
Item was removed:
- ----- Method: ChessMove>>moveCastlingQueenSide:from:to: (in category 'initialize') -----
- moveCastlingQueenSide: aPiece from: startSquare to: endSquare
- movingPiece := aPiece.
- sourceSquare := startSquare.
- destinationSquare := endSquare.
- type := MoveCastlingQueenSide.
- capturedPiece := 0.!
Item was removed:
- ----- Method: ChessMove>>moveEncoded: (in category 'initialize') -----
- moveEncoded: encodedMove
- destinationSquare := encodedMove bitAnd: 255.
- sourceSquare := (encodedMove bitShift: -8) bitAnd: 255.
- movingPiece := (encodedMove bitShift: -16) bitAnd: 255.
- capturedPiece := (encodedMove bitShift: -24) bitAnd: 255.
- type := MoveNormal.
- !
Item was removed:
- ----- Method: ChessMove>>moveString (in category 'printing') -----
- moveString
- ^String streamContents:[:aStream|
- aStream nextPutAll: (#('' 'N' 'B' 'R' 'Q' 'K') at: movingPiece).
- aStream nextPutAll: (String with: ($a asInteger + (sourceSquare - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (sourceSquare -1 bitShift: -3)) asCharacter).
- capturedPiece = 0 ifTrue:[
- aStream nextPutAll: '-'.
- ] ifFalse:[
- aStream nextPutAll: 'x'.
- aStream nextPutAll: (#('' 'N' 'B' 'R' 'Q' 'K') at: capturedPiece).
- ].
- aStream nextPutAll: (String with: ($a asInteger + (destinationSquare - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (destinationSquare -1 bitShift: -3)) asCharacter).
- ].!
Item was removed:
- ----- Method: ChessMove>>moveType (in category 'accessing') -----
- moveType
- ^type!
Item was removed:
- ----- Method: ChessMove>>moveType: (in category 'accessing') -----
- moveType: aType
- ^type := aType!
Item was removed:
- ----- Method: ChessMove>>movingPiece (in category 'accessing') -----
- movingPiece
- ^movingPiece!
Item was removed:
- ----- Method: ChessMove>>movingPiece: (in category 'accessing') -----
- movingPiece: aValue
- ^movingPiece := aValue!
Item was removed:
- ----- Method: ChessMove>>printOn: (in category 'printing') -----
- printOn: aStream
- super printOn: aStream.
- aStream nextPutAll:'('.
- aStream nextPutAll: (#('' 'N' 'B' 'R' 'Q' 'K') at: movingPiece).
- aStream nextPutAll: (String with: ($a asInteger + (sourceSquare - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (sourceSquare -1 bitShift: -3)) asCharacter).
- capturedPiece = 0 ifTrue:[
- aStream nextPutAll: '-'.
- ] ifFalse:[
- aStream nextPutAll: 'x'.
- aStream nextPutAll: (#('' 'N' 'B' 'R' 'Q' 'K') at: capturedPiece).
- ].
- aStream nextPutAll: (String with: ($a asInteger + (destinationSquare - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (destinationSquare -1 bitShift: -3)) asCharacter).
- aStream nextPutAll:')'.!
Item was removed:
- ----- Method: ChessMove>>promote:to: (in category 'initialize') -----
- promote: move to: promotion
- movingPiece := move movingPiece.
- capturedPiece := move capturedPiece.
- sourceSquare := move sourceSquare.
- destinationSquare := move destinationSquare.
- type := move moveType.
- type := type bitOr: (promotion bitShift: PromotionShift).
- !
Item was removed:
- ----- Method: ChessMove>>promotion (in category 'accessing') -----
- promotion
- ^type bitShift: ExtractPromotionShift!
Item was removed:
- ----- Method: ChessMove>>sourceSquare (in category 'accessing') -----
- sourceSquare
- ^sourceSquare!
Item was removed:
- ----- Method: ChessMove>>sourceSquare: (in category 'accessing') -----
- sourceSquare: aValue
- ^sourceSquare := aValue!
Item was removed:
- ----- Method: ChessMove>>staleMate: (in category 'initialize') -----
- staleMate: aPiece
- movingPiece := aPiece.
- sourceSquare := 0.
- destinationSquare := 0.
- type := MoveStaleMate.
- capturedPiece := 0.!
Item was removed:
- ----- Method: ChessMove>>triggerSquareIn: (in category 'accessing') -----
- triggerSquareIn: aChessBoard
-
- type = MoveCastlingKingSide ifTrue: [^ aChessBoard activePlayer initialRightRookSquare].
- type = MoveCastlingQueenSide ifTrue: [^ aChessBoard activePlayer initialLeftRookSquare].
-
- ^destinationSquare!
Item was removed:
- ----- Method: ChessMove>>value (in category 'accessing') -----
- value
- ^value!
Item was removed:
- ----- Method: ChessMove>>value: (in category 'accessing') -----
- value: newValue
- value := newValue!
Item was removed:
- Object subclass: #ChessMoveGenerator
- instanceVariableNames: 'myPlayer myPieces itsPieces castlingStatus enpassantSquare forceCaptures moveList firstMoveIndex lastMoveIndex streamList streamListIndex attackSquares kingAttack'
- classVariableNames: 'EmptyPieceMap'
- poolDictionaries: 'ChessConstants'
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
-
- !ChessMoveGenerator commentStamp: '<historical>' prior: 0!
- This class generates moves for any given board. It's speed is critical - for each new position all moves need to be generated in that position. It may be worthwhile to make give this class a little plugin support at some time.!
Item was removed:
- ----- Method: ChessMoveGenerator>>attackSquares (in category 'public') -----
- attackSquares
- ^attackSquares!
Item was removed:
- ----- Method: ChessMoveGenerator>>blackPawnCaptureAt:direction: (in category 'moves-pawns') -----
- blackPawnCaptureAt: square direction: dir
- | destSquare move piece |
- destSquare := square-8-dir.
- piece := itsPieces at: destSquare.
- piece = 0 ifFalse:[
- (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
- move: Pawn from: square to: destSquare capture: piece.
- piece = King ifTrue:[kingAttack := move].
- destSquare <= 8 "a promotion"
- ifTrue:[self promotePawn: move].
- ].
- "attempt an en-passant capture"
- enpassantSquare = destSquare ifTrue:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- captureEnPassant: Pawn from: square to: destSquare.
- ].!
Item was removed:
- ----- Method: ChessMoveGenerator>>blackPawnPushAt: (in category 'moves-pawns') -----
- blackPawnPushAt: square
- | destSquare move |
- "Try to push this pawn"
- destSquare := square-8.
- (myPieces at: destSquare) = 0 ifFalse:[^self].
- (itsPieces at: destSquare) = 0 ifFalse:[^self].
- (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
- move: Pawn from: square to: destSquare.
- destSquare <= 8 "a promotion (can't be double-push so get out)"
- ifTrue:[^self promotePawn: move].
-
- "Try to double-push if possible"
- square > 48 ifFalse:[^self].
- destSquare := square-16.
- (myPieces at: destSquare) = 0 ifFalse:[^self].
- (itsPieces at: destSquare) = 0 ifFalse:[^self].
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- doublePush: Pawn from: square to: destSquare.!
Item was removed:
- ----- Method: ChessMoveGenerator>>canCastleBlackKingSide (in category 'support') -----
- canCastleBlackKingSide
- (castlingStatus bitAnd: CastlingEnableKingSide) = 0 ifFalse:[^false].
- "Quickly check if all the squares are zero"
- ((myPieces at: G8) + (myPieces at: F8) + (itsPieces at: G8) + (itsPieces at: F8) = 0) ifFalse:[^false].
- "Check for castling squares under attack.. See canCastleBlackQueenSide for details"
- (self checkAttack:{G7. G6. G5. G4. G3. G2. G1} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{F7. F6. F5. F4. F3. F2. F1} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{E7. E6. E5. E4. E3. E2. E1.} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{D8. C8. B8. A8} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{F7. E6. D5. C4. B3. A2} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{E7. D6. C5. B4. A3} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{D7. C6. B5. A4} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{F7. G6. H5} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{G7. H6} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{H7} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkUnprotectedAttack:{H7. G7. E7. D7. C7. H6. G6. F6. E6. D6} fromPiece:Knight) ifTrue:[^false].
- (self checkUnprotectedAttack:{H7. G7. F7. E7. D7} fromPiece:Pawn) ifTrue:[^false].
- (self checkUnprotectedAttack:{G7} fromPiece:King) ifTrue:[^false].
-
- ^true.
-
-
-
-
- !
Item was removed:
- ----- Method: ChessMoveGenerator>>canCastleBlackQueenSide (in category 'support') -----
- canCastleBlackQueenSide
- (castlingStatus bitAnd: CastlingEnableQueenSide) = 0 ifFalse:[^false].
- "Quickly check if all the squares are zero"
- ((myPieces at: B8) + (myPieces at: C8) + (myPieces at: D8) +
- (itsPieces at: B8) + (itsPieces at: C8) + (itsPieces at: D8)
- = 0) ifFalse:[^false].
- "Check to see if any of the squares involved in castling are under attack. First
- check for vertical (rook-like) attacks"
- (self checkAttack:{B7. B6. B5. B4. B3. B2. B1} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{C7. C6. C5. C4. C3. C2. C1} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{D7. D6. D5. D4. D3. D2. D1} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{E7. E6. E5. E4. E3. E2. E1} fromPieces:RookMovers) ifTrue:[^false].
- "Check for a rook attack from the baseline"
- (self checkAttack:{F8. G8. H8} fromPieces:RookMovers) ifTrue:[^false].
- "Check for bishop attacks from the diagonals"
- (self checkAttack:{C7. D6. E5. F4. G3. H2} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{D7. E6. F5. G4. H3} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{E7. F6. G5. H4} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{F7. G6. H5} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{A7} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{B7. A6} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{C7. B6. A5} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{D7. C6. B5. A4} fromPieces:BishopMovers) ifTrue:[^false].
- "Check for a knight attack"
- (self checkUnprotectedAttack:{A7. B7. C7. D7. E7. F7. G7. A6. B6. C6. D6. E6. F6} fromPiece:Knight) ifTrue:[^false].
- "check for a pawn attack"
- (self checkUnprotectedAttack:{A7. B7. C7. D7. E7. F7} fromPiece:Pawn) ifTrue:[^false].
- "check for a king attack"
- (self checkUnprotectedAttack:{B7. C7. } fromPiece:King) ifTrue:[^false].
- ^true.
- !
Item was removed:
- ----- Method: ChessMoveGenerator>>canCastleWhiteKingSide (in category 'support') -----
- canCastleWhiteKingSide
- (castlingStatus bitAnd: CastlingEnableKingSide) = 0 ifFalse: [^false].
- "Quickly check if all the squares are zero"
- ((myPieces at:G1) + (myPieces at:F1) + (itsPieces at:G1) + (itsPieces at:F1) = 0) ifFalse:[^false].
- "Check for castling squares under attack.. See canCastleBlackQueenSide for details"
- (self checkAttack:{G2. G3. G4. G5. G6. G7. G8} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{F2. F3. F4. F5. F6. F7. F8} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{E2. E3. E4. E5. E6. E7. E8} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{A1. A2. A3. A4} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{F2. E3. D4. C5. B6. A7} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{E2. D3. C4. B5. A6} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{D2. C3. B4. A5} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{F2. G3. H4} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{G2. H3} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{H2} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkUnprotectedAttack:{H2. G2. E2. D2. C2. H3. G3. F3. E3. D3} fromPiece:Knight) ifTrue:[^false].
- (self checkUnprotectedAttack:{H2. G2. F2. E2. D2} fromPiece:Pawn) ifTrue:[^false].
- (self checkUnprotectedAttack:{G2} fromPiece:King) ifTrue:[^false].
- ^true.!
Item was removed:
- ----- Method: ChessMoveGenerator>>canCastleWhiteQueenSide (in category 'support') -----
- canCastleWhiteQueenSide
- (castlingStatus bitAnd: CastlingEnableQueenSide) = 0 ifFalse: [^false].
- "Quickly check if all the squares are zero"
- ((myPieces at:B1) + (myPieces at:C1) + (myPieces at:D1) +
- (itsPieces at:B1) + (itsPieces at:C1) + (itsPieces at:D1) = 0) ifFalse:[^false].
- "Check for castling squares under attack.. See canCastleBlackQueenSide for details"
- (self checkAttack:{B2. B3. B4. B5. B6. B7. B8} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{C2. C3. C4. C5. C6. C7. C8} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{D2. D3. D4. D5. D6. D7. D8} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{E2. E3. E4. E5. E6. E7. E8} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{F1. G1. H1} fromPieces:RookMovers) ifTrue:[^false].
- (self checkAttack:{C2. D3. E4. F5. G6. H7} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{D2. E3. F4. G5. H6} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{E2. F3. G4. H5} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{F2. G3. H4} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{A2} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{B2. A3} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{C2. B3. A4} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkAttack:{D2. C3. B4. A5} fromPieces:BishopMovers) ifTrue:[^false].
- (self checkUnprotectedAttack:{A2. B2. C2. D2. E2. F2. G2. A3. B3. C3. D3. E3. F3} fromPiece:Knight) ifTrue:[^false].
- (self checkUnprotectedAttack:{A2. B2. C2. D2. E2. F2} fromPiece:Pawn) ifTrue:[^false].
- (self checkUnprotectedAttack:{B2. C2} fromPiece:King) ifTrue:[^false].
- ^true.!
Item was removed:
- ----- Method: ChessMoveGenerator>>checkAttack:fromPieces: (in category 'support') -----
- checkAttack:squares fromPieces:pieces
- "check for an unprotected attack along squares by one of pieces. Squares is a list of
- squares such that any piece in pieces can attack unless blocked by another piece.
- E.g., a Bishop of Queen on the file B7 C6 D5 E4 F3 G2 H1 can attack A8 unless blocked by
- another piece. To find out if A8 is under attack along B7 C6 D5 E4 F3 G2 H1, use
- checkAttack:{B7. C6.D5. E4. F3. G2. H1} fromPieces:BishopMovers. Note the order is important;
- squares must be listed in increasing distance from the square of interest"
-
- squares do:[:sqr|
- "invariant: no piece has been seen on this file at all"
- "one of my pieces blocks any attack"
- (myPieces at:sqr) = 0 ifFalse:[^false].
- "One of its pieces blocks an attack unless it is the kind of piece that can move along this
- file: a Bishop or Queen for a diagonal and a Rook or Queen for a Horizontal or
- Verrtical File"
- (itsPieces at:sqr) = 0 ifFalse:[
- ^pieces includes:(itsPieces at:sqr).
- ].
-
- ].
- "no pieces along file, no attack"
- ^false.
-
-
- !
Item was removed:
- ----- Method: ChessMoveGenerator>>checkUnprotectedAttack:fromPiece: (in category 'support') -----
- checkUnprotectedAttack:squares fromPiece:piece
- "check to see if my opponent has a piece of type piece on any of squares. In general, this
- is used because that piece could launch an attack on me from those squares".
- squares do:[:sqr|
- (itsPieces at:sqr) = piece ifTrue:[^true].
- ].
- ^false.
-
-
- !
Item was removed:
- ----- Method: ChessMoveGenerator>>findAllPossibleMovesFor: (in category 'public') -----
- findAllPossibleMovesFor: player
- "Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
-
- | piece actions square |
- myPlayer := player.
- myPieces := player pieces.
- itsPieces := player opponent pieces.
- castlingStatus := player castlingStatus.
- enpassantSquare := player opponent enpassantSquare.
- firstMoveIndex = lastMoveIndex ifFalse: [self error: 'I am confused'].
- kingAttack := nil.
- myPlayer isWhitePlayer ifTrue:[
- actions := #(moveWhitePawnAt: moveKnightAt: moveBishopAt:
- moveRookAt: moveQueenAt: moveWhiteKingAt:)
- ] ifFalse:[
- actions := #(moveBlackPawnAt: moveKnightAt: moveBishopAt:
- moveRookAt: moveQueenAt: moveBlackKingAt:)
- ].
- square := 0.
- [square < 64] whileTrue:[
- "Note: The following is only to skip empty fields efficiently.
- It could well be replaced by going through each field and test it
- for zero but this is *much* faster."
- square := self skipEmptySquaresIn: myPieces
- using: EmptyPieceMap
- startingAt: square + 1.
- square = 0 ifTrue: [^self moveList].
- piece := myPieces at: square.
- self perform: (actions at: piece) with: square.
- kingAttack ifNotNil: [^self moveList].
- ].
- ^self moveList!
Item was removed:
- ----- Method: ChessMoveGenerator>>findAttackSquaresFor: (in category 'public') -----
- findAttackSquaresFor: player
- "Mark all the fields of a board that are attacked by the given player.
- The pieces attacking a field are encoded as (1 << Piece) so that we can
- record all types of pieces that attack the square."
-
- | move square piece attack list |
- forceCaptures := false.
- attackSquares ifNil: [attackSquares := ByteArray new: 64].
- attackSquares atAllPut: 0.
- list := self findAllPossibleMovesFor: player.
-
- [move := list next.
- move isNil] whileFalse:
- [square := move destinationSquare.
- piece := move movingPiece.
- attack := attackSquares at: square.
- attack := attack bitOr: (1 bitShift: piece).
- attackSquares at: square put: attack].
- self recycleMoveList: list.
- ^attackSquares!
Item was removed:
- ----- Method: ChessMoveGenerator>>findPossibleMovesFor: (in category 'public') -----
- findPossibleMovesFor: player
- "Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
- forceCaptures := false.
- ^self findAllPossibleMovesFor: player.!
Item was removed:
- ----- Method: ChessMoveGenerator>>findPossibleMovesFor:at: (in category 'public') -----
- findPossibleMovesFor: player at: square
- "Find all possible moves at the given square. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
- | piece action |
- forceCaptures := false.
- myPlayer := player.
- myPieces := player pieces.
- itsPieces := player opponent pieces.
- castlingStatus := player castlingStatus.
- enpassantSquare := player opponent enpassantSquare.
- firstMoveIndex = lastMoveIndex ifFalse:[self error:'I am confused'].
- kingAttack := nil.
- piece := myPieces at: square.
- piece = 0 ifFalse:[
- action := #(movePawnAt:
- moveKnightAt:
- moveBishopAt:
- moveRookAt:
- moveQueenAt:
- moveKingAt:) at: piece.
- self perform: action with: square.
- ].
- ^self moveList!
Item was removed:
- ----- Method: ChessMoveGenerator>>findQuiescenceMovesFor: (in category 'public') -----
- findQuiescenceMovesFor: player
- "Find all the quiescence moves (that is moves capturing pieces)"
- forceCaptures := true.
- ^self findAllPossibleMovesFor: player.!
Item was removed:
- ----- Method: ChessMoveGenerator>>initialize (in category 'initialize') -----
- initialize
- EmptyPieceMap ifNil:[
- EmptyPieceMap := ByteArray new: 256.
- 2 to: 7 do:[:i| EmptyPieceMap at: i put: 1]].
-
- streamList := Array new: 100. "e.g., 100 plies"
- 1 to: streamList size do:[:i| streamList at: i put: (ChessMoveList on: #())].
- moveList := Array new: streamList size * 30. "avg. 30 moves per ply"
- 1 to: moveList size do:[:i| moveList at: i put: (ChessMove new init)].
- firstMoveIndex := lastMoveIndex := streamListIndex := 0.!
Item was removed:
- ----- Method: ChessMoveGenerator>>kingAttack (in category 'public') -----
- kingAttack
- ^kingAttack!
Item was removed:
- ----- Method: ChessMoveGenerator>>moveBishopAt: (in category 'moves-general') -----
- moveBishopAt: square
- | moves |
- moves := BishopMoves at: square.
- 1 to: moves size do:[:i|
- self movePiece: Bishop along: (moves at: i) at: square.
- ].
- !
Item was removed:
- ----- Method: ChessMoveGenerator>>moveBlackKingAt: (in category 'moves-general') -----
- moveBlackKingAt: square
- | capture |
- (KingMoves at: square) do:[:destSquare|
- (myPieces at: destSquare) = 0 ifTrue:[
- capture := itsPieces at: destSquare.
- (forceCaptures and:[capture = 0]) ifFalse:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- move: King from: square to: destSquare capture: capture.
- capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
- ].
- ].
- ].
- forceCaptures ifTrue:[^self].
- "now consider castling"
- self canCastleBlackKingSide ifTrue:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- moveCastlingKingSide: King from: square to: square+2.
- ].
- self canCastleBlackQueenSide ifTrue:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- moveCastlingQueenSide: King from: square to: square-2.
- ].!
Item was removed:
- ----- Method: ChessMoveGenerator>>moveBlackPawnAt: (in category 'moves-pawns') -----
- moveBlackPawnAt: square
- "Pawns only move in one direction so check for which direction to use"
- forceCaptures ifFalse:[self blackPawnPushAt: square].
- (square bitAnd: 7) = 1
- ifFalse:[self blackPawnCaptureAt: square direction: 1].
- (square bitAnd: 7) = 0
- ifFalse:[self blackPawnCaptureAt: square direction: -1].
- !
Item was removed:
- ----- Method: ChessMoveGenerator>>moveKingAt: (in category 'moves-general') -----
- moveKingAt: square
- myPlayer isWhitePlayer
- ifTrue:[^self moveWhiteKingAt: square]
- ifFalse:[^self moveBlackKingAt: square]!
Item was removed:
- ----- Method: ChessMoveGenerator>>moveKnightAt: (in category 'moves-general') -----
- moveKnightAt: square
- | capture moves destSquare |
- moves := KnightMoves at: square.
- 1 to: moves size do:[:i|
- destSquare := moves at: i.
- (myPieces at: destSquare) = 0 ifTrue:[
- capture := itsPieces at: destSquare.
- (forceCaptures and:[capture = 0]) ifFalse:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- move: Knight from: square to: destSquare capture: capture.
- capture = King ifTrue:[kingAttack := (moveList at: lastMoveIndex)].
- ].
- ].
- ].!
Item was removed:
- ----- Method: ChessMoveGenerator>>moveList (in category 'public') -----
- moveList
- | list |
- kingAttack ifNotNil:[
- lastMoveIndex := firstMoveIndex.
- ^nil].
- list := streamList at: (streamListIndex := streamListIndex + 1).
- list on: moveList from: firstMoveIndex+1 to: lastMoveIndex.
- firstMoveIndex := lastMoveIndex.
- ^list!
Item was removed:
- ----- Method: ChessMoveGenerator>>movePawnAt: (in category 'moves-general') -----
- movePawnAt: square
- "Pawns only move in one direction so check for which direction to use"
- myPlayer isWhitePlayer
- ifTrue:[^self moveWhitePawnAt: square]
- ifFalse:[^self moveBlackPawnAt: square]!
Item was removed:
- ----- Method: ChessMoveGenerator>>movePiece:along:at: (in category 'moves-general') -----
- movePiece: piece along: rayList at: square
- | destSquare capture |
- 1 to: rayList size do:[:i|
- destSquare := rayList at: i.
- (myPieces at: destSquare) = 0 ifFalse:[^self].
- capture := itsPieces at: destSquare.
- (forceCaptures and:[capture = 0]) ifFalse:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- move: piece from: square to: destSquare capture: capture.
- capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
- ].
- capture = 0 ifFalse:[^self].
- ].!
Item was removed:
- ----- Method: ChessMoveGenerator>>moveQueenAt: (in category 'moves-general') -----
- moveQueenAt: square
- | moves |
- moves := RookMoves at: square.
- 1 to: moves size do:[:i|
- self movePiece: Queen along: (moves at: i) at: square.
- ].
- moves := BishopMoves at: square.
- 1 to: moves size do:[:i|
- self movePiece: Queen along: (moves at: i) at: square.
- ].!
Item was removed:
- ----- Method: ChessMoveGenerator>>moveRookAt: (in category 'moves-general') -----
- moveRookAt: square
- | moves |
- moves := RookMoves at: square.
- 1 to: moves size do:[:i|
- self movePiece: Rook along: (moves at: i) at: square.
- ].
- !
Item was removed:
- ----- Method: ChessMoveGenerator>>moveWhiteKingAt: (in category 'moves-general') -----
- moveWhiteKingAt: square
- | capture |
- (KingMoves at: square) do:[:destSquare|
- (myPieces at: destSquare) = 0 ifTrue:[
- capture := itsPieces at: destSquare.
- (forceCaptures and:[capture = 0]) ifFalse:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- move: King from: square to: destSquare capture: capture.
- capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
- ].
- ].
- ].
- forceCaptures ifTrue:[^self].
- "now consider castling"
- self canCastleWhiteKingSide ifTrue:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- moveCastlingKingSide: King from: square to: square+2.
- ].
- self canCastleWhiteQueenSide ifTrue:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- moveCastlingQueenSide: King from: square to: square-2.
- ].!
Item was removed:
- ----- Method: ChessMoveGenerator>>moveWhitePawnAt: (in category 'moves-pawns') -----
- moveWhitePawnAt: square
- "Pawns only move in one direction so check for which direction to use"
- forceCaptures ifFalse:[self whitePawnPushAt: square].
- (square bitAnd: 7) = 0
- ifFalse:[self whitePawnCaptureAt: square direction: 1].
- (square bitAnd: 7) = 1
- ifFalse:[self whitePawnCaptureAt: square direction: -1].
- !
Item was removed:
- ----- Method: ChessMoveGenerator>>profileGenerationFor: (in category 'public') -----
- profileGenerationFor: player
- | list |
- Smalltalk garbageCollect.
- MessageTally spyOn:[
- 1 to: 100000 do:[:i|
- list := self findPossibleMovesFor: player.
- self recycleMoveList: list].
- ].
- !
Item was removed:
- ----- Method: ChessMoveGenerator>>promotePawn: (in category 'moves-pawns') -----
- promotePawn: move
- "Duplicate the given move and embed all promotion types"
- (moveList at: (lastMoveIndex := lastMoveIndex + 1)) promote: move to: Knight.
- (moveList at: (lastMoveIndex := lastMoveIndex + 1)) promote: move to: Bishop.
- (moveList at: (lastMoveIndex := lastMoveIndex + 1)) promote: move to: Rook.
- move promote: move to: Queen.!
Item was removed:
- ----- Method: ChessMoveGenerator>>recycleMoveList: (in category 'public') -----
- recycleMoveList: aChessMoveList
- (streamList at: streamListIndex) == aChessMoveList ifFalse:[^self error:'I am confused'].
- streamListIndex := streamListIndex - 1.
- firstMoveIndex := lastMoveIndex := aChessMoveList startIndex - 1.
- !
Item was removed:
- ----- Method: ChessMoveGenerator>>skipEmptySquaresIn:using:startingAt: (in category 'private') -----
- skipEmptySquaresIn: pieces using: aMap startingAt: startIndex
- "Find the first empty (zero) square in pieces. The method is layed out so we can (re)use the a particularly effective String primitive (which requires the map argument) but the failure code will do the more natural search for zero instead of the actual primitive equivalent."
- <primitive: 'primitiveFindFirstInString' module: 'MiscPrimitivePlugin'>
- startIndex to: pieces size do:[:index|
- (pieces at: index) = 0 ifFalse:[^index].
- ].
- ^0!
Item was removed:
- ----- Method: ChessMoveGenerator>>whitePawnCaptureAt:direction: (in category 'moves-pawns') -----
- whitePawnCaptureAt: square direction: dir
- | destSquare move piece |
- destSquare := square+8+dir.
- piece := itsPieces at: destSquare.
- piece = 0 ifFalse:[
- (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
- move: Pawn from: square to: destSquare capture: piece.
- piece = King ifTrue:[kingAttack := move].
- destSquare > 56 "a promotion"
- ifTrue:[self promotePawn: move].
- ].
- "attempt an en-passant capture"
- enpassantSquare = destSquare ifTrue:[
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- captureEnPassant: Pawn from: square to: destSquare.
- ].!
Item was removed:
- ----- Method: ChessMoveGenerator>>whitePawnPushAt: (in category 'moves-pawns') -----
- whitePawnPushAt: square
- "Pawns only move in one direction so check for which direction to use"
- | destSquare move |
- "Try to push this pawn"
- destSquare := square+8.
-
- (myPieces at: destSquare) = 0 ifFalse:[^self].
- (itsPieces at: destSquare) = 0 ifFalse:[^self].
- (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
- move: Pawn from: square to: destSquare.
- destSquare > 56 "a promotion (can't be double-push so get out)"
- ifTrue:[^self promotePawn: move].
-
- "Try to double-push if possible"
- square <= 16 ifFalse:[^self].
- destSquare := square+16.
- (myPieces at: destSquare) = 0 ifFalse:[^self].
- (itsPieces at: destSquare) = 0 ifFalse:[^self].
- (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- doublePush: Pawn from: square to: destSquare.!
Item was removed:
- ReadStream subclass: #ChessMoveList
- instanceVariableNames: 'startIndex'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
-
- !ChessMoveList commentStamp: '<historical>' prior: 0!
- An optimized representation of a set of moves - mainly there to avoid excessive allocation (and garbage collections) in a few critical places.!
Item was removed:
- ----- Method: ChessMoveList>>contents (in category 'accessing') -----
- contents
- ^collection copyFrom: startIndex to: readLimit!
Item was removed:
- ----- Method: ChessMoveList>>on:from:to: (in category 'private') -----
- on: aCollection from: firstIndex to: lastIndex
- startIndex := firstIndex.
- ^super on: aCollection from: firstIndex to: lastIndex.
- !
Item was removed:
- ----- Method: ChessMoveList>>sortUsing: (in category 'sorting') -----
- sortUsing: historyTable
-
- ^collection
- quickSortFrom: startIndex
- to: readLimit
- by: [ :a :b | historyTable sorts: a before: b ]!
Item was removed:
- ----- Method: ChessMoveList>>startIndex (in category 'accessing') -----
- startIndex
- ^startIndex!
Item was removed:
- ImageMorph subclass: #ChessPieceMorph
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
Item was removed:
- ----- Method: ChessPieceMorph>>wantsToBeDroppedInto: (in category 'dropping/grabbing') -----
- wantsToBeDroppedInto: aMorph
- ^aMorph isKindOf: ChessMorph!
Item was removed:
- ChessPieceMorph subclass: #ChessPieceMorphWC
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess960'!
-
- !ChessPieceMorphWC commentStamp: 'spfa 5/31/2020 10:36' prior: 0!
- ChessPieceMorphWC class side provides scalable images from Wikimedia Commons!
Item was removed:
- ----- Method: ChessPieceMorphWC class>>pieceExtent (in category 'forms library') -----
- pieceExtent
-
- ^ 314 @ 302!
Item was removed:
- ----- Method: ChessPieceMorphWC class>>pieces (in category 'forms library') -----
(excessive size, no diff calculated)
Item was removed:
- ----- Method: ChessPieceMorphWC class>>piecesWithExtent: (in category 'forms library') -----
- piecesWithExtent: aPoint
-
- | form dict ng og pg i ib iw |
-
- form := self pieces.
- dict := Dictionary new.
- ng := #( whiteKing blackKing whiteQueen blackQueen whiteBishop blackBishop whiteKnight blackKnight whiteRook blackRook whitePawn blackPawn).
-
- og := #(55 55 10 10 0 0 0 0 0 0 0 0).
- pg := #(0 0 0 0 20 20 50 50 90 90 120 120).
-
- i := 0.
- 0 to: 5 do: [:n |
- ib := (i := i + 1) * 2 - 1.
- iw := i * 2.
- dict at: (ng at: ib)
- put: ((form contentsOfArea: (315 * n + (pg at: ib) @0
- corner: 315 * n + 314 - (og at: ib) @ 302))
- scaledToSize: aPoint).
- dict at: (ng at: iw)
- put: ((form contentsOfArea: (315 * n + (pg at: iw) @327
- corner: 315 * n + 314 - (og at: iw) @ 629))
- scaledToSize: aPoint)].
-
- ^ dict!
Item was removed:
- ----- Method: ChessPieceMorphWC class>>piecesWithHeight: (in category 'forms library') -----
- piecesWithHeight: anInteger
-
- ^ self piecesWithExtent: self pieceExtent x * anInteger / self pieceExtent y @ anInteger!
Item was removed:
- Object subclass: #ChessPlayer
- instanceVariableNames: 'board pieces opponent castlingRookSquare enpassantSquare castlingStatus materialValue numPawns positionalValue'
- classVariableNames: ''
- poolDictionaries: 'ChessConstants'
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
-
- !ChessPlayer commentStamp: '<historical>' prior: 0!
- This class represents a player in the game, including its pieces and the current value of the player's position.!
Item was removed:
- ----- Method: ChessPlayer class>>king (in category 'accessing') -----
- king
- ^King!
Item was removed:
- ----- Method: ChessPlayer class>>rook (in category 'accessing') -----
- rook
- ^Rook!
Item was removed:
- ----- Method: ChessPlayer>>addBlackPieces (in category 'adding/removing') -----
- addBlackPieces
- self initialize.
- 49 to: 56 do:[:i| self addPiece: Pawn at: i].
- self addPiece: Rook at: 57.
- self addPiece: Knight at: 58.
- self addPiece: Bishop at: 59.
- self addPiece: Queen at: 60.
- self addPiece: King at: 61.
- self addPiece: Bishop at: 62.
- self addPiece: Knight at: 63.
- self addPiece: Rook at: 64.
- !
Item was removed:
- ----- Method: ChessPlayer>>addPiece:at: (in category 'adding/removing') -----
- addPiece: piece at: square
- pieces at: square put: piece.
- materialValue := materialValue + (PieceValues at: piece).
- positionalValue := positionalValue + ((PieceCenterScores at: piece) at: square).
- piece = Pawn ifTrue:[numPawns := numPawns + 1].
- board updateHash: piece at: square from: self.
- self userAgent ifNotNil:[self userAgent addedPiece: piece at: square white: self isWhitePlayer].!
Item was removed:
- ----- Method: ChessPlayer>>addWhitePieces (in category 'adding/removing') -----
- addWhitePieces
- self addPiece: Rook at: 1.
- self addPiece: Knight at: 2.
- self addPiece: Bishop at: 3.
- self addPiece: Queen at: 4.
- self addPiece: King at: 5.
- self addPiece: Bishop at: 6.
- self addPiece: Knight at: 7.
- self addPiece: Rook at: 8.
- 9 to: 16 do:[:i| self addPiece: Pawn at: i].
- !
Item was removed:
- ----- Method: ChessPlayer>>applyCastleKingSideMove: (in category 'moving') -----
- applyCastleKingSideMove: move
- self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.
- self movePiece: Rook from: move sourceSquare+3 to: (castlingRookSquare := move sourceSquare+1).
- pieces at: castlingRookSquare put: King.
- castlingStatus := castlingStatus bitOr: CastlingDone.!
Item was removed:
- ----- Method: ChessPlayer>>applyCastleQueenSideMove: (in category 'moving') -----
- applyCastleQueenSideMove: move
- self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.
- self movePiece: Rook from: move sourceSquare-4 to: (castlingRookSquare := move sourceSquare-1).
- pieces at: castlingRookSquare put: King.
- castlingStatus := castlingStatus bitOr: CastlingDone.!
Item was removed:
- ----- Method: ChessPlayer>>applyDoublePushMove: (in category 'moving') -----
- applyDoublePushMove: move
- enpassantSquare := (move sourceSquare + move destinationSquare) bitShift: -1.
- "Above means: the field between start and destination"
- ^self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.!
Item was removed:
- ----- Method: ChessPlayer>>applyEnpassantMove: (in category 'moving') -----
- applyEnpassantMove: move
- | capturedSquare |
- capturedSquare := move destinationSquare - (self isWhitePlayer ifTrue:[8] ifFalse:[-8]).
- opponent removePiece: move capturedPiece at: capturedSquare.
- self userAgent ifNotNil:[(self userAgent atSquare: capturedSquare) removeAllMorphs].
- ^self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare!
Item was removed:
- ----- Method: ChessPlayer>>applyMove: (in category 'moving') -----
- applyMove: move
- "Apply the given move"
- | action |
- "Apply basic move"
- action := #(
- applyNormalMove:
- applyDoublePushMove:
- applyEnpassantMove:
- applyCastleKingSideMove:
- applyCastleQueenSideMove:
- applyResign:
- applyStaleMate:
- ) at: (move moveType bitAnd: ChessMove basicMoveMask).
- self perform: action with: move.
-
- "Promote if necessary"
- self applyPromotion: move.
-
- "Maintain castling status"
- self updateCastlingStatus: move.
- !
Item was removed:
- ----- Method: ChessPlayer>>applyNormalMove: (in category 'moving') -----
- applyNormalMove: move
- | piece |
- (piece := move capturedPiece) = EmptySquare
- ifFalse:[opponent removePiece: piece at: move destinationSquare].
- ^self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.!
Item was removed:
- ----- Method: ChessPlayer>>applyPromotion: (in category 'moving') -----
- applyPromotion: move
- | piece |
- piece := move promotion.
- piece = 0 ifFalse:[self replacePiece: move movingPiece with: piece at: move destinationSquare].!
Item was removed:
- ----- Method: ChessPlayer>>applyResign: (in category 'moving') -----
- applyResign: move
- "Give up."
- self userAgent ifNotNil:[
- self isWhitePlayer
- ifTrue:[self userAgent finishedGame: 0]
- ifFalse:[self userAgent finishedGame: 1].
- ].!
Item was removed:
- ----- Method: ChessPlayer>>applyStaleMate: (in category 'moving') -----
- applyStaleMate: move
- "Itsa draw."
- self userAgent ifNotNil:[self userAgent finishedGame: 0.5].!
Item was removed:
- ----- Method: ChessPlayer>>board (in category 'accessing') -----
- board
- ^board!
Item was removed:
- ----- Method: ChessPlayer>>board: (in category 'accessing') -----
- board: aBoard
- board := aBoard!
Item was removed:
- ----- Method: ChessPlayer>>canCastleKingSide (in category 'testing') -----
- canCastleKingSide
- (castlingStatus bitAnd: CastlingEnableKingSide) = 0 ifFalse: [^false].
- self isWhitePlayer
- ifTrue:
- [(pieces sixth) = 0 ifFalse: [^false].
- pieces seventh = 0 ifFalse: [^false].
- (opponent pieceAt: 6) = 0 ifFalse: [^false].
- (opponent pieceAt: 7) = 0 ifFalse: [^false]]
- ifFalse:
- [(pieces at: 62) = 0 ifFalse: [^false].
- (pieces at: 63) = 0 ifFalse: [^false].
- (opponent pieceAt: 62) = 0 ifFalse: [^false].
- (opponent pieceAt: 63) = 0 ifFalse: [^false]].
- ^true!
Item was removed:
- ----- Method: ChessPlayer>>canCastleQueenSide (in category 'testing') -----
- canCastleQueenSide
- (castlingStatus bitAnd: CastlingEnableQueenSide) = 0 ifFalse: [^false].
- self isWhitePlayer
- ifTrue:
- [pieces second = 0 ifFalse: [^false].
- (pieces third) = 0 ifFalse: [^false].
- pieces fourth = 0 ifFalse: [^false].
- (opponent pieceAt: 2) = 0 ifFalse: [^false].
- (opponent pieceAt: 3) = 0 ifFalse: [^false].
- (opponent pieceAt: 4) = 0 ifFalse: [^false]]
- ifFalse:
- [(pieces at: 58) = 0 ifFalse: [^false].
- (pieces at: 59) = 0 ifFalse: [^false].
- (pieces at: 60) = 0 ifFalse: [^false].
- (opponent pieceAt: 58) = 0 ifFalse: [^false].
- (opponent pieceAt: 59) = 0 ifFalse: [^false].
- (opponent pieceAt: 60) = 0 ifFalse: [^false]].
- ^true!
Item was removed:
- ----- Method: ChessPlayer>>castlingRookSquare (in category 'accessing') -----
- castlingRookSquare
- ^castlingRookSquare!
Item was removed:
- ----- Method: ChessPlayer>>castlingStatus (in category 'accessing') -----
- castlingStatus
- ^castlingStatus!
Item was removed:
- ----- Method: ChessPlayer>>copyPlayer: (in category 'copying') -----
- copyPlayer: aPlayer
- "Copy all the volatile state from aPlayer"
- castlingRookSquare := aPlayer castlingRookSquare.
- enpassantSquare := aPlayer enpassantSquare.
- castlingStatus := aPlayer castlingStatus.
- materialValue := aPlayer materialValue.
- numPawns := aPlayer numPawns.
- positionalValue := aPlayer positionalValue.
- pieces replaceFrom: 1 to: pieces size with: aPlayer pieces startingAt: 1.!
Item was removed:
- ----- Method: ChessPlayer>>enpassantSquare (in category 'accessing') -----
- enpassantSquare
- ^enpassantSquare!
Item was removed:
- ----- Method: ChessPlayer>>evaluate (in category 'evaluation') -----
- evaluate
- ^self evaluateMaterial + self evaluatePosition!
Item was removed:
- ----- Method: ChessPlayer>>evaluateMaterial (in category 'evaluation') -----
- evaluateMaterial
- "Compute the board's material balance, from the point of view of the side
- player. This is an exact clone of the eval function in CHESS 4.5"
- | total diff value pawns |
- self materialValue = opponent materialValue ifTrue:[^0]. "both sides are equal"
- total := self materialValue + opponent materialValue.
- diff := self materialValue - opponent materialValue.
-
- pawns := numPawns.
- pawns < 0 ifTrue: ["happens - a bug somewhere" pawns := 0].
-
- value := (2400 min: diff) +
- ((diff * (12000 - total) * pawns) // (6400 * (pawns + 1))).
- ^value!
Item was removed:
- ----- Method: ChessPlayer>>evaluatePosition (in category 'evaluation') -----
- evaluatePosition
- "Compute the board's positional balance, from the point of view of the side player."
- ^positionalValue - opponent positionalValue!
Item was removed:
- ----- Method: ChessPlayer>>findPossibleMoves (in category 'moves-general') -----
- findPossibleMoves
- "Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
- | moveList moves |
- moveList := board generator findPossibleMovesFor: self.
- moveList ifNil:[^nil].
- moves := moveList contents collect:[:move| move copy].
- board generator recycleMoveList: moveList.
- ^moves!
Item was removed:
- ----- Method: ChessPlayer>>findPossibleMovesAt: (in category 'moves-general') -----
- findPossibleMovesAt: square
- "Find all possible moves at the given square. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
- | moveList moves |
- moveList := board generator findPossibleMovesFor: self at: square.
- moveList ifNil:[^nil].
- moves := moveList contents collect:[:move| move copy].
- board generator recycleMoveList: moveList.
- ^moves!
Item was removed:
- ----- Method: ChessPlayer>>findQuiescenceMoves (in category 'moves-general') -----
- findQuiescenceMoves
- "Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
- | moveList moves |
- moveList := board generator findQuiescenceMovesFor: self.
- moveList ifNil:[^nil].
- moves := moveList contents collect:[:move| move copy].
- board generator recycleMoveList: moveList.
- ^moves!
Item was removed:
- ----- Method: ChessPlayer>>findValidMoves (in category 'moves-general') -----
- findValidMoves
- "Find all the valid moves"
- | moveList |
- moveList := self findPossibleMoves ifNil:[^nil].
- ^moveList select:[:move| self isValidMove: move].!
Item was removed:
- ----- Method: ChessPlayer>>findValidMovesAt: (in category 'moves-general') -----
- findValidMovesAt: square
- "Find all the valid moves"
- | moveList |
- moveList := (self findPossibleMovesAt: square) ifNil:[^nil].
- ^moveList select:[:move| self isValidMove: move].!
Item was removed:
- ----- Method: ChessPlayer>>initialLeftRookSquare (in category 'configuration') -----
- initialLeftRookSquare
-
- ^ self isWhitePlayer ifTrue: [A1] ifFalse: [A8]!
Item was removed:
- ----- Method: ChessPlayer>>initialRightRookSquare (in category 'configuration') -----
- initialRightRookSquare
-
- ^ self isWhitePlayer ifTrue: [H1] ifFalse: [H8]!
Item was removed:
- ----- Method: ChessPlayer>>initialize (in category 'initialize') -----
- initialize
- "ChessPlayer initialize"
- pieces := ByteArray new: 64.
- materialValue := 0.
- positionalValue := 0.
- numPawns := 0.
- enpassantSquare := 0.
- castlingRookSquare := 0.
- castlingStatus := 0.!
Item was removed:
- ----- Method: ChessPlayer>>isValidMove: (in category 'testing') -----
- isValidMove: move
- "Is the given move actually valid for the receiver?
- If the receiver's king can't be taken after applying the move, it is."
- | copy |
- copy := board copy.
- copy nextMove: move.
- ^copy activePlayer findPossibleMoves notNil!
Item was removed:
- ----- Method: ChessPlayer>>isValidMoveFrom:to: (in category 'testing') -----
- isValidMoveFrom: sourceSquare to: destSquare
- | move |
- move := (self findValidMovesAt: sourceSquare)
- detect:[:any| (any triggerSquareIn: board) = destSquare] ifNone:[nil].
- ^move notNil!
Item was removed:
- ----- Method: ChessPlayer>>isWhitePlayer (in category 'testing') -----
- isWhitePlayer
- ^board whitePlayer == self!
Item was removed:
- ----- Method: ChessPlayer>>materialValue (in category 'accessing') -----
- materialValue
- ^materialValue!
Item was removed:
- ----- Method: ChessPlayer>>movePiece:from:to: (in category 'adding/removing') -----
- movePiece: piece from: sourceSquare to: destSquare
- | score |
- score := PieceCenterScores at: piece.
- positionalValue := positionalValue - (score at: sourceSquare).
- positionalValue := positionalValue + (score at: destSquare).
- pieces at: sourceSquare put: 0.
- pieces at: destSquare put: piece.
- board updateHash: piece at: sourceSquare from: self.
- board updateHash: piece at: destSquare from: self.
- self userAgent ifNotNil:[self userAgent movedPiece: piece from: sourceSquare to: destSquare].!
Item was removed:
- ----- Method: ChessPlayer>>numPawns (in category 'accessing') -----
- numPawns
- ^numPawns!
Item was removed:
- ----- Method: ChessPlayer>>opponent (in category 'accessing') -----
- opponent
- ^opponent!
Item was removed:
- ----- Method: ChessPlayer>>opponent: (in category 'accessing') -----
- opponent: aPlayer
- opponent := aPlayer!
Item was removed:
- ----- Method: ChessPlayer>>pieceAt: (in category 'accessing') -----
- pieceAt: square
- "Return the piece at the given square"
- ^pieces at: square!
Item was removed:
- ----- Method: ChessPlayer>>pieces (in category 'accessing') -----
- pieces
- ^pieces!
Item was removed:
- ----- Method: ChessPlayer>>positionalValue (in category 'evaluation') -----
- positionalValue
- "Evaluate our current position"
- ^positionalValue!
Item was removed:
- ----- Method: ChessPlayer>>postCopy (in category 'copying') -----
- postCopy
-
- pieces := pieces copy!
Item was removed:
- ----- Method: ChessPlayer>>prepareNextMove (in category 'initialize') -----
- prepareNextMove
- "Clear enpassant square and reset any pending extra kings"
- enpassantSquare := 0.
- castlingRookSquare = 0 ifFalse:[pieces at: castlingRookSquare put: Rook].
- castlingRookSquare := 0.
- !
Item was removed:
- ----- Method: ChessPlayer>>removePiece:at: (in category 'adding/removing') -----
- removePiece: piece at: square
-
- (pieces at: square) = piece ifFalse: ["fix"
- "Happens at time - some moves have a capturedPiece absent from the board"
- ^self].
-
- pieces at: square put: 0.
- materialValue := materialValue - (PieceValues at: piece).
- positionalValue := positionalValue - ((PieceCenterScores at: piece) at: square).
- piece = Pawn ifTrue:[numPawns := numPawns - 1].
- board updateHash: piece at: square from: self.
- self userAgent ifNotNil:[self userAgent removedPiece: piece at: square].
- !
Item was removed:
- ----- Method: ChessPlayer>>replacePiece:with:at: (in category 'adding/removing') -----
- replacePiece: oldPiece with: newPiece at: square
- pieces at: square put: newPiece.
- materialValue := materialValue - (PieceValues at: oldPiece) + (PieceValues at: newPiece).
- positionalValue := positionalValue - ((PieceCenterScores at: oldPiece) at: square).
- positionalValue := positionalValue + ((PieceCenterScores at: newPiece) at: square).
-
- oldPiece = Pawn ifTrue:[numPawns := numPawns - 1].
- newPiece = Pawn ifTrue:[numPawns := numPawns + 1].
- board updateHash: oldPiece at: square from: self.
- board updateHash: newPiece at: square from: self.
- self userAgent ifNotNil:[self userAgent replacedPiece: oldPiece with: newPiece at: square white: self isWhitePlayer].!
Item was removed:
- ----- Method: ChessPlayer>>undoCastleKingSideMove: (in category 'undo') -----
- undoCastleKingSideMove: move
- self prepareNextMove. "in other words, remove extra kings"
- self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
- self movePiece: Rook from: move sourceSquare+1 to: move sourceSquare+3.!
Item was removed:
- ----- Method: ChessPlayer>>undoCastleQueenSideMove: (in category 'undo') -----
- undoCastleQueenSideMove: move
- self prepareNextMove. "in other words, remove extra kings"
- self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
- self movePiece: Rook from: move sourceSquare-1 to: move sourceSquare-4.
- !
Item was removed:
- ----- Method: ChessPlayer>>undoDoublePushMove: (in category 'undo') -----
- undoDoublePushMove: move
- enpassantSquare := 0.
- self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.!
Item was removed:
- ----- Method: ChessPlayer>>undoEnpassantMove: (in category 'undo') -----
- undoEnpassantMove: move
- self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
- opponent addPiece: move capturedPiece at: move destinationSquare -
- (self isWhitePlayer ifTrue:[8] ifFalse:[-8]).
- !
Item was removed:
- ----- Method: ChessPlayer>>undoMove: (in category 'undo') -----
- undoMove: move
- "Undo the given move"
- | action |
- self undoPromotion: move.
- "Apply basic move"
- action := #(
- undoNormalMove:
- undoDoublePushMove:
- undoEnpassantMove:
- undoCastleKingSideMove:
- undoCastleQueenSideMove:
- undoResign:
- undoStaleMate:
- ) at: (move moveType bitAnd: ChessMove basicMoveMask).
- self perform: action with: move.!
Item was removed:
- ----- Method: ChessPlayer>>undoNormalMove: (in category 'undo') -----
- undoNormalMove: move
- | piece |
- self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
- (piece := move capturedPiece) = EmptySquare
- ifFalse:[opponent addPiece: piece at: move destinationSquare].
- !
Item was removed:
- ----- Method: ChessPlayer>>undoPromotion: (in category 'undo') -----
- undoPromotion: move
- | piece |
- piece := move promotion.
- piece = 0 ifFalse:[self replacePiece: piece with: move movingPiece at: move destinationSquare].!
Item was removed:
- ----- Method: ChessPlayer>>undoResign: (in category 'undo') -----
- undoResign: move!
Item was removed:
- ----- Method: ChessPlayer>>undoStaleMate: (in category 'undo') -----
- undoStaleMate: move!
Item was removed:
- ----- Method: ChessPlayer>>updateCastlingStatus: (in category 'moving') -----
- updateCastlingStatus: move
-
- "Cannot castle when king has moved"
- (move movingPiece = King)
- ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableAll].
-
- "See if a rook has moved"
- (move movingPiece = Rook) ifFalse:[^self].
-
- self isWhitePlayer ifTrue:[
- (move sourceSquare = 1)
- ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableQueenSide].
- (move sourceSquare = 8)
- ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableKingSide].
- ] ifFalse:[
- (move sourceSquare = 57)
- ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableQueenSide].
- (move sourceSquare = 64)
- ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableKingSide].
- ].!
Item was removed:
- ----- Method: ChessPlayer>>userAgent (in category 'accessing') -----
- userAgent
- ^board userAgent!
Item was removed:
- Object subclass: #ChessPlayerAI
- instanceVariableNames: 'board boardList boardListIndex player historyTable transTable generator random variations activeVariation bestVariation nodesVisited ttHits stamp alphaBetaCuts startTime ply myMove myProcess stopThinking bestMove'
- classVariableNames: 'AlphaBetaGiveUp AlphaBetaIllegal AlphaBetaMaxVal AlphaBetaMinVal ValueAccurate ValueBoundary ValueLowerBound ValueThreshold ValueUpperBound'
- poolDictionaries: 'ChessConstants'
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
-
- !ChessPlayerAI commentStamp: '<historical>' prior: 0!
- I am the AI that will beat you eventually. Well, maybe not today ... BUT MY TIME WILL COME!!!!!!!
Item was removed:
- ----- Method: ChessPlayerAI class>>initialize (in category 'class initialization') -----
- initialize
- "ChessPlayerAI initialize"
- AlphaBetaGiveUp := -29990.
- AlphaBetaIllegal := -31000.
- AlphaBetaMaxVal := 30000.
- AlphaBetaMinVal := -30000.
- ValueAccurate := 2.
- ValueBoundary := 4.
- ValueLowerBound := 4.
- ValueUpperBound := 5.
- ValueThreshold := 200.!
Item was removed:
- ----- Method: ChessPlayerAI>>activePlayer: (in category 'initialize') -----
- activePlayer: aPlayer
- player := aPlayer.
- board := player board.
- generator := board generator.
- self reset.!
Item was removed:
- ----- Method: ChessPlayerAI>>copyVariation: (in category 'searching') -----
- copyVariation: move
- | av mv count |
- count := 0.
- av := variations at: ply + 1.
- ply < 9
- ifTrue:
- [mv := variations at: ply + 2.
- count := mv first.
- av
- replaceFrom: 3
- to: count + 2
- with: mv
- startingAt: 2].
- av at: 1 put: count + 1.
- av at: 2 put: move encodedMove!
Item was removed:
- ----- Method: ChessPlayerAI>>initialize (in category 'initialize') -----
- initialize
- historyTable := ChessHistoryTable new.
- "NOTE: transposition table is initialized only when we make the first move. It costs a little to do all the entries and the garbage collections so we do it only when we *really* need it."
- transTable := nil.
- random := Random new.
- nodesVisited := ttHits := alphaBetaCuts := stamp := 0.
- variations := Array new: 11.
- 1 to: variations size do:[:i|
- variations at: i put: (Array new: variations size).
- (variations at: i) atAllPut: 0].
- bestVariation := Array new: variations size.
- bestVariation atAllPut: 0.
- activeVariation := Array new: variations size.
- activeVariation atAllPut: 0.
- self reset.!
Item was removed:
- ----- Method: ChessPlayerAI>>initializeTranspositionTable (in category 'initialize') -----
- initializeTranspositionTable
- "Initialize the transposition table. Note: For now we only use 64k entries since they're somewhat space intensive. If we should get a serious speedup at some point we may want to increase the transposition table - 256k seems like a good idea; but right now 256k entries cost us roughly 10MB of space. So we use only 64k entries (2.5MB of space).
- If you have doubts about the size of the transition table (e.g., if you think it's too small or too big) then modify the value below and have a look at ChessTranspositionTable>>clear which can print out some valuable statistics.
- "
- transTable := ChessTranspositionTable new: 16. "1 << 16 entries"!
Item was removed:
- ----- Method: ChessPlayerAI>>isThinking (in category 'thinking') -----
- isThinking
- ^myProcess notNil!
Item was removed:
- ----- Method: ChessPlayerAI>>mtdfSearch:score:depth: (in category 'searching') -----
- mtdfSearch: theBoard score: estimate depth: depth
- "An implementation of the MTD(f) algorithm. See:
- http://www.cs.vu.nl/~aske/mtdf.html
- "
-
- | beta move value low high goodMove |
- value := estimate.
- low := AlphaBetaMinVal.
- high := AlphaBetaMaxVal.
- [low >= high] whileFalse:
- [beta := value = low ifTrue: [value + 1] ifFalse: [beta := value].
- move := self
- searchMove: theBoard
- depth: depth
- alpha: beta - 1
- beta: beta.
- stopThinking ifTrue: [^move].
- move ifNil: [^move].
- value := move value.
- value < beta
- ifTrue: [high := value]
- ifFalse:
- ["NOTE: It is important that we do *NOT* return a move from a search which didn't reach the beta goal (e.g., value < beta). This is because all it means is that we didn't reach beta and the move returned is not the move 'closest' to beta but just one that triggered cut-off. In other words, if we'd take a move which value is less than beta it could mean that this move is a *LOT* worse than beta."
-
- low := value.
- goodMove := move.
- activeVariation
- replaceFrom: 1
- to: activeVariation size
- with: (variations first)
- startingAt: 1]].
- ^goodMove!
Item was removed:
- ----- Method: ChessPlayerAI>>negaScout:depth:alpha:beta: (in category 'searching') -----
- negaScout: theBoard depth: depth alpha: initialAlpha beta: initialBeta
- "Modified version to return the move rather than the score"
- | move score alpha bestScore moveList newBoard beta goodMove a b notFirst |
- self
- assert: [initialAlpha < initialBeta].
- ply < 10
- ifTrue: [(variations at: ply + 1)
- at: 1
- put: 0].
- ply := 0.
- alpha := initialAlpha.
- beta := initialBeta.
- bestScore := AlphaBetaMinVal.
- "Generate new moves"
- moveList := generator findPossibleMovesFor: theBoard activePlayer.
- moveList
- ifNil: [^ nil].
- moveList size = 0
- ifTrue: [generator recycleMoveList: moveList.
- ^ nil].
- "Sort move list according to history heuristics"
- moveList sortUsing: historyTable.
- "And search"
- a := alpha.
- b := beta.
- notFirst := false.
- [(move := moveList next) isNil]
- whileFalse: [newBoard := (boardList at: ply + 1)
- copyBoard: theBoard.
- newBoard nextMove: move.
- "Search recursively"
- "Search recursively"
- ply := ply + 1.
- score := 0
- - (self
- ngSearch: newBoard
- depth: depth - 1
- alpha: 0 - b
- beta: 0 - a).
- (notFirst
- and: [score > a
- and: [score < beta
- and: [depth > 1]]])
- ifTrue: [score := 0
- - (self
- ngSearch: newBoard
- depth: depth - 1
- alpha: 0 - beta
- beta: 0 - score)].
- notFirst := true.
- ply := ply - 1.
- stopThinking
- ifTrue: [generator recycleMoveList: moveList.
- ^ move].
- score = AlphaBetaIllegal
- ifFalse: [score > bestScore
- ifTrue: [ply < 10
- ifTrue: [self copyVariation: move].
- goodMove := move copy.
- goodMove value: score.
- activeVariation
- replaceFrom: 1
- to: activeVariation size
- with: variations first
- startingAt: 1.
- bestScore := score].
- "See if we can cut off the search"
- score > a
- ifTrue: [a := score.
- a >= beta
- ifTrue: [transTable
- storeBoard: theBoard
- value: score
- type: (ValueBoundary
- bitOr: (ply bitAnd: 1))
- depth: depth
- stamp: stamp.
- historyTable addMove: move.
- alphaBetaCuts := alphaBetaCuts + 1.
- generator recycleMoveList: moveList.
- ^ goodMove]].
- b := a + 1]].
- transTable
- storeBoard: theBoard
- value: bestScore
- type: (ValueAccurate
- bitOr: (ply bitAnd: 1))
- depth: depth
- stamp: stamp.
- generator recycleMoveList: moveList.
- ^ goodMove!
Item was removed:
- ----- Method: ChessPlayerAI>>ngSearch:depth:alpha:beta: (in category 'searching') -----
- ngSearch: theBoard depth: depth alpha: initialAlpha beta: initialBeta
- "A basic alpha-beta algorithm; based on negaMax rather than from the text books"
-
- | move score alpha entry bestScore moveList newBoard beta a b notFirst |
- self assert: [initialAlpha < initialBeta].
- ply < 10 ifTrue: [(variations at: ply + 1) at: 1 put: 0].
- depth = 0
- ifTrue:
- [^self
- quiesce: theBoard
- alpha: initialAlpha
- beta: initialBeta].
- nodesVisited := nodesVisited + 1.
- "See if there's already something in the transposition table. If so, skip the entire search."
- entry := transTable lookupBoard: theBoard.
- alpha := initialAlpha.
- beta := initialBeta.
- (entry isNil or: [entry depth < depth])
- ifFalse:
- [ttHits := ttHits + 1.
- (entry valueType bitAnd: 1) = (ply bitAnd: 1)
- ifTrue: [beta := entry value max: initialBeta]
- ifFalse: [alpha := 0 - entry value max: initialAlpha].
- beta > initialBeta ifTrue: [^beta].
- alpha >= initialBeta ifTrue: [^alpha]].
- bestScore := AlphaBetaMinVal.
-
- "Generate new moves"
- moveList := generator findPossibleMovesFor: theBoard activePlayer.
- moveList ifNil: [^0 - AlphaBetaIllegal].
- moveList isEmpty
- ifTrue:
- [generator recycleMoveList: moveList.
- ^bestScore].
-
- "Sort move list according to history heuristics"
- moveList sortUsing: historyTable.
-
- "And search"
- a := alpha.
- b := beta.
- notFirst := false.
- [(move := moveList next) isNil] whileFalse:
- [newBoard := (boardList at: ply + 1) copyBoard: theBoard.
- newBoard nextMove: move.
- "Search recursively"
- ply := ply + 1.
- score := 0 - (self
- ngSearch: newBoard
- depth: depth - 1
- alpha: 0 - b
- beta: 0 - a).
- (notFirst and: [score > a and: [score < beta and: [depth > 1]]])
- ifTrue:
- [score := 0 - (self
- ngSearch: newBoard
- depth: depth - 1
- alpha: 0 - beta
- beta: 0 - score)].
- notFirst := true.
- ply := ply - 1.
- stopThinking
- ifTrue:
- [generator recycleMoveList: moveList.
- ^score].
- score = AlphaBetaIllegal
- ifFalse:
- [score > bestScore
- ifTrue:
- [ply < 10 ifTrue: [self copyVariation: move].
- bestScore := score].
- score > a
- ifTrue:
- [a := score.
- a >= beta
- ifTrue:
- [transTable
- storeBoard: theBoard
- value: score
- type: (ValueBoundary bitOr: (ply bitAnd: 1))
- depth: depth
- stamp: stamp.
- historyTable addMove: move.
- alphaBetaCuts := alphaBetaCuts + 1.
- generator recycleMoveList: moveList.
- ^score]].
- b := a + 1]].
- transTable
- storeBoard: theBoard
- value: bestScore
- type: (ValueAccurate bitOr: (ply bitAnd: 1))
- depth: depth
- stamp: stamp.
- generator recycleMoveList: moveList.
- ^bestScore!
Item was removed:
- ----- Method: ChessPlayerAI>>quiesce:alpha:beta: (in category 'searching') -----
- quiesce: theBoard alpha: initialAlpha beta: initialBeta
- "A variant of alpha-beta considering only captures and null moves to obtain a quiet position, e.g. one that is unlikely to change heavily in the very near future."
-
- | move score alpha entry bestScore moveList newBoard beta |
- self assert: [initialAlpha < initialBeta].
- ply < 10 ifTrue: [(variations at: ply + 1) at: 1 put: 0].
- nodesVisited := nodesVisited + 1.
- "See if there's already something in the transposition table."
- entry := transTable lookupBoard: theBoard.
- alpha := initialAlpha.
- beta := initialBeta.
- entry isNil
- ifFalse:
- [ttHits := ttHits + 1.
- (entry valueType bitAnd: 1) = (ply bitAnd: 1)
- ifTrue: [beta := entry value max: initialBeta]
- ifFalse: [alpha := 0 - entry value max: initialAlpha].
- beta > initialBeta ifTrue: [^beta].
- alpha >= initialBeta ifTrue: [^alpha]].
- ply < 2
- ifTrue:
- ["Always generate moves if ply < 2 so that we don't miss a move that
- would bring the king under attack (e.g., make an invalid move)."
-
- moveList := generator findQuiescenceMovesFor: theBoard activePlayer.
- moveList ifNil: [^0 - AlphaBetaIllegal]].
-
- "Evaluate the current position, assuming that we have a non-capturing move."
- bestScore := theBoard activePlayer evaluate.
- "TODO: What follows is clearly not the Right Thing to do. The score we just evaluated doesn't take into account that we may be under attack at this point. I've seen it happening various times that the static evaluation triggered a cut-off which was plain wrong in the position at hand.
- There seem to be three ways to deal with the problem. #1 is just deepen the search. If we go one ply deeper we will most likely find the problem (although that's not entirely certain). #2 is to improve the evaluator function and make it so that the current evaluator is only an estimate saying if it's 'likely' that a non-capturing move will do. The more sophisticated evaluator should then take into account which pieces are under attack. Unfortunately that could make the AI play very passive, e.g., avoiding situations where pieces are under attack even if these attacks are outweighed by other factors. #3 would be to insert a null move here to see *if* we are under attack or not (I've played with this) but for some reason the resulting search seemed to explode rapidly. I'm uncertain if that's due to the transposition table being too small (I don't *really* think so but it may be) or if I've just got something else wrong."
- bestScore > alpha
- ifTrue:
- [alpha := bestScore.
- bestScore >= beta
- ifTrue:
- [moveList ifNotNil: [generator recycleMoveList: moveList].
- ^bestScore]].
-
- "Generate new moves"
- moveList ifNil:
- [moveList := generator findQuiescenceMovesFor: theBoard activePlayer.
- moveList ifNil: [^0 - AlphaBetaIllegal]].
- moveList isEmpty
- ifTrue:
- [generator recycleMoveList: moveList.
- ^bestScore].
-
- "Sort move list according to history heuristics"
- moveList sortUsing: historyTable.
-
- "And search"
- [(move := moveList next) isNil] whileFalse:
- [newBoard := (boardList at: ply + 1) copyBoard: theBoard.
- newBoard nextMove: move.
- "Search recursively"
- ply := ply + 1.
- score := 0 - (self
- quiesce: newBoard
- alpha: 0 - beta
- beta: 0 - alpha).
- stopThinking
- ifTrue:
- [generator recycleMoveList: moveList.
- ^score].
- ply := ply - 1.
- score = AlphaBetaIllegal
- ifFalse:
- [score > bestScore
- ifTrue:
- [ply < 10 ifTrue: [self copyVariation: move].
- bestScore := score].
- "See if we can cut off the search"
- score > alpha
- ifTrue:
- [alpha := score.
- score >= beta
- ifTrue:
- [transTable
- storeBoard: theBoard
- value: score
- type: (ValueBoundary bitOr: (ply bitAnd: 1))
- depth: 0
- stamp: stamp.
- historyTable addMove: move.
- alphaBetaCuts := alphaBetaCuts + 1.
- generator recycleMoveList: moveList.
- ^bestScore]]]].
- transTable
- storeBoard: theBoard
- value: bestScore
- type: (ValueAccurate bitOr: (ply bitAnd: 1))
- depth: 0
- stamp: stamp.
- generator recycleMoveList: moveList.
- ^bestScore!
Item was removed:
- ----- Method: ChessPlayerAI>>reset (in category 'initialize') -----
- reset
- transTable ifNotNil:[transTable clear].
- historyTable clear.
- !
Item was removed:
- ----- Method: ChessPlayerAI>>reset: (in category 'initialize') -----
- reset: aBoard
- self reset.
- boardList ifNil:[
- boardList := Array new: 100.
- 1 to: boardList size do:[:i| boardList at: i put: (aBoard copy userAgent: nil)].
- boardListIndex := 0].
- board := aBoard.!
Item was removed:
- ----- Method: ChessPlayerAI>>search:depth:alpha:beta: (in category 'searching') -----
- search: theBoard depth: depth alpha: initialAlpha beta: initialBeta
- "A basic alpha-beta algorithm; based on negaMax rather than from the text books"
-
- | move score alpha entry bestScore moveList newBoard beta |
- self assert: [initialAlpha < initialBeta].
- ply < 10 ifTrue: [(variations at: ply + 1) at: 1 put: 0].
- depth = 0
- ifTrue:
- [^self
- quiesce: theBoard
- alpha: initialAlpha
- beta: initialBeta].
- nodesVisited := nodesVisited + 1.
- "See if there's already something in the transposition table. If so, skip the entire search."
- entry := transTable lookupBoard: theBoard.
- alpha := initialAlpha.
- beta := initialBeta.
- (entry isNil or: [entry depth < depth])
- ifFalse:
- [ttHits := ttHits + 1.
- (entry valueType bitAnd: 1) = (ply bitAnd: 1)
- ifTrue: [beta := entry value max: initialBeta]
- ifFalse: [alpha := 0 - entry value max: initialAlpha].
- beta > initialBeta ifTrue: [^beta].
- alpha >= initialBeta ifTrue: [^alpha]].
- bestScore := AlphaBetaMinVal.
-
- "Generate new moves"
- moveList := generator findPossibleMovesFor: theBoard activePlayer.
- moveList ifNil: [^0 - AlphaBetaIllegal].
- moveList isEmpty
- ifTrue:
- [generator recycleMoveList: moveList.
- ^bestScore].
-
- "Sort move list according to history heuristics"
- moveList sortUsing: historyTable.
-
- "And search"
- [(move := moveList next) isNil] whileFalse:
- [newBoard := (boardList at: ply + 1) copyBoard: theBoard.
- newBoard nextMove: move.
- "Search recursively"
- ply := ply + 1.
- score := 0 - (self
- search: newBoard
- depth: depth - 1
- alpha: 0 - beta
- beta: 0 - alpha).
- stopThinking
- ifTrue:
- [generator recycleMoveList: moveList.
- ^score].
- ply := ply - 1.
- score = AlphaBetaIllegal
- ifFalse:
- [score > bestScore
- ifTrue:
- [ply < 10 ifTrue: [self copyVariation: move].
- bestScore := score].
- "See if we can cut off the search"
- score > alpha
- ifTrue:
- [alpha := score.
- score >= beta
- ifTrue:
- [transTable
- storeBoard: theBoard
- value: score
- type: (ValueBoundary bitOr: (ply bitAnd: 1))
- depth: depth
- stamp: stamp.
- historyTable addMove: move.
- alphaBetaCuts := alphaBetaCuts + 1.
- generator recycleMoveList: moveList.
- ^bestScore]]]].
- transTable
- storeBoard: theBoard
- value: bestScore
- type: (ValueAccurate bitOr: (ply bitAnd: 1))
- depth: depth
- stamp: stamp.
- generator recycleMoveList: moveList.
- ^bestScore!
Item was removed:
- ----- Method: ChessPlayerAI>>searchMove:depth:alpha:beta: (in category 'searching') -----
- searchMove: theBoard depth: depth alpha: initialAlpha beta: initialBeta
- "Modified version to return the move rather than the score"
-
- | move score alpha bestScore moveList newBoard beta goodMove |
- self assert: [initialAlpha < initialBeta].
- ply < 10 ifTrue: [(variations at: ply + 1) at: 1 put: 0].
- ply := 0.
- alpha := initialAlpha.
- beta := initialBeta.
- bestScore := AlphaBetaMinVal.
-
- "Generate new moves"
- moveList := generator findPossibleMovesFor: theBoard activePlayer.
- moveList ifNil: [^nil].
- moveList isEmpty
- ifTrue:
- [generator recycleMoveList: moveList.
- ^nil].
-
- "Sort move list according to history heuristics"
- moveList sortUsing: historyTable.
-
- "And search"
- [(move := moveList next) isNil] whileFalse:
- [newBoard := (boardList at: ply + 1) copyBoard: theBoard.
- newBoard nextMove: move.
- "Search recursively"
- ply := ply + 1.
- score := 0 - (self
- search: newBoard
- depth: depth - 1
- alpha: 0 - beta
- beta: 0 - alpha).
- stopThinking
- ifTrue:
- [generator recycleMoveList: moveList.
- ^move].
- ply := ply - 1.
- score = AlphaBetaIllegal
- ifFalse:
- [score > bestScore
- ifTrue:
- [ply < 10 ifTrue: [self copyVariation: move].
- goodMove := move copy.
- goodMove value: score.
- bestScore := score].
- "See if we can cut off the search"
- score > alpha
- ifTrue:
- [alpha := score.
- score >= beta
- ifTrue:
- [transTable
- storeBoard: theBoard
- value: score
- type: (ValueBoundary bitOr: (ply bitAnd: 1))
- depth: depth
- stamp: stamp.
- historyTable addMove: move.
- alphaBetaCuts := alphaBetaCuts + 1.
- generator recycleMoveList: moveList.
- ^goodMove]]]].
- transTable
- storeBoard: theBoard
- value: bestScore
- type: (ValueAccurate bitOr: (ply bitAnd: 1))
- depth: depth
- stamp: stamp.
- generator recycleMoveList: moveList.
- ^goodMove!
Item was removed:
- ----- Method: ChessPlayerAI>>startThinking (in category 'thinking') -----
- startThinking
- self isThinking ifTrue:[^self].
- self activePlayer: board activePlayer.
- self thinkStep.!
Item was removed:
- ----- Method: ChessPlayerAI>>statusString (in category 'accessing') -----
- statusString
- | av count |
- ^String streamContents:[:s|
- (myMove == #none or:[myMove == nil]) ifFalse:[
- s print: myMove value / 100.0; space.
- ].
- av := bestVariation.
- count := av at: 1.
- count > 0 ifFalse:[
- av := activeVariation.
- count := av at: 1].
- count > 0 ifFalse:[
- s nextPutAll:'***'.
- av := variations at: 1.
- count := av at: 1.
- count > 3 ifTrue:[count := 3]].
- 2 to: count + 1 do:[:index|
- s nextPutAll: (ChessMove decodeFrom: (av at: index)) moveString.
- s space].
-
- s nextPut:$[.
- s print: nodesVisited.
- " s nextPut:$|.
- s print: ttHits.
- s nextPut: $|.
- s print: alphaBetaCuts.
- " s nextPut:$].
-
- ].!
Item was removed:
- ----- Method: ChessPlayerAI>>think (in category 'thinking') -----
- think
- | move |
- self isThinking ifTrue: [^nil].
- self startThinking.
- [(move := self thinkStep) isNil] whileTrue.
- ^move!
Item was removed:
- ----- Method: ChessPlayerAI>>thinkProcess (in category 'thinking') -----
- thinkProcess
- | score theMove depth |
- stopThinking := false.
- score := board activePlayer evaluate.
- depth := 1.
- stamp := stamp + 1.
- ply := 0.
- historyTable clear.
- transTable clear.
- startTime := Time millisecondClockValue.
- nodesVisited := ttHits := alphaBetaCuts := 0.
- bestVariation at: 1 put: 0.
- activeVariation at: 1 put: 0.
- [nodesVisited < 50000] whileTrue:
- ["whats this ? (aoy) false ifTrue:[] ????!!"
-
- theMove := false
- ifTrue:
- [self
- mtdfSearch: board
- score: score
- depth: depth]
- ifFalse:
- [self
- negaScout: board
- depth: depth
- alpha: AlphaBetaMinVal
- beta: AlphaBetaMaxVal].
- theMove ifNil: [^myProcess := nil].
- stopThinking ifTrue: [^myProcess := nil].
- myMove := theMove.
- bestVariation
- replaceFrom: 1
- to: bestVariation size
- with: activeVariation
- startingAt: 1.
- score := theMove value.
- depth := depth + 1].
- myProcess := nil!
Item was removed:
- ----- Method: ChessPlayerAI>>thinkStep (in category 'thinking') -----
- thinkStep
- transTable ifNil: [self initializeTranspositionTable].
- myProcess isNil
- ifTrue:
- [myMove := #none.
- false
- ifTrue:
- [self thinkProcess.
- ^myMove].
- myProcess := [self thinkProcess] forkAt: Processor userBackgroundPriority.
- myProcess suspend.
- ^nil].
- myProcess resume.
- (Delay forMilliseconds: 50) wait.
- myProcess ifNil: [^myMove == #none ifTrue: [nil] ifFalse: [myMove]].
- myProcess suspend.
- "Do we have a valid move?"
- myMove == #none ifTrue: [^nil]. "no"
- "Did we time out?"
- Time millisecondClockValue - startTime > self timeToThink
- ifTrue:
- ["Yes. Abort and return current move."
-
- stopThinking := true.
- myProcess resume.
- [myProcess isNil] whileFalse: [(Delay forMilliseconds: 10) wait].
- ^myMove == #none ifTrue: [nil] ifFalse: [myMove]].
- "Keep thinking"
- ^nil!
Item was removed:
- ----- Method: ChessPlayerAI>>timeToThink (in category 'thinking') -----
- timeToThink
- "Return the number of milliseconds we're allowed to think"
- ^5000!
Item was removed:
- Object subclass: #ChessTTEntry
- instanceVariableNames: 'value valueType depth hashLock timeStamp'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
-
- !ChessTTEntry commentStamp: '<historical>' prior: 0!
- This class represents an entry in the transposition table, storing the value (plus some maintenance information) of some position.!
Item was removed:
- ----- Method: ChessTTEntry>>clear (in category 'accessing') -----
- clear
- value := valueType := timeStamp := depth := -1.!
Item was removed:
- ----- Method: ChessTTEntry>>depth (in category 'accessing') -----
- depth
- ^depth!
Item was removed:
- ----- Method: ChessTTEntry>>depth: (in category 'accessing') -----
- depth: aNumber
- depth := aNumber!
Item was removed:
- ----- Method: ChessTTEntry>>hashLock (in category 'accessing') -----
- hashLock
- ^hashLock!
Item was removed:
- ----- Method: ChessTTEntry>>hashLock: (in category 'accessing') -----
- hashLock: aNumber
- hashLock := aNumber!
Item was removed:
- ----- Method: ChessTTEntry>>timeStamp (in category 'accessing') -----
- timeStamp
- ^timeStamp!
Item was removed:
- ----- Method: ChessTTEntry>>timeStamp: (in category 'accessing') -----
- timeStamp: aNumber
- timeStamp := aNumber!
Item was removed:
- ----- Method: ChessTTEntry>>value (in category 'accessing') -----
- value
- ^value!
Item was removed:
- ----- Method: ChessTTEntry>>value: (in category 'accessing') -----
- value: newValue
- value := newValue!
Item was removed:
- ----- Method: ChessTTEntry>>valueType (in category 'accessing') -----
- valueType
- ^valueType!
Item was removed:
- ----- Method: ChessTTEntry>>valueType: (in category 'accessing') -----
- valueType: newType
- valueType := newType!
Item was removed:
- Object subclass: #ChessTranspositionTable
- instanceVariableNames: 'array used collisions'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games-Chess'!
-
- !ChessTranspositionTable commentStamp: '<historical>' prior: 0!
- The transposition table is a lookup cache for positions in a game that occur through transpositions in move. As an example, the same position is obtained by the moves:
- 1. e2-e4 Nb8-c6
- 2. d2-d4
- and
- 1. d2-d4 Nb8-c6
- 2. e2-e4
- An extremely large number of search branches can be cut off immediately by recognizing that the current position is just the transposition of another one. The transposition table is one of the techniques that actually make modern chess programs good enough to compete with or even beat humans.
- !
Item was removed:
- ----- Method: ChessTranspositionTable class>>new: (in category 'instance creation') -----
- new: bits
- ^self basicNew initialize: bits!
Item was removed:
- ----- Method: ChessTranspositionTable>>clear (in category 'initialize') -----
- clear
- "Set the following to true for printing information about the fill rate and number of collisions. The transposition table should have *plenty* of free space (it should rarely exceed 30% fill rate) and *very* few collisions (those require us to evaluate positions repeatedly that we've evaluated before -- bad idea!!)"
-
- | entry |
- false
- ifTrue:
- [used position > 0
- ifTrue:
- ['entries used: ' , used position printString , ' ('
- , (used position * 100 // array size) printString , '%) '
- displayAt: 0 @ 0].
- collisions > 0
- ifTrue:
- ['collisions: ' , collisions printString , ' ('
- , (collisions * 100 // array size) printString , '%) '
- displayAt: 0 @ 15]].
- used position: 0.
- [(entry := used next) isNil] whileFalse: [entry clear].
- used resetToStart.
- collisions := 0!
Item was removed:
- ----- Method: ChessTranspositionTable>>initialize: (in category 'initialize') -----
- initialize: nBits
- "Initialize the receiver using 1<<nBits entries. See also ChessPlayerAI>>initializeTranspositionTable."
- | entry |
- array := Array new: 1 << nBits.
- used := ReadWriteStream on: (Array new: 50000). "<- will grow if not sufficient!!"
- entry := ChessTTEntry new clear.
- 1 to: array size do:[:i| array at: i put: entry shallowCopy].
- collisions := 0.
- Smalltalk garbageCollect. "We *really* want them old here"!
Item was removed:
- ----- Method: ChessTranspositionTable>>lookupBoard: (in category 'lookup') -----
- lookupBoard: aBoard
- | key entry |
- key := aBoard hashKey bitAnd: array size - 1.
- entry := array at: key + 1.
- entry ifNil:[^nil].
- entry valueType = -1 ifTrue:[^nil].
- entry hashLock = aBoard hashLock ifFalse:[^nil].
- ^entry!
Item was removed:
- ----- Method: ChessTranspositionTable>>storeBoard:value:type:depth:stamp: (in category 'initialize') -----
- storeBoard: aBoard value: value type: valueType depth: depth stamp: timeStamp
- | key entry |
- key := aBoard hashKey bitAnd: array size - 1.
- entry := array at: key + 1.
- entry valueType = -1
- ifTrue:[used nextPut: entry]
- ifFalse:[entry hashLock = aBoard hashLock ifFalse:[collisions := collisions + 1]].
- (entry valueType = -1
- or:[entry depth <= depth
- or:[entry timeStamp < timeStamp]]) ifFalse:[^self].
- entry hashLock: aBoard hashLock.
- entry value: value.
- entry valueType: valueType.
- entry depth: depth.
- entry timeStamp: timeStamp.
- !
Item was removed:
- EllipseMorph subclass: #ChineseCheckerPiece
- instanceVariableNames: 'boardLoc myBoard'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !ChineseCheckerPiece commentStamp: '<historical>' prior: 0!
- I represent a player piece for Chinese Checkers. Mostly I act as an ellipse, but my special methods ensure that I cannot be picked up or dropped except in the proper circumstances.
-
- Structure:
- myBoard a ChineseCheckers morph
- boardLoc my current logical position on the board.
- !
Item was removed:
- ----- Method: ChineseCheckerPiece class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^ false!
Item was removed:
- ----- Method: ChineseCheckerPiece>>boardLoc (in category 'accessing') -----
- boardLoc
-
- ^ boardLoc!
Item was removed:
- ----- Method: ChineseCheckerPiece>>handlesMouseDown: (in category 'event handling') -----
- handlesMouseDown: evt
-
- ^ true!
Item was removed:
- ----- Method: ChineseCheckerPiece>>justDroppedInto:event: (in category 'dropping/grabbing') -----
- justDroppedInto: newOwner event: evt
-
- newOwner == myBoard ifFalse:
- ["Only allow dropping into my board."
- ^self rejectDropMorphEvent: evt].
- ^super justDroppedInto: newOwner event: evt!
Item was removed:
- ----- Method: ChineseCheckerPiece>>mouseDown: (in category 'event handling') -----
- mouseDown: evt
-
- ((owner isKindOf: ChineseCheckers)
- and: [owner okToPickUpPieceAt: boardLoc])
- ifTrue: [evt hand grabMorph: self]!
Item was removed:
- ----- Method: ChineseCheckerPiece>>setBoard:loc: (in category 'accessing') -----
- setBoard: aBoard loc: aBoardLoc
-
- myBoard := aBoard.
- boardLoc := aBoardLoc!
Item was removed:
- BorderedMorph subclass: #ChineseCheckers
- instanceVariableNames: 'board sixDeltas teams homes autoPlay whoseMove plannedMove plannedMovePhase colors movePhase animateMoves pathMorphs'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !ChineseCheckers commentStamp: '<historical>' prior: 0!
- An implementation of Chinese Checkers by Dan Ingalls. April 9, 2000.
-
- board: A 19x19 rhombic array, addressed by row@col points, in which is imbedded the familiar six-pointed layout of cells. A cell outside the board is nil (-).
- - - - - - - - - - - - - - - - - - - -
- - - - - - - - - - - - - - 5 - - - - -
- - - - - - - - - - - - - 5 5 - - - - -
- - - - - - - - - - - - 5 5 5 - - - - -
- - - - - - - - - - - 5 5 5 5 - - - - -
- - - - - - 6 6 6 6 0 0 0 0 0 4 4 4 4 -
- - - - - - 6 6 6 0 0 0 0 0 0 4 4 4 - -
- - - - - - 6 6 0 0 0 0 0 0 0 4 4 - - -
- - - - - - 6 0 0 0 0 0 0 0 0 4 - - - -
- - - - - - 0 0 0 0 0 0 0 0 0 - - - - -
- - - - - 1 0 0 0 0 0 0 0 0 3 - - - - -
- - - - 1 1 0 0 0 0 0 0 0 3 3 - - - - -
- - - 1 1 1 0 0 0 0 0 0 3 3 3 - - - - -
- - 1 1 1 1 0 0 0 0 0 3 3 3 3 - - - - -
- - - - - - 2 2 2 2 - - - - - - - - - -
- - - - - - 2 2 2 - - - - - - - - - - -
- - - - - - 2 2 - - - - - - - - - - - -
- - - - - - 2 - - - - - - - - - - - - -
- - - - - - - - - - - - - - - - - - - -
- Cells within the board contain 0 if empty, or a team number (1..6) if occupied by a piece of that team. An extra border of nils around the whole reduces bounds checking to a nil test.
-
- sixDeltas: An array giving the x@y deltas for the 6 valid steps in CCW order from a given cell. For team 1 they are: in fr, fl, l, bl, br, r. To get, eg fl for a given team, use (sixDeltas atWrap: team+1).
-
- teams: An array of six teams, each of which is an array of the x@y locations of the 10 pieces.
-
- homes: The x@y coordinates of the six home points, namely 14@2, 18@6, 14@14, 6@18, 2@14, 6@6. The goal, or farthest point in destination triangle, is thus (homes atWrap: teamNo+3).
-
- autoPlay: An array of booleans, parallel to teams, where true means that Squeak will make the moves for the corresponding team.
-
- whoseMove: A team number specifying whose turn it is next. Set to 0 when game is over.
-
- plannedMove: If not nil, it means the board is in a state where it is animating the next move to be made so that it can be seen.
-
- movePhase: Holds the state of display of the planned move so that, eg, it can appear one jump at a time. Advances from 1 to (plannedMove size * 2).
-
- A move is an array of locs which are the path of the move.
-
- Once the morph is open, the menu command 'reset...' allows you to reset the board and change the number of players. The circle at turnIndicatorLoc indicates the color of the team whose turn it is. If it is a human, play waits for drag and drop of a piece of that color.
-
- The current strategy is very simple: generate all moves, score them and pick the best. Beyond this, it will look ahead a number of moves, but this becomes very expensive without pruning. Pruning would help the speed of play, especially in the end game where we look a little deeper. A more effective strategy would consider opponents' possible moves as well, but this is left as an exercise for the serious programmer.!
Item was removed:
- ----- Method: ChineseCheckers class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'ChineseCheckers' translatedNoop
- categories: {'Games' translatedNoop}
- documentation: 'Halma - the classic board game of Chinese Checkers, written by Dan Ingalls' translatedNoop!
Item was removed:
- ----- Method: ChineseCheckers>>acceptDroppingMorph:event: (in category 'layout') -----
- acceptDroppingMorph: aPiece event: evt
-
- | dropLoc |
- dropLoc := self boardLocAt: evt cursorPoint.
- dropLoc = aPiece boardLoc ifTrue: "Null move"
- [^ aPiece rejectDropMorphEvent: evt].
- (plannedMove := (self allMovesFrom: aPiece boardLoc)
- detect: [:move | move last = dropLoc]
- ifNone: [nil])
- ifNil: [^ aPiece rejectDropMorphEvent: evt. "Not a valid move"].
-
- super acceptDroppingMorph: aPiece event: evt.
- movePhase := 1. "Start the animation if any."
- !
Item was removed:
- ----- Method: ChineseCheckers>>addCustomMenuItems:hand: (in category 'menus') -----
- addCustomMenuItems: aCustomMenu hand: aHandMorph
- "Include our modest command set in the ctrl-menu"
-
- super addCustomMenuItems: aCustomMenu hand: aHandMorph.
- aCustomMenu addLine.
- self addMenuItemsTo: aCustomMenu hand: aHandMorph!
Item was removed:
- ----- Method: ChineseCheckers>>addMenuItemsTo:hand: (in category 'menu') -----
- addMenuItemsTo: aMenu hand: aHandMorph
-
- aMenu add: 'new game' translated target: self action: #newGame.
- aMenu add: 'reset...' translated target: self action: #reset.
- animateMoves
- ifTrue: [aMenu add: 'don''t animate moves' translated target: self action: #dontAnimateMoves]
- ifFalse: [aMenu add: 'animate moves' translated target: self action: #animateMoves]
-
- !
Item was removed:
- ----- Method: ChineseCheckers>>allMovesFrom: (in category 'moves') -----
- allMovesFrom: boardLoc "boardLoc must be occupied"
- | team stepMoves jumpDict |
- team := self at: boardLoc.
- stepMoves := (sixDeltas collect: [:d | boardLoc + d])
- select: [:p | (self at: p) notNil and: [(self at: p) = 0]].
- jumpDict := Dictionary new.
- jumpDict at: boardLoc put: (Array with: boardLoc).
- self jumpFor: team from: boardLoc havingVisited: jumpDict.
- jumpDict removeKey: boardLoc.
- ^ (stepMoves collect: [:p | {boardLoc. p}]) , jumpDict values
- reject:
- [:move | "Don't include any moves that land in other homes."
- (self distFrom: move last to: self boardCenter) >= 5 "In a home..."
- and: [(self distFrom: move last to: (homes atWrap: team+3)) > 3 "...not my goal..."
- and: [(self distFrom: move last to: (homes at: team)) > 3 "...nor my home"]]]!
Item was removed:
- ----- Method: ChineseCheckers>>animateMoves (in category 'menu') -----
- animateMoves
-
- animateMoves := true!
Item was removed:
- ----- Method: ChineseCheckers>>at: (in category 'accessing') -----
- at: p
- ^ (board at: p x) at: p y!
Item was removed:
- ----- Method: ChineseCheckers>>at:put: (in category 'accessing') -----
- at: p put: x
- ^ (board at: p x) at: p y put: x!
Item was removed:
- ----- Method: ChineseCheckers>>bestMove:forTeam: (in category 'moves') -----
- bestMove: ply forTeam: team
- | score bestScore bestMove |
- bestScore := -999.
- (teams at: team) do:
- [:boardLoc |
- (self allMovesFrom: boardLoc) do:
- [:move |
- score := self score: move for: team.
- (score > -99 and: [ply > 0]) ifTrue:
- [score := score "Add 0.7 * score of next move (my guess)"
- + (0 max: ((self score: ((self copyBoard makeMove: move)
- bestMove: ply - 1 forTeam: team) for: team) * 0.7))].
- score > bestScore ifTrue:
- [bestScore := score. bestMove := move]]].
- ^ bestMove!
Item was removed:
- ----- Method: ChineseCheckers>>board:teams: (in category 'initialization') -----
- board: b teams: t
- board := b.
- teams := t!
Item was removed:
- ----- Method: ChineseCheckers>>boardCenter (in category 'board geometry') -----
- boardCenter
- ^ 10@10!
Item was removed:
- ----- Method: ChineseCheckers>>boardLocAt: (in category 'board geometry') -----
- boardLocAt: cellPoint
-
- | dx dy row col |
- dx := self width/15.0. dy := dx * 0.8660254037844385 "(Float pi / 3) sin".
- row := (cellPoint y - self position y) // dy + 1.
- col := (cellPoint x - self position x) / (dx/2.0) + 16 - row // 2.
- ^ row @ col!
Item was removed:
- ----- Method: ChineseCheckers>>cellPointAt: (in category 'board geometry') -----
- cellPointAt: boardLoc
- | dx dy row col |
- dx := self width/15.0. dy := dx * 0.8660254037844385 "(Float pi / 3) sin".
- row := boardLoc x.
- col := boardLoc y.
- ^ self position + ((col*2+row-16*dx//2)@(row-1*dy)) asIntegerPoint!
Item was removed:
- ----- Method: ChineseCheckers>>checkDoneAfter: (in category 'moves') -----
- checkDoneAfter: move
-
- | team locsAfterMove |
- (team := self at: move first) = 0 ifTrue: [^ false].
- (locsAfterMove := (teams at: team) copy) replaceAll: move first with: move last.
- ^ self testDone: locsAfterMove for: team!
Item was removed:
- ----- Method: ChineseCheckers>>copyBoard (in category 'initialization') -----
- copyBoard
- "Return a copy of the board for the purpose of looking ahead one or more moves."
-
- ^ self copy
- board: (board collect: [:row | row copy])
- teams: (teams collect: [:team | team copy])!
Item was removed:
- ----- Method: ChineseCheckers>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color
- r: 0.6
- g: 0.4
- b: 0.0!
Item was removed:
- ----- Method: ChineseCheckers>>distFrom:to: (in category 'board geometry') -----
- distFrom: a to: b
- "The six possible moves are: 1@0, 1@ -1, 0@1, 0@ -1, -1@0, -1@1."
- | dx dy |
- dx := b x - a x.
- dy := b y - a y.
- dx abs >= dy abs
- ifTrue: ["Major change is in x-coord..."
- dx >= 0
- ifTrue: [(dy between: (0-dx) and: 0)
- ifTrue: [^ dx "no lateral motion"].
- ^ dx + ((0-dx) - dy max: dy - 0) "added lateral dist"]
- ifFalse: ["Reverse sign and rerun same code"
- ^ self distFrom: b to: a]]
- ifFalse: ["Transpose and re-run same code"
- ^ self distFrom: a transposed to: b transposed]!
Item was removed:
- ----- Method: ChineseCheckers>>dontAnimateMoves (in category 'menu') -----
- dontAnimateMoves
-
- animateMoves := false!
Item was removed:
- ----- Method: ChineseCheckers>>drawOn: (in category 'drawing') -----
- drawOn: aCanvas
-
- | row1 row2 offset dotExtent |
- super drawOn: aCanvas. "Draw square board"
-
- "Only draw rows in the clipping region"
- dotExtent := (self width//25) asPoint.
- offset := self pieceSize - dotExtent + 1 // 2. "Offset of smaller dots rel to larger"
- row1 := (self boardLocAt: aCanvas clipRect topLeft) x max: 1.
- row2 := (self boardLocAt: aCanvas clipRect bottomRight) x min: board size.
- row1 to: row2 do:
- [:row | (board at: row) withIndexDo:
- [:cell :i | cell ifNotNil:
- [aCanvas fillOval: ((self cellPointAt: (row@i)) + offset extent: dotExtent)
- color: (colors at: cell+1)]]]!
Item was removed:
- ----- Method: ChineseCheckers>>endGameFor: (in category 'moves') -----
- endGameFor: team
- "Return true if we are in the end game (all players within 1 of home triangle)."
-
- | goalLoc |
- goalLoc := homes atWrap: team+3. "Farthest cell across the board"
- (teams at: team)
- do: [:boardLoc | (self distFrom: boardLoc to: goalLoc) > 4 ifTrue: [^ false]].
- ^ true!
Item was removed:
- ----- Method: ChineseCheckers>>extent: (in category 'geometry') -----
- extent: newExtent
-
- | extraY |
- extraY := (newExtent x / 15.0 * 1.25) asInteger.
- super extent: (newExtent x) @ (newExtent x + extraY).
- self submorphsDo:
- [:m | (m isKindOf: ChineseCheckerPiece) ifTrue:
- [m position: (self cellPointAt: m boardLoc); extent: self pieceSize]]!
Item was removed:
- ----- Method: ChineseCheckers>>handlesMouseDown: (in category 'event handling') -----
- handlesMouseDown: evt
- "Prevent stray clicks from picking up the whole game in MVC."
-
- ^ Smalltalk isMorphic not or: [evt yellowButtonPressed]!
Item was removed:
- ----- Method: ChineseCheckers>>initialize (in category 'initialization') -----
- initialize
- "Default creation is for one person against Squeak."
- super initialize.
- ""
- self extent: 382 @ 413.
-
- animateMoves := true.
- self teams: #(2 5 ) autoPlay: {false. true}!
Item was removed:
- ----- Method: ChineseCheckers>>initializeToStandAlone (in category 'parts bin') -----
- initializeToStandAlone
- "Default creation is for one person against Squeak."
-
- super initializeToStandAlone.
- self extent: 382@413.
- self color: (Color r: 0.6 g: 0.4 b: 0.0).
- self borderWidth: 2.
- animateMoves := true.
- self teams: #(2 5) autoPlay: {false. true}.
- !
Item was removed:
- ----- Method: ChineseCheckers>>jumpFor:from:havingVisited: (in category 'moves') -----
- jumpFor: team from: loc havingVisited: dict
- "Recursively explore all jumps from loc, leaving in dict
- the prior position from which we got there"
-
- "Fasten seatbelts..."
- ((((sixDeltas
- collect: [:d | loc + d])
- select: [:p | (self at: p) notNil and: [(self at: p) > 0]])
- collect: [:p | p + (p - loc)])
- select: [:p | (self at: p) notNil and: [(self at: p) = 0]])
- do: [:p | (dict includesKey: p) ifFalse:
- [dict at: p put: ((dict at: loc) copyWith: p).
- self jumpFor: team from: p havingVisited: dict]]!
Item was removed:
- ----- Method: ChineseCheckers>>makeMove: (in category 'moves') -----
- makeMove: move
- | team |
- team := self at: move first.
- self at: move last put: team.
- self at: move first put: 0.
- (teams at: team) replaceAll: move first with: move last!
Item was removed:
- ----- Method: ChineseCheckers>>mouseDown: (in category 'event handling') -----
- mouseDown: evt
-
- | menu |
- evt yellowButtonPressed ifFalse: [^ self].
- menu := MenuMorph new defaultTarget: self.
- self addMenuItemsTo: menu hand: evt hand.
- menu popUpEvent: evt in: self world.
- !
Item was removed:
- ----- Method: ChineseCheckers>>newGame (in category 'menu') -----
- newGame
- "Reset the board, with same teams."
-
- | teamNumbers |
- teamNumbers := (1 to: 6) reject: [:i | (teams at: i) isEmpty].
- self teams: teamNumbers
- autoPlay: (teamNumbers collect: [:i | autoPlay at: i]).
- !
Item was removed:
- ----- Method: ChineseCheckers>>nextTurn (in category 'game sequence') -----
- nextTurn
-
- (self testDone: (teams at: whoseMove) for: whoseMove) ifTrue:
- [(self pieceAt: self turnIndicatorLoc) extent: self width asPoint//6; borderWidth: 2.
- ^ whoseMove := 0. "Game over."].
-
- [whoseMove := whoseMove\\6 + 1.
- (teams at: whoseMove) isEmpty] "Turn passes to the next player"
- whileTrue: [].
- (self pieceAt: self turnIndicatorLoc) color: (colors at: whoseMove+1)!
Item was removed:
- ----- Method: ChineseCheckers>>okToPickUpPieceAt: (in category 'drag and drop') -----
- okToPickUpPieceAt: boardLoc
-
- ^ (self at: boardLoc) = whoseMove and: [(autoPlay at: whoseMove) not]!
Item was removed:
- ----- Method: ChineseCheckers>>pieceAt: (in category 'drag and drop') -----
- pieceAt: boardLoc
-
- self submorphsDo:
- [:m | ((m isMemberOf: ChineseCheckerPiece) and: [m boardLoc = boardLoc])
- ifTrue: [^ m]].
- ^ nil!
Item was removed:
- ----- Method: ChineseCheckers>>pieceSize (in category 'board geometry') -----
- pieceSize
-
- ^ self width asPoint // 20!
Item was removed:
- ----- Method: ChineseCheckers>>printOn: (in category 'printing') -----
- printOn: s
- "For testing only"
-
- 1 to: board size
- do:
- [:row |
- s
- cr;
- next: row put: $ .
- (board at: row) do:
- [:cell |
- s
- space;
- nextPut: (cell isNil ifTrue: [$-] ifFalse: [cell printString last])]]!
Item was removed:
- ----- Method: ChineseCheckers>>reset (in category 'menu') -----
- reset
- "Reset the board, choosing anew how many teams."
-
- | nPlayers nHumans |
- nPlayers := (SelectionMenu
- selections: (1 to: 6))
- startUpWithCaption: 'How many players?' translated.
- nPlayers ifNil: [nPlayers := 2].
- nHumans := (SelectionMenu
- selections: (0 to: nPlayers))
- startUpWithCaption: 'How many humans?' translated.
- nHumans ifNil: [nHumans := 1].
- self teams: (#((1) (2 5) (2 4 6) (1 2 4 5) (1 2 3 4 6) (1 2 3 4 5 6)) at: nPlayers)
- autoPlay: ((1 to: nPlayers) collect: [:i | i > nHumans]).
- !
Item was removed:
- ----- Method: ChineseCheckers>>score:for: (in category 'moves') -----
- score: move for: team
- "Return the decrease in distance toward this team's goal"
-
- | goal closerToGoal wasBack nowBack |
- goal := homes atWrap: team+3.
- wasBack := self distFrom: move first to: goal.
- nowBack := self distFrom: move last to: goal.
- closerToGoal := wasBack - nowBack.
- closerToGoal < -1 ifTrue: [^ -99]. "Quick rejection if move backward more than 1"
- (nowBack <= 3 and: [self checkDoneAfter: move]) ifTrue: [^ 999].
- "Reward closerToGoal, but add bias to move those left far behind."
- ^ (closerToGoal*5) + wasBack!
Item was removed:
- ----- Method: ChineseCheckers>>showNextMoveSegment (in category 'game sequence') -----
- showNextMoveSegment
- "Display the current move in progress. Starts with movePhase = 1.
- Increments movePhase at each tick. Ends by setting movePhase to 0."
-
- | dot p1 p2 delta secondPhase line |
- delta := self width//40.
- movePhase <= plannedMove size
- ifTrue:
- ["First we trace the move with dots and lines..."
- movePhase = 1 ifTrue: [pathMorphs := OrderedCollection new].
- p1 := self cellPointAt: (plannedMove at: movePhase).
- dot := (ImageMorph new image: (Form dotOfSize: 7)) position: p1 + delta - (7//2).
- self addMorph: dot. pathMorphs addLast: dot.
- movePhase > 1 ifTrue:
- [p2 := self cellPointAt: (plannedMove at: movePhase-1).
- line := PolygonMorph vertices: {p2 + delta. p1 + delta} color: Color black
- borderWidth: 3 borderColor: Color black.
- self addMorph: line. pathMorphs addLast: line]]
- ifFalse:
- ["...then we erase the path while moving the piece."
- secondPhase := movePhase - plannedMove size.
- pathMorphs removeFirst delete.
- secondPhase > 1 ifTrue:
- [pathMorphs removeFirst delete.
- self makeMove: {plannedMove at: secondPhase - 1. plannedMove at: secondPhase}.
- (self pieceAt: (plannedMove at: secondPhase - 1))
- position: (self cellPointAt: (plannedMove at: secondPhase));
- setBoard: self loc: (plannedMove at: secondPhase).
- self changed]].
-
- (movePhase := movePhase + 1) > (plannedMove size * 2)
- ifTrue: [movePhase := 0 "End of animated move"].
-
- !
Item was removed:
- ----- Method: ChineseCheckers>>step (in category 'game sequence') -----
- step
- whoseMove = 0 ifTrue: [^self]. "Game over."
- plannedMove isNil
- ifTrue:
- [(autoPlay at: whoseMove) ifFalse: [^self]. "Waiting for a human."
- plannedMove := (self endGameFor: whoseMove)
- ifTrue:
- ["Look deeper at the end."
-
- self bestMove: 2 forTeam: whoseMove]
- ifFalse: [self bestMove: 1 forTeam: whoseMove].
- movePhase := 1 "Start the animated move"].
- animateMoves
- ifTrue:
- ["Display the move in phases..."
-
- movePhase > 0 ifTrue: [^self showNextMoveSegment]]
- ifFalse:
- ["... or skip the entire animated move if requested."
-
- self makeMove: plannedMove.
- (self pieceAt: plannedMove first)
- position: (self cellPointAt: plannedMove last);
- setBoard: self loc: plannedMove last.
- self changed.
- movePhase := 0].
- plannedMove := nil. "End the animated move"
- self nextTurn!
Item was removed:
- ----- Method: ChineseCheckers>>stepTime (in category 'testing') -----
- stepTime
-
- ^ 200!
Item was removed:
- ----- Method: ChineseCheckers>>teams:autoPlay: (in category 'initialization') -----
- teams: teamsPlaying autoPlay: ifAuto
- "Initialize board, teams, steps, jumps"
- | p q teamInPlay |
- colors := (#(gray) , #(red green blue cyan magenta yellow white) shuffled)
- collect: [:c | Color perform: c]. "New set of colors each time."
- self removeAllMorphs. "eg, from previous game."
- board := (1 to: 19) collect: [:i | Array new: 19].
- sixDeltas := {0@1. -1@1. -1@0. 0@ -1. 1@ -1. 1@0}.
- homes := {14@2. 18@6. 14@14. 6@18. 2@14. 6@6}.
- teams := (1 to: 6) collect: [:i | OrderedCollection new].
- autoPlay := (1 to: 6) collect: [:i | false].
- 1 to: 6 do:
- [:team | p:= homes at: team.
- (teamInPlay := teamsPlaying includes: team) ifTrue:
- [autoPlay at: team put: (ifAuto at: (teamsPlaying indexOf: team))].
- "Place empty cells in rhombus extending out from each
- home, and occupied cells in active home triangles."
- 1 to: 5 do: [:i | q := p.
- 1 to: 5 do: [:j |
- (teamInPlay and: [j <= (5 - i)])
- ifTrue: [self at: q put: team.
- (teams at: team) add: q.
- self addMorph:
- ((ChineseCheckerPiece
- newBounds: ((self cellPointAt: q) extent: self pieceSize)
- color: (colors at: team+1))
- setBoard: self loc: q)]
- ifFalse: [self at: q put: 0].
- q := q + (sixDeltas at: team). "right,forward"].
- p := p + (sixDeltas atWrap: team+1). "left,forward"].
- teams at: team put: (teams at: team) asArray].
- whoseMove := teamsPlaying first.
- self addMorph:
- ((ChineseCheckerPiece
- newBounds: ((self cellPointAt: self turnIndicatorLoc) extent: self pieceSize)
- color: (colors at: whoseMove+1))
- setBoard: self loc: self turnIndicatorLoc).
- plannedMove := nil.
- self changed!
Item was removed:
- ----- Method: ChineseCheckers>>testDone:for: (in category 'moves') -----
- testDone: teamLocs for: team
- "Return true if we are done (all players in home triangle)."
-
- | goalLoc |
- goalLoc := homes atWrap: team+3.
- teamLocs
- do: [:boardLoc | (self distFrom: boardLoc to: goalLoc) > 3 ifTrue: [^ false]].
- ^ true!
Item was removed:
- ----- Method: ChineseCheckers>>turnIndicatorLoc (in category 'board geometry') -----
- turnIndicatorLoc
-
- ^ 16@11!
Item was removed:
- ----- Method: ChineseCheckers>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
- wantsDroppedMorph: aPiece event: evt
-
- ^ aPiece isKindOf: ChineseCheckerPiece
- !
Item was removed:
- WordGamePanelMorph subclass: #CipherPanel
- instanceVariableNames: 'originalText quote originalMorphs decodingMorphs'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !CipherPanel commentStamp: '<historical>' prior: 0!
- The CipherPanel, as its name suggests, is a tool for decoding simple substitution codes, such as are presented on the puzzle pages of many Sunday newspapers. Most of the capability is inherited from the two WordGame classes used. To try it out, choose newMorph/Games/CipherPanel in a morphic project, or execute, in any project:
-
- CipherPanel new openInWorld
- !
Item was removed:
- ----- Method: CipherPanel class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'Cipher' translatedNoop
- categories: {'Games' translatedNoop}
- documentation: 'The Cipher Panel: A playground for cryptograms, by Dan Ingalls' translatedNoop!
Item was removed:
- ----- Method: CipherPanel class>>encode: (in category 'as yet unclassified') -----
- encode: aString
- "CipherPanel encode: 'Now is the time for all good men to come to the aid of their country.'"
-
- | dict repeat |
- dict := Dictionary new.
- repeat := true.
- [repeat] whileTrue:
- [repeat := false.
- ($A to: $Z) with: ($A to: $Z) shuffled do:
- [:a :b | a = b ifTrue: [repeat := true].
- dict at: a put: b]].
- ^ aString asUppercase collect: [:a | dict at: a ifAbsent: [a]]!
Item was removed:
- ----- Method: CipherPanel class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^ true!
Item was removed:
- ----- Method: CipherPanel class>>new (in category 'instance creation') -----
- new
- "NOTE: Use newFromQuote: rather than new to create new CipherPanels"
-
- ^ self newFromQuote: self sampleString
-
- " Here are some other examples...
- World addMorph: (CipherPanel newFromQuote: 'BPFFXY LZY PK ROY RPBY PG XPAY HOYG EJCM SXJROYK FJG''R APR QCR PR''K EJC HOJ GYYF ROY LXRYMLRPJGK. KJCMSY CGNGJHG')
-
- World addMorph: (CipherPanel newFromQuote: 'Y FRV TRK HJRH QVL QS HJL BPLRHLTH WZLRTXPLT YV ZYSL YT OQYVB MJRH WLQWZL TRK KQX FRVVQH OQ.')
-
- World addMorph: (CipherPanel newFromQuote: 'XI''H SAZRG: SDCIZCIZT EZDEAZ TD CDI SGZRIZ EGDPGZHH.')
-
- World addMorph: (CipherPanel newFromQuote: 'PY MOJ WPMMWJ MZGYR ZL MOJ GZSWH PM''R YZ RZZYJS HZYJ MOBY RBPH.')
-
- World addMorph: (CipherPanel newFromQuote: 'PYSLHYA DJP VBHHLXYAA BPY BGNBMA PLUVQ LX AQMGY; QVY HPLXSLHBG LXUPYCLYXQA BPY NBPK BXC DPLYXCGM AKLGYA.')
-
- World addMorph: (CipherPanel newFromQuote: 'U HWVS RJ AHOST RLO FOOQOST TJUSM AJIO LOVNC WUXRUSM VST HWVCUSM LVSTZVWW. -- TVNUT WORROEIVS VXROE LUA KGUSRGHWO-ZCHVAA LOVER JHOEVRUJS')
- "!
Item was removed:
- ----- Method: CipherPanel class>>newFromQuote: (in category 'as yet unclassified') -----
- newFromQuote: encodedString
- "Use this to creat new panels instead of new."
-
- ^ super new encodedQuote: encodedString!
Item was removed:
- ----- Method: CipherPanel class>>randomComment (in category 'as yet unclassified') -----
- randomComment
- "CipherPanel randomComment"
- "Generate cryptic puzzles from method comments in the system"
- | c s |
- s := 'none'.
- [s = 'none']
- whileTrue: [s := ((c := SystemNavigation new allClasses atRandom) selectors
- collect: [:sel | (c firstCommentAt: sel) asString])
- detect: [:str | str size between: 100 and: 200]
- ifNone: ['none' translated]].
- ^ s!
Item was removed:
- ----- Method: CipherPanel class>>sampleString (in category 'as yet unclassified') -----
- sampleString
- ^
- 'E SGJC OSCVC LICGNV, ENGRCV, JEVEMAV. E SGJC OSEV QGVVEMA XMI [SMWWDHMML] ... EO''V HMALCIXKW OM SGJC VMNCOSEAR OSGO EAVQEICV GAL LIEJCV DMK. -- ZGIZIG VOICEVGAL'!
Item was removed:
- ----- Method: CipherPanel class>>tedsHack (in category 'as yet unclassified') -----
- tedsHack
- "Generate cryptic puzzles from method comments in the system"
- (self newFromQuote: (self encode: (self randomComment))) openInWorld
-
- "CipherPanel tedsHack"!
Item was removed:
- ----- Method: CipherPanel>>addMenuItemsTo:hand: (in category 'menu') -----
- addMenuItemsTo: aMenu hand: aHandMorph
- aMenu
- add: 'show cipher help' translated
- target: self
- action: #showHelpWindow.
- aMenu
- add: 'show cipher hints' translated
- target: self
- action: #showHintsWindow.
- aMenu
- add: 'clear cipher typing' translated
- target: self
- action: #clearTyping.
- aMenu
- add: 'enter a new cipher' translated
- target: self
- action: #enterANewCipher.
- aMenu
- add: 'quote from Squeak' translated
- target: self
- action: #squeakCipher!
Item was removed:
- ----- Method: CipherPanel>>buttonRow (in category 'menu') -----
- buttonRow
- | row aButton |
- row := AlignmentMorph newRow color: self color;
- hResizing: #shrinkWrap;
- vResizing: #shrinkWrap.
- #('show help' 'show hints' 'clear typing' 'enter a new cipher' 'quote from Squeak' ) translatedNoop
- with: #(#showHelpWindow #showHintsWindow #clearTyping #enterANewCipher #squeakCipher )
- do: [:label :selector |
- aButton := SimpleButtonMorph new target: self.
- aButton color: Color transparent;
- borderWidth: 1 px;
- borderColor: Color black.
- aButton actionSelector: selector.
- aButton label: label translated.
- row addMorphBack: aButton.
- row addTransparentSpacerOfSize: 3 px @ 0].
- ^ row!
Item was removed:
- ----- Method: CipherPanel>>cipherStats (in category 'menu') -----
- cipherStats
-
- | letterCounts digraphs d digraphCounts |
- letterCounts := (quote copyWithout: Character space) asBag sortedCounts.
- digraphs := Bag new.
- quote withIndexDo:
- [:c :i |
- i < quote size ifTrue:
- [d := quote at: i+1.
- (c ~= Character space and: [d ~= Character space]) ifTrue:
- [digraphs add: (String with: c with: d)]]].
- digraphCounts := digraphs sortedCounts.
- ^ String streamContents:
- [:strm |
- 1 to: 10 do:
- [:i |
- strm cr; tab; nextPut: (letterCounts at: i) value.
- strm tab; print: (letterCounts at: i) key.
- (digraphCounts at: i) key > 1 ifTrue:
- [strm tab; tab; tab; nextPutAll: (digraphCounts at: i) value.
- strm tab; print: (digraphCounts at: i) key]]]!
Item was removed:
- ----- Method: CipherPanel>>clearTyping (in category 'defaults') -----
- clearTyping
- self isClean
- ifTrue: [^ self].
- (self confirm: 'Are you sure you want to discard all typing?' translated)
- ifFalse: [^ self].
- super clearTyping!
Item was removed:
- ----- Method: CipherPanel>>encodedQuote: (in category 'initialization') -----
- encodedQuote: aString
- "World addMorph: CipherPanel new"
- | morph prev |
- aString isEmpty
- ifTrue: [^ self].
- (letterMorphs isNil
- or: [self isClean])
- ifFalse: [(self confirm: 'Are you sure you want to discard all typing?' translated)
- ifFalse: [^ self]].
- haveTypedHere := false.
- quote := aString asUppercase.
- prev := nil.
- originalMorphs := quote asArray
- withIndexCollect: [:c :i | WordGameLetterMorph new plain indexInQuote: i id1: nil;
-
- setLetter: (quote at: i)].
- letterMorphs := OrderedCollection new.
- decodingMorphs := quote asArray
- withIndexCollect: [:c :i | (quote at: i) isLetter
- ifTrue: [morph := WordGameLetterMorph new underlined indexInQuote: i id1: nil.
- morph
- on: #mouseDown
- send: #mouseDownEvent:letterMorph:
- to: self.
- morph
- on: #keyStroke
- send: #keyStrokeEvent:letterMorph:
- to: self.
- letterMorphs addLast: morph.
- morph predecessor: prev.
- prev
- ifNotNil: [prev successor: morph].
- prev := morph]
- ifFalse: [WordGameLetterMorph new plain indexInQuote: i id1: nil;
-
- setLetter: (quote at: i)]].
- self color: originalMorphs first color.
- self extent: 500 px @ 500 px.!
Item was removed:
- ----- Method: CipherPanel>>enterANewCipher (in category 'menu') -----
- enterANewCipher
- self clearTyping;
- encodedQuote: (FillInTheBlank request: 'Type a cipher text to work on here below...' translated)!
Item was removed:
- ----- Method: CipherPanel>>extent: (in category 'geometry') -----
- extent: newExtent
- "Lay out with word wrap, alternating bewteen decoded and encoded lines."
- "Currently not tolerant of narrow (less than a word) margins"
-
- | w h relLoc topLeft thisWord i m corner row firstWord |
- self removeAllMorphs.
- w := originalMorphs first width - 1 px. h := originalMorphs first height * 2 + 10 px.
- topLeft := self position + self borderWidth + (0 @ 10 px).
- thisWord := OrderedCollection new.
- i := 1. firstWord := true. relLoc := 0@0. corner := topLeft.
- [i <= originalMorphs size] whileTrue:
- [m := originalMorphs at: i.
- thisWord addLast: ((decodingMorphs at: i) position: topLeft + relLoc).
- thisWord addLast: (m position: topLeft + relLoc + (0@m height)).
- (m letter = Character space or: [i = originalMorphs size])
- ifTrue: [self addAllMorphs: thisWord.
- corner := corner max: thisWord last bounds bottomRight.
- thisWord reset. firstWord := false].
- relLoc := relLoc + (w@0).
- (relLoc x + w) > newExtent x
- ifTrue: [firstWord
- ifTrue: ["No spaces -- force a line break"
- thisWord removeLast; removeLast.
- self addAllMorphs: thisWord.
- corner := corner max: thisWord last bounds bottomRight]
- ifFalse: [i := i - (thisWord size//2) + 1].
- thisWord reset. firstWord := true.
- relLoc := 0@(relLoc y + h)]
- ifFalse: [i := i + 1]].
- row := self buttonRow. row fullBounds.
- self addMorph: row.
- super extent: (corner - topLeft) + (self borderWidth * 2) + (0 @ row height + 10 px).
- row align: row bounds bottomCenter with: self bounds bottomCenter - (0 @ 2 px).!
Item was removed:
- ----- Method: CipherPanel>>initializeToStandAlone (in category 'parts bin') -----
- initializeToStandAlone
- super initializeToStandAlone.
- self encodedQuote: self class sampleString!
Item was removed:
- ----- Method: CipherPanel>>keyCharacter:atIndex:nextFocus: (in category 'defaults') -----
- keyCharacter: aLetter atIndex: indexInQuote nextFocus: nextFocus
-
- | encodedLetter |
- encodedLetter := quote at: indexInQuote.
- originalMorphs with: decodingMorphs do:
- [:e :d | e letter = encodedLetter ifTrue: [d setLetter: aLetter color: Color red]].
- !
Item was removed:
- ----- Method: CipherPanel>>showHelpWindow (in category 'menu') -----
- showHelpWindow
-
- 'The Cipher Panel displays an encrypted message. The encryption is a simple substitution code; each letter of the alphabet has been changed to a different one.
-
- You can solve the cipher by clicking above any letter in the message, and typing the letter you think it should be. The Cipher Panel automatically makes the same substitution anywhere else that letter occurs in the encoded message.
-
- If you are having trouble, you can use the command menu to ''show cipher hints''. That will display how many of each letter occurs, which is often a help in solving ciphers.' translated
- editWithLabel: 'About the Cipher Panel' translated.!
Item was removed:
- ----- Method: CipherPanel>>showHintsWindow (in category 'menu') -----
- showHintsWindow
-
- ('Most bodies of english text follow a general pattern of letter usage. The following are the most common letters, in approximate order of frequency:
- E T A O N I R S H
- The following are the most common digraphs:
- EN ER RE NT TH ON IN
-
- The message you are trying to decode has the following specific statistics: {1}
-
- Good luck!!' translated format: {self cipherStats})
- editWithLabel: 'Some Useful Statistics' translated.!
Item was removed:
- ----- Method: CipherPanel>>squeakCipher (in category 'menu') -----
- squeakCipher
- self encodedQuote: (CipherPanel encode: (CipherPanel randomComment))!
Item was removed:
- WordGamePanelMorph subclass: #CrosticPanel
- instanceVariableNames: 'crosticPanel quotePanel cluesCol2 answers quote clues cluesPanel'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !CrosticPanel commentStamp: '<historical>' prior: 0!
- The CrosticPanel, as its name suggests, is a tool for decoding acrostic puzzles, such as are presented on the puzzle pages of some Sunday newspapers. Much of the capability is inherited from the two WordGame classes used. To try it out, choose newMorph/Games/CrosticPanel in a morphic project, or execute, in any project:
-
- CrosticPanel new openInWorld
-
- The instance variables of this class include...
- letterMorphs (in superclass) a collection of all the letterMorphs in this panel
- quote a string, being the entire quote in uppercase with no blanks
- clues a collection of the clue strings
- answers a collection of the answer indices.
- For each answer, this is an array of the indices into the quote string.
-
- The final structure of a CrosticPanel is as follows
- self a CrosticPanel the overall holder
- quotePanel a CrosticQuotePanel holds the grid of letters from the quote
- cluesPanel an AlignmentMorph holds most of the clue rows
- cluesCol2 an AlignmentMorph holds the rest of the clue rows
-
- Each clue row is a horizontal AlignmentMorph with a textMorph and another alignmentMorph full of the letterMorphs for the answer.
- !
Item was removed:
- ----- Method: CrosticPanel class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'Crostic' translatedNoop
- categories: {'Games' translatedNoop}
- documentation: 'The Crostic Panel: A classic word diagram game, by Dan Ingalls' translatedNoop!
Item was removed:
- ----- Method: CrosticPanel class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^ true!
Item was removed:
- ----- Method: CrosticPanel class>>new (in category 'instance creation') -----
- new
- "NOTE: Use newFromFile: rather than new to create new CrosticPanels"
-
- ^ self newFromFile: (ReadStream on: self sampleFile)!
Item was removed:
- ----- Method: CrosticPanel class>>newFromFile: (in category 'instance creation') -----
- newFromFile: aStream
- "World addMorph: CrosticPanel new"
- "World addMorph: (CrosticPanel newFromFile: (FileStream
- readOnlyFileNamed: 'first.crostic'))"
- | quoteWithBlanks citation clue numberLine numbers clues answers indexableQuote quotePanel crosticPanel buttonRow quoteWidth |
- aStream next asciiValue = 31 & (aStream next asciiValue = 139)
- ifTrue: ["It's gzipped..."
- aStream skip: -2.
- ^ self newFromFile: aStream asUnZippedStream ascii].
- aStream skip: -2.
- quoteWithBlanks := aStream nextLine.
- quoteWithBlanks := quoteWithBlanks asUppercase
- select: [:c | c isLetter
- or: [' -' includes: c]].
- indexableQuote := quoteWithBlanks
- select: [:c | c isLetter].
- citation := aStream nextLine.
- aStream nextLine.
- clues := OrderedCollection new.
- answers := OrderedCollection new.
- [aStream atEnd]
- whileFalse: [clue := aStream nextLine.
- "Transcript cr; show: clue."
- clues addLast: clue.
- numberLine := aStream nextLine.
- numbers := Scanner new scanTokens: numberLine.
- answers addLast: numbers].
- aStream close.
- "Consistency check:"
- (citation asUppercase
- select: [:c | c isLetter])
- = (String
- withAll: (answers
- collect: [:a | indexableQuote at: a first]))
- ifFalse: [self error: 'mal-formed crostic file' translated].
- crosticPanel := super new.
- quotePanel := CrosticQuotePanel new
- quote: quoteWithBlanks
- answers: answers
- cluesPanel: crosticPanel.
- crosticPanel color: quotePanel firstSubmorph color;
-
- quote: indexableQuote
- clues: clues
- answers: answers
- quotePanel: quotePanel.
- buttonRow := crosticPanel buttonRow.
- quoteWidth := crosticPanel width + quotePanel firstSubmorph width max: buttonRow width.
- quotePanel extent: quoteWidth @ 9999.
- crosticPanel addMorph: quotePanel.
- ^ crosticPanel breakColumnAndResizeWithButtons: buttonRow!
Item was removed:
- ----- Method: CrosticPanel class>>oldStyle (in category 'as yet unclassified') -----
- oldStyle
- "return true if we should cross-index all the cells (takes more space)."
-
- ^ false!
Item was removed:
- ----- Method: CrosticPanel class>>sampleFile (in category 'as yet unclassified') -----
- sampleFile
- "If you want to enter a new acrostic, follow this format exactly with regard to CRs and the like, and store it in a file. Do not double the string quotes as here -- that is only because they are embedded in a string. Finally, compress the file in the fileList (so it will be easy to transport and hard to read), and name it 'yourName.crostic' so that the 'open' button on the panel will recognize it."
- ^
- 'Men and women do not feel the same way about dirt. Women for some hormonal reason can see individual dirt molecules, whereas men tend not to notice them until they join together into clumps large enough to support commercial agriculture.
- Dave Barry''s Guide to Marriage
-
- Boccaccio''s collection of tales
- 74 19 175 156 9 122 84 113 104
- Wooden instrument of Swiss herders
- 67 184 153 103 14 142 148 54 3
- Evening service
- 76 99 154 171 89 194 69
- Russian-born American anarchist (2 wds)
- 159 102 177 25 186 134 128 82 50 62 11
- Apple-polish (2 wds)
- 32 190 129 126 179 157 79 170
- Visual-gesture means of communication
- 4 178 27 168 150 185 114
- Postponed contest
- 173 58 77 65 8 124 85
- Groundbreaking invention
- 98 15 116 162 112 37 92 155 70 187
- Material used to make English longbows
- 132 195 28
- Gracile
- 48 191 145 152
- Have the effrontery; experience a high (2 wds)
- 164 61 137 33 17 45
- Florentine painter who experimented with perspective
- 91 181 189 2 20 81 167
- Sondheim opus (3 wds)
- 72 109 147 13 192 165 93 40 115 138 6 63
- Spanish rake
- 108 56 44 133 193 29 125
- Emergence as of an adult butterfly
- 106 149 59 41 24 135 87 68
- Type of rifle (hyph)
- 111 7 143 73 39 30 105 95 53
- Free of charge (3 wds)
- 176 107 120 130 160 22 46 34 94 71
- Pie filling
- 86 75 136 118 43
- Master filmmaker
- 31 151 174 51 163 144
- Longtime sportswriter for the NY Herald tribune (2 wds)
- 60 140 12 101 55 188 166 121
- Birthplace of Erasmus
- 47 64 141 21 10 180 36 80 1
- Mae West classic (3 wds)
- 127 123 161 110 183 5 139 97 88
- Element that glows blue in the dark
- 100 90 35 182 146 117 169 26
- Sturm und Drang writer
- 158 172 119 16 52 23
- Starfish or sea cucumber
- 18 66 96 83 57 49 78 131 38 42
- '!
Item was removed:
- ----- Method: CrosticPanel>>addMenuItemsTo:hand: (in category 'menu') -----
- addMenuItemsTo: aMenu hand: aHandMorph
- aMenu
- add: 'show crostic help' translated
- target: self
- action: #showHelpWindow.
- aMenu
- add: 'show crostic hints' translated
- target: self
- action: #showHintsWindow.
- aMenu
- add: 'show crostic errors' translated
- target: self
- action: #showErrors.
- aMenu
- add: 'clear crostic typing' translated
- target: self
- action: #clearTyping.
- aMenu
- add: 'open crostic file...' translated
- target: self
- action: #openFile!
Item was removed:
- ----- Method: CrosticPanel>>breakColumnAndResizeWithButtons: (in category 'initialization') -----
- breakColumnAndResizeWithButtons: buttonRow
- | indexToSplit yToSplit |
- "The column of clues has been laid out, and the crostic panel has been resized to that width and embedded as a submorph. This method breaks the clues in two, placing the long part to the left of the crostic and the short one below it."
-
- yToSplit := cluesPanel height + quotePanel height // 2 + self top.
- indexToSplit := cluesPanel submorphs findFirst: [:m | m bottom > yToSplit].
- cluesCol2 := AlignmentMorph newColumn color: self color;
- hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0;
- cellPositioning: #topLeft.
- cluesCol2 addAllMorphs: (cluesPanel submorphs copyFrom: indexToSplit + 1
- to: cluesPanel submorphs size).
- cluesPanel position: self position + self borderWidth + (0 @ 4).
- quotePanel position: self position + (quotePanel width @ 0).
- cluesCol2 position: self position + quotePanel extent + (0 @ 4).
- self addMorph: cluesCol2.
- self addMorph: buttonRow.
- buttonRow align: buttonRow topLeft with: cluesCol2 bottomLeft.
- self extent: 100@100; bounds: ((self fullBounds topLeft - self borderWidth asPoint)
- corner: (self fullBounds bottomRight - (2@0))).
- !
Item was removed:
- ----- Method: CrosticPanel>>buttonRow (in category 'menu') -----
- buttonRow
- | row aButton |
- row := AlignmentMorph newRow color: self color;
- hResizing: #shrinkWrap;
- vResizing: #shrinkWrap.
- #('show help' 'show errors' 'show hints' 'clear' 'open...' ) translatedNoop
- with: #(#showHelpWindow #showErrors #showHintsWindow #clearTyping #openFile )
- do: [:label :selector |
- aButton := SimpleButtonMorph new target: self.
- aButton color: Color transparent;
- borderWidth: 1 px;
- borderColor: Color black.
- aButton actionSelector: selector.
- aButton label: label translated.
- row addMorphBack: aButton.
- row addTransparentSpacerOfSize: 3 px @ 0].
- ^ row!
Item was removed:
- ----- Method: CrosticPanel>>clearTyping (in category 'defaults') -----
- clearTyping
- self isClean
- ifTrue: [^ self].
- (self confirm: 'Are you sure you want to discard all typing?' translated)
- ifFalse: [^ self].
- super clearTyping.
- quotePanel clearTyping!
Item was removed:
- ----- Method: CrosticPanel>>highlight: (in category 'defaults') -----
- highlight: morph
-
- self unhighlight.
- quotePanel unhighlight.
- morph startOfWord morphsInWordDo:
- [:m | m color: Color lightGreen.
- (quotePanel letterMorphs at: m indexInQuote) color: Color lightMagenta].
- morph color: Color green.
- (quotePanel letterMorphs at: morph indexInQuote) color: Color magenta.
- !
Item was removed:
- ----- Method: CrosticPanel>>initializeToStandAlone (in category 'parts bin') -----
- initializeToStandAlone
- | aStream quoteWithBlanks indexableQuote citation clue numberLine numbers buttonRow quoteWidth |
- super initializeToStandAlone.
- aStream := ReadStream on: self class sampleFile.
- quoteWithBlanks := aStream nextLine.
- quoteWithBlanks := quoteWithBlanks asUppercase
- select: [:c | c isLetter
- or: [' -' includes: c]].
- indexableQuote := quoteWithBlanks
- select: [:c | c isLetter].
- citation := aStream nextLine.
- aStream nextLine.
- clues := OrderedCollection new.
- answers := OrderedCollection new.
- [aStream atEnd]
- whileFalse: [clue := aStream nextLine.
- "Transcript cr; show: clue."
- clues addLast: clue.
- numberLine := aStream nextLine.
- numbers := Scanner new scanTokens: numberLine.
- answers addLast: numbers].
- aStream close.
- "Consistency check:"
- (citation asUppercase
- select: [:c | c isLetter])
- = (String
- withAll: (answers
- collect: [:a | indexableQuote at: a first]))
- ifFalse: [self error: 'mal-formed crostic file' translated].
- quotePanel := CrosticQuotePanel new
- quote: quoteWithBlanks
- answers: answers
- cluesPanel: self.
- self color: quotePanel firstSubmorph color;
-
- quote: indexableQuote
- clues: clues
- answers: answers
- quotePanel: quotePanel.
- buttonRow := self buttonRow.
- quoteWidth := self width + quotePanel firstSubmorph width max: buttonRow width.
- quotePanel extent: quoteWidth @ 9999.
- self addMorph: quotePanel.
- self breakColumnAndResizeWithButtons: buttonRow!
Item was removed:
- ----- Method: CrosticPanel>>keyCharacter:atIndex:nextFocus: (in category 'defaults') -----
- keyCharacter: aLetter atIndex: indexInQuote nextFocus: nextFocus
-
- (self letterMorphs at: indexInQuote) setLetter: aLetter.
- (quotePanel letterMorphs at: indexInQuote) setLetter: aLetter.
- self highlight: nextFocus
- !
Item was removed:
- ----- Method: CrosticPanel>>lostFocus (in category 'defaults') -----
- lostFocus
-
- self unhighlight.
- quotePanel unhighlight!
Item was removed:
- ----- Method: CrosticPanel>>openFile (in category 'menu') -----
- openFile
- | fileName crostic file |
-
- fileName := FileChooserDialog openOn: FileDirectory default suffixList: { 'crostic' } label: 'Select a Crostic file...' translated.
- fileName ifNil: [^nil].
-
- file := FileStream readOnlyFileNamed: fileName.
- crostic := CrosticPanel newFromFile: file.
- file close.
- (self isClean
- or: [self confirm: 'Is it OK to discard this crostic?' translated])
- ifTrue: [self world
- addMorphFront: (crostic position: self position).
- self delete]
- ifFalse: [self world addMorphFront: crostic]!
Item was removed:
- ----- Method: CrosticPanel>>quote:clues:answers:quotePanel: (in category 'initialization') -----
- quote: indexableQuote clues: clueStrings answers: answerIndices quotePanel: panel
-
- | row clue answer answerMorph letterMorph prev clueText clueStyle |
- quote := indexableQuote.
- quotePanel := panel.
- clues := clueStrings.
- answers := answerIndices.
- cluesPanel := AlignmentMorph newColumn color: self color;
- hResizing: #shrinkWrap; vResizing: #shrinkWrap;
- cellPositioning: #topLeft; layoutInset: 1 px.
- letterMorphs := Array new: quotePanel letterMorphs size.
- clueStyle := nil.
- 1 to: clues size do:
- [:i | clue := clues at: i. answer := answers at: i.
- row := AlignmentMorph newRow cellPositioning: #bottomLeft.
- clueText := (TextMorph newBounds: (0 @ 0 extent: 120 px @ 20 px) color: Color black)
- string: (CrosticPanel oldStyle
- ifTrue: [(($A to: $Z) at: i) asString , '. ' , clue]
- ifFalse: [clue])
- fontName: 'ComicPlain' size: 13 px.
- clueStyle ifNil: ["Make up a special style with decreased leading"
- clueStyle := clueText textStyle copy.
- clueStyle gridForFont: 1 withLead: -2].
- clueText text: clueText asText textStyle: clueStyle. "All clues share same style"
- clueText composeToBounds.
- row addMorphBack: clueText.
- answerMorph := AlignmentMorph newRow layoutInset: 0.
- prev := nil.
- answer do:
- [:n | letterMorph := WordGameLetterMorph new underlined
- indexInQuote: n
- id1: (CrosticPanel oldStyle ifTrue: [n printString] ifFalse: [nil]);
- setLetter: Character space.
- letterMorph on: #mouseDown send: #mouseDownEvent:letterMorph: to: self.
- letterMorph on: #keyStroke send: #keyStrokeEvent:letterMorph: to: self.
- letterMorph predecessor: prev.
- prev ifNotNil: [prev successor: letterMorph].
- prev := letterMorph.
- letterMorphs at: n put: letterMorph.
- answerMorph addMorphBack: letterMorph].
- answerMorph color: answerMorph firstSubmorph color.
- row addMorphBack: answerMorph.
- row fullBounds.
- row color: answerMorph firstSubmorph color.
- cluesPanel addMorphBack: row].
- self addMorph: cluesPanel.
- self bounds: cluesPanel fullBounds.!
Item was removed:
- ----- Method: CrosticPanel>>showErrors (in category 'menu') -----
- showErrors
-
- letterMorphs do:
- [:m | (m letter ~= Character space and: [m letter ~= (quote at: m indexInQuote)])
- ifTrue: [m color: Color red.
- (quotePanel letterMorphs at: m indexInQuote) color: Color red]]!
Item was removed:
- ----- Method: CrosticPanel>>showHelpWindow (in category 'menu') -----
- showHelpWindow
-
- 'The Crostic Panel presents an acrostic puzzle for solution. As you type in answers for the clues, the letters also get entered in the text of the hidden quote. Conversely, as you guess words in the quote, those letters will fill in missing places in your answers. In addition, the first letters of all the answers together form the author''s name and title of the work from which the quote is taken.
-
- If you wish to make up other acrostic puzzles, follow the obvious file format in the sampleFile method. If you wish to print an acrostic to work it on paper, then change the oldStyle method to return true, and it will properly cross-index all the cells.
-
- Have fun!!' translated
- editWithLabel: 'About the Crostic Panel' translated.!
Item was removed:
- ----- Method: CrosticPanel>>showHintsWindow (in category 'menu') -----
- showHintsWindow
- | hints |
- (self confirm: 'As hints, you will be given the five longest answers.
- Do you really want to do this?' translated)
- ifFalse: [^ self].
- hints := (answers sorted: [:x :y | x size > y size]) first: 5.
- (('The five longest answers are...
- ' translated
- , (String
- streamContents: [:strm |
- hints
- do: [:hint | strm cr;
- nextPutAll: (hint
- collect: [:i | quote at: i])].
- strm cr; cr]) , 'Good luck!!' translated))
- editWithLabel: 'Crostic Hints' translated.!
Item was removed:
- WordGamePanelMorph subclass: #CrosticQuotePanel
- instanceVariableNames: 'cluesPanel'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
Item was removed:
- ----- Method: CrosticQuotePanel>>extent: (in category 'geometry') -----
- extent: newExtent
-
- | w h nAcross relLoc topLeft |
- w := self firstSubmorph width - 1 px. h := self firstSubmorph height - 1 px.
- nAcross := newExtent x - (self borderWidth - 1 px * 2) - 1 px // w.
- topLeft := self position + self borderWidth - 1 px.
- submorphs withIndexDo:
- [:m :i |
- relLoc := (i-1 \\ nAcross * w) @ (i-1 // nAcross * h).
- m position: topLeft + relLoc].
- super extent: ((w * nAcross + 1) @ (submorphs size - 1 // nAcross + 1 * h+1))
- + (self borderWidth - 1 px * 2).!
Item was removed:
- ----- Method: CrosticQuotePanel>>highlight: (in category 'defaults') -----
- highlight: morph
-
- self unhighlight.
- cluesPanel unhighlight.
- morph startOfWord morphsInWordDo:
- [:m | m color: Color lightGreen.
- (cluesPanel letterMorphs at: m indexInQuote) color: Color lightMagenta].
- morph color: Color green.
- (cluesPanel letterMorphs at: morph indexInQuote) color: Color magenta.
- !
Item was removed:
- ----- Method: CrosticQuotePanel>>keyCharacter:atIndex:nextFocus: (in category 'defaults') -----
- keyCharacter: aLetter atIndex: indexInQuote nextFocus: nextFocus
-
- (self letterMorphs at: indexInQuote) setLetter: aLetter.
- (cluesPanel letterMorphs at: indexInQuote) setLetter: aLetter.
- self highlight: nextFocus
- !
Item was removed:
- ----- Method: CrosticQuotePanel>>lostFocus (in category 'defaults') -----
- lostFocus
-
- self unhighlight.
- cluesPanel unhighlight!
Item was removed:
- ----- Method: CrosticQuotePanel>>quote:answers:cluesPanel: (in category 'initialization') -----
- quote: quoteWithBlanks answers: theAnswers cluesPanel: panel
-
- | n morph prev clueIxs |
- cluesPanel := panel.
- self color: Color gray.
- clueIxs := Array new: quoteWithBlanks size.
- theAnswers withIndexDo: [:a :i | a do: [:j | clueIxs at: j put: i]].
- letterMorphs := OrderedCollection new.
- prev := nil.
- self addAllMorphs: (quoteWithBlanks asArray collect:
- [:c |
- c isLetter
- ifTrue: [n := letterMorphs size + 1.
- morph := WordGameLetterMorph new boxed.
- CrosticPanel oldStyle
- ifTrue: [morph indexInQuote: n id1: n printString.
- morph id2: (($A to: $Z) at: (clueIxs at: n)) asString]
- ifFalse: [morph indexInQuote: n id1: nil].
- morph setLetter: Character space.
- morph on: #mouseDown send: #mouseDownEvent:letterMorph: to: self.
- morph on: #keyStroke send: #keyStrokeEvent:letterMorph: to: self.
- letterMorphs addLast: morph]
- ifFalse: [morph := WordGameLetterMorph new boxed indexInQuote: nil id1: nil.
- CrosticPanel oldStyle ifTrue: [morph extent: 26 px @ 24 px "Oops"]].
- morph predecessor: prev.
- prev ifNotNil: [prev successor: morph].
- prev := morph]).!
Item was removed:
- RectangleMorph subclass: #DoubleClickExample
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Demo'!
-
- !DoubleClickExample commentStamp: '<historical>' prior: 0!
- Illustrates the double-click capabilities of Morphic.
-
- If you have a kind of morph you wish to have respond specially to a double-click, it should:
-
- (1) Respond "true" to #handlesMouseDown:
-
- (2) In its mouseDown: method, send #waitForClicksOrDrag:event: to the hand.
-
- (3) Reimplement #click: to react to single-clicked mouse-down.
-
- (4) Reimplement #doubleClick: to make the appropriate response to a double-click.
-
- (5) Reimplement #drag: to react to non-clicks. This message is sent continuously until the button is released. You can check the event argument to react differently on the first, intermediate, and last calls.!
Item was removed:
- ----- Method: DoubleClickExample class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'DoubleClick' translatedNoop
- categories: #()
- documentation: 'An example of how to use double-click in moprhic' translatedNoop!
Item was removed:
- ----- Method: DoubleClickExample>>balloonText (in category 'accessing') -----
- balloonText
- ^ 'Double-click on me to change my color;
- single-click on me to change border color;
- hold mouse down within me and then move it to grow
- (if I''m red) or shrink (if I''m blue).' translated
- !
Item was removed:
- ----- Method: DoubleClickExample>>click: (in category 'event handling') -----
- click: evt
- self showBalloon: 'click' hand: evt hand.
- self borderColor: (self borderColor = Color black ifTrue: [Color yellow] ifFalse: [Color black])
- !
Item was removed:
- ----- Method: DoubleClickExample>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color red!
Item was removed:
- ----- Method: DoubleClickExample>>doubleClick: (in category 'event handling') -----
- doubleClick: evt
- self showBalloon: 'doubleClick' hand: evt hand.
- self color: ((color = Color blue) ifTrue: [Color red] ifFalse: [Color blue])
- !
Item was removed:
- ----- Method: DoubleClickExample>>handlesMouseDown: (in category 'event handling') -----
- handlesMouseDown: evt
- ^ true!
Item was removed:
- ----- Method: DoubleClickExample>>mouseDown: (in category 'event handling') -----
- mouseDown: evt
- "Do nothing upon mouse-down except inform the hand to watch for a double-click; wait until an ensuing click:, doubleClick:, or drag: message gets dispatched"
-
- evt hand waitForClicksOrDrag: self event: evt!
Item was removed:
- ----- Method: DoubleClickExample>>startDrag: (in category 'event handling') -----
- startDrag: evt
- "We'll get a mouseDown first, some mouseMoves, and a mouseUp event last"
- | oldCenter |
- evt isMouseDown ifTrue:
- [self showBalloon: 'drag (mouse down)' hand: evt hand.
- self world displayWorld.
- (Delay forMilliseconds: 750) wait].
- evt isMouseUp ifTrue:
- [self showBalloon: 'drag (mouse up)' hand: evt hand].
- (evt isMouseUp or: [evt isMouseDown]) ifFalse:
- [self showBalloon: 'drag (mouse still down)' hand: evt hand].
- (self containsPoint: evt cursorPoint)
- ifFalse: [^ self].
-
- oldCenter := self center.
- color = Color red
- ifTrue:
- [self extent: self extent + (1@1)]
- ifFalse:
- [self extent: ((self extent - (1@1)) max: (16@16))].
- self center: oldCenter!
Item was removed:
- MagnifierMorph subclass: #FishEyeMorph
- instanceVariableNames: 'gridNum d clipRects toRects quads savedExtent'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Demo'!
Item was removed:
- ----- Method: FishEyeMorph class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'FishEye' translatedNoop
- categories: #()
- documentation: 'An extreme-wide-angle lens' translatedNoop!
Item was removed:
- ----- Method: FishEyeMorph>>calculateTransform (in category 'initialization') -----
- calculateTransform
- | stepX stepY rect tx ty arrayX arrayY |
- (gridNum x = 0 or: [gridNum y = 0]) ifTrue: [^self].
- stepX := srcExtent x // gridNum x.
- stepY := srcExtent y // gridNum y.
-
- arrayX := (1 to: gridNum y + 1) collect: [:j | Float32Array new: gridNum x + 1].
- arrayY := (1 to: gridNum y + 1) collect: [:j | Float32Array new: gridNum x + 1].
-
- 0 to: gridNum y do: [:j |
- 0 to: gridNum x do: [:i |
- (arrayX at: (j + 1)) at: (i + 1) put: i*stepX.
- (arrayY at: (j + 1)) at: (i + 1) put: j*stepY.
- ].
- ].
-
- 0 to: gridNum y do: [:j |
- self transformX: (arrayX at: (j+1)).
- self transformY: (arrayY at: (j+1)).
- ].
-
- 0 to: gridNum y do: [:j |
- arrayX at: (j+1) put: ((1 to: gridNum x +1) collect: [:i | ((arrayX at: (j+1)) at: i) asInteger]).
- arrayY at: (j+1) put: ((1 to: gridNum x +1) collect: [:i | ((arrayY at: (j+1)) at: i) asInteger]).
- ].
-
-
- clipRects := (1 to: gridNum y) collect: [:j | Array new: gridNum x].
- toRects := (1 to: gridNum y) collect: [:j | Array new: gridNum x].
- quads := (1 to: gridNum y) collect: [:j | Array new: gridNum x].
- 0 to: gridNum y - 1 do: [:j |
- 0 to: gridNum x- 1 do: [:i |
- rect := (((arrayX at: (j+1)) at: (i+1))@((arrayY at: (j+1)) at: (i+1)))
- corner: ((arrayX at: (j+2)) at: (i+2))@((arrayY at: (j+2)) at: (i+2)).
- (clipRects at: j+1) at: i+1 put: rect.
-
- rect width >= stepX ifTrue: [rect := rect expandBy: (1@0)].
- rect height >= stepY ifTrue: [rect := rect expandBy: (0@1)].
- (toRects at: j+1) at: i+1 put: rect.
-
- tx := (i)*stepX.
- ty := (j)*stepY.
- (quads at: j+1) at: i+1
- put: {(tx)@(ty). (tx)@(ty+stepY). (tx+stepX)@(ty+stepY). (tx+stepX)@(ty)}.
- ].
- ].
-
- !
Item was removed:
- ----- Method: FishEyeMorph>>chooseMagnification (in category 'menus') -----
- chooseMagnification
- self inform: 'Magnification is fixed, sorry.' translated!
Item was removed:
- ----- Method: FishEyeMorph>>chooseMagnification: (in category 'menu') -----
- chooseMagnification: evt
- !
Item was removed:
- ----- Method: FishEyeMorph>>extent: (in category 'geometry') -----
- extent: aPoint
- "Round to a number divisible by grid. Note that the superclass has its own implementation."
- | g gridSize |
- gridSize := self gridSizeFor: aPoint.
- "self halt."
- g := (aPoint - (2 * self borderWidth)) // gridSize.
- srcExtent := g * gridSize.
- gridNum := g.
- ^super extent: self defaultExtent!
Item was removed:
- ----- Method: FishEyeMorph>>g:max:focus: (in category 'initialization') -----
- g: aFloatArray max: max focus: focus
- | dNormX array |
-
- dNormX := aFloatArray - focus.
-
- array := dNormX / max.
- array *= d.
- array += 1.0.
- array := 1.0 / array.
- dNormX *= (d+1.0).
- array *= dNormX.
- ^array += focus.
- !
Item was removed:
- ----- Method: FishEyeMorph>>gridSizeFor: (in category 'private') -----
- gridSizeFor: aPoint
- "returns appropriate size for specified argument"
- | g |
- g := aPoint x min: aPoint y.
- g <= 256 ifTrue: [^8].
- ^16.!
Item was removed:
- ----- Method: FishEyeMorph>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
- "magnification should be always 1"
- magnification := 1.
- d := 1.3.
- self extent: 130 @ 130!
Item was removed:
- ----- Method: FishEyeMorph>>initializeToStandAlone (in category 'parts bin') -----
- initializeToStandAlone
- super initializeToStandAlone.
- "magnification should be always 1"
- magnification := 1.
- d := 1.3.
- self extent: 130@130.
- !
Item was removed:
- ----- Method: FishEyeMorph>>magnifiedForm (in category 'magnifying') -----
- magnifiedForm
- | warp warpForm fromForm |
-
- savedExtent ~= srcExtent ifTrue: [
- savedExtent := srcExtent.
- self calculateTransform].
-
- warpForm := Form extent: srcExtent depth: Display depth.
- fromForm := super magnifiedForm.
-
- warp := (WarpBlt current toForm: warpForm)
- sourceForm: fromForm;
- colorMap: nil;
- cellSize: 2;
- combinationRule: Form over.
-
- 1 to: gridNum y do: [:j |
- 1 to: gridNum x do: [:i |
- warp
- clipRect: ((clipRects at: j) at: i);
- copyQuad: ((quads at: j) at: i)
- toRect: ((toRects at: j) at: i).
- ].
- ].
- ^warpForm
- !
Item was removed:
- ----- Method: FishEyeMorph>>transformX: (in category 'initialization') -----
- transformX: aFloatArray
- | focus gridNum2 subArray dMaxX |
-
- focus := srcExtent x asFloat / 2.
-
- gridNum2 := (aFloatArray findFirst: [:x | x > focus]) - 1.
-
- dMaxX := 0.0 - focus.
- subArray := self g: (aFloatArray copyFrom: 1 to: gridNum2) max: dMaxX focus: focus.
-
- aFloatArray replaceFrom: 1 to: gridNum2 with: subArray startingAt: 1.
-
-
- dMaxX := focus. " = (size - focus)"
- subArray := self g: (aFloatArray copyFrom: gridNum2 + 1 to: gridNum x + 1)
- max: dMaxX focus: focus.
-
- aFloatArray replaceFrom: gridNum2 + 1 to: gridNum x + 1 with: subArray startingAt: 1.
- !
Item was removed:
- ----- Method: FishEyeMorph>>transformY: (in category 'initialization') -----
- transformY: aFloatArray
- | focus subArray dMaxY |
- focus := srcExtent y asFloat / 2.
- dMaxY := (aFloatArray first) <= focus
- ifTrue: [0.0 - focus]
- ifFalse: [focus].
- subArray := self
- g: (aFloatArray copyFrom: 1 to: gridNum x + 1)
- max: dMaxY
- focus: focus.
- aFloatArray
- replaceFrom: 1
- to: gridNum x + 1
- with: subArray
- startingAt: 1!
Item was removed:
- ----- Method: Form>>blendColor: (in category '*Etoys-Squeakland-converting') -----
- blendColor: aTranslucentColor
- "((ScriptingSystem formAtKey: #TryIt) blendColor: (Color black alpha:
- 0.5)) displayAt: 0 @ 0"
- "((ScriptingSystem formAtKey: #TryIt) blendColor: (Color red alpha: 0.5))
- displayAt: 0 @ 0"
- | form canvas |
- form := self deepCopy asFormOfDepth: 32.
- canvas := form getCanvas.
- canvas
- stencil: form
- at: 0 @ 0
- sourceRect: (0 @ 0 extent: form extent)
- color: aTranslucentColor.
- ^ canvas form!
Item was removed:
- ----- Method: Form>>scaledToHeight: (in category '*Etoys-Squeakland-scaling, rotation') -----
- scaledToHeight: newHeight
- "Answer the receiver, scaled such that it has the desired height."
-
- newHeight = self height ifTrue: [^ self].
- ^self magnify: self boundingBox by: (newHeight / self height) smoothing: 2.
- !
Item was removed:
- ----- Method: Form>>scaledToWidth: (in category '*Etoys-Squeakland-scaling, rotation') -----
- scaledToWidth: newWidth
- "Answer the receiver, scaled such that it has the desired width."
-
- newWidth = self width ifTrue: [^ self].
- ^self magnify: self boundingBox by: (newWidth / self width) smoothing: 2.
- !
Item was removed:
- AlignmentMorph subclass: #FreeCell
- instanceVariableNames: 'board cardsRemainingDisplay elapsedTimeDisplay gameNumberDisplay lastGameLost state autoMoveRecursionCount myFillStyle'
- classVariableNames: 'Statistics'
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
Item was removed:
- ----- Method: FreeCell class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'FreeCell' translatedNoop
- categories: {'Games' translatedNoop}
- documentation: 'A unique solitaire card game' translatedNoop!
Item was removed:
- ----- Method: FreeCell class>>initialize (in category 'class initialization') -----
- initialize
-
- Statistics := FreeCellStatistics new.!
Item was removed:
- ----- Method: FreeCell>>autoMovingHome (in category 'actions') -----
- autoMovingHome
-
- elapsedTimeDisplay pause.
- autoMoveRecursionCount := autoMoveRecursionCount + 1.!
Item was removed:
- ----- Method: FreeCell>>board (in category 'accessing') -----
- board
-
- board ifNil:
- [board := FreeCellBoard new
- target: self;
- actionSelector: #boardAction:].
- ^board!
Item was removed:
- ----- Method: FreeCell>>boardAction: (in category 'actions') -----
- boardAction: actionSymbol
-
- actionSymbol = #cardMovedHome ifTrue: [^self cardMovedHome].
- actionSymbol = #autoMovingHome ifTrue: [^self autoMovingHome].!
Item was removed:
- ----- Method: FreeCell>>buildButton:target:label:selector: (in category 'private') -----
- buildButton: aButton target: aTarget label: aLabel selector: aSelector
- "wrap a button or switch in an alignmentMorph to provide some space around the button"
-
- | a |
- aButton
- target: aTarget;
- label: aLabel;
- actionSelector: aSelector;
- borderStyle: (BorderStyle raised width: 2 px);
- color: Color gray.
- a := AlignmentMorph newColumn
- wrapCentering: #center; cellPositioning: #topCenter;
- hResizing: #shrinkWrap;
- vResizing: #shrinkWrap;
- color: Color transparent;
- layoutInset: 1 px.
- a addMorph: aButton.
- ^ a!
Item was removed:
- ----- Method: FreeCell>>cardMovedHome (in category 'actions') -----
- cardMovedHome
-
- cardsRemainingDisplay value: (cardsRemainingDisplay value - 1).
- autoMoveRecursionCount := autoMoveRecursionCount - 1 max: 0.
- cardsRemainingDisplay value = 0
- ifTrue: [self gameWon]
- ifFalse: [autoMoveRecursionCount = 0 ifTrue: [elapsedTimeDisplay continue]].!
Item was removed:
- ----- Method: FreeCell>>colorNearBottom (in category 'visual properties') -----
- colorNearBottom
-
- ^Color r: 0.0 g: 0.455 b: 0.18!
Item was removed:
- ----- Method: FreeCell>>colorNearTop (in category 'visual properties') -----
- colorNearTop
-
- ^ (Color r: 0.304 g: 0.833 b: 0.075)!
Item was removed:
- ----- Method: FreeCell>>currentGame (in category 'accessing') -----
- currentGame
-
- ^self board cardDeck seed!
Item was removed:
- ----- Method: FreeCell>>defaultBackgroundColor (in category 'user interface') -----
- defaultBackgroundColor
-
- ^Color r: 0.365 g: 1.0 b: 0.09!
Item was removed:
- ----- Method: FreeCell>>defaultBorderWidth (in category 'initialization') -----
- defaultBorderWidth
- "answer the default border width for the receiver"
- ^ 2 px!
Item was removed:
- ----- Method: FreeCell>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ self colorNearTop!
Item was removed:
- ----- Method: FreeCell>>fillStyle (in category 'visual properties') -----
- fillStyle
-
- myFillStyle ifNil: [
- myFillStyle := GradientFillStyle ramp: {
- 0.0 -> self colorNearTop.
- 1.0 -> self colorNearBottom
- }.
- ].
- ^myFillStyle
- origin: self position;
- direction: (self width // 2)@self height
- !
Item was removed:
- ----- Method: FreeCell>>gameLost (in category 'actions') -----
- gameLost
-
- state := #lost.
- elapsedTimeDisplay stop.
- cardsRemainingDisplay highlighted: true; flash: true.
- Statistics gameLost: self currentGame!
Item was removed:
- ----- Method: FreeCell>>gameWon (in category 'actions') -----
- gameWon
-
- state := #won.
- elapsedTimeDisplay stop; highlighted: true; flash: true.
- Statistics gameWon: self currentGame!
Item was removed:
- ----- Method: FreeCell>>help (in category 'actions') -----
- help
-
- self helpText editWithLabel: 'FreeCell Help'.!
Item was removed:
- ----- Method: FreeCell>>helpText (in category 'accessing') -----
- helpText
- ^ 'The objective of FreeCell is to move all of the cards to the four "home cells" in the upper right corner. Each home cell will hold one suit and must be filled sequentially starting with the Ace.
-
- There are four "free cells" in the upper left corner that can each hold one card. Cards can be moved from the bottom of a stack to a free cell or to another stack.
-
- When moving a card to another stack, it must have a value that is one less than the exposed card and of a different color.' translated!
Item was removed:
- ----- Method: FreeCell>>inAutoMove (in category 'actions') -----
- inAutoMove
- "Return true if an automove sequence is in progress"
-
- ^ autoMoveRecursionCount > 0!
Item was removed:
- ----- Method: FreeCell>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
- Statistics newSession.
- autoMoveRecursionCount := 0.
- self listDirection: #topToBottom.
- self wrapCentering: #center;
- cellPositioning: #topCenter.
- self vResizing: #shrinkWrap.
- self hResizing: #shrinkWrap.
- self
- addMorph: self makeControls;
- addMorph: self board;
- newGame!
Item was removed:
- ----- Method: FreeCell>>makeCardsRemainingDisplay (in category 'initialization') -----
- makeCardsRemainingDisplay
- cardsRemainingDisplay := LedMorph new digits: 2;
- extent: 10 px * 2 @ 15 px.
- ^ self wrapPanel: cardsRemainingDisplay label: 'Cards Left: ' translated!
Item was removed:
- ----- Method: FreeCell>>makeControlBar (in category 'initialization') -----
- makeControlBar
-
- ^AlignmentMorph newRow
- color: self colorNearBottom;
- borderStyle: (BorderStyle inset width: 2 px);
- layoutInset: 0;
- hResizing: #spaceFill; vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter;
- yourself.!
Item was removed:
- ----- Method: FreeCell>>makeControls (in category 'initialization') -----
- makeControls
-
- ^self makeControlBar
- addMorph: AlignmentMorph newVariableTransparentSpacer;
- addMorph: self makeUndoButton;
- addMorph: self makeHelpButton;
- addMorph: self makeQuitButton;
- addMorph: self makeStatisticsButton;
- addMorph: self makeGameNumberDisplay;
- addMorph: self makePickGameButton;
- addMorph: self makeSameGameButton;
- addMorph: self makeNewGameButton;
- addMorph: self makeElapsedTimeDisplay;
- addMorph: self makeCardsRemainingDisplay;
- yourself.!
Item was removed:
- ----- Method: FreeCell>>makeElapsedTimeDisplay (in category 'initialization') -----
- makeElapsedTimeDisplay
- elapsedTimeDisplay := LedTimerMorph new digits: 3;
- extent: 10 px * 3 @ 15 px.
- ^ self wrapPanel: elapsedTimeDisplay label: 'Elapsed Time: ' translated!
Item was removed:
- ----- Method: FreeCell>>makeGameNumberDisplay (in category 'initialization') -----
- makeGameNumberDisplay
- gameNumberDisplay := LedMorph new digits: 5;
- extent: 10 px * 5 @ 15 px.
- ^ self wrapPanel: gameNumberDisplay label: 'Game #: ' translated!
Item was removed:
- ----- Method: FreeCell>>makeHelpButton (in category 'initialization') -----
- makeHelpButton
- ^ self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'Help' translated
- selector: #help!
Item was removed:
- ----- Method: FreeCell>>makeNewGameButton (in category 'initialization') -----
- makeNewGameButton
- ^ self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'New game' translated
- selector: #newGame!
Item was removed:
- ----- Method: FreeCell>>makePickGameButton (in category 'initialization') -----
- makePickGameButton
- ^ self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'Pick game' translated
- selector: #pickGame!
Item was removed:
- ----- Method: FreeCell>>makeQuitButton (in category 'initialization') -----
- makeQuitButton
- ^ self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'Quit' translated
- selector: #quit!
Item was removed:
- ----- Method: FreeCell>>makeSameGameButton (in category 'initialization') -----
- makeSameGameButton
- ^ self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'Same game' translated
- selector: #sameGame!
Item was removed:
- ----- Method: FreeCell>>makeStatisticsButton (in category 'initialization') -----
- makeStatisticsButton
- ^ self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'Statistics' translated
- selector: #statistics!
Item was removed:
- ----- Method: FreeCell>>makeUndoButton (in category 'initialization') -----
- makeUndoButton
- ^ self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'Undo' translated
- selector: #undo!
Item was removed:
- ----- Method: FreeCell>>modelSleep (in category 'user interface') -----
- modelSleep
- "When fixing #contains: calls beware of reinventing #includes:"
- (#(newGame sameGame pickGame won lost ) includes: state)
- ifTrue: [elapsedTimeDisplay pause]!
Item was removed:
- ----- Method: FreeCell>>modelWakeUp (in category 'user interface') -----
- modelWakeUp
- "Maybe less performant but more readable"
- (#(won lost) includes: state)
- ifFalse: [elapsedTimeDisplay resume]!
Item was removed:
- ----- Method: FreeCell>>newGame (in category 'actions') -----
- newGame
- Collection initialize.
- self newGameNumber: nil.
- state := #newGame!
Item was removed:
- ----- Method: FreeCell>>newGameNumber: (in category 'actions') -----
- newGameNumber: aSeedOrNil
- cardsRemainingDisplay value ~~ 0 ifTrue: [self gameLost].
- cardsRemainingDisplay flash: false; highlighted: false; value: 52.
- elapsedTimeDisplay flash: false; highlighted: false.
- "board handles nil case"
- self board pickGame: aSeedOrNil.
- elapsedTimeDisplay reset; start.
- gameNumberDisplay value: self currentGame!
Item was removed:
- ----- Method: FreeCell>>openInWindowLabeled:inWorld: (in category 'initialization') -----
- openInWindowLabeled: aString inWorld: aWorld
-
- ^(super openInWindowLabeled: aString inWorld: aWorld)
- model: self;
- yourself!
Item was removed:
- ----- Method: FreeCell>>pickGame (in category 'actions') -----
- pickGame
- | seed |
- seed := self promptForSeed.
- seed isNil ifTrue: [^ self].
- self newGameNumber: seed.
- state := #pickGame!
Item was removed:
- ----- Method: FreeCell>>promptForSeed (in category 'actions') -----
- promptForSeed
- | ss ii hh |
- [hh := board hardness
- ifNil: [0].
- ss := FillInTheBlank request: 'Pick a game number between 1 and 32000.
- or
- set the hardness of the next game by typing ''H 30''.
- Above 100 is very hard. Zero is standard game.
- Current hardness is: ' translated , hh printString.
- "Let the user cancel."
- ss isEmpty
- ifTrue: [^ nil].
- ss := ss withoutQuoting.
- ss first asLowercase == $h
- ifTrue: ["Set the hardness"
- [ii := ss numericSuffix]
- on: Error
- do: [ii := 0].
- board hardness: ii.
- ^ nil].
- [ii := ss asNumber asInteger]
- on: Error
- do: [ii := 0].
- ii between: 1 and: 32000] whileFalse.
- ^ ii!
Item was removed:
- ----- Method: FreeCell>>quit (in category 'actions') -----
- quit
- cardsRemainingDisplay value ~~ 0 ifTrue: [self gameLost].
-
- self owner == self world
- ifTrue: [self delete]
- ifFalse: [self owner delete].
- Statistics close!
Item was removed:
- ----- Method: FreeCell>>sameGame (in category 'actions') -----
- sameGame
- self newGameNumber: self currentGame.
- state := #sameGame.
-
- !
Item was removed:
- ----- Method: FreeCell>>statistics (in category 'actions') -----
- statistics
-
- Statistics display!
Item was removed:
- ----- Method: FreeCell>>undo (in category 'actions') -----
- undo
-
- ^ self commandHistory undoOrRedoCommand!
Item was removed:
- ----- Method: FreeCell>>wrapPanel:label: (in category 'private') -----
- wrapPanel: anLedPanel label: aLabel
- "wrap an LED panel in an alignmentMorph with a label to its left"
-
- | a |
- a := AlignmentMorph newRow
- wrapCentering: #center; cellPositioning: #leftCenter;
- hResizing: #shrinkWrap;
- vResizing: #shrinkWrap;
- borderWidth: 0;
- layoutInset: 5 px;
- color: Color transparent.
- a addMorph: anLedPanel.
- a addMorph: (StringMorph contents: aLabel).
- ^ a!
Item was removed:
- AlignmentMorph subclass: #FreeCellBoard
- instanceVariableNames: 'cardDeck lastCardDeck freeCells homeCells stacks target actionSelector hardness'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !FreeCellBoard commentStamp: '<historical>' prior: 0!
- The model of a freecell game. Holds the stacks of cards.
- cardDeck
- lastCardDeck
- freeCells
- homeCells
- stacks array of CardDecks of the columns of cards.
- ----
- Hardness: a number from 1 to 10000.
- After dealing, count down the number. For each count, go to next column, pick a ramdom card (with same generator as deck) and move it one place in its stack. This is a kind of bubble sort. Interesting that the slowness of bubble sort is a plus -- gives fine gradation in the hardness.
- Moving a card: Move red cards to deep half, black to shallow (or vice versa). Within a color, put low cards deep and high cards shallow.
- If speed is an issue, move several steps at once, decrementing counter.
-
- (May make it easier? If running columns, need a way to make harder in other ways.)!
Item was removed:
- ----- Method: FreeCellBoard class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: FreeCellBoard>>acceptCard:onStack: (in category 'actions') -----
- acceptCard: aCard onStack: aDeck
- " assumes that number of cards was check at drag time, need to reduce count if dropping
- into an empty stack"
- aCard hasSubmorphs
- ifTrue: [
- aDeck ifEmpty: [
- (aCard submorphCount+1) > (self maxDraggableStackSize: true)
- ifTrue: [^false]]]
- ifFalse: [^ nil].
- ^nil.
-
- !
Item was removed:
- ----- Method: FreeCellBoard>>acceptSingleCard:on: (in category 'actions') -----
- acceptSingleCard: aCard on: aDeck
- "Home cells and free cells don't accept multiple cards on a home cell,
- defer to deck for other cases"
- aCard hasSubmorphs
- ifTrue: [^ false]
- ifFalse: [^ nil]!
Item was removed:
- ----- Method: FreeCellBoard>>actionSelector: (in category 'accessing') -----
- actionSelector: aSymbolOrString
-
- (nil = aSymbolOrString or:
- ['nil' = aSymbolOrString or:
- [aSymbolOrString isEmpty]])
- ifTrue: [^ actionSelector := nil].
-
- actionSelector := aSymbolOrString asSymbol.
- !
Item was removed:
- ----- Method: FreeCellBoard>>addHardness (in category 'hardness') -----
- addHardness
- | cnt rand pileInd pile |
- "post process the layout of cards to make it harder. See class comment."
-
- hardness ifNil: [^ self].
- cnt := hardness.
- rand := Random new seed: cardDeck seed. "Same numbers but different purpose"
- pileInd := 1.
- [(cnt := cnt - 1) > 0] whileTrue: [
- pile := stacks atWrap: (pileInd := pileInd + 1).
- cnt := cnt - (self makeHarder: pile rand: rand toDo: cnt)]. "mostly 0, but moves cards"!
Item was removed:
- ----- Method: FreeCellBoard>>autoMoveCardsHome (in category 'private') -----
- autoMoveCardsHome
- | first |
-
- first := false.
- (self stacks, self freeCells) do: [:deck |
- self homeCells do: [ :homeCell |
- deck hasCards ifTrue: [
- (homeCell repelCard: deck topCard) ifFalse: [
- (self isPlayableCardInHomeCells: deck topCard) ifTrue: [
- first ifFalse: [ " trigger autoMoving event on first move."
- first := true.
- self performActionSelector: #autoMovingHome
- ].
- self visiblyMove: deck topCard to: homeCell.
- ]
- ]
- ]
- ]
- ].
-
- !
Item was removed:
- ----- Method: FreeCellBoard>>captureStateBeforeGrab (in category 'undo') -----
- captureStateBeforeGrab
-
- self removeProperty: #stateBeforeGrab.
- self setProperty: #stateBeforeGrab toValue: self capturedState
- !
Item was removed:
- ----- Method: FreeCellBoard>>capturedState (in category 'undo') -----
- capturedState
-
- self valueOfProperty: #stateBeforeGrab ifPresentDo: [:st | ^ st].
- ^ { freeCells collect: [:deck | deck submorphs].
- homeCells collect: [:deck | deck submorphs].
- stacks collect: [:deck | deck submorphs] }
- !
Item was removed:
- ----- Method: FreeCellBoard>>cardCell (in category 'layout') -----
- cardCell
-
- ^PlayingCardDeck new
- layout: #pile;
- listDirection: #topToBottom;
- enableDragNDrop;
- color: Color transparent;
- borderColor: (Color gray alpha: 0.5);
- borderWidth: 2 px;
- layoutBounds: (0@0 extent: PlayingCardMorph width @ PlayingCardMorph height);
- yourself!
Item was removed:
- ----- Method: FreeCellBoard>>cardDeck (in category 'accessing') -----
- cardDeck
- ^cardDeck!
Item was removed:
- ----- Method: FreeCellBoard>>cardMoved (in category 'actions') -----
- cardMoved
- "Free cells and stacks do nothing special here - yet - th 12/15/1999
- 16:15 "
- self autoMoveCardsHome!
Item was removed:
- ----- Method: FreeCellBoard>>cardMovedHome (in category 'actions') -----
- cardMovedHome
-
- self autoMoveCardsHome.
- self performActionSelector: #cardMovedHome.!
Item was removed:
- ----- Method: FreeCellBoard>>cellsRow (in category 'layout') -----
- cellsRow
- | row |
-
- row := (AlignmentMorph newRow)
- vResizing: #shrinkWrap;
- hResizing: #shrinkWrap;
- color: Color transparent;
- addAllMorphs: self freeCells;
- addMorphBack: self cellsRowSpacer;
- addAllMorphs: self homeCells;
- yourself.
- ^row!
Item was removed:
- ----- Method: FreeCellBoard>>cellsRowSpacer (in category 'layout') -----
- cellsRowSpacer
- | column |
-
- column := (AlignmentMorph newColumn)
- vResizing: #rigid;
- hResizing: #rigid;
- color: Color transparent;
- extent: PlayingCardMorph cardSize;
- yourself.
- ^column!
Item was removed:
- ----- Method: FreeCellBoard>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color green!
Item was removed:
- ----- Method: FreeCellBoard>>doubleClickInStack:OnCard: (in category 'actions') -----
- doubleClickInStack: aDeck OnCard: aCard
-
- "if there is an empty free cell, move the card there. otherwise try for an empty stack"
-
- aCard == aDeck topCard ifFalse: [^self].
- freeCells do: [:freeCell |
- freeCell ifEmpty: [
- self visiblyMove: aCard to: freeCell.
- ^ aCard
- ]
- ].
- stacks do: [ :each |
- each ifEmpty: [
- self visiblyMove: aCard to: each.
- ^ aCard
- ]
- ].
- !
Item was removed:
- ----- Method: FreeCellBoard>>dragCard:fromHome: (in category 'actions') -----
- dragCard: aCard fromHome: aCardDeck
-
- ^nil "don't allow any cards to be dragged from a home cell"!
Item was removed:
- ----- Method: FreeCellBoard>>dragCard:fromStack: (in category 'actions') -----
- dragCard: aCard fromStack: aCardDeck
- | i cards |
-
- cards := aCardDeck cards.
- i := cards indexOf: aCard ifAbsent: [^ nil].
- i > (self maxDraggableStackSize: false) ifTrue: [^ nil].
- [i > 1] whileTrue:
- [(aCardDeck inStackingOrder: (cards at: i-1)
- onTopOf: (cards at: i)) ifFalse: [^ nil].
- i := i-1].
- ^ aCard!
Item was removed:
- ----- Method: FreeCellBoard>>drawOn: (in category 'drawing') -----
- drawOn: aCanvas
-
- "we don't have anything to draw, but we need a color so the inset border of one of our submorphs will work"
- !
Item was removed:
- ----- Method: FreeCellBoard>>freeCell (in category 'layout') -----
- freeCell
- | freeCell |
- freeCell := self cardCell.
- freeCell stackingPolicy: #single;
- emptyDropPolicy: #any;
- target: self;
- cardDroppedSelector: #cardMoved;
- acceptCardSelector: #acceptSingleCard:on:.
- ^ freeCell!
Item was removed:
- ----- Method: FreeCellBoard>>freeCells (in category 'layout') -----
- freeCells
-
- ^freeCells ifNil: [freeCells := (1 to: 4) collect: [:i | self freeCell]]!
Item was removed:
- ----- Method: FreeCellBoard>>hardness (in category 'accessing') -----
- hardness
- ^ hardness!
Item was removed:
- ----- Method: FreeCellBoard>>hardness: (in category 'accessing') -----
- hardness: integer
- hardness := integer "or nil"!
Item was removed:
- ----- Method: FreeCellBoard>>homeCell (in category 'layout') -----
- homeCell
- | homeCell |
- homeCell := self cardCell.
- homeCell stackingPolicy: #straight;
- stackingOrder: #ascending;
- emptyDropPolicy: #inOrder;
- target: self;
- cardDroppedSelector: #cardMovedHome;
- cardDraggedSelector: #dragCard:fromHome:;
- acceptCardSelector: #acceptSingleCard:on:.
- ^ homeCell!
Item was removed:
- ----- Method: FreeCellBoard>>homeCells (in category 'layout') -----
- homeCells
-
- ^homeCells ifNil: [homeCells := (1 to: 4) collect: [:i | self homeCell]]!
Item was removed:
- ----- Method: FreeCellBoard>>inAutoMove (in category 'actions') -----
- inAutoMove
- "Return true if an automove sequence is in progress"
-
- ^ owner inAutoMove!
Item was removed:
- ----- Method: FreeCellBoard>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
- self listDirection: #topToBottom;
- hResizing: #shrinkWrap;
- vResizing: #rigid;
- height: 500 px;
- layout!
Item was removed:
- ----- Method: FreeCellBoard>>isPlayableCardInHomeCells: (in category 'private') -----
- isPlayableCardInHomeCells: aPlayingCard
- | unplayedOther topsThisColor topsOtherColor unplayedSame |
- " are all cards that could be played on this card if it stayed on the stack present in the
- home cells?"
-
- aPlayingCard cardNumber <= 2 ifTrue: [^true]. "special case for Aces and 2's"
- topsThisColor := OrderedCollection new.
- topsOtherColor := OrderedCollection new.
- self homeCells do: [ :deck |
- deck hasCards ifTrue: [
- (aPlayingCard suitColor == deck topCard suitColor
- ifTrue: [topsThisColor] ifFalse: [topsOtherColor]) add: deck topCard cardNumber.
- ]
- ].
- unplayedOther := topsOtherColor size < 2 ifTrue: [1] ifFalse: [topsOtherColor min + 1].
- unplayedSame := topsThisColor size < 2 ifTrue: [1] ifFalse: [topsThisColor min + 1].
- unplayedOther > (aPlayingCard cardNumber - 1) ifTrue: [^true].
- unplayedOther < (aPlayingCard cardNumber - 1) ifTrue: [^false].
- ^unplayedSame >= (unplayedOther - 1)
- !
Item was removed:
- ----- Method: FreeCellBoard>>layout (in category 'layout') -----
- layout
-
- self
- addMorphBack: self cellsRow;
- addMorphBack: self stacksRow.
- !
Item was removed:
- ----- Method: FreeCellBoard>>makeHarder:rand:toDo: (in category 'hardness') -----
- makeHarder: pile rand: rand toDo: cnt
- | deepColor ind thisPile thisCard otherCard |
- "Move cards in a stack to make it harder. Pick a card from the pile. Only consider moving it deeper (toward last of pile)."
-
- deepColor := stacks first cards last suitColor.
- ind := ((pile cards size - 1) atRandom: rand). "front card"
- thisPile := pile cards. "submorphs array. We will stomp it."
- thisCard := thisPile at: ind.
- otherCard := thisPile at: ind+1.
-
- "Move deepColor cards deeper, past cards of the other color"
- (thisCard suitColor == deepColor) & (otherCard suitColor ~~ deepColor) ifTrue: [
- thisPile at: ind put: otherCard.
- thisPile at: ind+1 put: thisCard.
- ^ 0]. "single moves for now. Make multiple when it's too slow this way"
-
- "When colors the same, move low numbered cards deeper, past high cards"
- (thisCard suitColor == otherCard suitColor) ifTrue: [
- (thisCard cardNumber < otherCard cardNumber) ifTrue: [
- thisPile at: ind put: otherCard.
- thisPile at: ind+1 put: thisCard.
- ^ 0]]. "single moves for now. Make multiple when it's too slow this way"
- ^ 0!
Item was removed:
- ----- Method: FreeCellBoard>>maxDraggableStackSize: (in category 'private') -----
- maxDraggableStackSize: dropIntoEmptyStack
- "Note: dropIntoEmptyStack, means one less empty stack to work with.
- This needs to be reevaluated at time of drop."
- "Not super smart - doesn't use stacks that are buildable though not empty"
-
- | nFree nEmptyStacks |
- nFree := (freeCells select: [:d | d hasCards not]) size.
- nEmptyStacks := (stacks select: [:d | d hasCards not]) size.
- dropIntoEmptyStack ifTrue: [nEmptyStacks := nEmptyStacks - 1].
- ^ (1 + nFree) * (2 raisedTo: nEmptyStacks)!
Item was removed:
- ----- Method: FreeCellBoard>>performActionSelector: (in category 'private') -----
- performActionSelector: actionSymbol
- (target notNil and: [actionSelector notNil])
- ifTrue: [target perform: actionSelector with: actionSymbol]!
Item was removed:
- ----- Method: FreeCellBoard>>pickGame: (in category 'initialization') -----
- pickGame: aSeedOrNil
- | sorted msg |
- cardDeck := PlayingCardDeck newDeck.
- aSeedOrNil == 1
- ifTrue: ["Special case of game 1 does a time profile playing the entire
- (trivial) game."
- sorted := cardDeck submorphs
- sorted: [:a :b | a cardNumber >= b cardNumber].
- cardDeck removeAllMorphs; addAllMorphs: sorted.
- self resetBoard.
- self world doOneCycle.
- Utilities
- informUser: 'Game #1 is a special case
- for performance analysis' translated
- during: [msg := self world firstSubmorph.
- msg align: msg topRight with: owner bottomRight.
- MessageTally
- spyOn: [sorted last owner doubleClickOnCard: sorted last]]]
- ifFalse: [aSeedOrNil
- ifNotNil: [cardDeck seed: aSeedOrNil].
- cardDeck shuffle.
- self resetBoard]!
Item was removed:
- ----- Method: FreeCellBoard>>rememberUndoableAction:named: (in category 'undo') -----
- rememberUndoableAction: aBlock named: caption
-
- self inAutoMove ifTrue: [^ aBlock value].
- ^ super rememberUndoableAction: aBlock named: caption!
Item was removed:
- ----- Method: FreeCellBoard>>resetBoard (in category 'initialization') -----
- resetBoard
-
- self purgeAllCommands.
- self resetFreeCells;
- resetHomeCells;
- resetStacks;
- addHardness;
- changed.!
Item was removed:
- ----- Method: FreeCellBoard>>resetFreeCells (in category 'initialization') -----
- resetFreeCells
-
- freeCells do: [:deck | deck removeAllCards]!
Item was removed:
- ----- Method: FreeCellBoard>>resetHomeCells (in category 'initialization') -----
- resetHomeCells
-
- homeCells do: [:deck | deck removeAllCards]!
Item was removed:
- ----- Method: FreeCellBoard>>resetStacks (in category 'initialization') -----
- resetStacks
- | card stackStream stack |
-
- stacks do: [:deck | deck removeAllCards].
- stackStream := ReadStream on: stacks.
- [card := cardDeck deal.
- card notNil] whileTrue: [
- stack := stackStream next ifNil: [stackStream reset; next].
- stack addCard: card].
- !
Item was removed:
- ----- Method: FreeCellBoard>>stack (in category 'card in a stack') -----
- stack
- ^ PlayingCardDeck new color: Color transparent;
- layout: #stagger;
- listDirection: #topToBottom;
- enableDragNDrop;
- stackingPolicy: #altStraight;
- stackingOrder: #descending;
- emptyDropPolicy: #any;
- target: self;
- cardDroppedSelector: #cardMoved;
- cardDraggedSelector: #dragCard:fromStack:;
- acceptCardSelector: #acceptCard:onStack:;
- cardDoubleClickSelector: #doubleClickInStack:OnCard:!
Item was removed:
- ----- Method: FreeCellBoard>>stacks (in category 'layout') -----
- stacks
-
- ^stacks ifNil: [stacks:= (1 to: 8) collect: [:i | self stack]]!
Item was removed:
- ----- Method: FreeCellBoard>>stacksRow (in category 'layout') -----
- stacksRow
- | row |
-
- row := (AlignmentMorph newRow)
- vResizing: #spaceFill;
- hResizing: #spaceFill;
- wrapCentering: #topLeft;
- cellPositioning: #topLeft;
- color: Color transparent;
- yourself.
- self stacks do: [:stack |
- row
- addMorphBack: AlignmentMorph newVariableTransparentSpacer;
- addMorphBack: stack].
- row addMorphBack: AlignmentMorph newVariableTransparentSpacer.
- ^row!
Item was removed:
- ----- Method: FreeCellBoard>>target: (in category 'accessing') -----
- target: anObject
-
- target := anObject!
Item was removed:
- ----- Method: FreeCellBoard>>undoFromCapturedState: (in category 'undo') -----
- undoFromCapturedState: st
- freeCells with: st first do: [:deck :morphs | deck removeAllMorphs; addAllMorphs: morphs].
- homeCells with: st second do: [:deck :morphs | deck removeAllMorphs; addAllMorphs: morphs].
- stacks with: st third do: [:deck :morphs | deck removeAllMorphs; addAllMorphs: morphs]!
Item was removed:
- ----- Method: FreeCellBoard>>visiblyMove:to: (in category 'private') -----
- visiblyMove: aCard to: aCell
- | p1 p2 nSteps |
- self inAutoMove ifFalse: [self captureStateBeforeGrab].
- owner owner addMorphFront: aCard.
- p1 := aCard position.
- p2 := aCell position.
- nSteps := 10.
- 1 to: nSteps-1 do: "Note final step happens with actual drop"
- [:i | aCard position: ((p2*i) + (p1*(nSteps-i))) // nSteps.
- self world displayWorld].
- aCell acceptDroppingMorph: aCard event: nil!
Item was removed:
- Object subclass: #FreeCellStatistics
- instanceVariableNames: 'sessionWins sessionLosses totalWins totalLosses streakWins streakLosses winsWithReplay lossesWithReplay lastGameWon lastGameLost currentCount currentType window statsMorph'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
Item was removed:
- ----- Method: FreeCellStatistics class>>includeInNewMorphMenu (in category 'instance creation') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: FreeCellStatistics>>buildButton:target:label:selector: (in category 'user interface') -----
- buildButton: aButton target: aTarget label: aLabel selector: aSelector
- "wrap a button or switch in an alignmentMorph to provide some space around the button"
-
- | a |
- aButton
- target: aTarget;
- label: aLabel;
- actionSelector: aSelector;
- borderStyle: (BorderStyle raised width: 2 px);
- color: Color gray.
- a := AlignmentMorph newColumn
- wrapCentering: #center; cellPositioning: #topCenter;
- hResizing: #spaceFill;
- vResizing: #shrinkWrap;
- color: Color transparent;
- layoutInset: 1 px.
- a addMorph: aButton.
- ^ a!
Item was removed:
- ----- Method: FreeCellStatistics>>changed (in category 'updating') -----
- changed
-
- window ifNotNil: [
- statsMorph ifNotNil: [statsMorph contents: self statsText]]!
Item was removed:
- ----- Method: FreeCellStatistics>>close (in category 'user interface') -----
- close
-
- window ifNotNil: [
- window delete.
- window := nil].!
Item was removed:
- ----- Method: FreeCellStatistics>>color (in category 'user interface') -----
- color
-
- ^Color green darker!
Item was removed:
- ----- Method: FreeCellStatistics>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color green!
Item was removed:
- ----- Method: FreeCellStatistics>>display (in category 'user interface') -----
- display
- | panel |
-
- (window notNil and: [window owner notNil]) ifTrue: [window activate. ^nil].
- panel := AlignmentMorph newColumn.
- panel
- wrapCentering: #center; cellPositioning: #topCenter;
- hResizing: #rigid;
- vResizing: #rigid;
- extent: 250 px @ 150 px;
- color: self color;
- addMorphBack: self makeStatistics;
- addMorphBack: self makeControls.
- window := panel openInWindowLabeled: 'FreeCell Statistics' translated.!
Item was removed:
- ----- Method: FreeCellStatistics>>gameLost: (in category 'actions') -----
- gameLost: gameNumber
-
- "Don't count multiple losses of the same game"
- gameNumber = lastGameLost ifTrue: [^ self].
- lastGameLost := gameNumber.
-
- sessionLosses := sessionLosses + 1.
- totalLosses := totalLosses + 1.
- lossesWithReplay := lossesWithReplay + 1.
- currentType = #losses
- ifTrue: [currentCount := currentCount + 1]
- ifFalse:
- [currentCount := 1.
- currentType := #losses].
- self updateStreak.
- self changed!
Item was removed:
- ----- Method: FreeCellStatistics>>gameWon: (in category 'actions') -----
- gameWon: gameNumber
- sessionWins := sessionWins + 1.
- totalWins := totalWins + 1.
- gameNumber = lastGameWon ifFalse:
- [gameNumber = lastGameLost ifTrue:
- ["Finally won a game by replaying"
- lossesWithReplay := lossesWithReplay - 1].
- winsWithReplay := winsWithReplay + 1].
- lastGameWon := gameNumber.
- currentType = #wins
- ifTrue: [currentCount := currentCount + 1]
- ifFalse: [currentCount := 1.
- currentType := #wins].
- self updateStreak.
- self changed!
Item was removed:
- ----- Method: FreeCellStatistics>>initialize (in category 'initialization') -----
- initialize
- super initialize.
- self reset!
Item was removed:
- ----- Method: FreeCellStatistics>>makeControls (in category 'user interface') -----
- makeControls
- | row |
-
- row := AlignmentMorph newRow.
- row
- wrapCentering: #center; cellPositioning: #leftCenter;
- hResizing: #spaceFill;
- vResizing: #shrinkWrap;
- color: self color;
- borderStyle: (BorderStyle inset width: 2 px);
- addMorphBack: self makeOkButton;
- addMorphBack: self makeResetButton.
- ^row.!
Item was removed:
- ----- Method: FreeCellStatistics>>makeOkButton (in category 'user interface') -----
- makeOkButton
-
- ^self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'OK' translated
- selector: #ok!
Item was removed:
- ----- Method: FreeCellStatistics>>makeResetButton (in category 'user interface') -----
- makeResetButton
-
- ^self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'Reset' translated
- selector: #reset!
Item was removed:
- ----- Method: FreeCellStatistics>>makeStatistics (in category 'user interface') -----
- makeStatistics
- | row |
-
- row := AlignmentMorph newRow.
- row
- wrapCentering: #center; cellPositioning: #leftCenter;
- hResizing: #spaceFill;
- vResizing: #spaceFill;
- color: self color;
- borderStyle: (BorderStyle inset width: 2 px);
- addMorphBack: (AlignmentMorph newColumn
- wrapCentering: #center; cellPositioning: #topCenter;
- color: self color;
- addMorph: (statsMorph := TextMorph new contents: self statsText)).
- ^row.!
Item was removed:
- ----- Method: FreeCellStatistics>>newSession (in category 'actions') -----
- newSession
-
- sessionWins := 0.
- sessionLosses := 0.
- currentCount := 0.
- currentType := nil.
- self changed.!
Item was removed:
- ----- Method: FreeCellStatistics>>ok (in category 'actions') -----
- ok
-
- window delete.
- window := nil.!
Item was removed:
- ----- Method: FreeCellStatistics>>print:type:on: (in category 'printing') -----
- print: aNumber type: type on: aStream
- "I moved the code from #printWins:on: and #printLosses:on: here because
- it is basically
- the same. I hope this increases the maintainability. - th 12/20/1999 20:37"
- aStream print: aNumber.
- type = #wins
- ifTrue: [aNumber = 1
- ifTrue: [aStream nextPutAll: ' win' translated]
- ifFalse: [aStream nextPutAll: ' wins' translated]].
- type = #losses
- ifTrue: [aNumber = 1
- ifTrue: [aStream nextPutAll: ' loss' translated]
- ifFalse: [aStream nextPutAll: ' losses' translated]]!
Item was removed:
- ----- Method: FreeCellStatistics>>printOn: (in category 'printing') -----
- printOn: aStream
-
- self printSessionOn: aStream.
- aStream cr.
- self printTotalOn: aStream.
- aStream cr.
- self printReplaysOn: aStream.
- aStream cr.
- self printStreaksOn: aStream.!
Item was removed:
- ----- Method: FreeCellStatistics>>printReplaysOn: (in category 'printing') -----
- printReplaysOn: aStream
- | total |
- aStream nextPutAll: 'With replays: ' translated;
- tab.
- self
- print: winsWithReplay
- type: #wins
- on: aStream.
- aStream nextPutAll: ', '.
- self
- print: lossesWithReplay
- type: #losses
- on: aStream.
- total := winsWithReplay + lossesWithReplay.
- total ~~ 0
- ifTrue: [aStream nextPutAll: ', ';
- print: (winsWithReplay / total * 100) asInteger;
- nextPut: $%]!
Item was removed:
- ----- Method: FreeCellStatistics>>printSessionOn: (in category 'printing') -----
- printSessionOn: aStream
- | total |
- aStream nextPutAll: 'This session: ' translated, String tab.
- self
- print: sessionWins
- type: #wins
- on: aStream.
- aStream nextPutAll: ', '.
- self
- print: sessionLosses
- type: #losses
- on: aStream.
- total := sessionWins + sessionLosses.
- total ~~ 0
- ifTrue: [aStream nextPutAll: ', ';
- print: (sessionWins / total * 100) asInteger;
- nextPut: $%]!
Item was removed:
- ----- Method: FreeCellStatistics>>printStreaksOn: (in category 'printing') -----
- printStreaksOn: aStream
- aStream nextPutAll: 'Streaks: ' translated;
- tab;
- tab.
- self
- print: streakWins
- type: #wins
- on: aStream.
- aStream nextPutAll: ', '.
- self
- print: streakLosses
- type: #losses
- on: aStream.
- aStream cr; tab; tab; tab; tab; nextPutAll: 'Current: ' translated.
- self
- print: currentCount
- type: currentType
- on: aStream!
Item was removed:
- ----- Method: FreeCellStatistics>>printTotalOn: (in category 'printing') -----
- printTotalOn: aStream
- | total |
- aStream nextPutAll: 'Total: ' translated;
- tab;
- tab;
- tab.
- self
- print: totalWins
- type: #wins
- on: aStream.
- aStream nextPutAll: ', '.
- self
- print: totalLosses
- type: #losses
- on: aStream.
- total := totalWins + totalLosses.
- total ~~ 0
- ifTrue: [aStream nextPutAll: ', ';
- print: (totalWins / total * 100) asInteger;
- nextPut: $%]!
Item was removed:
- ----- Method: FreeCellStatistics>>reset (in category 'actions') -----
- reset
-
- sessionWins := 0.
- sessionLosses := 0.
- totalWins := 0.
- totalLosses := 0.
- streakWins := 0.
- streakLosses := 0.
- winsWithReplay := 0.
- lossesWithReplay := 0.
- lastGameWon := 0.
- lastGameLost := 0.
- currentCount := 0.
- currentType := nil.
- self changed!
Item was removed:
- ----- Method: FreeCellStatistics>>statsText (in category 'user interface') -----
- statsText
-
- ^ String cr,self printString,String cr!
Item was removed:
- ----- Method: FreeCellStatistics>>stringMorphFromPrintOn: (in category 'user interface') -----
- stringMorphFromPrintOn: aSelector
-
- ^StringMorph new
- contents: (String streamContents: [:s | self perform: aSelector with: s]);
- yourself.!
Item was removed:
- ----- Method: FreeCellStatistics>>updateStreak (in category 'actions') -----
- updateStreak
- "I moved the code from #printWins:on: and #printLosses:on: here because
- it is basically the same. I hope this increases the maintainability.
- th 12/20/1999 20:41"
- currentType = #losses ifTrue: [streakLosses := streakLosses max: currentCount].
- currentType = #wins ifTrue: [streakWins := streakWins max: currentCount]!
Item was removed:
- RectangleMorph subclass: #HeadingMorph
- instanceVariableNames: 'degrees magnitude'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Demo'!
Item was removed:
- ----- Method: HeadingMorph>>defaultBorderWidth (in category 'initialization') -----
- defaultBorderWidth
- "answer the default border width for the receiver"
- ^ 1!
Item was removed:
- ----- Method: HeadingMorph>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color
- r: 0.6
- g: 1.0
- b: 1.0!
Item was removed:
- ----- Method: HeadingMorph>>degrees (in category 'accessing') -----
- degrees
-
- ^ (degrees + 90.0) \\ 360.0!
Item was removed:
- ----- Method: HeadingMorph>>degrees: (in category 'accessing') -----
- degrees: aNumber
-
- degrees := (aNumber asFloat + 270.0) \\ 360.0.!
Item was removed:
- ----- Method: HeadingMorph>>drawArrowFrom:to:width:color:on: (in category 'drawing') -----
- drawArrowFrom: p1 to: p2 width: w color: aColor on: aCanvas
-
- | d p |
- d := (p1 - p2) theta radiansToDegrees.
- aCanvas line: p1 to: p2 width: w color: aColor.
- p := p2 + (Point r: 5 degrees: d - 50).
- aCanvas line: p to: p2 width: w color: aColor.
- p := p2 + (Point r: 5 degrees: d + 50).
- aCanvas line: p to: p2 width: w color: aColor.
- !
Item was removed:
- ----- Method: HeadingMorph>>drawOn: (in category 'drawing') -----
- drawOn: aCanvas
-
- | x y r center box |
- super drawOn: aCanvas.
- box := self innerBounds.
- 1 to: 9 do: [:i |
- x := box left + ((box width * i) // 10).
- aCanvas line: (x@box top) to: (x@(box bottom - 1)) color:
- Color black.
- y := box top + ((box height * i) // 10).
- aCanvas line: (box left@y) to: ((box right - 1)@y) color:
- Color black].
-
- r := ((box width asFloat * magnitude asFloat) / 2.0) - 1.0.
- center := box center.
- self drawArrowFrom: center - (1@1)
- to: center + ((r * degrees degreesToRadians cos)@0) - (1@1)
- width: 3
- color: (Color red)
- on: aCanvas.
- self drawArrowFrom: center - (1@1)
- to: center + (0@(r * degrees degreesToRadians sin)) - (1@1)
- width: 3
- color: (Color red)
- on: aCanvas.
- self drawArrowFrom: center - (1@1)
- to: center + (Point r: r degrees: degrees) - (1@1)
- width: 3
- color: Color black
- on: aCanvas.
- !
Item was removed:
- ----- Method: HeadingMorph>>extent: (in category 'geometry') -----
- extent: aPoint
- "Contrain extent to be square."
-
- | d |
- d := aPoint x min: aPoint y.
- super extent: d@d.
- !
Item was removed:
- ----- Method: HeadingMorph>>handlesMouseDown: (in category 'event handling') -----
- handlesMouseDown: evt
-
- ^ true
- !
Item was removed:
- ----- Method: HeadingMorph>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
- degrees := 90.0.
- magnitude := 1.0.
-
- self extent: 160 @ 160!
Item was removed:
- ----- Method: HeadingMorph>>magnitude (in category 'accessing') -----
- magnitude
-
- ^ magnitude!
Item was removed:
- ----- Method: HeadingMorph>>magnitude: (in category 'accessing') -----
- magnitude: aNumber
-
- magnitude := (aNumber asFloat max: 0.0) min: 1.0.!
Item was removed:
- ----- Method: HeadingMorph>>mouseDown: (in category 'events') -----
- mouseDown: evt
-
- | v |
- self changed.
- v := evt cursorPoint - bounds center.
- degrees := v theta radiansToDegrees.
- magnitude := (v r asFloat / (bounds width asFloat / 2.0)) min: 1.0.
- !
Item was removed:
- ----- Method: HeadingMorph>>mouseMove: (in category 'events') -----
- mouseMove: evt
-
- self mouseDown: evt!
Item was removed:
- ImageMorph subclass: #ImageMorphWithSpotlight
- instanceVariableNames: 'spotImage spotShape spotBuffer spotOn'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Demo'!
-
- !ImageMorphWithSpotlight commentStamp: '<historical>' prior: 0!
- This class implements an image that appears one way or another depending upon whether it lies within a spotlight shape that moves with the cursor. As delivered, the shape is a simple circle, the spotlighted appearance is that of a ColorForm, and the non-highlighted apperarance is a derived gray-scale form.
-
- The implementation will space-efficient if supplied with a ColorForm, because the gray-scale derived form will share the same bitmap.
-
- In general, any two images can be used -- one could be blurred, the other sharp -- and the masking form can be any shape.
-
- At some point this class should be merged somehow with ScreeningMorph.!
Item was removed:
- ----- Method: ImageMorphWithSpotlight>>backgroundImage:spotImage:spotShape: (in category 'all') -----
- backgroundImage: bkgndImage spotImage: anImage spotShape: formOfDepth1
-
- "See class comment."
- spotImage := anImage.
- spotShape := formOfDepth1.
- spotBuffer := Form extent: spotShape extent depth: spotImage depth.
- super image: bkgndImage.
- spotOn := false.!
Item was removed:
- ----- Method: ImageMorphWithSpotlight>>drawOn: (in category 'drawing') -----
- drawOn: aCanvas
-
- super drawOn: aCanvas.
- spotOn ifTrue:
- [aCanvas paintImage: spotBuffer at: spotBuffer offset].
- !
Item was removed:
- ----- Method: ImageMorphWithSpotlight>>image: (in category 'accessing') -----
- image: anImage
-
- "The spotlight will reveal the original form supplied
- while the background form will be derived grayscale."
- "See class comment."
- self backgroundImage: anImage asGrayScale
- spotImage: anImage
- spotShape: (Form dotOfSize: 100)
- !
Item was removed:
- ----- Method: ImageMorphWithSpotlight>>spotChanged (in category 'all') -----
- spotChanged
-
- self invalidRect:
- ((spotBuffer offset extent: spotBuffer extent) "intersect: self bounds")!
Item was removed:
- ----- Method: ImageMorphWithSpotlight>>step (in category 'stepping') -----
- step
- | cp |
- ((self bounds expandBy: spotBuffer extent // 2) containsPoint: (cp := self cursorPoint))
- ifTrue:
- [(cp - (spotBuffer extent // 2)) = spotBuffer offset ifTrue: [^ self]. "No change"
- "Cursor has moved where its spotShape is visible"
- spotOn := true.
- self spotChanged.
- spotBuffer offset: cp - (spotBuffer extent // 2).
- self spotChanged.
- (BitBlt current toForm: spotBuffer)
- "clear the buffer"
- fill: spotBuffer boundingBox fillColor: (Bitmap with: 0) rule: Form over;
- "Clip anything outside the base form"
- clipRect: (spotBuffer boundingBox
- intersect: (self bounds translateBy: spotBuffer offset negated));
- "Fill the spotBuffer with the spot image"
- copyForm: spotImage to: self position - spotBuffer offset rule: Form over;
- "Mask everything outside the spot shape to 0 (transparent)."
- copyForm: spotShape to: spotShape offset negated rule: Form and
- colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)]
- ifFalse:
- [spotOn ifTrue: [self spotChanged. spotOn := false]]!
Item was removed:
- ----- Method: ImageMorphWithSpotlight>>stepTime (in category 'testing') -----
- stepTime
-
- ^ 20!
Item was removed:
- StringMorph subclass: #InfoStringMorph
- instanceVariableNames: 'stepTime block'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Demo'!
-
- !InfoStringMorph commentStamp: '<historical>' prior: 0!
- A generalization of the clock morph
-
- Try
- InfoStringMorph new openInWorld
- or
- (InfoStringMorph on: [Smalltalk vmParameterAt: 9])
- stepTime: 50;
- openInWorld!
Item was removed:
- ----- Method: InfoStringMorph class>>on: (in category 'instance creation') -----
- on: aBlock
- ^ self new block: aBlock!
Item was removed:
- ----- Method: InfoStringMorph>>block (in category 'accessing') -----
- block
- ^ block!
Item was removed:
- ----- Method: InfoStringMorph>>block: (in category 'accessing') -----
- block: aBlock
- block := aBlock!
Item was removed:
- ----- Method: InfoStringMorph>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
- stepTime := 1000.
- block := [Time now]!
Item was removed:
- ----- Method: InfoStringMorph>>step (in category 'stepping') -----
- step
- self contents: block value asString!
Item was removed:
- ----- Method: InfoStringMorph>>stepTime (in category 'testing') -----
- stepTime
- ^ stepTime!
Item was removed:
- ----- Method: InfoStringMorph>>stepTime: (in category 'accessing') -----
- stepTime: anInteger
- stepTime := anInteger!
Item was removed:
- AlignmentMorph subclass: #Mines
- instanceVariableNames: 'board minesDisplay timeDisplay helpText level levelButton hiScoreDisplay'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
Item was removed:
- ----- Method: Mines class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'Mines' translatedNoop
- categories: {'Games' translatedNoop}
- documentation: 'Find those mines' translatedNoop!
Item was removed:
- ----- Method: Mines>>board (in category 'access') -----
- board
-
- board ifNil:
- [board := MinesBoard new
- target: self;
- actionSelector: #selection].
- ^ board!
Item was removed:
- ----- Method: Mines>>buildButton:target:label:selector: (in category 'initialize') -----
- buildButton: aButton target: aTarget label: aLabel selector: aSelector
- "wrap a button or switch in an alignmentMorph to allow a row of buttons to fill space"
-
- | a |
- aButton
- target: aTarget;
- label: aLabel;
- actionSelector: aSelector;
- borderStyle: (BorderStyle raised width: 2);
- color: color.
- a := AlignmentMorph newColumn
- wrapCentering: #center; cellPositioning: #topCenter;
- hResizing: #spaceFill;
- vResizing: #shrinkWrap;
- color: color.
- a addMorph: aButton.
- ^ a
-
- !
Item was removed:
- ----- Method: Mines>>defaultBorderColor (in category 'initialization') -----
- defaultBorderColor
- ^ Color transparent!
Item was removed:
- ----- Method: Mines>>defaultBorderStyle (in category 'initialization') -----
- defaultBorderStyle
- ^ BorderStyle raised!
Item was removed:
- ----- Method: Mines>>defaultBorderWidth (in category 'initialization') -----
- defaultBorderWidth
- "answer the default border width for the receiver"
- ^ 2 px!
Item was removed:
- ----- Method: Mines>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color lightGray!
Item was removed:
- ----- Method: Mines>>help: (in category 'actions') -----
- help: helpState
-
- helpState
- ifTrue: [self addMorphBack: self helpText]
- ifFalse: [helpText delete]!
Item was removed:
- ----- Method: Mines>>helpString (in category 'access') -----
- helpString
- ^ 'Mines is a quick and dirty knock-off of the Minesweeper game found on Windows. I used this to teach myself Squeak. I liberally borrowed from the <SameGame> example, so the code should look pretty familiar, though like any project it has rapidly ...morphed... to reflect my own idiosyncracies. Note especially the lack of any idiomatic structure to the code - I simply haven''t learned them yet.
-
- Mines is a very simple, yet extremely frustrating, game to play. The rules are just this: there are 99 mines laid down on the board. Find them without ""finding"" them. Your first tile is free - click anywhere. The tiles will tell you how many mines are right next to it, including the diagonals. If you uncover the number ''2'', you know that there are two mines hidden in the adjacent tiles. If you think you have found a mine, you can flag it by either ''shift'' clicking, or click with the ''yellow'' mouse button. Once you have flagged all of the mines adjacent to a numbered tile, you can click on the tile again to uncover the rest. Of course, you could be wrong about those too...
-
- You win once you have uncovered all of the tiles that do not contain mines. Good luck...
-
- David A. Smith
- dastrs(a)bellsouth.net' translated!
Item was removed:
- ----- Method: Mines>>helpText (in category 'access') -----
- helpText
-
- helpText ifNil:
- [helpText := PluggableTextMorph new
- width: self width; "board width;"
- editString: self helpString].
- ^ helpText!
Item was removed:
- ----- Method: Mines>>hiScoreDisplay (in category 'access') -----
- hiScoreDisplay
-
- ^ hiScoreDisplay!
Item was removed:
- ----- Method: Mines>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
-
- super initialize.
-
- level := 1.
- self listDirection: #topToBottom;
- wrapCentering: #center;
- cellPositioning: #topCenter;
- vResizing: #shrinkWrap;
- hResizing: #shrinkWrap;
- layoutInset: 3 px;
- addMorph: self makeControls;
- addMorph: self board.
- helpText := nil.
-
- self newGame!
Item was removed:
- ----- Method: Mines>>level (in category 'access') -----
- level
- ^level!
Item was removed:
- ----- Method: Mines>>makeControls (in category 'initialize') -----
- makeControls
- | row |
- row := AlignmentMorph newRow color: color;
- borderWidth: 2 px;
- layoutInset: 3 px.
- row borderStyle: BorderStyle inset.
- row hResizing: #spaceFill;
- vResizing: #shrinkWrap;
- wrapCentering: #center;
- cellPositioning: #leftCenter;
- extent: 5 px @ 5 px.
- row
- addMorph: (self
- buildButton: SimpleSwitchMorph new
- target: self
- label: ' Help ' translated
- selector: #help:).
- row
- addMorph: (self
- buildButton: (levelButton := SimpleButtonMorph new)
- target: self
- label: level asString translated
- selector: #nextLevel).
- row
- addMorph: (self
- buildButton: SimpleButtonMorph new
- target: self
- label: ' Quit ' translated
- selector: #delete).
- "row
- addMorph: (self
- buildButton: SimpleButtonMorph new
- target: self
- label: ' Hint ' translated
- selector: #hint)."
- row
- addMorph: (self
- buildButton: SimpleButtonMorph new
- target: self
- label: ' New game ' translated
- selector: #newGame).
- minesDisplay := LedMorph new digits: 2;
- extent: 2 * 10 px @ 15 px.
- row
- addMorph: (self wrapPanel: minesDisplay label: 'Mines:' translated).
- timeDisplay := LedTimerMorph new digits: 3; extent: 3 * 10 px @ 15 px.
-
- row
- addMorph: (self wrapPanel: timeDisplay label: 'Time:' translated).
- hiScoreDisplay := LedMorph new digits: 3; extent: 3 * 10 px@ 15 px.
- row
- addMorph: (self wrapPanel: hiScoreDisplay label: 'Hi Score:' translated).
- ^ row!
Item was removed:
- ----- Method: Mines>>minesDisplay (in category 'access') -----
- minesDisplay
-
- ^ minesDisplay!
Item was removed:
- ----- Method: Mines>>newGame (in category 'actions') -----
- newGame
- | boardSize |
- boardSize := MinesBoard boardSizeAt: level.
- timeDisplay value: 0; flash: false.
- timeDisplay stop.
- timeDisplay reset.
- minesDisplay value: (boardSize at: 3).
- hiScoreDisplay value: (boardSize at: 4).
- levelButton label: (boardSize at: 5) asString.
- self board resetBoard: level.!
Item was removed:
- ----- Method: Mines>>nextLevel (in category 'actions') -----
- nextLevel
- level := level + 1.
- level = 4 ifTrue:[level := 1].
- self newGame
-
- !
Item was removed:
- ----- Method: Mines>>timeDisplay (in category 'access') -----
- timeDisplay
-
- ^ timeDisplay!
Item was removed:
- ----- Method: Mines>>wrapPanel:label: (in category 'initialize') -----
- wrapPanel: anLedPanel label: aLabel
- "wrap an LED panel in an alignmentMorph with a label to its left"
-
- | a |
- a := AlignmentMorph newRow
- wrapCentering: #center; cellPositioning: #leftCenter;
- hResizing: #shrinkWrap;
- vResizing: #shrinkWrap;
- borderWidth: 0;
- layoutInset: 3 px;
- color: color lighter.
- a addMorph: anLedPanel.
- a addMorph: (StringMorph contents: aLabel).
- ^ a
- !
Item was removed:
- AlignmentMorph subclass: #MinesBoard
- instanceVariableNames: 'protoTile rows columns flashCount tileCount target actionSelector arguments gameStart gameOver boardSize'
- classVariableNames: 'BoardSizes'
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
Item was removed:
- ----- Method: MinesBoard class>>boardSizeAt: (in category 'accessing') -----
- boardSizeAt: level
- ^BoardSizes at: level!
Item was removed:
- ----- Method: MinesBoard class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: MinesBoard class>>initialize (in category 'class initialization') -----
- initialize
- "boardSizes are column, row, mines, highScore"
- BoardSizes := Dictionary new.
- BoardSizes at: 1 put:{8. 8. 10. 999. 'Beginner'}.
- BoardSizes at: 2 put:{16. 16. 40. 999. 'Intermediate'}.
- BoardSizes at: 3 put:{30. 16. 99. 999. 'Expert'}!
Item was removed:
- ----- Method: MinesBoard>>actionSelector (in category 'accessing') -----
- actionSelector
-
- ^ actionSelector!
Item was removed:
- ----- Method: MinesBoard>>actionSelector: (in category 'accessing') -----
- actionSelector: aSymbolOrString
-
- (nil = aSymbolOrString or:
- ['nil' = aSymbolOrString or:
- [aSymbolOrString isEmpty]])
- ifTrue: [^ actionSelector := nil].
-
- actionSelector := aSymbolOrString asSymbol.
- !
Item was removed:
- ----- Method: MinesBoard>>adjustTiles (in category 'accessing') -----
- adjustTiles
- "reset tiles"
-
- | newSubmorphs count r c |
-
- submorphs do: "clear out all of the tiles."
- [:m | m privateOwner: nil].
-
- newSubmorphs := OrderedCollection new.
-
- r := 0.
- c := 0.
- count := columns * rows.
-
- 1 to: count do:
- [:m |
- newSubmorphs add:
- (protoTile copy
- position: self position + (self protoTile extent * (c @ r));
- actionSelector: #tileClickedAt:newSelection:modifier:;
- arguments: (Array with: (c+1) @ (r+1));
- target: self;
- privateOwner: self).
- c := c + 1.
- c >= columns ifTrue: [c := 0. r := r + 1]].
- submorphs := newSubmorphs asArray.
-
- !
Item was removed:
- ----- Method: MinesBoard>>blowUp (in category 'actions') -----
- blowUp
- owner timeDisplay stop.
- self submorphsDo:
- [:m |
- m isMine ifTrue:
- [m switchState: true.].
- ].
- flashCount := 2.
- gameOver := true.!
Item was removed:
- ----- Method: MinesBoard>>clearMines: (in category 'actions') -----
- clearMines: location
-
- | al tile |
-
- (self countFlags: location) = (self findMines: location) ifTrue:
- [
- {-1@ -1. -1@0. -1@1. 0@1. 1@1. 1@0. 1@ -1. 0@ -1} do:
- [:offsetPoint |
- al := location + offsetPoint.
- ((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue: [
- tile := self tileAt: al.
- (tile mineFlag or: [tile switchState]) ifFalse:[
- self stepOnTile: al].].].
- ].!
Item was removed:
- ----- Method: MinesBoard>>countFlags: (in category 'actions') -----
- countFlags: location
-
- | al at flags |
- flags := 0.
- {-1@ -1. -1@0. -1@1. 0@1. 1@1. 1@0. 1@ -1. 0@ -1} do:
- [:offsetPoint |
- al := location + offsetPoint.
- ((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue:
- [at := self tileAt: al.
- (at mineFlag ) ifTrue:
- [flags := flags+1]]].
- ^flags.!
Item was removed:
- ----- Method: MinesBoard>>defaultBorderColor (in category 'initialization') -----
- defaultBorderColor
- ^ Color transparent!
Item was removed:
- ----- Method: MinesBoard>>defaultBorderStyle (in category 'initialization') -----
- defaultBorderStyle
- ^ BorderStyle inset!
Item was removed:
- ----- Method: MinesBoard>>defaultBorderWidth (in category 'initialization') -----
- defaultBorderWidth
- "answer the default border width for the receiver"
- ^ 2 px!
Item was removed:
- ----- Method: MinesBoard>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color lightGray!
Item was removed:
- ----- Method: MinesBoard>>extent: (in category 'geometry') -----
- extent: aPoint
- "constrain the extent to be a multiple of the protoTile size during resizing"
- super extent: (aPoint truncateTo: protoTile extent).!
Item was removed:
- ----- Method: MinesBoard>>findMines: (in category 'actions') -----
- findMines: location
-
- | al at mines |
- mines := 0.
- {-1@ -1. -1@0. -1@1. 0@1. 1@1. 1@0. 1@ -1. 0@ -1} do:
- [:offsetPoint |
- al := location + offsetPoint.
- ((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue:
- [at := self tileAt: al.
- (at isMine ) ifTrue:
- [mines := mines+1]]].
- ^mines.!
Item was removed:
- ----- Method: MinesBoard>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
- target := nil.
- actionSelector := #selection.
- arguments := #().
- ""
- self layoutPolicy: nil;
- hResizing: #rigid;
- vResizing: #rigid.
- ""
- boardSize := BoardSizes at: 1.
-
- columns := self preferredColumns.
- rows := self preferredRows.
- flashCount := 0.
- ""
- self extent: self protoTile extent * (columns @ rows).
- self adjustTiles.
- self resetBoard: 1.!
Item was removed:
- ----- Method: MinesBoard>>preferredColumns (in category 'preferences') -----
- preferredColumns
-
- ^ boardSize at: 1!
Item was removed:
- ----- Method: MinesBoard>>preferredMines (in category 'preferences') -----
- preferredMines
-
- ^boardSize at:3!
Item was removed:
- ----- Method: MinesBoard>>preferredRows (in category 'preferences') -----
- preferredRows
-
- ^ boardSize at:2!
Item was removed:
- ----- Method: MinesBoard>>protoTile (in category 'accessing') -----
- protoTile
-
- protoTile ifNil: [protoTile := MinesTile new].
- ^ protoTile!
Item was removed:
- ----- Method: MinesBoard>>protoTile: (in category 'accessing') -----
- protoTile: aTile
-
- protoTile := aTile!
Item was removed:
- ----- Method: MinesBoard>>resetBoard: (in category 'initialization') -----
- resetBoard: aLevel
-
- boardSize := BoardSizes at: aLevel.
- columns := self preferredColumns.
- rows := self preferredRows.
- flashCount := 0.
- ""
- self extent: self protoTile extent * (columns @ rows).
- self adjustTiles.
-
- gameStart := false.
- gameOver := false.
-
- flashCount := 0.
- tileCount := 0.
- Collection initialize. "randomize the Collection class"
- self purgeAllCommands.
- self submorphsDo: "set tiles to original state."
- [:m | m privateOwner: nil. "Don't propagate all these changes..."
- m mineFlag: false.
- m disabled: false.
- m switchState: false.
- m isMine: false.
- m privateOwner: self].
- self changed "Now note the change in bulk"!
Item was removed:
- ----- Method: MinesBoard>>selectTilesAdjacentTo: (in category 'actions') -----
- selectTilesAdjacentTo: location
-
- | al at mines |
- " {-1@0. 0@ -1. 1@0. 0@1} do:"
- {-1@ -1. -1@0. -1@1. 0@1. 1@1. 1@0. 1@ -1. 0@ -1} do:
- [:offsetPoint |
- al := location + offsetPoint.
- ((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue:
- [at := self tileAt: al.
- (at switchState not and: [at disabled not]) ifTrue:
- [
- mines := (self tileAt: al) nearMines.
- at mineFlag ifTrue: [at mineFlag: false.]. "just in case we flagged it as a mine."
- at switchState: true.
- tileCount := tileCount + 1.
- mines=0 ifTrue: [self selectTilesAdjacentTo: al]]]]
- !
Item was removed:
- ----- Method: MinesBoard>>setMines: (in category 'initialization') -----
- setMines: notHere
-
- | count total c r sm |
- count := 0.
- total := self preferredMines.
- [count < total] whileTrue:[
- c := columns atRandom.
- r := rows atRandom.
- c@r = notHere ifFalse: [
- sm := self tileAt: c@r.
- sm isMine ifFalse: [
- "sm color: Color red lighter lighter lighter lighter."
- sm isMine: true.
- count := count + 1.]]
- ].
- 1 to: columns do: [ :col |
- 1 to: rows do: [ :row |
- (self tileAt: col @ row) nearMines: (self findMines: (col @ row))
- ]].
- !
Item was removed:
- ----- Method: MinesBoard>>step (in category 'stepping') -----
- step
-
- flashCount = 0 ifFalse: [
- self submorphsDo:
- [:m |
- m color: m color negated.].
- flashCount := flashCount - 1.
- ].
- !
Item was removed:
- ----- Method: MinesBoard>>stepOnTile: (in category 'actions') -----
- stepOnTile: location
-
- | mines tile score |
- tile := self tileAt: location.
- tile mineFlag ifFalse:[
- tile isMine ifTrue: [tile color: Color gray darker darker. self blowUp. ^false.]
- ifFalse:[
- mines := self findMines: location.
- tile switchState: true.
- tileCount := tileCount + 1.
- mines = 0 ifTrue:
- [self selectTilesAdjacentTo: location]].
- tileCount = ((columns*rows) - self preferredMines) ifTrue:[ gameOver := true. flashCount := 2. owner timeDisplay stop.
- score := owner timeDisplay value.
- ( score < (boardSize at:4))
- ifTrue:[(BoardSizes at: owner level ) at: 4 put: score.
- owner hiScoreDisplay value: score]].
- ^ true.]
- ifTrue: [^ false.]
-
- !
Item was removed:
- ----- Method: MinesBoard>>stepTime (in category 'testing') -----
- stepTime
-
- ^ 300!
Item was removed:
- ----- Method: MinesBoard>>target (in category 'accessing') -----
- target
-
- ^ target!
Item was removed:
- ----- Method: MinesBoard>>target: (in category 'accessing') -----
- target: anObject
-
- target := anObject!
Item was removed:
- ----- Method: MinesBoard>>tileAt: (in category 'accessing') -----
- tileAt: aPoint
-
- ^ submorphs at: (aPoint x + ((aPoint y - 1) * columns))!
Item was removed:
- ----- Method: MinesBoard>>tileClickedAt:newSelection:modifier: (in category 'actions') -----
- tileClickedAt: location newSelection: isNewSelection modifier: mod
- | tile |
- "self halt."
- gameOver ifTrue: [^ false].
- tile := self tileAt: location.
-
- isNewSelection ifFalse: [
- mod ifTrue: [
- tile mineFlag: ((tile mineFlag) not).
- tile mineFlag ifTrue: [owner minesDisplay value: (owner minesDisplay value - 1)]
- ifFalse: [owner minesDisplay value: (owner minesDisplay value + 1)].
- ^ true.].
-
- gameStart ifFalse: [
- self setMines: location.
- gameStart := true.
- owner timeDisplay start.].
- ^ self stepOnTile: location.
- ]
- ifTrue:[ self clearMines: location.].!
Item was removed:
- SimpleSwitchMorph subclass: #MinesTile
- instanceVariableNames: 'switchState disabled oldSwitchState isMine nearMines palette mineFlag'
- classVariableNames: 'PreferredColor'
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
Item was removed:
- ----- Method: MinesTile class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: MinesTile>>color: (in category 'accessing') -----
- color: aColor
- super color: aColor.
- onColor := aColor.
- offColor := aColor.
- self changed!
Item was removed:
- ----- Method: MinesTile>>disabled (in category 'accessing') -----
- disabled
-
- ^ disabled
- !
Item was removed:
- ----- Method: MinesTile>>disabled: (in category 'accessing') -----
- disabled: aBoolean
-
- disabled := aBoolean.
- disabled
- ifTrue:
- [self color: owner color.
- self borderColor: owner color]
- ifFalse:
- [self setSwitchState: self switchState]!
Item was removed:
- ----- Method: MinesTile>>doButtonAction: (in category 'accessing') -----
- doButtonAction: modifier
- "Perform the action of this button. The first argument of the message sent to the target is the current state of this switch,
- the second argument is the modifier button state."
-
- (target notNil and: [actionSelector notNil])
- ifTrue:
- [^target perform: actionSelector
- withArguments: ((arguments copyWith: switchState) copyWith: modifier)]!
Item was removed:
- ----- Method: MinesTile>>drawOn: (in category 'drawing') -----
- drawOn: aCanvas
- "Draw a rectangle with a solid, inset, or raised border.
- Note: the raised border color *and* the inset border color are generated
- from the receiver's own color, instead of having the inset border color
- generated from the owner's color, as in BorderedMorph."
-
- | font rct |
- super drawOn: aCanvas.
-
- self borderStyle style == #inset ifTrue: [
- self isMine ifTrue: [
- font := StrikeFont familyName: 'Atlanta' size: 22 px emphasized: 1.
- rct := self bounds insetBy: ((self bounds width) - (font widthOfString: '*'))/2 @0.
- rct := rct top: rct top + 1.
- aCanvas drawString: '*' in: (rct translateBy: 1@1) font: font color: Color black.
- ^ aCanvas drawString: '*' in: rct font: font color: Color red .].
- self nearMines > 0 ifTrue: [
- font := StrikeFont familyName: 'ComicBold' size: 22 px emphasized: 1.
- rct := self bounds insetBy: ((self bounds width) - (font widthOfString: nearMines asString))/2 @0.
- rct := rct top: rct top + 1.
- aCanvas drawString: nearMines asString in: (rct translateBy: 1@1) font: font color: Color black.
- ^ aCanvas drawString: nearMines asString in: rct font: font color: ((palette at: nearMines) ) .]].!
Item was removed:
- ----- Method: MinesTile>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
- self label: ''.
- self borderWidth: 3 px.
- bounds := 0@0 corner: 20 px@20 px.
- offColor := self preferredColor.
- onColor := self preferredColor.
- switchState := false.
- oldSwitchState := false.
- disabled := false.
- isMine := false.
- nearMines := 0.
- self useSquareCorners.
- palette := (Color wheel: 8) asOrderedCollection reverse.
- " flashColor := palette removeLast."
- !
Item was removed:
- ----- Method: MinesTile>>isMine (in category 'accessing') -----
- isMine
-
- ^ isMine!
Item was removed:
- ----- Method: MinesTile>>isMine: (in category 'accessing') -----
- isMine: aBoolean
-
- isMine := aBoolean.
- !
Item was removed:
- ----- Method: MinesTile>>mineFlag (in category 'accessing') -----
- mineFlag
-
- ^ mineFlag.
- !
Item was removed:
- ----- Method: MinesTile>>mineFlag: (in category 'accessing') -----
- mineFlag: boolean
-
- mineFlag := boolean.
- mineFlag ifTrue: [
- self color: Color red lighter lighter lighter lighter.]
- ifFalse: [
- self color: self preferredColor.].
- ^ mineFlag.
- !
Item was removed:
- ----- Method: MinesTile>>mouseDown: (in category 'event handling') -----
- mouseDown: evt
- "The only real alternative mouse clicks are the yellow button or the shift key. I will treat them as the same thing, and ignore two button presses for now. I am keeping this code around, because it is the only documentation I have of MouseButtonEvent."
- | mod |
- " Transcript show: 'anyModifierKeyPressed - '; show: evt anyModifierKeyPressed printString ; cr;
- show: 'commandKeyPressed - '; show: evt commandKeyPressed printString ; cr;
- show: 'controlKeyPressed - '; show:evt controlKeyPressed printString ; cr;
- show: 'shiftPressed - '; show: evt shiftPressed printString ; cr;
- show: 'buttons - '; show: evt buttons printString ; cr;
- show: 'handler - '; show: evt handler printString ; cr;
- show: 'position - '; show: evt position printString ; cr;
- show: 'type - '; show: evt type printString ; cr;
- show: 'anyButtonPressed - '; show: evt anyButtonPressed printString ; cr;
- show: 'blueButtonPressed - '; show: evt blueButtonPressed printString ; cr;
- show: 'redButtonPressed - '; show: evt redButtonPressed printString ; cr;
- show: 'yellowButtonPressed - '; show: evt yellowButtonPressed printString ; cr; cr; cr."
-
-
- mod := (evt yellowButtonPressed) | (evt shiftPressed).
- switchState ifFalse:[
- (self doButtonAction: mod) ifTrue:
- [mod ifFalse: [ self setSwitchState: true. ].].
- ] ifTrue: [
- self doButtonAction: mod.].!
Item was removed:
- ----- Method: MinesTile>>mouseMove: (in category 'event handling') -----
- mouseMove: evt
-
- "don't do anything, here"!
Item was removed:
- ----- Method: MinesTile>>mouseUp: (in category 'event handling') -----
- mouseUp: evt
-
- "don't do anything, here"!
Item was removed:
- ----- Method: MinesTile>>nearMines (in category 'accessing') -----
- nearMines
-
- ^ nearMines.
- !
Item was removed:
- ----- Method: MinesTile>>nearMines: (in category 'accessing') -----
- nearMines: nMines
-
- nearMines := nMines.
- !
Item was removed:
- ----- Method: MinesTile>>preferredColor (in category 'initialization') -----
- preferredColor
- "PreferredColor := nil <-- to reset cache"
- PreferredColor ifNil:
- ["This actually takes a while to compute..."
- PreferredColor := Color gray lighter lighter lighter].
- ^ PreferredColor!
Item was removed:
- ----- Method: MinesTile>>switchState (in category 'accessing') -----
- switchState
-
- ^ switchState!
Item was removed:
- ----- Method: MinesTile>>switchState: (in category 'accessing') -----
- switchState: aBoolean
-
- switchState := aBoolean.
- disabled ifFalse:
- [switchState
- ifTrue:[
- "flag ifTrue: [self setFlag]." "if this is a flagged tile, unflag it."
- self borderStyle: (BorderStyle inset width: 1).
- self color: onColor]
- ifFalse:[
- self borderStyle: (BorderStyle raised width: 3).
- self color: offColor]]!
Item was removed:
- RectangleMorph subclass: #MorphExample
- instanceVariableNames: 'phase ball star'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Demo'!
-
- !MorphExample commentStamp: 'kfr 10/26/2003 18:38' prior: 0!
- This is a example of how to use a morph. It consists of only two
- methods, initialize and step.
-
- DoIt:
- MorphExample new openInWorld.
-
-
-
- !
Item was removed:
- ----- Method: MorphExample>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- phase := 1.
- self extent: 200 @ 200.
- ball := EllipseMorph new extent: 30 @ 30.
- self
- addMorph: ((star := StarMorph new extent: 150 @ 150) center: self center)!
Item was removed:
- ----- Method: MorphExample>>step (in category 'stepping') -----
- step
- phase := phase\\8 + 1.
- phase = 1 ifTrue: [^ ball delete].
- phase < 4 ifTrue:[^self].
- phase = 4 ifTrue: [self addMorph: ball].
- ball align: ball center with: (star vertices at: (phase-3*2)).!
Item was removed:
- Object subclass: #PlayingCard
- instanceVariableNames: 'cardNo suit suitNo cardForm'
- classVariableNames: 'ASpadesLoc CachedBlank CachedDepth CardSize FaceForms FaceLoc FaceSuitLoc MidSpotLocs NumberForms NumberLoc SuitForms SuitLoc TopSpotLocs'
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !PlayingCard commentStamp: '<historical>' prior: 0!
- This class assembles card images from their parts. The images are broken down so that the image data is very compact, and the code is written to display properly at all color depths. The method imageData may be removed after initialization to save space, but must be re-built prior to fileOut if you wish to retain the images.
-
- To use in morphic, one can simply put these forms into ImageMorphs (see example in buildImage). However it should be possible to define a subclass of ImageMorph that simply creates playingCard instances on the fly whenever the image form is needed. This would avoid storing all the images.!
Item was removed:
- ----- Method: PlayingCard class>>imageData (in category 'all') -----
- imageData ^ 'AgQALwAlAAAAAIDjaN4VEeFDEREREBIiIiIiIiIiIYiBiIGIgYiIiIgSIiIiEBIiIiIREiIiIhgRGBEYERiBiIEiIiIiEBIiIiERESIiIiFEREREREQRGBIiIiIiEBIiIhERERIiIiIRERERERFEQSIiIiISEBIiIhERERIiIiIRERERERERESIiIiEREBIiIhERERIiIiESIiIiISERESIiIhIUEBIiIiERESIiIhISIiIiISEhESIiIhIUEBIiERIREhESIhIRESERESEhISIiIhIUEBIhERERERERIhEREhESESEhISIiIhIUEBIREREREREREhISIhIiISEhISIiIhIUEBIREREREREREhISIhIiISEhISIiIhIUEBIREREREREREhISIhIiISEhISIiIhIUEBIhEREhIRERIhISIREiISEhISIiIhIUEBIiERIKISIREuIfIhEhISEhESIiEhQQEiIiIhESIiIhERIhESIhISEhIhIiEhQQEiIiIRERIiIiEhIiIiIhISISEhEiEhQQEiIiIiIiIiIREhISIhIRISERIRQREhQQEiIiIiIiIiEiEhISEhISESEhIUREEhQQEiIiIiIiIiEhIhISEhIRISIhFIREEhQQEiIiIiIiEREiISEhQSEiFBEUSIREEhQQEiIiIiERERERERQURBQRREQURESBEhQQEiIiERRBiBEhGBFERERERBFIREQSEhQQEiIhREREGIEREYERREREERSIRIEiEhQQEiEUJCQkIYgRIYGBEUQRGBRERBIhEhQQEhEURERERBiBERgYERERgUREgSIREhQQFBESQkJCQkGIERgYgREYgUhEQSEREhQQFBEUREREREEYQRGBGBGBFIhEEiEREhQQFBEUJCQkJCERhBGBiIiIFERIEhFBEhQQFBEUREQREUEUGBEYERQRFEREEhEREhQQEYgRQkEiIhEREYEYGIiIFISBIhF
BEhQQGIiBRBIhEiEUQYEYERQRSIRBIREREhQQEYgRFBIUQSERERgRgYiBRESBIRERERQQERERERIUQSEURBgRgRQRRERBIREiEiEQEUQRERIhEiERERGBgYiBRISBIRIiIREQEREREREiIhERERERERERSIRBIRIRIiEQESISIREREUQSIiFEQRERFESBIRIiEREQBAAvACUAAAAAgONk3hURExERERAYiIiIiIQRQhISESEJIuNPIiIiEBGIiIiIhBFCESEhESIiIiIiIhESIiIiEBIYiIgRhBFCEiESESIiIiIiIRERIiIiEBIhiIgYRBFCEhIhISIiIiIiEREREiIiEBIhiIiEQRRCESIiERIiIiIiEREREiIiEBIiGIiEQRQiEiIiIRIiIiIiEREREiIiEBIiGBGEERQiERIREUEiIiIiIRERIiIiEBIiGBhEEUQhIRIhEUEiIiIREhESERIiEBIhiIRBEUIhIiEiIRQSIiEREREREREiEBIhiIRBFEISIiEiIRQSIhERERERERESEBIYEUQRRCISIiEiIRFBIhERERERERESEBGIFEERQiEiIhESIUFEEhERERERERESEBIRRBEUQiEiIiIiIUQUQSERESEhEREiEBIiERFEIhQSIhESERQRRBIREiEiERIiEBIiIRFCIhFBIiEiERFBFEEiIhESIiIiEBIiERRCIRgREiIhgREUEUQSIRERIiIiEBIhEUQhFISBgREYFIhBRBFBIiIiIiIiEBIRFEISIUhEgYGESIQSFEEUEiIRIiIiEBERQRERERSIRERIiEEREUQUEiFEESIiEBEUiIERESEUiIiIRBISGBQUEhQRRBIiEBGIGIgSISIRFBEUESIRgYFBIUREQSIiEBiIgYGBISERIURBIREYiBESIhEUEhESEBRERBiIEREhIUhBISGBgRGBIiIhIYiBEBREREGIGBEhIURBIRiIFBGBEhESGIESEBREREQRiIgR
ERQREYGBRBGBEYiBEREiEBgYGBREEYGIiBEYiIERhBGBGIgSEiISEBGBgYGBRBEYiIiIgRERhEEYERESIRESEBgYEREREUSBERERERgRhEERRBQRISISEBGBGIiIiBFEgREYEYEYREQUIkERERESEBgYiBERGIgUQRERgYEYREGBQkQUEiISEBGIERgYERiBSBERGBEYRBiBFERBEREiEBQRGBgYGBGIFBERgYEYRBgYgUIkFBIiEBRBGBEREYgYFIEYERgYQYgRERQkQREiEBQkEUREQREYgUGBEREYQYGIFEFERBQSEBQiQUIiRBiBgRERGIEREYERFCIUIkEREBFERBIRJBERgURBREQYgYGIFCEhQkQUEAQALwAlAAAAAIDjaN4VEeE/EREREBIiIiEUFEFEQUFEFBREFBIiIiIiIiIiEBEiIiIRQUQUQUFEFBRBQSIiIhESIiIiEBQSIiIhFBRBEUERFBEUEiIiIRERIiIiEBRBIiIiFERERERERERBEiIiEREREiIiEBREEiIiERERERERERERIiIiEREREiIiEBERESIiGBIiIiIhgYGBIiIiEREREiIiEBiIEiIiGBIiIiIhgYGBIiIiIRERIiIiEBGIEiIiGBERIREhgYGBIiIREhESERIiEBiIEiIiGBESERIRgYGBIiEREREREREiEBGIEiIiGBIiEiIhgYGBIhERERERERESEBiIEiIhGBIiEiIhgYGBIhERERERERESEBGIEiIYGBIiEiIhgYGBIhERERERERESEBiIEiIYGBIhESIhgYGBEiERESEhEREiEAoRGBIi4iMiIiGBgRiBIhESISIREiIQGIgSIYgYISERIiGBEYgRIiIiERIiIiIQERgSIYGIESIiIhGBiBERESIhEREiIiIQGIgSIYiBFBIiIUGBGBESEhIiIiIiIiIQGIgRIhEUFEERFEQYiBEhEkESIiIiIiEQEYEiEUFBFERBFEQREREYE
kRBEiIiIhgQEhIiIRQUFIhBEUESIRIYEkSEIRIiIYgQERERIUFBFERBIREiESGIEkiIQhERGIgQEiESIRQUFIhBIhIhEhiIEohIghERGIgQERgSIUFBFERBEiIRIYgREkiIQhERGIgQEhgSIRQUFIhBESESQYiIEkSEQhERGIgQEYgSIUFBFERBIREkGIEREkREQhERGIgQEhgSFBQRFIhBEhIRiIiIEkSEQhERGIgQEYgREUERFERBQSFBgYEREkiIQhERGIgQGIgRERERSIQYFBQYiIiIEohIghERGIgQGIgRIREhREQRgUGBgREREkiIQRFEGIgQGIgSIhIhSIQYiBiIiIiIEkSEQUSIGIgQGIgSEiIRREQREYgYEREREhERREREGIgQGIgRISEhSIQYiIiIiIiIESIUSIREGIgQGIgSEhIRREQRhBgRGBSBIiFEREQRGIgQGIgRISEkiEGIgUEiIUESIiFIhEESGIgQGIgSEhIUREEYiBIREhIiIhRERBISGIgQGIgRISEUiEGBESFEQSEiIRSIQSEhGIgQBAAvACUAAAAAgONg3hUR4dsREREQEiIiIiIiIhiIgYiBiIiIiIiIgSIiIiIQEiIiIkIiIiGIERgRGIGIiIiIEiIREiEQEiIiJEQiIiIURERESBEYgYiBIiGBIhQQEiIiRERCIiIRERERFERIERgRIhiBIhQQEiIpRERJIiIhEREREREUREQSIhiBIhQQEiKUREREkiIhIiIiESERERESIYgSEREQEiKUREREkiIhIRIiEhIRERESIYEiQkIQEiRERERERCIhESEiEhISEhISIRIiQkIQEkREREREREImIiIiEhISEhISIYEiEhIQEiRERERERCISIiIiEhISEhISIYgSEREQEiKUREREkiEiIiIiEhISEhISIhiBIhQQEiKUREREkiEWIiIiISEhISEhIhiBIhQQEiIpRERJIiIhERISISEhISEhIiGBIh
QQEiIiRERCIiIhIhESIhISEhISEiIREhQQEiIiJEQiIiIiESIiIiEhISEhISIiIhQQEiIiIkIiIiIhIiIiERIhISEhISIiIhQQEiERIiIiIiIhEiIhIiEhISEhISIiIhQQEhISERIiIhEhIiIhIRIhISEhISIiIhQQEhEhISEiISESIiIhEiISEhISEiIiIhQQERISEhISISIiIiIiCRFbIiIUEBEhISIiIRgSIiIRERERiBIiGIEiEREREBISEiIhERGBEREREREhGIEhEYgSIYgSEBIhIhERFEEYERRBERIRIYgREhiBIRiBEBIiEUEYFEERgUFEEQkR4ScRIYIQEhFEREGBEhGBRBQRiIiIiIiIiBEREREQEUREQRgYEUQRFEESEhISEhISIYEREREQFERBGIiBgUQYERIiIiIiIiIiGBRBEiEQFEEYiIERGBEYEiIRERERERIhgYFEESEQFBiIgRERGBIYEhGIiIiIiBIYEUgUQREQEYiBEREhGBEYEYgRERERgSGBiBSBRBEQGIgRESIhEYERGBERREQYEiGBGIFIFEEQGIFEERIiEYERgRFEREQYEhgREYEREREQGBQUQREiEYERgRERERGBIhgRERSBSBQQEYhBRBESERgRgUREREGBIYERGBSBSBQQEUiEFEERIRgRgRERERgSIYEUSBQREREQFEFIhBERERERGBIiIhgRERERERSIQUQQBAAvACUAAAAAgONo3hUR4bsREREQEhiIiIiIFEEiEhIRgSIiIiIiIiIiIiIQEiGIiIEYFEEhISEhiBIiIiIiIkIiIiIQEiGIiIiIFEEiIRIRGBIiIiIiJEQiIiIQEiIYiIEYFEEiEiEhEYEiIiIiRERCIiIQEiIYiIiBFBIRIiIRERgSIiIpRERJIiIQEiIYiBGBRBEiIiIhQRgSIiKUREREkiIQEiIYiIgRQSIREhERQRGBIiKUREREkiIQEiIYgRgUQSEhESERRBG
BIiRERERERCIQEiIYiIEUESIiISIhRBEYEkREREREREIQEiGIEYFEEhIiISIhREEYEiRERERERCIQEiGIiBFBISEiISIhREEYEiKUREREkiIQEhiBgRRBIRIiERIhREEYEiKUREREkiIQEiGIEUQSISIiIiIhREQRgSIpRERJIiIQEiIRFEEiFBIiERIYFEQRgSIiRERCIiIQEiIhRBIiEUEiISIYEUQRgSIiJEQiIiIQEiIUQSIhiBESIiGIEhQRgSIiIkIiIiIQEiFEERESGIgRERGIEhERgSIiIiIiIiIQEhRBEhERIREYiIERIRERgSIiIhESIiIQEUQRIQohERIi4acREhGBIiIRiBEiIhAUQSESERERESIiIhESERgRIiIYEYgSEhAUGBIRESESEREREREhIRGBIiGIiIEiERAREYEhEREhIRESERESERIYEiIRGBIhgRARGBgSEREhISEhISERESGIESIiIRIYgRARgRGBIhESEREhIREREhiBERIiIhGBEhAYEUEYESERERESERESIYGBEhEiIRERIhARFBGBiBEYERERERIhGBGBIRESEiIREhARQRgUEYgRESIiIiEYgRGBIRERIhESEhAUEYERQhGIgRERERiBEUGBIREYEiEhEhARGBFBFCERGIiIiIEYEUGBEhGIESISEhARgRgUEUJBgRERERiIEUIYERiBERISEhAYERgRQSQhGBERGIEYEUIYgYgSEhEhIhASEhGBQUJCGBJBGIiIEUJBiIERERESIhARERGBQSQhGBJBGBEYEUEUGBESEhIRIhASEhIYEUJCGBJBGIiIERRBgRgREREREhAREREYFCQhGBERERERREhBgUGBEhISERASEhIRgUJCGBREREREiIQYESQYERERERAEAC8AJQAAAACA42neFRHjZxERERASIiIiIhQkRCRCRCRCRCQRIiIiIiIiIhASIiIiIiFCRCRCRCRCQkESIiIiQiIi
IhASIiIiIiIUIiRCIiRCJBEiIiIkRCIiIhARIiIiIiIhRERERERERBIiIiJEREIiIhAREiIiIiIhERERERERERIiIilEREkiIhARgSIiIiIhERGBIiIiIhEiIpRERESSIhARgSIiIiIhEYGBIiIiIhEiIpRERESSIhARgSIiIiIhgYGBIREhERgSJEREREREIhARgSIiEiIhgYGBEhESERgSREREREREQhARgSIhEiIhgYGBIiISIhgSJEREREREIhARgSEYEiIhgYGBIiISIhgSIpRERESSIhARERiBIiIhgYGBIiISIhgSIpRERESSIhAUiIERIiIhgYGBIiERIhgSIilEREkiIhARgRESIiIhgYGBIiIiIhgREiJEREIiIhAUgRIiIiEYgYGBIiERISgYgSIkRCIiIhARgSIiIhiBgYGBEiIiIRiBgSIiQiIiIhAUgSIiIhgRgRgUISIiEkGIgSIiIiIiIRARgSIiIhiIGIFERBERREQRERIiIiIiFBAUgSIiIhERERFEREREREESGBESIiIhgRARgSIiEUERIRERREREQRERGBIREiIhhBAUgSIRGBQRESEREREREREhGBEYgRIhgRARgREREYFBEREhERERESERGBIYgUERhBAUgRERERgUERERISEhIRFBGBERgURBgRARgRFBERGBQREREREREUFBGIEhiBFBhBARESEUEREYFBFBQUFBQUFBIYERGIgRgRASISGBQRERgUEUhISEhISBIYgSERiBhBARESEYFBERGBQRQUFBQUFBIRiBEhERgRASIRGBgUEREYFBEUFBQUFBIRGIgREhhBAREUQYERgRERgUEUFBQUFBIRIRiIERgRASESQYGIFBERGBQRSEhISBIRISEYiBhBARgURBgRFIEREYFBFBQUFBIRIRgRERgRARgSJBgYFIQRERgUERQUFBIRIREYFBhBAUgURBgRFISBEhGBQRQUFBIRIYgYEhgRARg
SJBgYFIQRERFIFBFISBERIRGBRBhBAUgURBgRFIESERhEgUEUFBERGIGBQhgRARgSJBgYFBEREUGESBQRQRIRERgURBhBAEAC8AJQAAAACA42neFRHjZxERERASIiIiIiIiIhgYiBiIGIgYiIiBIiIiIhASIkRJIilEQiERgRGBEYERgRgSIiIiIhASJEREkpRERCIYiIiIiIiBiBEiESIiIhASREREQkREREIhREREREiIiBIhiBIiIhASREREREREREIhERERERRERBIhiBESIhASREREREREREIhIiIiIhERERERgSIRIhASREREREREREIhIiIiIhISEhIhgSIYEhASlERERERERJIRERIRERISEhEYgREYEhASKURERERESSEhESERIRISEhEYgRIhIhASKURERERESSEhIiEiIhISEhIYgSIhIhASIpREREREQiEhIiEiIhISEhIhERERIhASIiREREREIiEhIiEiIhISEiEiFERBIhASIiJERERCIhISIhESIiEhISEhEREREhASIiIkREQiIhISIiIiIiEiEhIRQUFBQRASIiIiREIiIiESEhESIiISEhIUREREERASIiIiJCIhEREiEiIiISEhISIRRERBIhASIiIiIiERQRIhISIhISEhIiEiERQSRBASIiIiERERFBESISEhIREiIRISIhEUQRASIiIRFBIhFEEhEiEhIhIREiIiEUERERASIhEiFBIiEUQRIhEhEhiBIhIhQUGBERASERISFBISIRRBEYESEYiBISIUgUERgRARiEEhIUEhIhRBGBgRiIgSIiFIFBERGBAYREESIUEiIhFEEYEYiIgRIiGEFBgRERAUQRERIhQSEiFEQRGIiIgSIhhBQRSIERAUEREUEhRBISEUQRiIiIEiEhQUQREYgRARgRFEQSFEEiIURBiIiBEhIhFEERFEiBAYRIERRBIURBIRQYiIgUEiIRRBERRESBAUSIhBEREhFE
ESEYiIgRIhFEEREUSEGBAUiIFIgRESIREREREREREUQRERFEREiBAYiBQRGBEREiIiRERERERBERERRIQYgRAYiBSIiBgSIiQRERERERESEREURESIgRAYiBQRGBgSIiIiIhREQSIiERFEhBiIERAYiBSIiBgSIiIiERJEQSEhERSERIiBERARiIFIgRERERERIRERQRIREREUGIgRFBARGIiBERERESIhGIiIESIREUQYiIERQRAUEYEREYiIgSIhGBQYEiEhiIiIiBERRBAEAC8AJQAAAACA42neFRHjZxERERASIiIiIiIRISEiERSIiIEiIiIiIiIiIhASIiIiIiESEhISERSBiBIiREkiKURCIhASIiIiIhERIRIiERSIiBIkRESSlEREIhASIiIiIhgSEiEiIRSBgSJERERCREREQhASIiIiIRgRIiIRIRRIgSJEREREREREQhASIiIiIYQSIiIiERFIgSJEREREREREQhASIiIiEYQRESERIRFEiBJEREREREREQhASIiIiGEQREhESEREUSBKUREREREREkhASIiIhGEQSIhIiISERQSIpRERERERJIhASIiIhhEgSIhIiISEREiIpRERERERJIhASIiIhhEgSIhIiISIRESIiRERERESSIhASIiIhhEgSIREiIhIRERIiJEREREQiIhASIiIYRIgSIiIiIhIhEREiIkREREIiIhASIiIYRIERIREiIYEiERESIiRERCIiIhASIiIYRBGBIhIiGIEiIREREiJEQiIiIhASIiIYQYEYEiIhiBESIhERERIkIiIiIhASIiIYEoERgREYgRGBIiERERIiIiIiIhASIiIRghgRGIiBERgSEiIRESIiESESIhASIiEYGEKBEREREYQoERIiEiIhiBiBIhASIhiIgYIYgREYiBKBEREREiIhhEQSIhASIRGBGBhCGIiBJIgRESIiISIiGEiBIhASGIiIiIGIhCFIiBEhEiE
hIRIREYgSEhARERgRGIERGIiBERgRISIiFEGIgRGBEhAYiIiIiBEiEREYERgRIiIRRBiIEiEYEhAREYERGBISERERgYESEhFEERERIiGIEhAYiIiIgRIRESIRgYESIURBiIEhERGBIhARgYERgREhEiEhGBEhIUQYREEhQSESIhAYiIiIgSEhQRIhGBEiFEGESEESESESIhARGBgRgREhhEEiGBISFEGERBESEhIhIhAYiIiIgRIRiEQSERIhRBhEhBEhEhIhIhARgREYESEYGIQRERIhRBhERBIREiERIhAYiIiIESEYEYQRiBERRBhIRBISEiIUEhARgRiBESEYQYhBEYiBFBhEERIREhFEQRAYiIgUERIYQYRBgREYgRERRBEhEURERBAREYFEEhIYEYhBgYiBGIFESBISFEREQRAYiBREESEYGIQYGERIERRIiBESFERBGBAEAC8AJQAAAACA42jeFRHiZxERERASIiIiIhRCREJCRCQkRCQSIiIiIiIiIhARIhESIiFEJEJCRCQkQkEiREkiKURCIhAUEiGBIiIUQiJCIiQiJBEkRESSlEREIhAUEiGIEiIUREREREREQRJERERCREREQhAUEiGIEiIRERERERERERJEREREREREQhARERIYgSIhgYGBgSIiISJEREREREREQhASQkIhgSIhgYGBgSIRISJEREREREREQhASQkIiESIYGBgYEhEhISKUREREREREkhASEhIhgSIYGBgYEiIiJiIpRERERERJIhARERIYgSIYGBgYEiIiIhIpRERERERJIhAUEiGIEiIYGBgYEiIiIiEiRERERESSIhAUEiGIEiIYGBgYEiIRJhEiJEREREQiIhAUEiGBIiIYGBgYEhESISIiIkREREIiIhAUEhESIhEYGBgYEiIiISIiIiRERCIiIhAUEiIiIYiBGBgYEiIhESIiIiJEQiISIhAUEiIiGIGBgYEYEiIiISIiIiIkIhFB
EhAUEiIiGBiBgYGBREIiIREREiIiIhREEhAUEiIiGIEYgYEUREQRGIGIgSIiIiFBIhAUEiIiIYiIGBFEREREQYgRgSIiERFBIhAUEiIiIREREYgRREREQRiIgSIhIiFBIhAUEiIhFCQYiIiIERERiIGIESISIiIREhAUEiERERQhGIiIiIiIiIgRJBESIRISEhAUERIkQREUIRGIiIiIgREkRBERIhEREhAUFEIiJEERFCQRERERFCREERFEEiEiEhARERRCIiRBERQkJCQkJEQREUQiIREREhAYiBEUQiIkQQoRFBER4PtEIiJBESEiEBiBiIEUQiIkQRFBIiFBEUQiIkQRIhEiEBgYiBiBFEIiJEEUEhQRRCIiRBGBISESEBERgYhBERRCIiQRQUEUIiJEEYiBIiIREBIiGIQRiIEUQiJBFBFCIiQRiIiBISEREBEiIUEYiIiBRCIkERQiJEGIiIiBIiIREBIhIRGBEREREUIiQUIiQRERERGBISEREBEiIhiBIiIiIUQiERIkQSIiIiGBIiIREBESEhiBIRERIRRBIiFEESERESGBISEREBESIiGBIYgRESESERIRIREYgSGBIiIREBERISGBIYgRIhEhREEhEiEYgSGBISEREAQALwAlAAAAAIDjad4VEeNnEREREBIiIiIiIiIiGIiIiIiIiIiIiIEiIiIiEBIiIiIhIiIiIYiIiIGBgYGBgRIiIiIiEBIiIiIREiIiIhGBgYFBQUFBQSIiIiIiEBIiIiERESIiIkFBQUREREREEiIiIiIhEBIiIhERERIiIiFEREEREREREiIiIiIREBIiIREREREiIiEREREiIiIiESIiIiGBEBIiERERERESIiEhISEiIiIiEhIiIiGBEBIhERERERERIiEhISERESEREhIiIiGBEBIhERERERERIiEhISESERIRESIiIiGBEBIREREREREREiEhISEiIhIiEhIiIiGBEBIRERERE
REREiEhISEiIhIiEhIiIiGBEBIREREREREREiEhISEiIhIiEhIiIiGBEBIREREhIREREiEhISEiIREiEhIiIiGBEBIhERIhIhERIiEhISEhEiISEhIiIiGBEBIiIiIREiIiIREhISEhIREiESESIiGBEBIiIiERESIiEiEhISEiIiIiEhIhIiGBEBIiIiIiIiIhISEhISEiEiISEhIhIiGBEBIiIiIiIiERIRIhISESEhISEiEYESGBEBIiIiIiIRGBEiISISEiEhESIRGBEhGBEBIiIiIhGBSBEREhEhIhISGBQRgRIUGBEBIiIiERGBEYEYERERESEhGBEYESERGBEBIiIRgYEYEYFBGBgYERERgUGBEhREGBEBIhFEEREYFBgUQRERGBgRgRGBEhQRGBEBIUiBGBEYERgURIiIEREYFBgRIUREGBEBGEQRERgRgRgURIERiEQYERgRIUERGBEBSIQRgYGBgUGBRIiIiEQYEYESFEREGBEBRIEREYERgRGBERERERGBQYESFBEREREBhEEYGBiIGBGBEiISIhGBEYESFBiIgREBiEERGBgRGBGBIhIiEiGBGBEhQYERiIEBSIEYGBiIGBQYEhISEiGBGBEhQYgSGIEBRIERGBgRGBEYEiISIhgUGBERRBERIREBhEEYGBiIgYEYEhIiEhgRGBgRFEREEREBSEERGBgREYEYERERERgRgRERERERIiEBRIEYEYGIgYEYGIiIiIgRgRERERIiEREBEUEREYGBEYEYERERERgRgYgRGBEhIiEBIhIRgRgYgYFIERREERgRgRGIEREiEREAQALwAlAAAAAIDjWd4VEeMnEREREBIiIiIiIRIRISEkGBGIiBIiIiIiIiIiEBIhIiIiERESEhEkGIGIgSIiIiEiIiIiEBIhIiIiESEhEiEkGIiIgSIiIhESIiIiEBIhIiIiERISISIUGBGIEiIiIRERIiIiEBIYEiIiEhEiIhIUGI
GIEiIiEREREiIiEBIYEiIhEhIiIiEUQYiIgSIhERERESIiEBIYEiIhQhERIREUQYEYgSIRERERERIiEBIYEiIhQhESERIURBgYEiEREREREREiEBGIgSIhQhIiEiISRBiBIiEREREREREiEBGBgSIhQhIiEiIhREGBIhERERERERESEBGIgSIUQhIiEiIhJEQRIhERERERERESEBIYEiIUIRIhESIiFEQRIhERERERERESEBIYEiIUIRIiIiIiEkRBIhERESEhERESEBERESISEREhESIhQSREEiEREiEiEREiEBGIgSFCEREiEiIUESREESIiIhESIiIiEBIREiFCERgSIiERgRJEQRIiIRERIiIiEBGIgSFCGBGBERgYGIEkRBEiIiIiIiIiEBGIgSERGIEYGBgRiBESIiESIiIiRCIiEBIREiERGIiBERGIgRERERQRIiJEEUQiEBIUEhESEYGIiIgYERIhFERBgiRBiBRCEBIYEYESEYgYGBiBEiERREIYESJEEUQhEBIYFIgRERiIiIgRIRFERCGBGBEiRCIUEBEYFEgRIRgYGIESERREIhgRGIgSEiGEEBEYFEgRERGIiBEhFERCIYFBEYiBEhEYEBEYFEiBEhGIgRIRREQkQYEREREYEREYEBEYEkSBESERgSEURCJEQYFEQRERIiIYEBEYEUSIERGIEhFEQkRBEYERERESIiIYEBEYEhRIERhEgRREJEEREYgUREEiIiIYEBEYESRIgRhEgURCQREiERgRERIhIhGEEBEYEhFEiBhEgUQkERIiIRGBRBIREREUEBEYESFESIGIFEIRFCIRIhEYEREYEREREBEYEhIURIgRFCERIhEREiERgUGIGBEYEBEYESEhRERERBESIiIiIiIRGBiIGIiBEBEYEhISERERCRETERERiIiBGBARGBEhIURERAlED0REQRERGIEQERgSEg4REhESCxESERiIgREQBAAvACUAAAA
AgONM3hUR4dcREREQEiIRIiFBREFBRBQURBRBIiIiIiIiIiIQEiGIEiIUFEFBRBQUQUQSIiIiISIiIiIQEhgUgSIhQRFBERQRFEEiIiIiERIiIiIQEhgUgSIiFEREREREREEiIiIhEREiIiIQEhgUgSIiEREREREREREiIiIRERESIiIQEiGIEiIiEiIiGBgYGBIiIiERERERIiIQEiIRIiIiEhEiGBgYGBIiIhEREREREiIQEiGIEiIiEhIRIYGBgYEiIRERERERESIQEhgUgSIiYiIiIYGBgYEiIRERERERESIQEiGIEiIhIiIiIYGBgYEiERERERERERIQEiIRIiISIiIiIYGBgYEiERERERERERIQEiGIEiIRIhEmIYGBgYEiERERERERERIQEhgUgSIiEiEWIYGBgYEiERERISERERIQEhgUgSIiEiIiIYGBgYgRIRESISIRESIQEhgUgSIiERIiGIGBgYiIEiIiERIiIiIQEiGIEiIiEiIiGIGIGBgYgSIhEREiIiIQEhEREiIhEiIiQRgYGBiBgSIiIiIiIiIQEhIiESERFiJERBgRgYEYgSIiIiIiIiIQEiESIRERERRERBGIGBiIESIiIiIiIiIQEhIhERIREREJEeDrESIiIiIiIhASEhESEhEREREREREREREhIREiIiIiIhASERIRESGBgYGBgYGBgYEhESERIiIiIhARQREhISEREREREREREREhISEUESIiIhAUEUEhERIUREREREREREEhESFEQREiERARFBESEhIRSESESESESEEhISFBEUQRgRARQRgSEREhREgYSEgYREEhESERRBGIgRAUEYGBISEhFIGEiISBhEEhISFEEYgRERARGBgRIRERgUhEgYRIREEhESERGIiIERARgYGBEhGBERESERIREhEhISERiBERGBAYGBgRERgRgQkhKxERGIiIgRgQEYGBFBGBGIESERIREhERISERiBgREYEQ
GIgRJBgREYEJERMRGIiIiBGBEBgRFEGBGIiBCSITIhiBgREYFBARESQYEYERgQlEE0GIiIiBGEQQERRBgRiIiBEJESMRgYEREYFEEBGEGBERgRgRGBEhIiESESEYiIiIGEREEAQAJwAnAAAAAIDi8MMJIg8iISIiIiIiIiIiIiAJIg8iERIiIiIiIiIiIiAJIg8hEREiIiIiIiIiIiAJIuJ7EREREiIiIiIiIiIgIiIiIiIiIiEREhERIiIiIiIiIiAiIiIiIiIiEREhIRESIiIiIiIiICIiIiIiIiEREhESEREiIiIiIiIgIiIiIiIiEREhEREhERIiIiIiIiAiIiIiIiEREhERERIRESIiIiIiICIiIiIiEREhERIRESEREiIiIiIgIiIiIiEREhERISEREhERIiIiIiAiIiIiEREhERIREhERIRESIiIiICIiIiEREhERIRIRIRESEREiIiIgIiIiEREhERIRISESEREhERIiIiAiIiEREhERIRIREhEhERIRESIiICIiEREhERIREhESERIRESEREiIgIiEREhERIRERISERESEREhERIiAiEREhERESERESERESERERIRESICIREhEREREhESEhESERERESERIgIRESERIRERISERISERESERIRESAhESERESESESESESESESERESERICERIRERIRESEhESEhERIRERIREgERIRESIRESERISERIRESIRESERAREhESERESERESERESERESERIREBESERIRESEREREREREhERIREhEQERIREhESERESERIRERIREhESERAREhERIiERESEhISERESIhERIREBESERERERESERIREhEREREREhEQERIRERERESERERERIRERERESERARESERERESERERERESERERESERECERIhEREiEREhESEREiERESIREgIRERIiIhEREiERIhEREiIiERESAiEREREREREiIREiIRE
RERERESICIhEREREREiIRERIiERERERESIgIiIhERERIiIhEREiIiEREREiIiAJIg8RERESIiIiIiIiIiAJIjcRERESIiIiIiIiIiAiIiIiIiIiIREREREiIiIiIiIiICIiIiIiIiIRERERERIiIiIiIiIgAQALAAsAAAAAgB8LBw4AAAAOHwAAAAduwAAADv/gAAAHdcAAAAoOAAAAAQAJAAoAAAAAgB8KBxwAAAAKPgAAAAddAAAADv+AAAAHawAAAAocAAAAAQAPAA8AAAAAgDIPCwOAAAAHwAAADg/gAAAPB8AAADu4AAB//AAADv/+AAATfXwAADk4AAADgAAAB8AAAAEACwALAAAAAIAiCw8IAAAAHAAAAD4AAAAOfwAAAA8+AAAAHAAAAAgAAAAJAAEACQAKAAAAAIAkCg8IAAAAHAAAAD4AAAAOfwAAABM+AAAAHAAAAAgAAAAAAAAAAQAPAA8AAAAAgDoPEwEAAAADgAAAB8AAAA/gAAAKH/AAAA8/+AAAf/wAAD/4AAAKH/AAABMP4AAAB8AAAAOAAAABAAAAAQALAAsAAAAAgCYLBQALdwAAAPeAAAAO/4AAABd/AAAAPgAAABwAAAAIAAAAAAAAAAEACQAKAAAAAIAkCgt3AAAA94AAAA7/gAAAF38AAAA+AAAAHAAAAAgAAAAAAAAAAQAPAA8AAAAAgDEPDzx4AAB+/AAA/v4AABL//gAACn/8AAAbP/gAAB/wAAAP4AAAB8AAAAOAAAABAAAAAQALAAsAAAAAgCMLBQATCAAAABwAAAA+AAAAfwAAAA7/gAAAB2sAAAAKHAAAAAEACQAKAAAAAIAhChMIAAAAHAAAAD4AAAB/AAAADv+AAAAHawAAAAocAAAAAQAPAA8AAAAAgDUPGwEAAAADgAAAB8AAAA/gAAAf8AAAP/gAAAp//AAADv/+AAAT/X4AAHk8AAADgAAAB8AAAAEADAAMAAAAAIAmDAoCAA
AACgcAAAAKDYAAABMYwAAAH8AAAD/gAAAwYAAACnjwAAABAAoADAAAAACALwwrHwAAAD+AAAAxgAAAAYAAAAOAAAAHAAAADgAAABwAAAA5gAAAMYAAAAo/gAAAAQAKAAwAAAAAgC0MCj+AAAAXMwAAAAYAAAAMAAAAHwAAAB+AAAAKAYAAAA8xgAAAP4AAAB8AAAABAAoADAAAAACAKQwbAwAAAAcAAAAPAAAAHwAAADsAAABzAAAACn/AAAAKAwAAAAoHgAAAAQAKAAwAAAAAgCcMCn8AAAAKYAAAAAt+AAAAfwAAAAoDAAAACmMAAAALfwAAAD4AAAABAAoADAAAAACAKAwbDwAAAB8AAAA4AAAAMAAAAD8AAAA/gAAAEjGAAAALP4AAAB8AAAABAAoADAAAAACAGgwKP4AAAAcxgAAACgMAAAAOBgAAABIMAAAAAQAKAAwAAAAAgCYMCx8AAAA/gAAADjGAAAALHwAAAD+AAAAOMYAAAAs/gAAAHwAAAAEACgAMAAAAAIAoDAsfAAAAP4AAABIxgAAAGz+AAAAfgAAAAYAAAAOAAAAfAAAAHgAAAAEACgAMAAAAAIAYDAtngAAAb8AAACJswAAAC2/AAABngAAAAQAKAAwAAAAAgBkMCg8AAAAaBgAAAApmAAAAC34AAAA8AAAAAQAKAA4AAAAAgCAOCz4AAAB/AAAAImMAAAATfwAAAD4AAAAHAAAAAwAAAAEACgAMAAAAAIAsDAr3gAAAI2YAAABsAAAAeAAAAHAAAAB4AAAAbAAAAGYAAABjAAAACveAAAA='!
Item was removed:
- ----- Method: PlayingCard class>>includeInNewMorphMenu (in category 'all') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: PlayingCard class>>initialize (in category 'class initialization') -----
- initialize
- "PlayingCard initialize"
- "Read the stored forms from mime-encoded data in imageData."
- | forms f |
- f := Base64MimeConverter
- mimeDecodeToBytes: (ReadStream on: self imageData).
- forms := OrderedCollection new.
- f next = 2
- ifFalse: [self error: 'corrupted imageData' translated].
- [f atEnd]
- whileFalse: [forms
- add: (Form new readFrom: f)].
- "1/2 image of Kc, Qc, Jc, ... d, h, s, and center image of As"
- FaceForms := forms copyFrom: 1 to: 13.
- "Images of small club, smaller club (for face cards), large club (for
- 2-10, A),
- followed by 3 more each for diamonds, heardt, spaces, all as 1-bit
- forms. "
- SuitForms := forms copyFrom: 14 to: 25.
- "Images of A, 2, 3 ... J, Q, K as 1-bit forms"
- NumberForms := forms copyFrom: 26 to: 38.
- CardSize := 71 @ 96.
- FaceLoc := 12 @ 11.
- NumberLoc := 2 @ 4.
- SuitLoc := 3 @ 18.
- FaceSuitLoc := 2 @ 18.
- TopSpotLocs := {{}. {28 @ 10}. {28 @ 10}. {15 @ 10. 41 @ 10}. {15 @ 10. 41 @ 10}. {14 @ 10. 42 @ 10}. {14 @ 10. 42 @ 10}. {14 @ 10. 28 @ 26. 42 @ 10}. {14 @ 10. 14 @ 30. 42 @ 10. 42 @ 30}. {14 @ 10. 14 @ 30. 42 @ 10. 42 @ 30. 28 @ 21}}.
- "A"
- "2"
- "3"
- "4"
- "5"
- "6"
- "7"
- "8"
- "9"
- "10"
- MidSpotLocs := {{28 @ 40}. {}. {28 @ 40}. {}. {28 @ 40}. {14 @ 40. 42 @ 40}. {14 @ 40. 42 @ 40. 28 @ 26}. {14 @ 40. 42 @ 40}. {28 @ 40}. {}}.
- "A"
- "2"
- "3"
- "4"
- "5"
- "6"
- "7"
- "8"
- "9"
- "10"
- ASpadesLoc := 16 @ 27!
Item was removed:
- ----- Method: PlayingCard class>>test (in category 'all') -----
- test "Display all cards in the deck"
- "MessageTally spyOn: [20 timesRepeat: [PlayingCard test]]"
- 1 to: 13 do: [:i | 1 to: 4 do: [:j |
- (PlayingCard the: i of: (#(clubs diamonds hearts spades) at: j)) cardForm
- displayAt: (i-1*CardSize x)@(j-1*CardSize y)]]!
Item was removed:
- ----- Method: PlayingCard class>>the:of: (in category 'all') -----
- the: cardNo of: suitOrNumber
-
- ^ self new setCardNo: cardNo
- suitNo: (suitOrNumber isNumber
- ifTrue: [suitOrNumber]
- ifFalse: [#(clubs diamonds hearts spades) indexOf: suitOrNumber])
- cardForm: (Form extent: CardSize depth: Display depth)!
Item was removed:
- ----- Method: PlayingCard>>blankCard (in category 'all') -----
- blankCard
-
- CachedDepth = Display depth ifFalse:
- [CachedDepth := Display depth.
- CachedBlank := Form extent: CardSize depth: CachedDepth.
- CachedBlank fillWhite; border: CachedBlank boundingBox width: 1.
- CachedBlank fill: (0@0 extent: 2@2) fillColor: Color transparent. "Round the top corners"
- CachedBlank fill: (1@1 extent: 1@1) fillColor: Color black.
- CachedBlank fill: (CachedBlank width-2@0 extent: 2@2) fillColor: Color transparent.
- CachedBlank fill: (CachedBlank width-2@1 extent: 1@1) fillColor: Color black].
- ^ CachedBlank!
Item was removed:
- ----- Method: PlayingCard>>buildImage (in category 'all') -----
- buildImage "(PlayingCard the: 12 of: #hearts) cardForm display"
- "World addMorph: (ImageMorph new image: (PlayingCard the: 12 of: #hearts) cardForm)"
- "PlayingCard test"
- | blt numForm suitForm spot face ace sloc colorMap fillColor |
-
- "Set up blt to copy in color for 1-bit forms"
- blt := BitBlt current toForm: cardForm.
- fillColor := self color.
- colorMap := (((Array with: Color white with: fillColor)
- collect: [:c | cardForm pixelWordFor: c])
- as: Bitmap).
-
- blt copy: cardForm boundingBox from: 0@0 in: self blankCard. "Start with a blank card image"
- numForm := NumberForms at: cardNo. "Put number in topLeft"
- blt copyForm: numForm to: NumberLoc rule: Form over colorMap: colorMap.
-
- suitForm := SuitForms at: suitNo*3-2. "Put small suit just below number"
- sloc := SuitLoc.
- cardNo > 10 ifTrue:
- [suitForm := SuitForms at: suitNo*3-1. "Smaller for face cards"
- sloc := SuitLoc - (1@0)].
- blt copyForm: suitForm to: sloc rule: Form over colorMap: colorMap.
-
- cardNo <= 10
- ifTrue:
- ["Copy top-half spots to the number cards"
- spot := SuitForms at: suitNo*3. "Large suit spots"
- (TopSpotLocs at: cardNo) do:
- [:loc | blt copyForm: spot to: loc rule: Form over colorMap: colorMap]]
- ifFalse:
- ["Copy top half of face cards"
- face := FaceForms at: suitNo-1*3 + 14-cardNo.
- blt colorMap: self faceColorMap;
- copy: (FaceLoc extent: face extent) from: 0@0 in: face].
-
- "Now copy top half to bottom"
- self copyTopToBottomHalf.
-
- cardNo <= 10 ifTrue:
- ["Copy middle spots to the number cards"
- (MidSpotLocs at: cardNo) do:
- [:loc | blt copyForm: spot to: loc rule: Form over colorMap: colorMap]].
- (cardNo = 1 and: [suitNo = 4]) ifTrue:
- ["Special treatment for the ace of spades"
- ace := FaceForms at: 13.
- blt colorMap: self faceColorMap;
- copy: (ASpadesLoc extent: ace extent) from: 0@0 in: ace]
- !
Item was removed:
- ----- Method: PlayingCard>>cardForm (in category 'all') -----
- cardForm
-
- ^ cardForm!
Item was removed:
- ----- Method: PlayingCard>>color (in category 'all') -----
- color
- CachedDepth = 1 ifTrue: [^ Color black].
- CachedDepth = 2 ifTrue: [^ Color perform: (#(black gray gray black) at: suitNo)].
- ^ Color perform: (#(black red red black) at: suitNo)!
Item was removed:
- ----- Method: PlayingCard>>copyTopToBottomHalf (in category 'all') -----
- copyTopToBottomHalf
- "The bottom half is a 180-degree rotation of the top half (except for 7)"
- | topHalf corners |
- topHalf := 0@0 corner: cardForm width@(cardForm height+1//2).
- corners := topHalf corners.
- (WarpBlt current toForm: cardForm)
- sourceForm: cardForm;
- combinationRule: 3;
- copyQuad: ((3 to: 6) collect: [:i | corners atWrap: i])
- toRect: (CardSize - topHalf extent corner: CardSize).
- !
Item was removed:
- ----- Method: PlayingCard>>faceColorMap (in category 'all') -----
- faceColorMap
- | map |
- map := Color colorMapIfNeededFrom: 4 to: Display depth.
- ^ map!
Item was removed:
- ----- Method: PlayingCard>>setCardNo:suitNo:cardForm: (in category 'all') -----
- setCardNo: c suitNo: s cardForm: f
- cardNo := c.
- suitNo := s.
- cardForm := f.
- self buildImage!
Item was removed:
- AlignmentMorph subclass: #PlayingCardDeck
- instanceVariableNames: 'layout stackingPolicy stackingOrder emptyDropPolicy target acceptCardSelector cardDroppedSelector cardDoubleClickSelector cardDraggedSelector seed'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
Item was removed:
- ----- Method: PlayingCardDeck class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: PlayingCardDeck class>>newDeck (in category 'instance creation') -----
- newDeck
- ^self new newDeck!
Item was removed:
- ----- Method: PlayingCardDeck class>>newSuit: (in category 'instance creation') -----
- newSuit: suit
- ^self new newSuit: suit!
Item was removed:
- ----- Method: PlayingCardDeck class>>suits (in category 'symbols') -----
- suits
-
- ^{#Clubs. #Diamonds. #Hearts. #Spades}!
Item was removed:
- ----- Method: PlayingCardDeck class>>values (in category 'symbols') -----
- values
-
- ^#(Ace),((2 to: 9) collect: [:i | i printString asSymbol]), #(Jack Queen King)!
Item was removed:
- ----- Method: PlayingCardDeck>>acceptCard:default: (in category 'dropping/grabbing') -----
- acceptCard: aCard default: aBoolean
- "if target and acceptCardSelector are both not nil, send to target, if not
- nil answer
- else answer aBoolean"
- "Rewrote this a little (SmallLint calls this 'intention revealing')-th"
- ^ (target isNil or: [acceptCardSelector isNil])
- ifTrue: [aBoolean]
- ifFalse: [(target
- perform: acceptCardSelector
- with: aCard
- with: self)
- ifNil: [aBoolean]]!
Item was removed:
- ----- Method: PlayingCardDeck>>acceptCardSelector: (in category 'accessing') -----
- acceptCardSelector: aSymbolOrString
-
- acceptCardSelector := self nilOrSymbol: aSymbolOrString.!
Item was removed:
- ----- Method: PlayingCardDeck>>acceptDroppingMorph:event: (in category 'layout') -----
- acceptDroppingMorph: aMorph event: evt
- target
- rememberUndoableAction: [target inAutoMove
- ifFalse: [target removeProperty: #stateBeforeGrab].
- self addMorph: aMorph.
- aMorph hasSubmorphs
- ifTrue: ["Just dropped a sub-deck of cards"
- aMorph submorphs
- reverseDo: [:m | self addMorphFront: m]].
- (target notNil
- and: [cardDroppedSelector notNil])
- ifTrue: [target perform: cardDroppedSelector]]
- named: 'move card' translated!
Item was removed:
- ----- Method: PlayingCardDeck>>addCard: (in category 'accessing') -----
- addCard: aPlayingCard
- self addMorph: aPlayingCard!
Item was removed:
- ----- Method: PlayingCardDeck>>cardDoubleClickSelector: (in category 'accessing') -----
- cardDoubleClickSelector: aSymbolOrString
-
- cardDoubleClickSelector := self nilOrSymbol: aSymbolOrString.!
Item was removed:
- ----- Method: PlayingCardDeck>>cardDraggedSelector: (in category 'accessing') -----
- cardDraggedSelector: aSymbolOrString
-
- cardDraggedSelector := self nilOrSymbol: aSymbolOrString.!
Item was removed:
- ----- Method: PlayingCardDeck>>cardDroppedSelector: (in category 'accessing') -----
- cardDroppedSelector: aSymbolOrString
-
- cardDroppedSelector := self nilOrSymbol: aSymbolOrString.!
Item was removed:
- ----- Method: PlayingCardDeck>>cards (in category 'accessing') -----
- cards
-
- ^submorphs!
Item was removed:
- ----- Method: PlayingCardDeck>>deal (in category 'shuffling/dealing') -----
- deal
- | card |
- ^ self cards notEmpty
- ifTrue:
- [card := self topCard.
- card delete.
- card]
- ifFalse: [nil]!
Item was removed:
- ----- Method: PlayingCardDeck>>deal: (in category 'shuffling/dealing') -----
- deal: anInteger
-
- ^(1 to: anInteger) collect: [:i | self deal]!
Item was removed:
- ----- Method: PlayingCardDeck>>doubleClickOnCard: (in category 'events') -----
- doubleClickOnCard: aCard
- (target notNil and: [cardDoubleClickSelector notNil])
- ifTrue:
- [^target
- perform: cardDoubleClickSelector
- with: self
- with: aCard]!
Item was removed:
- ----- Method: PlayingCardDeck>>emptyDropNotOk: (in category 'dropping/grabbing') -----
- emptyDropNotOk: aPlayingCard
-
- ^(self emptyDropOk: aPlayingCard) not!
Item was removed:
- ----- Method: PlayingCardDeck>>emptyDropOk: (in category 'dropping/grabbing') -----
- emptyDropOk: aPlayingCard
-
- emptyDropPolicy = #any ifTrue: [^true].
- emptyDropPolicy = #inOrder ifTrue: [^self inStackingOrder: aPlayingCard].
- emptyDropPolicy = #anyClub ifTrue: [^aPlayingCard suit = #club].
- emptyDropPolicy = #anyDiamond ifTrue: [^aPlayingCard suit = #diamond].
- emptyDropPolicy = #anyHeart ifTrue: [^aPlayingCard suit = #heart].
- emptyDropPolicy = #anySpade ifTrue: [^aPlayingCard suit = #spade].!
Item was removed:
- ----- Method: PlayingCardDeck>>emptyDropPolicy: (in category 'accessing') -----
- emptyDropPolicy: aSymbol
- "#any #inOrder #anyClub #anyDiamond #anyHeart #anySpade"
-
- emptyDropPolicy := aSymbol!
Item was removed:
- ----- Method: PlayingCardDeck>>hasCards (in category 'accessing') -----
- hasCards
-
- ^self hasSubmorphs!
Item was removed:
- ----- Method: PlayingCardDeck>>ifEmpty: (in category 'dropping/grabbing') -----
- ifEmpty: aBlock
-
- self hasSubmorphs not ifTrue: [^aBlock value]!
Item was removed:
- ----- Method: PlayingCardDeck>>ifEmpty:ifNotEmpty: (in category 'dropping/grabbing') -----
- ifEmpty: aBlock1 ifNotEmpty: aBlock2
-
- self hasSubmorphs not
- ifTrue: [^aBlock1 value]
- ifFalse: [^aBlock2 value]!
Item was removed:
- ----- Method: PlayingCardDeck>>inStackingOrder: (in category 'dropping/grabbing') -----
- inStackingOrder: aPlayingCard
-
- ^self inStackingOrder: aPlayingCard event: nil!
Item was removed:
- ----- Method: PlayingCardDeck>>inStackingOrder:event: (in category 'dropping/grabbing') -----
- inStackingOrder: aCard event: evt
-
- self hasSubmorphs
- ifTrue: [^ self inStackingOrder: aCard onTopOf: self topCard]
- ifFalse: [stackingOrder = #ascending ifTrue: [^ aCard cardNumber = 1].
- stackingOrder = #descending ifTrue: [^ aCard cardNumber = 13]].
- ^ false.!
Item was removed:
- ----- Method: PlayingCardDeck>>inStackingOrder:onTopOf: (in category 'dropping/grabbing') -----
- inStackingOrder: aCard onTopOf: cardBelow
- | diff |
- (stackingPolicy = #altStraight and: [aCard suitColor = cardBelow suitColor]) ifTrue: [^ false].
- (stackingPolicy = #straight and: [aCard suit ~= cardBelow suit]) ifTrue: [^ false].
- diff := aCard cardNumber - cardBelow cardNumber.
- stackingOrder = #ascending ifTrue: [^ diff = 1].
- stackingOrder = #descending ifTrue: [^ diff = -1].
- ^ false.!
Item was removed:
- ----- Method: PlayingCardDeck>>initialize (in category 'initialization') -----
- initialize
- super initialize.
- self cellPositioning: #topLeft.
- self reverseTableCells: true.
- self layout: #grid.
- self hResizing: #shrinkWrap.
- self vResizing: #shrinkWrap.
- self borderWidth: 0.
- self layoutInset: 0.
- stackingPolicy := #stagger.
- stackingOrder := #ascending.
- emptyDropPolicy := #any.
- self newSeed.
- ^self!
Item was removed:
- ----- Method: PlayingCardDeck>>insertionIndexFor: (in category 'dropping/grabbing') -----
- insertionIndexFor: aMorph
- "Return the index at which the given morph should be inserted into the submorphs of the receiver."
-
- ^1!
Item was removed:
- ----- Method: PlayingCardDeck>>layout: (in category 'accessing') -----
- layout: aSymbol
- " #grid #pile #stagger"
- layout := aSymbol.
- layout == #grid
- ifTrue:[self maxCellSize: SmallInteger maxVal].
- layout == #pile
- ifTrue:[self maxCellSize: 0].
- layout == #stagger
- ifTrue:[self maxCellSize: self staggerOffset].!
Item was removed:
- ----- Method: PlayingCardDeck>>newDeck (in category 'initialization') -----
- newDeck
- | cards |
- cards := OrderedCollection new: 52.
- PlayingCardMorph suits
- do: [:suit | 1 to: 13
- do: [:cardNo | cards add: (PlayingCardMorph the: cardNo of: suit)]].
- self addAllMorphs: cards.
- ^self!
Item was removed:
- ----- Method: PlayingCardDeck>>newSeed (in category 'accessing') -----
- newSeed
- seed := (1 to: 32000) atRandom!
Item was removed:
- ----- Method: PlayingCardDeck>>newSuit: (in category 'initialization') -----
- newSuit: suit
- | cards |
- cards := OrderedCollection new: 13.
- 1 to: 13 do: [:cardNo | cards add: (PlayingCardMorph the: cardNo of: suit)].
- self addAllMorphs: cards.
- ^self!
Item was removed:
- ----- Method: PlayingCardDeck>>nilOrSymbol: (in category 'private') -----
- nilOrSymbol: aSymbolOrString
-
- (nil = aSymbolOrString or:
- ['nil' = aSymbolOrString or:
- [aSymbolOrString isEmpty]])
- ifTrue: [^nil]
- ifFalse: [^aSymbolOrString asSymbol]!
Item was removed:
- ----- Method: PlayingCardDeck>>printOn: (in category 'printing') -----
- printOn: aStream
- | cards |
- cards := self cards.
- aStream nextPutAll: 'aCardDeck('.
- cards size > 1
- ifTrue:
- [cards allButLast do:
- [:card |
- aStream
- print: card;
- nextPutAll: ', ']].
- cards notEmpty ifTrue: [aStream print: cards last].
- aStream nextPut: $)!
Item was removed:
- ----- Method: PlayingCardDeck>>removeAllCards (in category 'accessing') -----
- removeAllCards
- self removeAllMorphs!
Item was removed:
- ----- Method: PlayingCardDeck>>repelCard: (in category 'dropping/grabbing') -----
- repelCard: aCard
- stackingPolicy = #none ifTrue: [^ self repelCard: aCard default: true].
- stackingPolicy = #single ifTrue: [^ self ifEmpty: [self repelCard: aCard default: false]
- ifNotEmpty: [true]].
- (stackingPolicy = #altStraight or: [stackingPolicy = #straight])
- ifTrue: [self ifEmpty: [^ self repelCard: aCard default: (self emptyDropNotOk: aCard)]
- ifNotEmpty: [(self inStackingOrder: aCard onTopOf: self topCard)
- ifFalse: [^ self repelCard: aCard default: true]]].
- ^ false!
Item was removed:
- ----- Method: PlayingCardDeck>>repelCard:default: (in category 'dropping/grabbing') -----
- repelCard: aCard default: aBoolean
-
- ^(self acceptCard: aCard default: aBoolean not) not!
Item was removed:
- ----- Method: PlayingCardDeck>>repelsMorph:event: (in category 'dropping/grabbing') -----
- repelsMorph: aMorph event: evt
-
- (aMorph isKindOf: PlayingCardMorph)
- ifTrue: [^self repelCard: aMorph]
- ifFalse: [^true]!
Item was removed:
- ----- Method: PlayingCardDeck>>reverse (in category 'shuffling/dealing') -----
- reverse
- self invalidRect: self fullBounds.
- submorphs := submorphs reversed.
- self layoutChanged.!
Item was removed:
- ----- Method: PlayingCardDeck>>rootForGrabOf: (in category 'dropping/grabbing') -----
- rootForGrabOf: aCard
- self hasSubmorphs ifFalse: [^nil].
- (target notNil and: [cardDraggedSelector notNil])
- ifTrue:
- [^target
- perform: cardDraggedSelector
- with: aCard
- with: self]
- ifFalse: [^self firstSubmorph]!
Item was removed:
- ----- Method: PlayingCardDeck>>seed (in category 'accessing') -----
- seed
-
- ^seed!
Item was removed:
- ----- Method: PlayingCardDeck>>seed: (in category 'accessing') -----
- seed: anInteger
-
- seed := anInteger!
Item was removed:
- ----- Method: PlayingCardDeck>>shuffle (in category 'shuffling/dealing') -----
- shuffle
- self invalidRect: self fullBounds.
- submorphs := submorphs shuffledBy: (Random new seed: seed).
- self layoutChanged.!
Item was removed:
- ----- Method: PlayingCardDeck>>stackingOrder: (in category 'accessing') -----
- stackingOrder: aSymbol
- "#ascending #descending"
-
- stackingOrder := aSymbol!
Item was removed:
- ----- Method: PlayingCardDeck>>stackingPolicy (in category 'accessing') -----
- stackingPolicy
-
- ^ stackingPolicy!
Item was removed:
- ----- Method: PlayingCardDeck>>stackingPolicy: (in category 'accessing') -----
- stackingPolicy: aSymbol
- "#straight #altStraight #single #none"
-
- stackingPolicy := aSymbol!
Item was removed:
- ----- Method: PlayingCardDeck>>staggerOffset (in category 'layout') -----
- staggerOffset
- ^18 px!
Item was removed:
- ----- Method: PlayingCardDeck>>subDeckStartingAt: (in category 'accessing') -----
- subDeckStartingAt: aCard
- | i subDeck |
-
- i := submorphs indexOf: aCard ifAbsent: [^ aCard].
- i = 1 ifTrue: [^aCard].
- subDeck := PlayingCardDeck new.
- (submorphs copyFrom: 1 to: i-1) do:
- [:m | m class = aCard class ifTrue: [subDeck addMorphBack: m]].
- ^subDeck.
- !
Item was removed:
- ----- Method: PlayingCardDeck>>target: (in category 'accessing') -----
- target: anObject
-
- target := anObject!
Item was removed:
- ----- Method: PlayingCardDeck>>topCard (in category 'accessing') -----
- topCard
-
- ^self firstSubmorph!
Item was removed:
- ImageMorph subclass: #PlayingCardMorph
- instanceVariableNames: 'cardNumber suitNumber'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !PlayingCardMorph commentStamp: '<historical>' prior: 0!
- This class displays images from the PlayingCard class as morphs. It attempts to be space-efficient by only producing its images on demand.!
Item was removed:
- ----- Method: PlayingCardMorph class>>cardSize (in category 'access') -----
- cardSize
- " a real hack, but I don't want to muck with Dan's class "
- ^71 px @ 96 px!
Item was removed:
- ----- Method: PlayingCardMorph class>>height (in category 'access') -----
- height
- ^self cardSize y!
Item was removed:
- ----- Method: PlayingCardMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: PlayingCardMorph class>>suits (in category 'access') -----
- suits
- ^ #(clubs diamonds hearts spades)!
Item was removed:
- ----- Method: PlayingCardMorph class>>test (in category 'testing') -----
- test "Display all cards in the deck"
- "MessageTally spyOn: [20 timesRepeat: [PlayingCardMorph test]]"
- | table row |
- table := AlignmentMorph newColumn.
- self suits do: [:suit |
- row := AlignmentMorph newRow.
- table addMorph: row.
- 1 to: 13 do: [:cn |
- row addMorph:
- (PlayingCardMorph the: cn of: suit)]].
- table openInWorld.!
Item was removed:
- ----- Method: PlayingCardMorph class>>the:of: (in category 'initialize-release') -----
- the: cardNumber of: suit
-
- | image |
- image := (PlayingCard the: cardNumber of: suit) cardForm.
- image := image scaledToSize: image extent * RealEstateAgent scaleFactor.
- ^ self new
- image: image;
- cardNumber: cardNumber suitNumber: (self suits indexOf: suit)!
Item was removed:
- ----- Method: PlayingCardMorph class>>width (in category 'access') -----
- width
- ^self cardSize x!
Item was removed:
- ----- Method: PlayingCardMorph>>aboutToBeGrabbedBy: (in category 'dropping/grabbing') -----
- aboutToBeGrabbedBy: aHand
- "I'm about to be grabbed by the hand. If other cards are above me in a deck,
- then move them from the deck to being submorphs of me"
- | i |
- super aboutToBeGrabbedBy: aHand.
- self removeProperty: #undoGrabCommand. "So it won't interfere with overall move"
- self board captureStateBeforeGrab.
- i := owner submorphs indexOf: self ifAbsent: [^ self].
- i = 1 ifTrue: [^ self].
- (owner submorphs copyFrom: 1 to: i-1) do:
- [:m | m class = self class ifTrue: [self addMorphBack: m]].
- !
Item was removed:
- ----- Method: PlayingCardMorph>>board (in category 'access') -----
- board
-
- ^ owner owner owner!
Item was removed:
- ----- Method: PlayingCardMorph>>cardDeck (in category 'access') -----
- cardDeck
-
- ^self owner!
Item was removed:
- ----- Method: PlayingCardMorph>>cardNumber (in category 'access') -----
- cardNumber
- ^cardNumber!
Item was removed:
- ----- Method: PlayingCardMorph>>cardNumber:suitNumber: (in category 'access') -----
- cardNumber: c suitNumber: s
- cardNumber := c.
- suitNumber := s.!
Item was removed:
- ----- Method: PlayingCardMorph>>click: (in category 'event handling') -----
- click: evt
-
- "since we really want to know about double-clicks before making our move, ignore this and wait until #firstClickTimedOut: arrives"!
Item was removed:
- ----- Method: PlayingCardMorph>>doubleClick: (in category 'event handling') -----
- doubleClick: evt
-
- ^self cardDeck doubleClickOnCard: self!
Item was removed:
- ----- Method: PlayingCardMorph>>firstClickTimedOut: (in category 'event handling') -----
- firstClickTimedOut: evt
- | root popUp |
- root := owner rootForGrabOf: self.
- root isNil
- ifTrue:
- ["Display hidden card in front"
-
- popUp := self copy.
- self board owner owner addMorphFront: popUp.
- self world displayWorld.
- (Delay forMilliseconds: 750) wait.
- popUp delete]
- ifFalse: [evt hand grabMorph: root]!
Item was removed:
- ----- Method: PlayingCardMorph>>handlesMouseDown: (in category 'event handling') -----
- handlesMouseDown: evt
-
- ^ true!
Item was removed:
- ----- Method: PlayingCardMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
- justDroppedInto: newOwner event: evt
-
- (newOwner isKindOf: PlayingCardDeck)
- ifFalse: ["Can't drop a card anywhere but on a deck"
- self rejectDropMorphEvent: evt].
- ^super justDroppedInto: newOwner event: evt!
Item was removed:
- ----- Method: PlayingCardMorph>>mouseDown: (in category 'event handling') -----
- mouseDown: evt
- "Do nothing upon mouse-down except inform the hand to watch for a double-click; wait until an ensuing click:, doubleClick:, or drag: message gets dispatched"
-
- evt hand waitForClicksOrDrag: self event: evt selectors: { #click:. #doubleClick:. #firstClickTimedOut:. nil} threshold: 5!
Item was removed:
- ----- Method: PlayingCardMorph>>printOn: (in category 'printing') -----
- printOn: aStream
-
- aStream
- print: cardNumber;
- nextPutAll: ' of ';
- print: (self class suits at: suitNumber).!
Item was removed:
- ----- Method: PlayingCardMorph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
- slideBackToFormerSituation: evt
-
- super slideBackToFormerSituation: evt.
- self board removeProperty: #stateBeforeGrab.
- self hasSubmorphs ifTrue:
- ["Just cancelled a drop of multiple cards -- have to unload submorphs"
- self submorphs reverseDo: [:m | owner addMorphFront: m]].
- !
Item was removed:
- ----- Method: PlayingCardMorph>>suit (in category 'access') -----
- suit
- ^self class suits at: suitNumber!
Item was removed:
- ----- Method: PlayingCardMorph>>suitColor (in category 'access') -----
- suitColor
- ^#(black red red black) at: suitNumber!
Item was removed:
- ----- Method: PlayingCardMorph>>suitNumber (in category 'access') -----
- suitNumber
-
- ^suitNumber!
Item was removed:
- ----- Method: ProjectLoading class>>checkSecurity:preStream:projStream: (in category '*etoys') -----
- checkSecurity: aFileName preStream: preStream projStream: projStream
- "Answer true if passed"
- | trusted enterRestricted |
- trusted := SecurityManager default positionToSecureContentsOf:
- projStream.
- trusted ifFalse:
- [enterRestricted := (preStream isTypeHTTP or:
- [aFileName isNil])
- ifTrue: [Preferences securityChecksEnabled]
- ifFalse: [Preferences standaloneSecurityChecksEnabled].
- enterRestricted
- ifTrue: [SecurityManager default enterRestrictedMode
- ifFalse:
- [preStream close.
- ^ false]]].
- ^ true
- !
Item was changed:
+ ----- Method: ProjectLoading class>>checkStream: (in category '*Etoys') -----
- ----- Method: ProjectLoading class>>checkStream: (in category '*etoys') -----
checkStream: aStream
(aStream isNil
or: [aStream size = 0])
ifFalse: [^ false].
ProgressNotification signal: '9999 about to enter
project'.
"the hard part is over"
self inform: 'It looks like a problem occurred while
getting this project. It may be temporary,
so you may want to try again,' translated.
^ true!
Item was changed:
+ ----- Method: ProjectLoading class>>fileInName:archive:morphOrList: (in category '*Etoys') -----
- ----- Method: ProjectLoading class>>fileInName:archive:morphOrList: (in category '*etoys') -----
fileInName: aFileName archive: archive morphOrList: morphOrList
| baseChangeSet substituteFont numberOfFontSubstitutes exceptions anObject mgr |
ResourceCollector current: ResourceCollector new.
baseChangeSet := ChangeSet current.
self useTempChangeSet. "named zzTemp"
"The actual reading happens here"
substituteFont := Preferences standardEToysFont copy.
numberOfFontSubstitutes := 0.
exceptions := Set new.
[[anObject := morphOrList fileInObjectAndCodeForProject]
on: MissingFont do: [ :ex |
exceptions add: ex.
numberOfFontSubstitutes := numberOfFontSubstitutes + 1.
ex resume: substituteFont ]]
ensure: [ ChangeSet newChanges: baseChangeSet].
mgr := ResourceManager new initializeFrom: ResourceCollector current.
mgr fixJISX0208Resource.
mgr registerUnloadedResources.
archive ifNotNil:[mgr preLoadFromArchive: archive cacheName: aFileName].
ResourceCollector current: nil.
^ {anObject. numberOfFontSubstitutes. substituteFont. mgr}!
Item was changed:
+ ----- Method: ProjectLoading class>>loadFromImagePath: (in category '*Etoys') -----
- ----- Method: ProjectLoading class>>loadFromImagePath: (in category '*etoys') -----
loadFromImagePath: projectName
"Open the project in image path. This is used with projects in OLPC distribution.
- The image's directory is used.
- Squeaklets directory is ignored.
- If there is a project named projectName, it is opened.
"
"self openFromImagePath: 'Welcome'"
| directory aStream entries fileName |
(Project named: projectName)
ifNotNil: [:project | ^ project].
directory := FileDirectory on: Smalltalk imagePath.
entries := Project latestProjectVersionsFromFileEntries: directory entries.
fileName := (entries
detect: [:each | (Project parseProjectFileName: each name) first = projectName]
ifNone: [^ nil]) name.
'Loading a Project...' displaySequentialProgress: [ProgressNotification signal: '0'.
directory := FileDirectory on: Smalltalk imagePath.
aStream := directory readOnlyFileNamed: fileName.
^ self
loadName: fileName
stream: aStream
fromDirectory: directory
withProjectView: nil]!
Item was changed:
+ ----- Method: ProjectLoading class>>loadImageSegment:fromDirectory:withProjectView:numberOfFontSubstitutes:substituteFont:mgr: (in category '*Etoys') -----
- ----- Method: ProjectLoading class>>loadImageSegment:fromDirectory:withProjectView:numberOfFontSubstitutes:substituteFont:mgr: (in category '*etoys') -----
loadImageSegment: morphOrList fromDirectory: aDirectoryOrNil withProjectView: existingView numberOfFontSubstitutes: numberOfFontSubstitutes substituteFont: substituteFont mgr: mgr
| proj projectsToBeDeleted ef f |
(f := (Flaps globalFlapTabWithID: 'Navigator' translated)) ifNotNil: [f hideFlap].
proj := morphOrList arrayOfRoots
detect: [:mm | mm isKindOf: Project]
ifNone: [^ nil].
numberOfFontSubstitutes > 0 ifTrue: [
proj projectParameterAt: #substitutedFont put: substituteFont].
ef := proj projectParameterAt: #eToysFont.
(ef isNil or: [ef ~= substituteFont familySizeFace]) ifTrue: [
proj projectParameterAt: #substitutedFont put: substituteFont.
].
proj projectParameters at: #MultiSymbolInWrongPlace put: false.
"Yoshiki did not put MultiSymbols into outPointers in older images!!"
morphOrList arrayOfRoots do: [:obj |
obj fixUponLoad: proj seg: morphOrList "imageSegment"].
(proj projectParameters at: #MultiSymbolInWrongPlace) ifTrue: [
morphOrList arrayOfRoots do: [:obj | (obj isKindOf: HashedCollection ) ifTrue: [obj rehash]]].
proj resourceManager: mgr.
"proj versionFrom: preStream."
proj lastDirectory: aDirectoryOrNil.
proj setParent: Project current.
projectsToBeDeleted := OrderedCollection new.
existingView == #none ifFalse: [
self makeExistingView: existingView project: proj projectsToBeDeleted: projectsToBeDeleted].
ChangeSet allChangeSets add: proj changeSet.
Project current projectParameters
at: #deleteWhenEnteringNewProject
ifPresent: [ :ignored |
projectsToBeDeleted add: Project current.
Project current removeParameter: #deleteWhenEnteringNewProject.
].
projectsToBeDeleted isEmpty ifFalse: [
proj projectParameters
at: #projectsToBeDeleted
put: projectsToBeDeleted.
].
proj removeParameter: #eToysFont.
^ proj!
Item was changed:
+ ----- Method: ProjectLoading class>>loadName:stream:fromDirectory:withProjectView: (in category '*Etoys') -----
- ----- Method: ProjectLoading class>>loadName:stream:fromDirectory:withProjectView: (in category '*etoys') -----
loadName: aFileName stream: preStream fromDirectory: aDirectoryOrNil
withProjectView: existingView
^ self loadName: aFileName stream: preStream fromDirectory: aDirectoryOrNil
withProjectView: existingView clearOriginFlag: false.
!
Item was changed:
+ ----- Method: ProjectLoading class>>loadName:stream:fromDirectory:withProjectView:clearOriginFlag: (in category '*Etoys') -----
- ----- Method: ProjectLoading class>>loadName:stream:fromDirectory:withProjectView:clearOriginFlag: (in category '*etoys') -----
loadName: aFileName stream: preStream fromDirectory: aDirectoryOrNil
withProjectView: existingView clearOriginFlag: clearOriginFlag
"Reconstitute a Morph from the selected file, presumed to be
represent a Morph saved via the SmartRefStream mechanism, and open it
in an appropriate Morphic world."
| morphOrList archive mgr substituteFont numberOfFontSubstitutes resultArray anObject project manifests dict |
(self checkStream: preStream) ifTrue: [^ nil].
ProgressNotification signal: '0.2'.
archive := preStream isZipArchive
ifTrue:[ZipArchive new readFrom: preStream]
ifFalse:[nil].
manifests := (archive membersMatching: '*manifest').
(manifests size = 1 and: [((dict := self parseManifest: manifests first contents) at: 'Project-Format' ifAbsent: []) = 'S-Expression'])
ifTrue: [^ self loadSexpProjectDict: dict stream: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView].
morphOrList := self morphOrList: aFileName stream: preStream fromDirectory: aDirectoryOrNil archive: archive.
morphOrList ifNil: [^ nil].
ProgressNotification signal: '0.4'.
resultArray := self fileInName: aFileName archive: archive morphOrList: morphOrList.
anObject := resultArray first.
numberOfFontSubstitutes := resultArray second.
substituteFont := resultArray third.
mgr := resultArray fourth.
preStream close.
ProgressNotification signal: '0.7'.
"the hard part is over"
(anObject isKindOf: ImageSegment) ifTrue: [
project := self loadImageSegment: anObject
fromDirectory: aDirectoryOrNil
withProjectView: existingView
numberOfFontSubstitutes: numberOfFontSubstitutes
substituteFont: substituteFont
mgr: mgr.
project noteManifestDetailsIn: dict.
project removeParameter: #sugarProperties.
Smalltalk at: #SugarPropertiesNotification ifPresent: [:notification |
notification signal ifNotNil: [:props |
project keepSugarProperties: props monitor: true]].
clearOriginFlag ifTrue: [project forgetExistingURL].
ProgressNotification signal: '0.8'.
^ project
].!
Item was changed:
+ ----- Method: ProjectLoading class>>loadSexpProjectDict:stream:fromDirectory:withProjectView: (in category '*Etoys') -----
- ----- Method: ProjectLoading class>>loadSexpProjectDict:stream:fromDirectory:withProjectView: (in category '*etoys') -----
loadSexpProjectDict: dict stream: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView
| archive anObject newProj d member memberStream members newSet allNames realName oldSet s |
(self checkStream: preStream) ifTrue: [^ nil].
ProgressNotification signal: '0.2'.
preStream reset.
archive := preStream isZipArchive
ifTrue:[ZipArchive new readFrom: preStream]
ifFalse:[nil].
members := archive membersMatching: '*.cs'.
members do: [:e | newSet := ChangeSet newChangesFromStream: e contentStream named: 'zzTemp', Time totalSeconds printString].
member := (archive membersMatching: '*.sexp') first.
memberStream := member contentStream.
(self checkSecurity: member name preStream: preStream projStream: memberStream)
ifFalse: [^nil].
self flag: #tfel. "load all projects and save them again in the new format, then get rid of the error block!!"
s := memberStream basicUpToEnd.
d := [(DataStream on: memberStream) next] on: Error do: [:e |
(Smalltalk at: #MSExpParser) parse: s with: #ksexp].
anObject := d sissReadObjectsAsEtoysProject.
preStream close.
"anObject := (MSExpParser parse: (archive membersMatching: '*.sexp') first contents with: #ksexp) sissReadObjects."
anObject ifNil: [^ nil].
(anObject isKindOf: PasteUpMorph) ifFalse: [^ Project current world addMorph: anObject].
ProgressNotification signal: '0.7'.
newProj := MorphicProject new.
newProj installPasteUpAsWorld: anObject.
newSet ifNotNil: [oldSet := newProj changeSet. newProj setChangeSet: newSet. ChangeSet removeChangeSet: oldSet].
dict at: 'projectname' ifPresent: [:n |
allNames := Project allNames.
realName := Utilities keyLike: n satisfying:
[:nn | (allNames includes: nn) not].
newProj renameTo: realName.
].
anObject valueOfProperty: #projectVersion ifPresentDo: [:v | newProj version: v].
newProj noteManifestDetailsIn: dict.
ProgressNotification signal: '0.8'.
^ newProj.!
Item was removed:
- ----- Method: ProjectLoading class>>makeExistingView:project:projectsToBeDeleted: (in category '*etoys') -----
- makeExistingView: existingView project: proj projectsToBeDeleted: projectsToBeDeleted
- existingView ifNil: [
- Smalltalk isMorphic ifTrue: [
- proj createViewIfAppropriate.
- ] ifFalse: [
- ChangeSet allChangeSets add: proj changeSet.
- Project current openProject: proj.
- "Note: in MVC we get no further than the above"
- ].
- ] ifNotNil: [
- (existingView project isKindOf: DiskProxy) ifFalse: [
- existingView project changeSet name:
- ChangeSet defaultName.
- projectsToBeDeleted add: existingView project.
- ].
- (existingView owner isSystemWindow) ifTrue: [
- existingView owner model: proj
- ].
- existingView project: proj.
- ].
- !
Item was removed:
- ----- Method: ProjectLoading class>>morphOrList:stream:fromDirectory:archive: (in category '*etoys') -----
- morphOrList: aFileName stream: preStream fromDirectory: aDirectoryOrNil archive: archive
- "Answer morphOrList or nil if problem happened"
- | projStream localDir morphOrList |
- projStream := archive
- ifNil: [preStream]
- ifNotNil: [self projectStreamFromArchive: archive].
- (self checkSecurity: aFileName preStream: preStream projStream: projStream)
- ifFalse: [^nil].
- localDir := Project squeakletDirectory.
- aFileName ifNotNil: [
- (aDirectoryOrNil isNil or: [aDirectoryOrNil pathName
- ~= localDir pathName]) ifTrue: [
- localDir deleteFileNamed: aFileName.
- (localDir fileNamed: aFileName) binary
- nextPutAll: preStream remainingContents;
- close.
- ].
- ].
- morphOrList := projStream asUnZippedStream.
- preStream sleep. "if ftp, let the connection close"
- ^ morphOrList
- !
Item was changed:
+ ----- Method: ProjectLoading class>>openFromImagePath: (in category '*Etoys') -----
- ----- Method: ProjectLoading class>>openFromImagePath: (in category '*etoys') -----
openFromImagePath: projectName
| project |
project := self loadFromImagePath: projectName.
project
ifNil: [self inform: 'That didn''t work. Sorry' translated]
ifNotNil: [project enter].!
Item was removed:
- ----- Method: ProjectLoading class>>parseManifest: (in category '*etoys') -----
- parseManifest: aString
-
- | dict line index key value aStream |
- aStream := aString readStream.
- dict := Dictionary new.
- [(line := aStream nextLine) notNil] whileTrue: [
- index := line indexOf: $:.
- index > 0 ifTrue: [
- key := line copyFrom: 1 to: index - 1.
- value := (line copyFrom: index + 1 to: line size) withBlanksTrimmed.
- dict at: key put: value.
- ].
- ].
- ^ dict.!
Item was removed:
- AlignmentMorph subclass: #SameGame
- instanceVariableNames: 'board scoreDisplay selectionDisplay helpText'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !SameGame commentStamp: '<historical>' prior: 0!
- See SameGame>>helpString for an explanation of how to play!
Item was removed:
- ----- Method: SameGame class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'Same' translatedNoop
- categories: {'Games' translatedNoop}
- documentation: 'A board game implementedby Tim Olson, based on a game originally written for UNIX by Eiji Fukumoto.' translatedNoop!
Item was removed:
- ----- Method: SameGame>>board (in category 'access') -----
- board
-
- board ifNil:
- [board := SameGameBoard new
- target: self;
- actionSelector: #selection].
- ^ board!
Item was removed:
- ----- Method: SameGame>>board: (in category 'access') -----
- board: aSameGameBoard
-
- board := aSameGameBoard!
Item was removed:
- ----- Method: SameGame>>buildButton:target:label:selector: (in category 'initialization') -----
- buildButton: aButton target: aTarget label: aLabel selector: aSelector
- "wrap a button or switch in an alignmentMorph to allow a row of buttons to fill space"
-
- | a |
- aButton
- target: aTarget;
- label: aLabel;
- actionSelector: aSelector;
- borderStyle: (BorderStyle raised width: 2 px);
- color: color.
- a := AlignmentMorph newColumn
- wrapCentering: #center; cellPositioning: #topCenter;
- hResizing: #spaceFill;
- vResizing: #shrinkWrap;
- color: color.
- a addMorph: aButton.
- ^ a!
Item was removed:
- ----- Method: SameGame>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color lightGray!
Item was removed:
- ----- Method: SameGame>>help: (in category 'actions') -----
- help: helpState
-
- helpState
- ifTrue: [helpText := self helpText.
- "Text layout is broken, so add text and apply #spaceFill to make line breaks work"
- self addMorphBack: helpText.
- helpText textMorph hResizing: #spaceFill]
- ifFalse: [helpText delete]!
Item was removed:
- ----- Method: SameGame>>helpString (in category 'access') -----
- helpString
- ^ 'The object of SameGame is to maximize your score by removing tiles from the board. Tiles are selected and removed by clicking on a tile that has at least one adjacent tile of the same color (where adjacent is defined as up, down, left, or right).
-
- The first click selects a group of adjacent tiles, a second click in that group will remove it from the board, sliding tiles down and right to fill the space of the removed group. If you wish to select a different group, simply click on it instead.
-
- The score increases by "(selection - 2) squared", so you want to maximize the selection size as much as possible. However, making small strategic selections may allow you to increase the size of a later selection.
-
- If you are having a hard time finding a group, the "Hint" button will find one and select it for you (although it is likely not the best group to select!!).
-
- When there are no more groups available, the score display will flash with your final score. Your final score is reduced by 1 for each tile remaining on the board. If you manage to remove all tiles, your final score is increased by a bonus of 5 times the number of tiles on a full board.
-
- Come on, you can beat that last score!! Click "New game" ;-)
-
- SameGame was originally written by Eiji Fukumoto for UNIX and X; this version is based upon the same game concept, but was rewritten from scratch.' translated!
Item was removed:
- ----- Method: SameGame>>helpText (in category 'access') -----
- helpText
-
- helpText ifNil:
- [helpText := PluggableTextMorph new
- width: board width;
- editString: self helpString].
- ^ helpText!
Item was removed:
- ----- Method: SameGame>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
- self listDirection: #topToBottom;
- wrapCentering: #center;
- cellPositioning: #topCenter;
- vResizing: #shrinkWrap;
- hResizing: #shrinkWrap;
- layoutInset: 3 px;
- addMorph: self makeControls;
- addMorph: self board.
- helpText := nil.
- self newGame!
Item was removed:
- ----- Method: SameGame>>makeControls (in category 'initialization') -----
- makeControls
-
- | row |
- row := AlignmentMorph newRow
- color: color;
- borderWidth: 0;
- layoutInset: 3 px.
- row hResizing: #spaceFill; vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; extent: 5 px @ 5 px.
- row addMorph:
- (self
- buildButton: SimpleSwitchMorph new
- target: self
- label: 'Help' translated
- selector: #help:).
- row addMorph:
- (self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'Quit' translated
- selector: #delete).
- row addMorph:
- (self
- buildButton: SimpleButtonMorph new
- target: self board
- label: 'Hint' translated
- selector: #hint).
- row addMorph:
- (self
- buildButton: SimpleButtonMorph new
- target: self
- label: 'New game' translated
- selector: #newGame).
- selectionDisplay := LedMorph new
- digits: 2;
- extent: (10 px * 2 @ 15 px).
- row addMorph: (self wrapPanel: selectionDisplay label: 'Selection:' translated).
- scoreDisplay := LedMorph new
- digits: 4;
- extent: (10 px * 4 @ 15 px).
- row addMorph: (self wrapPanel: scoreDisplay label: 'Score:' translated).
- ^ row!
Item was removed:
- ----- Method: SameGame>>newGame (in category 'actions') -----
- newGame
-
- scoreDisplay value: 0; flash: false.
- selectionDisplay value: 0.
- self board resetBoard.!
Item was removed:
- ----- Method: SameGame>>scoreDisplay (in category 'access') -----
- scoreDisplay
-
- ^ scoreDisplay!
Item was removed:
- ----- Method: SameGame>>selection (in category 'actions') -----
- selection
- "a selection was made on the board; get its count and update the displays"
-
- | count score |
- count := self board selectionCount.
- count = 0
- ifTrue:
- [score := scoreDisplay value + (selectionDisplay value - 2) squared.
- board findSelection ifNil:
- [count := board tilesRemaining.
- score := count = 0
- ifTrue: [score + (5 * board rows * board columns)]
- ifFalse: [score - count max:0].
- scoreDisplay flash: true].
- scoreDisplay value: score].
- selectionDisplay value: count!
Item was removed:
- ----- Method: SameGame>>wrapPanel:label: (in category 'initialization') -----
- wrapPanel: anLedPanel label: aLabel
- "wrap an LED panel in an alignmentMorph with a label to its left"
-
- | a |
- a := AlignmentMorph newRow
- wrapCentering: #center; cellPositioning: #leftCenter;
- hResizing: #shrinkWrap;
- vResizing: #shrinkWrap;
- borderWidth: 0;
- layoutInset: 3;
- color: color lighter.
- a addMorph: anLedPanel.
- a addMorph: (StringMorph contents: aLabel).
- ^ a
-
- !
Item was removed:
- AlignmentMorph subclass: #SameGameBoard
- instanceVariableNames: 'protoTile rows columns palette selection selectionColor flashColor flash target actionSelector arguments'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !SameGameBoard commentStamp: '<historical>' prior: 0!
- I am an MxN array of SameGameTiles, and implement most of the logic to play the SameGame, including adjacent tile selection and removal.!
Item was removed:
- ----- Method: SameGameBoard class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: SameGameBoard>>acceptDroppingMorph:event: (in category 'layout') -----
- acceptDroppingMorph: aMorph event: evt
- "Allow the user to set the protoTile just by dropping it on this morph."
-
- self protoTile: aMorph.
- self removeAllMorphs.
- !
Item was removed:
- ----- Method: SameGameBoard>>actionSelector (in category 'accessing') -----
- actionSelector
-
- ^ actionSelector!
Item was removed:
- ----- Method: SameGameBoard>>actionSelector: (in category 'accessing') -----
- actionSelector: aSymbolOrString
-
- (nil = aSymbolOrString or:
- ['nil' = aSymbolOrString or:
- [aSymbolOrString isEmpty]])
- ifTrue: [^ actionSelector := nil].
-
- actionSelector := aSymbolOrString asSymbol.
- !
Item was removed:
- ----- Method: SameGameBoard>>adjustTiles (in category 'private') -----
- adjustTiles
- "add or remove new protoTile submorphs to fill out my new bounds"
-
- | newSubmorphs requiredSubmorphs count r c |
- columns := self width // protoTile width.
- rows := self height // protoTile height.
- requiredSubmorphs := rows * columns.
- newSubmorphs := OrderedCollection new.
- r := 0.
- c := 0.
- self submorphCount > requiredSubmorphs
- ifTrue: "resized smaller -- delete rows or columns"
- [count := 0.
- submorphs do:
- [:m |
- count < requiredSubmorphs
- ifTrue:
- [m position: self position + (protoTile extent * (c @ r)).
- m arguments: (Array with: c @ r).
- newSubmorphs add: m]
- ifFalse: [m privateOwner: nil].
- count := count + 1.
- c := c + 1.
- c >= columns ifTrue: [c := 0. r := r + 1]]]
- ifFalse: "resized larger -- add rows or columns"
- [submorphs do:
- [:m |
- m position: self position + (self protoTile extent * (c @ r)).
- m arguments: (Array with: c @ r).
- newSubmorphs add: m.
- c := c + 1.
- c >= columns ifTrue: [c := 0. r := r + 1]].
- 1 to: (requiredSubmorphs - self submorphCount) do:
- [:m |
- newSubmorphs add:
- (protoTile copy
- position: self position + (self protoTile extent * (c @ r));
- actionSelector: #tileClickedAt:newSelection:;
- arguments: (Array with: c @ r);
- target: self;
- privateOwner: self).
- c := c + 1.
- c >= columns ifTrue: [c := 0. r := r + 1]]].
- submorphs := newSubmorphs asArray.
- !
Item was removed:
- ----- Method: SameGameBoard>>capturedState (in category 'undo') -----
- capturedState
- "Note the state stored in the second element is an array of associations
- from submorph index to a shallowCopy of the morph, but only for those
- morphs that change. Therefore the capturedState record *first* delivers
- all the morphs, and *then* computes the difference and stores this back.
- In the end, both undo and redo records follow this format."
-
- | prior state oldMorphs priorChanges newChanges |
- (prior := self valueOfProperty: #priorState) isNil
- ifTrue:
- [state := {
- self shallowCopy. "selection, etc."
- self submorphs collect: [:m | m shallowCopy]. "state of all tiles"
- owner scoreDisplay flash. "score display"
- owner scoreDisplay value}.
- self setProperty: #priorState toValue: state.
- ^state].
- oldMorphs := prior second.
- priorChanges := OrderedCollection new.
- newChanges := OrderedCollection new.
- 1 to: oldMorphs size
- do:
- [:i |
- (oldMorphs at: i) color = (submorphs at: i) color
- ifFalse:
- [priorChanges addLast: i -> (oldMorphs at: i).
- newChanges addLast: i -> (submorphs at: i) shallowCopy]].
- self removeProperty: #priorState.
- prior at: 2 put: priorChanges asArray. "Store back into undo state.2"
- ^{
- self shallowCopy. "selection, etc."
- newChanges asArray. "state of tiles that changed"
- owner scoreDisplay flash. "score display"
- owner scoreDisplay value}!
Item was removed:
- ----- Method: SameGameBoard>>collapseColumn:fromRow: (in category 'actions') -----
- collapseColumn: col fromRow: row
-
- | targetTile sourceTile |
- (targetTile := self tileAt: col@row) disabled ifTrue:
- [row - 1 to: 0 by: -1 do:
- [:r |
- (sourceTile := self tileAt: col@r) disabled ifFalse:
- [targetTile color: sourceTile color.
- targetTile disabled: false.
- sourceTile disabled: true.
- ^ true]]].
- ^ false
- !
Item was removed:
- ----- Method: SameGameBoard>>collapseColumns: (in category 'actions') -----
- collapseColumns: columnsToCollapse
-
- | columnsToRemove |
- columnsToRemove := OrderedCollection new.
- columnsToCollapse do:
- [:c |
- rows - 1 to: 0 by: -1 do: [:r | self collapseColumn: c fromRow: r].
- (self tileAt: c@(rows-1)) disabled ifTrue: [columnsToRemove add: c]].
- self world displayWorld.
- columnsToRemove reverseDo: [:c | self removeColumn: c].
- !
Item was removed:
- ----- Method: SameGameBoard>>columns (in category 'accessing') -----
- columns
-
- ^ columns!
Item was removed:
- ----- Method: SameGameBoard>>columns: (in category 'accessing') -----
- columns: newColumns
-
- self extent: self protoTile extent * (newColumns @ rows)!
Item was removed:
- ----- Method: SameGameBoard>>columns:rows: (in category 'accessing') -----
- columns: newColumns rows: newRows
-
- self extent: self protoTile extent * (newColumns @ newRows)!
Item was removed:
- ----- Method: SameGameBoard>>defaultBorderWidth (in category 'initialization') -----
- defaultBorderWidth
- "answer the default border width for the receiver"
- ^ 2 px!
Item was removed:
- ----- Method: SameGameBoard>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color gray!
Item was removed:
- ----- Method: SameGameBoard>>deselectSelection (in category 'actions') -----
- deselectSelection
-
- selection ifNotNil:
- [selection do: [:loc | (self tileAt: loc) setSwitchState: false; color: selectionColor].
- selection := nil.
- flash := false]!
Item was removed:
- ----- Method: SameGameBoard>>extent: (in category 'geometry') -----
- extent: aPoint
- "constrain the extent to be a multiple of the protoTile size during resizing"
- super extent: (aPoint truncateTo: protoTile extent).
- self adjustTiles.!
Item was removed:
- ----- Method: SameGameBoard>>findSelection (in category 'actions') -----
- findSelection
- "find a possible selection and return it, or nil if no selection"
-
- | tile k testTile |
- 0 to: rows-1 do:
- [:r |
- 0 to: columns-1 do:
- [:c |
- tile := self tileAt: c@r.
- tile disabled ifFalse:
- [k := tile color.
- c+1 < columns ifTrue:
- [testTile := self tileAt: (c+1)@r.
- (testTile disabled not and: [testTile color = k]) ifTrue: [^ tile]].
- r+1 < rows ifTrue:
- [testTile := self tileAt: c@(r+1).
- (testTile disabled not and: [testTile color = k]) ifTrue: [^ tile]]]]].
- ^ nil
- !
Item was removed:
- ----- Method: SameGameBoard>>hint (in category 'actions') -----
- hint
- "find a possible selection and select it"
-
- | tile |
- self deselectSelection.
- tile := self findSelection.
- tile ifNotNil: [tile mouseDown: MouseButtonEvent new]!
Item was removed:
- ----- Method: SameGameBoard>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- target := nil.
- actionSelector := #selection.
- arguments := #().
- self layoutPolicy: nil.
- self hResizing: #rigid.
- self vResizing: #rigid.
- rows := self preferredRows.
- columns := self preferredColumns.
-
- palette := (Color wheel: self preferredTileTypes + 1) asOrderedCollection.
- flashColor := palette removeLast.
- flash := false.
- self extent: self protoTile extent * (columns @ rows).
- self resetBoard!
Item was removed:
- ----- Method: SameGameBoard>>preferredColumns (in category 'preferences') -----
- preferredColumns
-
- ^ 20!
Item was removed:
- ----- Method: SameGameBoard>>preferredRows (in category 'preferences') -----
- preferredRows
-
- ^ 10!
Item was removed:
- ----- Method: SameGameBoard>>preferredTileTypes (in category 'preferences') -----
- preferredTileTypes
-
- ^ 5!
Item was removed:
- ----- Method: SameGameBoard>>protoTile (in category 'accessing') -----
- protoTile
-
- protoTile ifNil: [protoTile := SameGameTile new].
- ^ protoTile!
Item was removed:
- ----- Method: SameGameBoard>>protoTile: (in category 'accessing') -----
- protoTile: aTile
-
- protoTile := aTile!
Item was removed:
- ----- Method: SameGameBoard>>removeColumn: (in category 'actions') -----
- removeColumn: column
-
- | sourceTile |
- column+1 to: columns-1 do:
- [:c |
- 0 to: rows-1 do:
- [:r |
- sourceTile := self tileAt: c@r.
- (self tileAt: c-1@r)
- color: sourceTile color;
- disabled: sourceTile disabled]].
- 0 to: rows-1 do:
- [:r | (self tileAt: columns-1@r) disabled: true]!
Item was removed:
- ----- Method: SameGameBoard>>removeSelection (in category 'actions') -----
- removeSelection
- selection
- ifNil: [^ self].
- self
- rememberUndoableAction: [selection
- do: [:loc | (self tileAt: loc) setSwitchState: false; disabled: true].
- self collapseColumns: (selection
- collect: [:loc | loc x] as: Set) sorted.
- selection := nil.
- flash := false.
- (target notNil
- and: [actionSelector notNil])
- ifTrue: [target perform: actionSelector withArguments: arguments]]
- named: 'remove selection' translated!
Item was removed:
- ----- Method: SameGameBoard>>resetBoard (in category 'initialization') -----
- resetBoard
- Collection initialize. "randomize"
- selection := nil.
- self purgeAllCommands.
- self submorphsDo:
- [:m |
- m disabled: false.
- m setSwitchState: false.
- m color: palette atRandom].
-
- !
Item was removed:
- ----- Method: SameGameBoard>>rows (in category 'accessing') -----
- rows
-
- ^ rows!
Item was removed:
- ----- Method: SameGameBoard>>rows: (in category 'accessing') -----
- rows: newRows
-
- self extent: self protoTile extent * (columns @ newRows)!
Item was removed:
- ----- Method: SameGameBoard>>selectTilesAdjacentTo: (in category 'actions') -----
- selectTilesAdjacentTo: location
-
- | al at |
- {-1@0. 0@ -1. 1@0. 0@1} do:
- [:offsetPoint |
- al := location + offsetPoint.
- ((al x between: 0 and: columns - 1) and: [al y between: 0 and: rows - 1]) ifTrue:
- [at := self tileAt: al.
- (at color = selectionColor and: [at switchState not and: [at disabled not]]) ifTrue:
- [selection add: al.
- at setSwitchState: true.
- self selectTilesAdjacentTo: al]]]
- !
Item was removed:
- ----- Method: SameGameBoard>>selectionCount (in category 'accessing') -----
- selectionCount
-
- ^ selection isNil
- ifTrue: [0]
- ifFalse: [selection size]!
Item was removed:
- ----- Method: SameGameBoard>>step (in category 'stepping') -----
- step
-
- | newColor |
- selection ifNotNil:
- [newColor := flash
- ifTrue: [selectionColor]
- ifFalse: [flashColor].
- selection do: [:loc | (self tileAt: loc) color: newColor].
- flash := flash not]
- !
Item was removed:
- ----- Method: SameGameBoard>>stepTime (in category 'testing') -----
- stepTime
-
- ^ 500!
Item was removed:
- ----- Method: SameGameBoard>>target (in category 'accessing') -----
- target
-
- ^ target!
Item was removed:
- ----- Method: SameGameBoard>>target: (in category 'accessing') -----
- target: anObject
-
- target := anObject!
Item was removed:
- ----- Method: SameGameBoard>>tileAt: (in category 'accessing') -----
- tileAt: aPoint
-
- ^ submorphs at: (aPoint x + (aPoint y * columns) + 1)!
Item was removed:
- ----- Method: SameGameBoard>>tileClickedAt:newSelection: (in category 'actions') -----
- tileClickedAt: location newSelection: isNewSelection
- | tile |
- isNewSelection
- ifTrue:
- [self deselectSelection.
- tile := self tileAt: location.
- selectionColor := tile color.
- selection := OrderedCollection with: location.
- self selectTilesAdjacentTo: location.
- selection size = 1
- ifTrue: [self deselectSelection]
- ifFalse:
- [(target notNil and: [actionSelector notNil])
- ifTrue: [target perform: actionSelector withArguments: arguments]]]
- ifFalse: [self removeSelection]!
Item was removed:
- ----- Method: SameGameBoard>>tilesRemaining (in category 'private') -----
- tilesRemaining
-
- ^ (submorphs reject: [:m | m disabled]) size
- !
Item was removed:
- ----- Method: SameGameBoard>>undoFromCapturedState: (in category 'undo') -----
- undoFromCapturedState: st
-
- self copyFrom: st first.
- st second do: [:assn | (submorphs at: assn key) copyFrom: assn value].
- selection ifNotNil:
- [selection do: [:loc | (self tileAt: loc) setSwitchState: false; color: selectionColor].
- selection := nil].
- owner scoreDisplay flash: st third. "score display"
- owner scoreDisplay value: st fourth.
- self changed.!
Item was removed:
- SimpleSwitchMorph subclass: #SameGameTile
- instanceVariableNames: 'switchState disabled oldSwitchState'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !SameGameTile commentStamp: '<historical>' prior: 0!
- I am a single tile for the SameGame. I act much like a switch.!
Item was removed:
- ----- Method: SameGameTile class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: SameGameTile>>color: (in category 'accessing') -----
- color: aColor
- super color: aColor.
- self borderColor: aColor.
- onColor := aColor.
- offColor := aColor.
- self changed!
Item was removed:
- ----- Method: SameGameTile>>disabled (in category 'accessing') -----
- disabled
-
- ^ disabled!
Item was removed:
- ----- Method: SameGameTile>>disabled: (in category 'accessing') -----
- disabled: aBoolean
-
- disabled := aBoolean.
- disabled
- ifTrue:
- [self color: owner color.
- self borderColor: owner color]
- ifFalse:
- [self setSwitchState: self switchState]!
Item was removed:
- ----- Method: SameGameTile>>doButtonAction (in category 'button') -----
- doButtonAction
- "Perform the action of this button. The last argument of the message sent to the target is the new state of this switch."
-
- (target notNil and: [actionSelector notNil])
- ifTrue:
- [target perform: actionSelector
- withArguments: (arguments copyWith: switchState)]!
Item was removed:
- ----- Method: SameGameTile>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
- self label: ''.
- self borderWidth: 2 px.
- bounds := 0 @ 0 corner: 16 px @ 16 px.
- offColor := Color gray.
- onColor := Color gray.
- switchState := false.
- oldSwitchState := false.
- disabled := false.
- self useSquareCorners.!
Item was removed:
- ----- Method: SameGameTile>>insetColor (in category 'accessing') -----
- insetColor
- "Use my own color for insets"
- ^color!
Item was removed:
- ----- Method: SameGameTile>>mouseDown: (in category 'event handling') -----
- mouseDown: evt
-
- disabled ifFalse:
- [oldSwitchState := switchState.
- self setSwitchState: (oldSwitchState = false).
- self doButtonAction].
- !
Item was removed:
- ----- Method: SameGameTile>>mouseMove: (in category 'event handling') -----
- mouseMove: evt
-
- "don't do anything, here"!
Item was removed:
- ----- Method: SameGameTile>>mouseUp: (in category 'event handling') -----
- mouseUp: evt
-
- "don't do anything, here"!
Item was removed:
- ----- Method: SameGameTile>>setSwitchState: (in category 'accessing') -----
- setSwitchState: aBoolean
-
- switchState := aBoolean.
- disabled ifFalse:
- [switchState
- ifTrue:
- [self borderInset.
- self color: onColor]
- ifFalse:
- [self borderRaised.
- self color: offColor]]!
Item was removed:
- ----- Method: SameGameTile>>switchState (in category 'accessing') -----
- switchState
-
- ^ switchState!
Item was removed:
- AlignmentMorph subclass: #SpectrumAnalyzerMorph
- instanceVariableNames: 'soundInput statusLight levelMeter graphMorph sonogramMorph fft displayType'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Sound-Interface'!
-
- !SpectrumAnalyzerMorph commentStamp: '<historical>' prior: 0!
- I am a tool for analyzing sound data from a microphone, CD, or other input source in real time. I have several display modes:
-
- signal snapshots of the raw signal data as it arrives
- spectrum frequency spectrum of the signal data as it arrives
- sonogram scrolling plot of the frequency spectrum over time,
- where the vertical axis is frequency, the horizontal
- axis is time, and amount of energy at a given
- frequency is shown as a grayscale value with
- larger values being darker
-
- To use this tool, be sure that you have selected the proper sound source using you host OS facilities. Set the desired sampling rate and FFT size (try 22050 samples/sec and an FFT size of 512) then click on the 'start' button. Use the slider to adjust the level so that the yellow level indicator peaks somewhere between the middle and the right edge at the maximum signal level.
-
- Note that if the level meter peaks hit the right edge, you will get 'clipping', which creates a bunch of spurious high frequency noise in the frequency spectrum. If the display is set to 'signal' mode, you can actually see the tops and bottoms of the waveform being cut off when clipping occurs.
-
- Many machines may not be able to perform spectrum analysis in real time, especially at higher sampling rates and larger FFT sizes. In both 'signal' and 'spectrum' modes, this tool will skip data to try to keep up with real time. However, in 'sonogram' mode it always processes all the data, even if it falls behind. This allows you to get a complete sonogram without dropouts even on a slower machine. However, as the sonogram display falls behind there will be a larger and larger time lag between when a sound is input and when it appears on the display.
-
- The smaller the FFT size, the less frequency resolution you get. The lower the sampling rate, the less total frequency range you get. For an FFT size of N and a sampling rate of R, each of the N/2 'bins' of the frequency spectrum has a frequency resolution of R / N. For example, at a sampleing rate of 22050 samples/second, the total frequency range is 0 to 11025 Hz and an FFT of size 256 would divide this range into 128 bins (the output of an FFT of size N has N/2 bins), each of which covers a frequency band about 86 Hz wide.
-
- To increase time resolution, increase the sampling rate and decrease the FFT size.
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self
- partName: 'Spectrum Analyzer' translatedNoop
- categories: {'Multimedia' translatedNoop}
- documentation: 'A device for analyzing sound input' translatedNoop
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>addButtonRow (in category 'private') -----
- addButtonRow
-
- | r |
- r := AlignmentMorph newRow vResizing: #shrinkWrap.
- r addMorphBack: (self buttonName: 'Menu' translated action: #invokeMenu).
- r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
- r addMorphBack: (self buttonName: 'Start' translated action: #start).
- r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
- r addMorphBack: (self buttonName: 'Stop' translated action: #stop).
- r addMorphBack: (Morph new extent: 12@1; color: Color transparent).
- self addMorphBack: r.
- ^ r fullBounds.
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>addLevelSliderIn: (in category 'private') -----
- addLevelSliderIn: aPoint
-
- | levelSlider r |
- (levelSlider := SimpleSliderMorph new)
- color: color;
- sliderColor: Color gray;
- extent: (aPoint x * 0.75) asInteger @ (aPoint y * 0.6) asInteger;
- minimumExtent: levelSlider extent;
- target: soundInput;
- actionSelector: #recordLevel:;
- orientation: #horizontal;
- adjustToValue: soundInput recordLevel.
- r := AlignmentMorph newRow
- color: color;
- layoutInset: 0;
- wrapCentering: #center; cellPositioning: #leftCenter;
- hResizing: #shrinkWrap;
- vResizing: #rigid;
- height: aPoint y + 2 px.
- r addMorphBack: (StringMorph contents: '0 ' font: Preferences standardButtonFont).
- r addMorphBack: levelSlider.
- r addMorphBack: (StringMorph contents: ' 10' font: Preferences standardButtonFont).
- self addMorphBack: r.!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>buttonName:action: (in category 'private') -----
- buttonName: aString action: aSymbol
-
- ^ SimpleButtonMorph new
- target: self;
- label: aString font: Preferences standardButtonFont;
- actionSelector: aSymbol
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>defaultBorderWidth (in category 'initialization') -----
- defaultBorderWidth
- "answer the default border width for the receiver"
- ^ 2 px!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>delete (in category 'submorphs - add/remove') -----
- delete
- "Turn off recording when this morph is deleted."
-
- super delete.
- soundInput stopRecording.
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>fftSize: (in category 'accessing') -----
- fftSize: aSize
-
- | on |
- on := soundInput isRecording.
- self stop.
- fft := FFT new: aSize.
- self resetDisplay.
- on ifTrue: [self start].!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- | full |
- super initialize.
- ""
- self listDirection: #topToBottom.
- soundInput := SoundInputStream new samplingRate: 22050.
- fft := FFT new: 512.
- displayType := 'sonogram'.
- self hResizing: #shrinkWrap.
- self vResizing: #shrinkWrap.
- full := self addButtonRow.
- submorphs last addMorphBack: (self makeStatusLightIn: full extent).
-
- self addLevelSliderIn: full extent.
- self addMorphBack: (self makeLevelMeterIn: full extent).
- self addMorphBack: (Morph new extent: 10 px @ 10 px;
- color: Color transparent).
- "spacer"
- self resetDisplay!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>invokeMenu (in category 'menu and buttons') -----
- invokeMenu
- "Invoke the settings menu."
-
- | aMenu |
- aMenu := CustomMenu new.
- aMenu addList: {
- {'set sampling rate' translated. #setSamplingRate}.
- {'set FFT size' translated. #setFFTSize}.
- {'set display type' translated. #setDisplayType}}.
- aMenu invokeOn: self defaultSelection: nil.
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>makeLevelMeterIn: (in category 'private') -----
- makeLevelMeterIn: aPoint
-
- | outerBox h |
- h := (aPoint y * 0.6) asInteger.
- outerBox := Morph new extent: aPoint x asInteger @ h; color: Color gray.
- levelMeter := Morph new extent: 1 px @ h; color: Color yellow.
- levelMeter position: outerBox topLeft + (1 px @ 1 px).
- outerBox addMorph: levelMeter.
- ^ outerBox!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>makeStatusLightIn: (in category 'private') -----
- makeStatusLightIn: aPoint
-
- | s p |
- p := (aPoint x min: aPoint y) asPoint.
- statusLight := RectangleMorph new extent: p.
- statusLight color: Color gray.
- s := StringMorph contents: '' font: Preferences standardButtonFont.
- statusLight addMorph: s.
- ^ statusLight!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>processBuffer: (in category 'private') -----
- processBuffer: buf
- "Analyze one buffer of data."
-
- | data |
- data := displayType = 'signal'
- ifTrue: [buf]
- ifFalse: [fft transformDataFrom: buf startingAt: 1].
- graphMorph ifNotNil:
- [graphMorph
- data: data;
- changed].
- sonogramMorph ifNotNil:
- [data := data collect: [:v | v sqrt]. "square root compresses dynamic range"
- data /= 400.0.
- sonogramMorph plotColumn: (data copyFrom: 1 to: data size // 1)]!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>removeAllDisplays (in category 'private') -----
- removeAllDisplays
- "Remove all currently showing displays."
-
- sonogramMorph ifNotNil: [sonogramMorph delete].
- graphMorph ifNotNil: [graphMorph delete].
- sonogramMorph := graphMorph := nil.
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>resetDisplay (in category 'menu and buttons') -----
- resetDisplay
- "Recreate my display after changing some parameter such as FFT size."
-
- displayType = 'signal' ifTrue: [self showSignal].
- displayType = 'spectrum' ifTrue: [self showSpectrum].
- displayType = 'sonogram' ifTrue: [self showSonogram].
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>setDisplayType (in category 'menu and buttons') -----
- setDisplayType
- "Set the display type."
-
- | aMenu choice on |
- aMenu := CustomMenu new title: ('display type (currently {1})' translated format:{displayType}).
- aMenu addList: {
- {'signal' translated. 'signal'}.
- {'spectrum' translated. 'spectrum'}.
- {'sonogram' translated. 'sonogram'}}.
- choice := aMenu startUp.
- choice ifNil: [^ self].
-
- on := soundInput isRecording.
- self stop.
- displayType := choice.
- self resetDisplay.
- on ifTrue: [self start].
-
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>setFFTSize (in category 'menu and buttons') -----
- setFFTSize
- "Set the size of the FFT used for frequency analysis."
-
- | aMenu sz |
- aMenu := CustomMenu new title: ('FFT size (currently {1})' translated format:{fft n}).
- ((7 to: 10) collect: [:n | 2 raisedTo: n]) do:[:r | aMenu add: r printString action: r].
- sz := aMenu startUp.
- sz ifNil: [^ self].
- self fftSize: sz.!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>setSamplingRate (in category 'menu and buttons') -----
- setSamplingRate
- "Set the sampling rate to be used for incoming sound data."
-
- | aMenu rate on |
- aMenu := CustomMenu new title:
- ('Sampling rate (currently {1})' translated format:{soundInput samplingRate}).
- #(11025 22050 44100) do:[:r | aMenu add: r printString action: r].
- rate := aMenu startUp.
- rate ifNil: [^ self].
- on := soundInput isRecording.
- self stop.
- soundInput samplingRate: rate.
- self resetDisplay.
- on ifTrue: [self start].
-
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>showSignal (in category 'private') -----
- showSignal
- "Display the actual signal waveform."
-
- displayType := 'signal'.
- self removeAllDisplays.
- graphMorph := GraphMorph new.
- graphMorph extent: (400 px + (graphMorph borderWidth * 2)) @ 128 px.
- graphMorph data: (Array new: 100 withAll: 0).
- graphMorph color: (Color r: 0.8 g: 1.0 b: 1.0).
- self addMorphBack: graphMorph.
- self extent: 10 px @ 10 px. "shrink to minimum size"!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>showSonogram (in category 'private') -----
- showSonogram
- "Display a sonogram showing the frequency spectrum versus time."
-
- | zeros h w |
- displayType := 'sonogram'.
- self removeAllDisplays.
- h := fft n // 2.
- h := h min: 512 px max: 64 px.
- w := 400 px.
- sonogramMorph :=
- Sonogram new
- extent: w@h
- minVal: 0.0
- maxVal: 1.0
- scrollDelta: w.
- zeros := Array new: sonogramMorph height withAll: 0.
- sonogramMorph width timesRepeat: [sonogramMorph plotColumn: zeros].
- self addMorphBack: sonogramMorph.
- self extent: 10 px @ 10 px. "shrink to minimum size"!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>showSpectrum (in category 'private') -----
- showSpectrum
- "Display the frequency spectrum."
-
- displayType := 'spectrum'.
- self removeAllDisplays.
- graphMorph := GraphMorph new.
- graphMorph extent: ((fft n // 2) + (graphMorph borderWidth * 2)) @ 128 px.
- graphMorph data: (Array new: fft n // 2 withAll: 0).
- self addMorphBack: graphMorph.
- self extent: 10 px @ 10 px. "shrink to minimum size"!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>start (in category 'stepping') -----
- start
- "Start displaying sound data."
-
- displayType = 'signal'
- ifTrue: [soundInput bufferSize: graphMorph width - (2 * graphMorph borderWidth)]
- ifFalse: [soundInput bufferSize: fft n].
- soundInput startRecording.
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>step (in category 'stepping') -----
- step
- "Update the record light, level meter, and display."
-
- | w |
- "update the record light and level meter"
- statusLight color:
- (soundInput isRecording ifTrue: [Color yellow] ifFalse: [Color gray]).
- statusLight firstSubmorph in: [:stringMorph |
- stringMorph contents:
- (soundInput isRecording ifTrue: ['On' translated] ifFalse: ['Off' translated]).
- stringMorph position: statusLight center - (stringMorph extent // 2)].
-
- w := ((121 px * soundInput meterLevel) // 100) max: 1.
- levelMeter width: w.
-
- "update the display if any data is available"
- self updateDisplay.!
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>stepTime (in category 'testing') -----
- stepTime
-
- ^ 0
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>stop (in category 'stepping') -----
- stop
- "Stop displaying sound data."
-
- soundInput stopRecording.
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>stopStepping (in category 'stepping') -----
- stopStepping
- "Turn off recording."
-
- super stopStepping.
- soundInput stopRecording.
- !
Item was removed:
- ----- Method: SpectrumAnalyzerMorph>>updateDisplay (in category 'private') -----
- updateDisplay
- "Update the display if any data is available."
-
- | buf bufCount |
- soundInput bufferCount = 0 ifTrue: [^ self].
-
- graphMorph ifNotNil: [
- [soundInput bufferCount > 0] whileTrue: [
- "skip to the most recent buffer"
- buf := soundInput nextBufferOrNil].
- ^ self processBuffer: buf].
-
- sonogramMorph ifNotNil: [
- "at small buffer sizes we have to update the sonogram in
- batches or we may get behind; shoot for 8 updates/second"
- bufCount := (soundInput samplingRate / (8 * soundInput bufferSize)) truncated max: 1.
- [bufCount > 0 and: [soundInput bufferCount > 0]] whileTrue: [
- self processBuffer: (soundInput nextBufferOrNil)]].
- !
Item was removed:
- AlignmentMorph subclass: #Tetris
- instanceVariableNames: 'board scoreDisplay pauseSwitch'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !Tetris commentStamp: '<historical>' prior: 0!
- This is a port of JTetris.java 1.0.0.
-
- How to start:
- choose new morph.../Games/Tetris
-
- How to play:
- 1) using buttons
- 2) using keyboard:
- drop - spacebar
- move to left - left arrow
- move to right - right arrow
- rotate clockwise - up arrow
- rotate anticlockwise - down arrow
- NOTE: mouse must be over Tetris!
Item was removed:
- ----- Method: Tetris class>>colors (in category 'constants') -----
- colors
-
- ^{
- Color r: 0.5 g: 0 b: 0.
- Color r: 0 g: 0.5 b: 0.
- Color r: 0 g: 0 b: 0.5.
- Color r: 0.5 g: 0.5 b: 0.
- Color r: 0.5 g: 0 b: 0.5.
- Color r: 0 g: 0.5 b: 0.5
- }
- !
Item was removed:
- ----- Method: Tetris class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- ^ self partName: 'Tetris' translatedNoop
- categories: {'Games' translatedNoop}
- documentation: 'Tetris, yes Tetris' translatedNoop!
Item was removed:
- ----- Method: Tetris>>buildButtonTarget:label:selector:help: (in category 'initialization') -----
- buildButtonTarget: aTarget label: aLabel selector: aSelector help: aString
-
- ^self rowForButtons
- addMorph: (
- SimpleButtonMorph new
- target: aTarget;
- label: aLabel;
- actionSelector: aSelector;
- borderStyle: (BorderStyle raised width: 2 px);
- color: color
- )!
Item was removed:
- ----- Method: Tetris>>buildSwitchTarget:label:selector:help: (in category 'initialization') -----
- buildSwitchTarget: aTarget label: aLabel selector: aSelector help: aString
-
- ^self rowForButtons
- addMorph: (
- SimpleSwitchMorph new
- target: aTarget;
- label: aLabel;
- actionSelector: aSelector;
- borderStyle: (BorderStyle raised width: 2 px);
- color: color
- )!
Item was removed:
- ----- Method: Tetris>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color lightGray!
Item was removed:
- ----- Method: Tetris>>handlesKeyboard: (in category 'event handling') -----
- handlesKeyboard: evt
- ^true!
Item was removed:
- ----- Method: Tetris>>handlesMouseOver: (in category 'event handling') -----
- handlesMouseOver: evt
- ^true
- !
Item was removed:
- ----- Method: Tetris>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
- board := TetrisBoard new game: self.
- board addDependent: self.
- self listDirection: #topToBottom;
- wrapCentering: #center;
- vResizing: #shrinkWrap;
- hResizing: #shrinkWrap;
- layoutInset: 3 px;
- addMorphBack: self makeGameControls;
- addMorphBack: self makeMovementControls;
- addMorphBack: self showScoreDisplay;
- addMorphBack: board.
- board newGame.
-
- self updateGameOver.!
Item was removed:
- ----- Method: Tetris>>isGameOver (in category 'testing') -----
- isGameOver
-
- ^ board isGameOver!
Item was removed:
- ----- Method: Tetris>>keyStroke: (in category 'event handling') -----
- keyStroke: evt
-
- | charValue |
- charValue := evt keyCharacter asciiValue.
- charValue = 28 ifTrue: [board moveLeft].
- charValue = 29 ifTrue: [board moveRight].
- charValue = 30 ifTrue: [board rotateClockWise].
- charValue = 31 ifTrue: [board rotateAntiClockWise].
- charValue = 32 ifTrue: [board dropAllTheWay].
- !
Item was removed:
- ----- Method: Tetris>>makeGameControls (in category 'initialization') -----
- makeGameControls
- ^ self rowForButtons
- addMorph: (self
- buildButtonTarget: self
- label: 'Quit' translated
- selector: #delete
- help: 'quit' translated);
-
- addMorph: (pauseSwitch := (self
- buildSwitchTarget: self
- label: 'Pause' translated
- selector: #pause
- help: 'pause' translated) firstSubmorph) owner;
-
- addMorph: (self
- buildButtonTarget: self
- label: 'New game' translated
- selector: #newGame
- help: 'new game' translated)!
Item was removed:
- ----- Method: Tetris>>makeMovementControls (in category 'initialization') -----
- makeMovementControls
- ^ self rowForButtons
- addMorph: (self
- buildButtonTarget: board
- label: '->'
- selector: #moveRight
- help: 'move to the right' translated);
-
- addMorph: (self
- buildButtonTarget: board
- label: ' ) '
- selector: #rotateClockWise
- help: 'rotate clockwise' translated);
-
- addMorph: (self
- buildButtonTarget: board
- label: ' | '
- selector: #dropAllTheWay
- help: 'drop' translated);
-
- addMorph: (self
- buildButtonTarget: board
- label: ' ( '
- selector: #rotateAntiClockWise
- help: 'rotate anticlockwise' translated);
-
- addMorph: (self
- buildButtonTarget: board
- label: '<-'
- selector: #moveLeft
- help: 'move to the left' translated)!
Item was removed:
- ----- Method: Tetris>>mouseEnter: (in category 'event handling') -----
- mouseEnter: evt
- evt hand newKeyboardFocus: self!
Item was removed:
- ----- Method: Tetris>>newGame (in category 'actions') -----
- newGame
-
- board newGame.!
Item was removed:
- ----- Method: Tetris>>pause (in category 'actions') -----
- pause
-
- board pause.
- pauseSwitch setSwitchState: self paused.!
Item was removed:
- ----- Method: Tetris>>paused (in category 'testing') -----
- paused
-
- ^ board paused!
Item was removed:
- ----- Method: Tetris>>rowForButtons (in category 'initialization') -----
- rowForButtons
-
- ^AlignmentMorph newRow
- color: color;
- borderWidth: 0;
- layoutInset: 3 px;
- vResizing: #shrinkWrap;
- wrapCentering: #center
- !
Item was removed:
- ----- Method: Tetris>>score: (in category 'events') -----
- score: anInteger
-
- scoreDisplay value: anInteger!
Item was removed:
- ----- Method: Tetris>>showScoreDisplay (in category 'initialization') -----
- showScoreDisplay
- ^ self rowForButtons hResizing: #shrinkWrap;
-
- addMorph: (self wrapPanel: ((scoreDisplay := LedMorph new) digits: 5;
- extent: 10 px * 4 @ 15 px) label: 'Score:' translated)!
Item was removed:
- ----- Method: Tetris>>update: (in category 'updating') -----
- update: what
-
- what = #paused ifTrue:
- [pauseSwitch setSwitchState: self paused].
- what = #isGameOver ifTrue:
- [self updateGameOver].
-
- ^ super update: what!
Item was removed:
- ----- Method: Tetris>>updateGameOver (in category 'events') -----
- updateGameOver
-
- scoreDisplay color: (self isGameOver ifTrue: [Color red] ifFalse: [Color green]).!
Item was removed:
- ----- Method: Tetris>>wrapPanel:label: (in category 'initialization') -----
- wrapPanel: anLedPanel label: aLabel
- "wrap an LED panel in an alignmentMorph with a label to its left"
-
- ^self rowForButtons
- color: color lighter;
- addMorph: anLedPanel;
- addMorph: (StringMorph contents: aLabel)
- !
Item was removed:
- Morph subclass: #TetrisBlock
- instanceVariableNames: 'angle shapeInfo board baseCellNumber'
- classVariableNames: 'ShapeChoices'
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
Item was removed:
- ----- Method: TetrisBlock class>>flipShapes: (in category 'support') -----
- flipShapes: anArray
-
- ^OrderedCollection new
- add: anArray;
- add: (anArray collect: [ :each | each y negated @ each x]);
- add: (anArray collect: [ :each | each x negated @ each y negated]);
- add: (anArray collect: [ :each | each y @ each x negated]);
- yourself
-
- !
Item was removed:
- ----- Method: TetrisBlock class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: TetrisBlock class>>shapeChoices (in category 'constants') -----
- shapeChoices
-
- ^ ShapeChoices ifNil: [
- ShapeChoices := {
- { { 0 @ 0 . 1 @ 0 . 0 @ 1 . 1 @ 1 } }. "square - one is sufficient here"
- self flipShapes: { 0 @ 0 . -1 @ 0 . 1 @ 0 . 0 @ -1 }. "T"
- {
- { 0 @ 0 . -1 @ 0 . 1 @ 0 . 2 @ 0 }.
- { 0 @ 0 . 0 @ -1 . 0 @ 1 . 0 @ 2 } "long - two are sufficient here"
- }.
- self flipShapes: { 0 @ 0 . 0 @ -1 . 0 @ 1 . 1 @ 1 }. "L"
- self flipShapes: { 0 @ 0 . 0 @ -1 . 0 @ 1 . -1 @ 1 }. "inverted L"
- self flipShapes: { 0 @ 0 . -1 @ 0 . 0 @ -1 . 1 @ -1 }. "S"
- self flipShapes: { 0 @ 0 . 1 @ 0 . 0 @ -1 . -1 @ -1 } "Z"
- }.
- ]
- !
Item was removed:
- ----- Method: TetrisBlock>>board: (in category 'as yet unclassified') -----
- board: theBoard
-
- board := theBoard.
- 4 timesRepeat: [
- self addMorph: (
- RectangleMorph new
- color: color;
- extent: board cellSize;
- borderRaised
- )
- ].
- self positionCellMorphs.!
Item was removed:
- ----- Method: TetrisBlock>>defaultBounds (in category 'initialization') -----
- defaultBounds
- "answer the default bounds for the receiver"
- ^ (2 px @ 2 px) negated extent: 1 px @ 1 px!
Item was removed:
- ----- Method: TetrisBlock>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Tetris colors atRandom!
Item was removed:
- ----- Method: TetrisBlock>>dropByOne (in category 'as yet unclassified') -----
- dropByOne
-
- ^self moveDeltaX: 0 deltaY: 1 deltaAngle: 0!
Item was removed:
- ----- Method: TetrisBlock>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
-
- "keep this puppy out of sight"
- shapeInfo := self class shapeChoices atRandom.
- baseCellNumber := 4 atRandom + 2 @ 1.
- angle := 4 atRandom!
Item was removed:
- ----- Method: TetrisBlock>>moveDeltaX:deltaY:deltaAngle: (in category 'as yet unclassified') -----
- moveDeltaX: deltaX deltaY: deltaY deltaAngle: deltaAngle
-
- | delta |
-
- delta := deltaX @ deltaY.
- (shapeInfo atWrap: angle + deltaAngle) do: [ :offsetThisCell |
- (board emptyAt: baseCellNumber + offsetThisCell + delta) ifFalse: [^ false]
- ].
- baseCellNumber := baseCellNumber + delta.
- angle := angle + deltaAngle - 1 \\ 4 + 1.
- self positionCellMorphs.
- ^ true !
Item was removed:
- ----- Method: TetrisBlock>>positionCellMorphs (in category 'as yet unclassified') -----
- positionCellMorphs
-
- (shapeInfo atWrap: angle) withIndexDo: [ :each :index |
- (submorphs at: index)
- position: (board originForCell: baseCellNumber + each)
- ].
- fullBounds := nil.
- self changed.
-
- !
Item was removed:
- PasteUpMorph subclass: #TetrisBoard
- instanceVariableNames: 'paused gameOver delay score currentBlock game'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
Item was removed:
- ----- Method: TetrisBoard class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^false!
Item was removed:
- ----- Method: TetrisBoard>>basicGameOver: (in category 'accessing') -----
- basicGameOver: aBoolean
-
- gameOver := aBoolean.
- self changed: #isGameOver.!
Item was removed:
- ----- Method: TetrisBoard>>basicPaused: (in category 'accessing') -----
- basicPaused: aBoolean
-
- paused := aBoolean.
- self changed: #paused.!
Item was removed:
- ----- Method: TetrisBoard>>cellSize (in category 'accessing') -----
- cellSize
-
- ^12 px @ 12 px!
Item was removed:
- ----- Method: TetrisBoard>>checkForFullRows (in category 'other') -----
- checkForFullRows
-
- | targetY morphsInRow bonus |
- self numRows to: 2 by: -1 do: [ :row |
- targetY := (self originForCell: 1@row) y.
- [
- morphsInRow := self submorphsSatisfying: [ :each | each top = targetY].
- morphsInRow size = self numColumns
- ] whileTrue: [
- bonus := (morphsInRow collect: [:each | each color]) asSet size = 1
- ifTrue: [1000]
- ifFalse: [100].
- self score: score + bonus.
- submorphs copy do: [ :each |
- each top = targetY ifTrue: [
- each delete
- ].
- each top < targetY ifTrue: [
- each position: each position + (0@self cellSize y)
- ].
- ].
- ].
- ].
-
- !
Item was removed:
- ----- Method: TetrisBoard>>defaultBounds (in category 'initialization') -----
- defaultBounds
- "answer the default bounds for the receiver"
- ^ 0 @ 0 extent: self numColumns @ self numRows * self cellSize + (1 px @ 1 px)!
Item was removed:
- ----- Method: TetrisBoard>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color
- lightBlue!
Item was removed:
- ----- Method: TetrisBoard>>dropAllTheWay (in category 'button actions') -----
- dropAllTheWay
-
- self running ifFalse: [^ self].
- [currentBlock dropByOne] whileTrue: [
- self score: score + 1
- ].
- !
Item was removed:
- ----- Method: TetrisBoard>>emptyAt: (in category 'data') -----
- emptyAt: aPoint
-
- | cellOrigin |
- (aPoint x between: 1 and: self numColumns) ifFalse: [^ false].
- (aPoint y < 1) ifTrue: [^ true]. "handle early phases"
- (aPoint y <= self numRows) ifFalse: [^ false].
- cellOrigin := self originForCell: aPoint.
- ^(self submorphsSatisfying: [ :each | each topLeft = cellOrigin]) isEmpty
-
- !
Item was removed:
- ----- Method: TetrisBoard>>game: (in category 'accessing') -----
- game: aTetris
-
- game := aTetris!
Item was removed:
- ----- Method: TetrisBoard>>isGameOver (in category 'testing') -----
- isGameOver
-
- ^ gameOver!
Item was removed:
- ----- Method: TetrisBoard>>moveLeft (in category 'button actions') -----
- moveLeft
-
- self running ifFalse: [^ self].
- currentBlock moveDeltaX: -1 deltaY: 0 deltaAngle: 0.
- !
Item was removed:
- ----- Method: TetrisBoard>>moveRight (in category 'button actions') -----
- moveRight
-
- self running ifFalse: [^ self].
- currentBlock moveDeltaX: 1 deltaY: 0 deltaAngle: 0.
- !
Item was removed:
- ----- Method: TetrisBoard>>newGame (in category 'button actions') -----
- newGame
-
- self removeAllMorphs.
- self basicGameOver: false.
- self basicPaused: false.
- delay := 500.
- currentBlock := nil.
- self score: 0.
- !
Item was removed:
- ----- Method: TetrisBoard>>numColumns (in category 'data') -----
- numColumns
-
- ^10
- !
Item was removed:
- ----- Method: TetrisBoard>>numRows (in category 'data') -----
- numRows
-
- ^27
- !
Item was removed:
- ----- Method: TetrisBoard>>originForCell: (in category 'accessing') -----
- originForCell: aPoint
-
- ^aPoint - (1@1) * self cellSize + self position
-
- !
Item was removed:
- ----- Method: TetrisBoard>>pause (in category 'button actions') -----
- pause
-
- gameOver ifTrue: [^ self].
- self basicPaused: self paused not.!
Item was removed:
- ----- Method: TetrisBoard>>paused (in category 'testing') -----
- paused
-
- ^ paused!
Item was removed:
- ----- Method: TetrisBoard>>rotateAntiClockWise (in category 'button actions') -----
- rotateAntiClockWise
-
- self running ifFalse: [^ self].
- currentBlock moveDeltaX: 0 deltaY: 0 deltaAngle: -1.
- !
Item was removed:
- ----- Method: TetrisBoard>>rotateClockWise (in category 'button actions') -----
- rotateClockWise
-
- self running ifFalse: [^ self].
- currentBlock moveDeltaX: 0 deltaY: 0 deltaAngle: 1.
- !
Item was removed:
- ----- Method: TetrisBoard>>running (in category 'button actions') -----
- running
-
- ^currentBlock notNil and: [paused not]!
Item was removed:
- ----- Method: TetrisBoard>>score: (in category 'accessing') -----
- score: aNumber
-
- score := aNumber.
- game score: score.!
Item was removed:
- ----- Method: TetrisBoard>>step (in category 'stepping') -----
- step
-
- (self ownerThatIsA: HandMorph) ifNotNil: [^self].
- paused ifTrue: [^ self].
- currentBlock ifNil: [
- currentBlock := TetrisBlock new.
- self addMorphFront: currentBlock.
- currentBlock board: self.
- ] ifNotNil: [
- currentBlock dropByOne ifFalse: [self storePieceOnBoard]
- ].
- !
Item was removed:
- ----- Method: TetrisBoard>>stepTime (in category 'testing') -----
- stepTime
- ^ delay!
Item was removed:
- ----- Method: TetrisBoard>>storePieceOnBoard (in category 'other') -----
- storePieceOnBoard
-
- currentBlock submorphs do: [ :each |
- self addMorph: each.
- ((each top - self top) // self cellSize y) < 3 ifTrue: [
- self basicPaused: true.
- self basicGameOver: true.
- ].
- ].
- currentBlock delete.
- currentBlock := nil.
- self checkForFullRows.
- self score: score + 10.
- delay := delay - 2 max: 80.
-
- !
Item was removed:
- EllipseMorph subclass: #WatchMorph
- instanceVariableNames: 'fontName cColor handsColor romanNumerals antialias'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Demo'!
-
- !WatchMorph commentStamp: '<historical>' prior: 0!
- This class is a representation of a watch.
- The labels' font is changeble. Labels' font size increase or decrease when resizing me.
-
- WatchMorph new openInWorld
- (WatchMorph fontName: 'ComicPlain' bgColor: Color transparent centerColor: Color transparent) openInWorld " transparent "
- (WatchMorph fontName: 'ComicBold' bgColor: Color white centerColor: Color black) openInWorld
-
- Structure:
- fontName String -- the labels' font name
- cColor Color -- center color
- handsColor Color
- romanNumerals Boolean
- antialias Boolean!
Item was removed:
- ----- Method: WatchMorph class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
- "Answer a description for use in parts bins."
-
- ^ self partName: 'Clock' translatedNoop
- categories: #('Just for Fun')
- documentation: 'An analog clock face' translatedNoop!
Item was removed:
- ----- Method: WatchMorph class>>example (in category 'examples') -----
- example
- "WatchMorph example openInWorld"
-
- ^ (WatchMorph
- fontName: #BitstreamVeraSerif
- bgColor: Color lightGray
- centerColor: Color red paler)
- handsColor: Color grape;
- toggleRoman;
- yourself!
Item was removed:
- ----- Method: WatchMorph class>>fontName:bgColor:centerColor: (in category 'instance creation') -----
- fontName: aString bgColor: aColor centerColor: otherColor
- ^ self new
- fontName: aString;
- color: aColor;
- centerColor: otherColor!
Item was removed:
- ----- Method: WatchMorph>>addCustomMenuItems:hand: (in category 'menus') -----
- addCustomMenuItems: aMenu hand: aHandMorph
- "Add morph-specific items to the given menu which was invoked by the given hand."
-
- super addCustomMenuItems: aMenu hand: aHandMorph.
- aMenu addLine.
- aMenu addUpdating: #romanNumeralString action: #toggleRoman.
- aMenu addUpdating: #antiAliasString action: #toggleAntialias.
- aMenu addLine.
- aMenu add: 'change font...' translated action: #changeFont.
- aMenu balloonTextForLastItem: 'Allows you to change the font used to display the numbers.' translated.
- aMenu add: 'change hands color...' translated action: #changeHandsColor.
- aMenu balloonTextForLastItem: 'Allows you to specify a new color for the hands of the watch. Note that actual *watch* color can be changed simply by using the halo''s recoloring handle.' translated.
- aMenu add: 'change center color...' translated action: #changeCenterColor.
- aMenu balloonTextForLastItem: 'Allows you to specify a new color to be used during PM hours for the center portion of the watch; during AM hours, a lighter shade of the same color will be used.' translated.!
Item was removed:
- ----- Method: WatchMorph>>antiAliasString (in category 'menus') -----
- antiAliasString
- ^ (antialias
- ifTrue: ['<on>']
- ifFalse: ['<off>'])
- , 'anti-aliasing' translated!
Item was removed:
- ----- Method: WatchMorph>>antialias: (in category 'accessing') -----
- antialias: aBoolean
- antialias := aBoolean!
Item was removed:
- ----- Method: WatchMorph>>centerColor: (in category 'accessing') -----
- centerColor: aColor
- "Set the center color as indicated; map nil into transparent"
-
- cColor := aColor ifNil: [Color transparent]!
Item was removed:
- ----- Method: WatchMorph>>changeCenterColor (in category 'menus') -----
- changeCenterColor
- "Let the user change the color of the center of the watch"
-
- ColorPickerMorph new
- choseModalityFromPreference;
- sourceHand: self activeHand;
- target: self;
- selector: #centerColor:;
- originalColor: self color;
- putUpFor: self near: self fullBounds!
Item was removed:
- ----- Method: WatchMorph>>changeFont (in category 'menus') -----
- changeFont
-
- self fontName: ((SelectionMenu labelList: StrikeFont familyNames
- selections: StrikeFont familyNames) startUp
- ifNil: [^ self])!
Item was removed:
- ----- Method: WatchMorph>>changeHandsColor (in category 'menus') -----
- changeHandsColor
- "Let the user change the color of the hands of the watch."
-
- ColorPickerMorph new
- choseModalityFromPreference;
- sourceHand: self activeHand;
- target: self;
- selector: #handsColor:;
- originalColor: self color;
- putUpFor: self near: self fullBounds!
Item was removed:
- ----- Method: WatchMorph>>createLabels (in category 'updating') -----
- createLabels
-
- | numeral font h r |
- self removeAllMorphs.
- font := StrikeFont familyName: fontName size: (h := self height min: self width)//8.
- r := 1.0 - (1.4 * font height / h).
- 1 to: 12 do:
- [:hour |
- numeral := romanNumerals
- ifTrue: [#('I' 'II' 'III' 'IV' 'V' 'VI' 'VII' ' VIII' 'IX' 'X' 'XI' 'XII') at: hour]
- ifFalse: [hour asString].
- self addMorphBack: ((StringMorph contents: numeral font: font emphasis: 1)
- center: (self radius: r hourAngle: hour)) lock].
- !
Item was removed:
- ----- Method: WatchMorph>>defaultColor (in category 'initialization') -----
- defaultColor
- "answer the default color/fill style for the receiver"
- ^ Color green!
Item was removed:
- ----- Method: WatchMorph>>drawOn: (in category 'drawing') -----
- drawOn: aCanvas
- "Draw the watch on the given canvas"
-
- | pHour pMin pSec time centerColor |
- time := Time now.
- pHour := self radius: 0.6 hourAngle: time hours + (time minutes/60.0).
- pMin := self radius: 0.72 hourAngle: (time minutes / 5.0).
- pSec := self radius: 0.8 hourAngle: (time seconds / 5.0).
- centerColor := cColor
- ifNil:
- [Color transparent]
- ifNotNil:
- [time hours < 12
- ifTrue: [cColor muchLighter]
- ifFalse: [cColor]].
-
- antialias ifTrue:
- [aCanvas asBalloonCanvas
- aaLevel: 4;
- drawOval: (self bounds insetBy: self borderWidth // 2 + 1) color: self fillStyle
- borderWidth: self borderWidth borderColor: self borderColor;
- drawOval: (self bounds insetBy: self extent*0.35) color: centerColor
- borderWidth: 0 borderColor: Color black;
- drawPolygon: {self center. pHour}
- color: Color transparent borderWidth: 3 borderColor: handsColor;
- drawPolygon: {self center. pMin}
- color: Color transparent borderWidth: 2 borderColor: handsColor;
- drawPolygon: {self center. pSec}
- color: Color transparent borderWidth: 1 borderColor: handsColor]
- ifFalse:
- [super drawOn: aCanvas.
- aCanvas
- fillOval: (self bounds insetBy: self extent*0.35) color: centerColor;
- line: self center to: pHour width: 3 color: handsColor;
- line: self center to: pMin width: 2 color: handsColor;
- line: self center to: pSec width: 1 color: handsColor]
- !
Item was removed:
- ----- Method: WatchMorph>>extent: (in category 'geometry') -----
- extent: newExtent
-
- super extent: newExtent.
- self createLabels!
Item was removed:
- ----- Method: WatchMorph>>fontName: (in category 'accessing') -----
- fontName: aString
-
- fontName := aString.
- self createLabels!
Item was removed:
- ----- Method: WatchMorph>>handsColor: (in category 'accessing') -----
- handsColor: aColor
-
- handsColor := aColor!
Item was removed:
- ----- Method: WatchMorph>>initialize (in category 'initialization') -----
- initialize
- "initialize the state of the receiver"
- super initialize.
- ""
-
- self handsColor: Color red.
- self centerColor: Color gray.
- romanNumerals := false.
- antialias := false.
- fontName := 'NewYork'.
- self extent: 130 px @ 130 px.
- self start!
Item was removed:
- ----- Method: WatchMorph>>radius:hourAngle: (in category 'private') -----
- radius: unitRadius hourAngle: hourAngle
- "unitRadius goes from 0.0 at the center to 1.0 on the circumference.
- hourAngle runs from 0.0 clockwise around to 12.0 with wrapping."
-
- ^ self center + (self extent * (Point r: 0.5 * unitRadius
- degrees: hourAngle * 30.0 - 90.0)).!
Item was removed:
- ----- Method: WatchMorph>>romanNumeralString (in category 'menus') -----
- romanNumeralString
- "Answer a string governing the roman-numerals checkbox"
- ^ (romanNumerals
- ifTrue: ['<on>']
- ifFalse: ['<off>'])
- , 'roman numerals' translated!
Item was removed:
- ----- Method: WatchMorph>>step (in category 'stepping') -----
- step
-
- self changed.!
Item was removed:
- ----- Method: WatchMorph>>toggleAntialias (in category 'menus') -----
- toggleAntialias
- antialias := antialias not!
Item was removed:
- ----- Method: WatchMorph>>toggleRoman (in category 'menus') -----
- toggleRoman
-
- romanNumerals := romanNumerals not.
- self createLabels!
Item was removed:
- BorderedMorph subclass: #WordGameLetterMorph
- instanceVariableNames: 'letter originalLetter idString linkedLetters predecessor successor indexInQuote lineMorph letterMorph style'
- classVariableNames: 'IDFont IDHeight LetterFont LetterHeight'
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !WordGameLetterMorph commentStamp: '<historical>' prior: 0!
- WordGameLetterMorph implements letter boxes for type-in and display of letter in word games. Several variant displays are supported, depending on the setting of style, and blanks can be displayed as black boxes or empty letter boxes.
-
- Default support for type-in is distributed between this class and WordGamePaneMorph
-
- letter the Character stored in this morph.
- Can be either blank or nil as well as a letter.
- indexInQuote a retained copy of the index of this character
- Facilitates responses to, eg, clicking or typing in this box.
- If indexInQuote==nil, then this is displayed as a black box
- predecessor another LetterMorph or nil
- Used for linked typing and, eg, word selection
- successor another LetterMorph or nil
- Used for linked typing and, eg, word selection
- style a Symbol, one of #(plain boxed underlined)
- Boxed and underlined display further depends on whether
- the id strings are nil or not.
- Each format has an associated default size
-
- The following two variables are also submorphs, as are the id strings if present.
- letterMorph a StringMorph for displaying the letter
- Used when changing the letter to be displayed
- lineMorph a PolygonMorph used to display the underline
- and also to place the id string in underlined format!
Item was removed:
- ----- Method: WordGameLetterMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^ false!
Item was removed:
- ----- Method: WordGameLetterMorph class>>initialize (in category 'class initialization') -----
- initialize "WordGameLetterMorph initialize"
-
- IDFont := StrikeFont familyName: 'ComicPlain' size: 13.
- IDHeight := IDFont height.
- LetterFont := StrikeFont familyName: 'ComicBold' size: 19.
- LetterHeight := LetterFont height.
-
- !
Item was removed:
- ----- Method: WordGameLetterMorph>>boxed (in category 'style inits') -----
- boxed
-
- style := #boxed!
Item was removed:
- ----- Method: WordGameLetterMorph>>handlesKeyboard: (in category 'event handling') -----
- handlesKeyboard: evt
- ^ true!
Item was removed:
- ----- Method: WordGameLetterMorph>>id2: (in category 'initialization') -----
- id2: idString
- "Add further clue id for acrostic puzzles."
-
- | idMorph |
- idString ifNotNil:
- [idMorph := StringMorph contents: idString font: IDFont.
- idMorph align: idMorph bounds topRight with: self bounds topRight + (-1 px @ -1 px).
- self addMorph: idMorph].
-
- !
Item was removed:
- ----- Method: WordGameLetterMorph>>indexInQuote (in category 'accessing') -----
- indexInQuote
-
- ^ indexInQuote!
Item was removed:
- ----- Method: WordGameLetterMorph>>indexInQuote:id1: (in category 'initialization') -----
- indexInQuote: qi id1: aString
- "Initialize me with the given index and an optional aString"
- | idMorph y |
- style = #boxed
- ifTrue: [aString isNil
- ifTrue: [self extent: 18 px @ 16 px;
- borderWidth: 1 px]
- ifFalse: [self extent: 26 px @ 24 px;
- borderWidth: 1 px]]
- ifFalse: [aString isNil
- ifTrue: [self extent: 18 px @ 16 px;
- borderWidth: 0]
- ifFalse: [self extent: 18 px @ 26 px;
- borderWidth: 0]].
- qi
- ifNil: [^ self color: Color gray].
- "blank"
- self color: self normalColor.
- indexInQuote := qi.
- style == #underlined
- ifTrue: [y := self bottom - 2 px.
- aString
- ifNotNil: [y := y - IDFont ascent + 2 px].
- lineMorph := PolygonMorph
- vertices: {self left + 2 px @ y. self right - 3 px @ y}
- color: Color gray
- borderWidth: 1 px
- borderColor: Color gray.
- self addMorph: lineMorph.
- aString
- ifNil: [^ self].
- idMorph := StringMorph contents: aString font: IDFont.
- idMorph align: idMorph bounds bottomCenter with: self bounds bottomCenter + (0 @ (IDFont descent - 1 px)).
- self addMorphBack: idMorph]
- ifFalse: [aString
- ifNil: [^ self].
- idMorph := StringMorph contents: aString font: IDFont.
- idMorph align: idMorph bounds topLeft with: self bounds topLeft + (2 px @ -1 px).
- self addMorph: idMorph
- "
- World addMorph: (WordGameLetterMorph new boxed
- indexInQuote: 123 id1: '123';
- id2: 'H'; setLetter: $W).
- World addMorph: (WordGameLetterMorph new underlined
- indexInQuote: 123 id1: '123';
- setLetter: $W).
- World addMorph: (WordGameLetterMorph new underlined
- indexInQuote: 123 id1: nil;
- setLetter: $W).
- "]!
Item was removed:
- ----- Method: WordGameLetterMorph>>isBlank (in category 'accessing') -----
- isBlank
- ^indexInQuote isNil!
Item was removed:
- ----- Method: WordGameLetterMorph>>keyboardFocusChange: (in category 'event handling') -----
- keyboardFocusChange: boolean
-
- | panel |
- boolean ifFalse:
- [panel := self nearestOwnerThat: [:m | m respondsTo: #checkForLostFocus].
- panel ifNotNil: [panel checkForLostFocus]]!
Item was removed:
- ----- Method: WordGameLetterMorph>>letter (in category 'accessing') -----
- letter
-
- ^ letter!
Item was removed:
- ----- Method: WordGameLetterMorph>>morphsInWordDo: (in category 'linking') -----
- morphsInWordDo: aBlock
- aBlock value: self.
- (successor isNil or: [successor isBlank]) ifTrue: [^self].
- successor morphsInWordDo: aBlock!
Item was removed:
- ----- Method: WordGameLetterMorph>>nextTypeableLetter (in category 'linking') -----
- nextTypeableLetter
-
- successor ifNil: [^ self].
- successor isBlank ifTrue: [^ successor nextTypeableLetter].
- ^ successor!
Item was removed:
- ----- Method: WordGameLetterMorph>>normalColor (in category 'initialization') -----
- normalColor
-
- ^ Color r: 1.0 g: 0.8 b: 0.2
- !
Item was removed:
- ----- Method: WordGameLetterMorph>>plain (in category 'style inits') -----
- plain
-
- style := #plain!
Item was removed:
- ----- Method: WordGameLetterMorph>>predecessor (in category 'accessing') -----
- predecessor
-
- ^ predecessor!
Item was removed:
- ----- Method: WordGameLetterMorph>>predecessor: (in category 'accessing') -----
- predecessor: pred
-
- predecessor := pred
- !
Item was removed:
- ----- Method: WordGameLetterMorph>>previousTypeableLetter (in category 'linking') -----
- previousTypeableLetter
-
- predecessor ifNil: [^ self].
- predecessor isBlank ifTrue: [^ predecessor previousTypeableLetter].
- ^ predecessor!
Item was removed:
- ----- Method: WordGameLetterMorph>>setLetter: (in category 'initialization') -----
- setLetter: aLetter
-
- ^ self setLetter: aLetter color: Color black
- !
Item was removed:
- ----- Method: WordGameLetterMorph>>setLetter:color: (in category 'initialization') -----
- setLetter: aLetter color: aColor
- letterMorph ifNotNil: [letterMorph delete].
- letter := aLetter.
- letter ifNil: [^letterMorph := nil].
- letterMorph := StringMorph contents: aLetter asString font: LetterFont.
- letterMorph color: aColor.
- style == #boxed
- ifTrue:
- [letterMorph align: letterMorph bounds bottomCenter
- with: self bounds bottomCenter + (0 @ (LetterFont descent - 2 px))]
- ifFalse:
- [lineMorph isNil
- ifTrue:
- [letterMorph align: letterMorph bounds bottomCenter
- with: self bounds bottomCenter + (0 @ (LetterFont descent - 4 px))]
- ifFalse:
- [letterMorph align: letterMorph bounds bottomCenter
- with: self center x @ (lineMorph top + LetterFont descent)]].
- self addMorphBack: letterMorph!
Item was removed:
- ----- Method: WordGameLetterMorph>>startOfWord (in category 'linking') -----
- startOfWord
- (predecessor isNil or: [predecessor isBlank]) ifTrue: [^self].
- ^predecessor startOfWord!
Item was removed:
- ----- Method: WordGameLetterMorph>>successor (in category 'accessing') -----
- successor
-
- ^ successor!
Item was removed:
- ----- Method: WordGameLetterMorph>>successor: (in category 'accessing') -----
- successor: succ
-
- successor := succ
- !
Item was removed:
- ----- Method: WordGameLetterMorph>>underlined (in category 'style inits') -----
- underlined
-
- style := #underlined!
Item was removed:
- ----- Method: WordGameLetterMorph>>unhighlight (in category 'typing') -----
- unhighlight
-
- (self isBlank or: [self color = self normalColor])
- ifFalse: [self color: self normalColor]!
Item was removed:
- BorderedMorph subclass: #WordGamePanelMorph
- instanceVariableNames: 'letterMorphs haveTypedHere'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Etoys-Squeakland-Morphic-Games'!
-
- !WordGamePanelMorph commentStamp: '<historical>' prior: 0!
- WordGamePanelMorph provides some default support for clicking and typing in a panel with letterMorphs.
-
- letterMorphs a collection of LetterMorphs
- Useful in referring specifically to active letterMorphs
- when submorphs may contain other morphs
-
- haveTypedHere a Boolean used to determine how backspace should be handled!
Item was removed:
- ----- Method: WordGamePanelMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
- includeInNewMorphMenu
-
- ^ false!
Item was removed:
- ----- Method: WordGamePanelMorph>>addCustomMenuItems:hand: (in category 'menus') -----
- addCustomMenuItems: aCustomMenu hand: aHandMorph
- "Include our modest command set in the ctrl-menu"
-
- super addCustomMenuItems: aCustomMenu hand: aHandMorph.
- aCustomMenu addLine.
- self addMenuItemsTo: aCustomMenu hand: aHandMorph!
Item was removed:
- ----- Method: WordGamePanelMorph>>addMenuItemsTo:hand: (in category 'menu') -----
- addMenuItemsTo: aCustomMenu hand: aHandMorph
- "override with actual menu items"!
Item was removed:
- ----- Method: WordGamePanelMorph>>checkForLostFocus (in category 'events') -----
- checkForLostFocus
- "Determine if the user has clicked outside this panel"
-
- self activeHand ifNil: [^ self].
- (self containsPoint: self activeHand position) ifFalse: [self lostFocus]!
Item was removed:
- ----- Method: WordGamePanelMorph>>clearTyping (in category 'defaults') -----
- clearTyping
- "Clear out all letters entered as a solution."
-
- letterMorphs do: [:m | (m letter notNil and: [m letter isLetter])
- ifTrue: [m setLetter: Character space]].
- self unhighlight.
- !
Item was removed:
- ----- Method: WordGamePanelMorph>>handlesMouseDown: (in category 'event handling') -----
- handlesMouseDown: event
- "Absorb mouseDown so stray clicks will not pick up the panel"
-
- ^ true!
Item was removed:
- ----- Method: WordGamePanelMorph>>highlight: (in category 'defaults') -----
- highlight: morph
-
- self unhighlight.
- morph color: Color green!
Item was removed:
- ----- Method: WordGamePanelMorph>>isClean (in category 'defaults') -----
- isClean
- "Return true only if all cells are blank."
-
- letterMorphs do:
- [:m | (m letter notNil and: [m letter ~= $ ]) ifTrue: [^ false]].
- ^ true
- !
Item was removed:
- ----- Method: WordGamePanelMorph>>keyCharacter:atIndex:nextFocus: (in category 'defaults') -----
- keyCharacter: keyCharacter atIndex: indexOfAffectedMorph nextFocus: nextFocus
-
- "Override with actual response"
- !
Item was removed:
- ----- Method: WordGamePanelMorph>>keyStrokeEvent:letterMorph: (in category 'events') -----
- keyStrokeEvent: evt letterMorph: morph
- "Handle typing. Calls keyCharacter:atIndex:nextFocus: for further behavior."
-
- | affectedMorph keyCharacter nextFocus |
- evt keyCharacter = Character backspace
- ifTrue:
- ["<delete> zaps the current selection if there has been no typing,
- but it zaps the previous selection if there has been prior typing."
-
- affectedMorph := haveTypedHere
- ifTrue: [morph previousTypeableLetter]
- ifFalse: [morph].
- keyCharacter := Character space.
- nextFocus := morph previousTypeableLetter]
- ifFalse:
- [affectedMorph := morph.
- keyCharacter := evt keyCharacter asUppercase.
- (keyCharacter isLetter or: [keyCharacter = Character space])
- ifFalse: [^self].
- haveTypedHere := true.
- nextFocus := morph nextTypeableLetter.
- nextFocus == morph
- ifTrue:
- ["If hit end of a word, change backspace mode"
-
- haveTypedHere := false]].
- evt hand newKeyboardFocus: nextFocus.
- self unhighlight.
- nextFocus color: Color green.
- self
- keyCharacter: keyCharacter
- atIndex: affectedMorph indexInQuote
- nextFocus: nextFocus!
Item was removed:
- ----- Method: WordGamePanelMorph>>letterMorphs (in category 'access') -----
- letterMorphs
-
- ^ letterMorphs!
Item was removed:
- ----- Method: WordGamePanelMorph>>lostFocus (in category 'defaults') -----
- lostFocus
-
- self unhighlight!
Item was removed:
- ----- Method: WordGamePanelMorph>>mouseDownEvent:letterMorph: (in category 'events') -----
- mouseDownEvent: evt letterMorph: morph
-
- haveTypedHere := false.
- evt hand newKeyboardFocus: morph.
- self highlight: morph!
Item was removed:
- ----- Method: WordGamePanelMorph>>unhighlight (in category 'defaults') -----
- unhighlight
-
- letterMorphs do: [:m | m ifNotNil: [m unhighlight]]
- !
1
0
David T. Lewis uploaded a new version of Graphics to project The Trunk:
http://source.squeak.org/trunk/Graphics-dtl.546.mcz
==================== Summary ====================
Name: Graphics-dtl.546
Author: dtl
Time: 4 November 2023, 9:47:53.713167 pm
UUID: bb78f594-06a2-4997-a097-0fde756a8dc9
Ancestors: Graphics-ul.545
Retain some Etoys classes and methods in the base image, based on Marcel's unload-etoys.33.cs Etoys removal script.
Reference squeak-dev 29-Aug-2023 Let's discuss the future of Etoys in Squeak 6.1 (and beyond)
=============== Diff against Graphics-ul.545 ===============
Item was added:
+ ----- Method: Form>>blendColor: (in category 'converting') -----
+ blendColor: aTranslucentColor
+ "((ScriptingSystem formAtKey: #TryIt) blendColor: (Color black alpha:
+ 0.5)) displayAt: 0 @ 0"
+ "((ScriptingSystem formAtKey: #TryIt) blendColor: (Color red alpha: 0.5))
+ displayAt: 0 @ 0"
+ | form canvas |
+ form := self deepCopy asFormOfDepth: 32.
+ canvas := form getCanvas.
+ canvas
+ stencil: form
+ at: 0 @ 0
+ sourceRect: (0 @ 0 extent: form extent)
+ color: aTranslucentColor.
+ ^ canvas form!
Item was added:
+ ----- Method: Form>>scaledToHeight: (in category 'scaling, rotation') -----
+ scaledToHeight: newHeight
+ "Answer the receiver, scaled such that it has the desired height."
+
+ newHeight = self height ifTrue: [^ self].
+ ^self magnify: self boundingBox by: (newHeight / self height) smoothing: 2.
+ !
Item was added:
+ ----- Method: Form>>scaledToWidth: (in category 'scaling, rotation') -----
+ scaledToWidth: newWidth
+ "Answer the receiver, scaled such that it has the desired width."
+
+ newWidth = self width ifTrue: [^ self].
+ ^self magnify: self boundingBox by: (newWidth / self width) smoothing: 2.
+ !
1
0
David T. Lewis uploaded a new version of MorphicExtras to project The Trunk:
http://source.squeak.org/trunk/MorphicExtras-dtl.351.mcz
==================== Summary ====================
Name: MorphicExtras-dtl.351
Author: dtl
Time: 4 November 2023, 9:46:37.529792 pm
UUID: a0c1ef30-0a8e-4cc1-b857-49351efc76da
Ancestors: MorphicExtras-dtl.350
Retain some Etoys classes and methods in the base image, based on Marcel's unload-etoys.33.cs Etoys removal script.
Reference squeak-dev 29-Aug-2023 Let's discuss the future of Etoys in Squeak 6.1 (and beyond)
=============== Diff against MorphicExtras-dtl.350 ===============
Item was changed:
SystemOrganization addCategory: #'MorphicExtras-AdditionalMorphs'!
SystemOrganization addCategory: #'MorphicExtras-AdditionalSupport'!
SystemOrganization addCategory: #'MorphicExtras-AdditionalWidgets'!
SystemOrganization addCategory: #'MorphicExtras-Books'!
SystemOrganization addCategory: #'MorphicExtras-Demo'!
SystemOrganization addCategory: #'MorphicExtras-EToy-Download'!
SystemOrganization addCategory: #'MorphicExtras-Exceptions'!
SystemOrganization addCategory: #'MorphicExtras-Flaps'!
SystemOrganization addCategory: #'MorphicExtras-GeeMail'!
SystemOrganization addCategory: #'MorphicExtras-Leds'!
SystemOrganization addCategory: #'MorphicExtras-Navigators'!
SystemOrganization addCategory: #'MorphicExtras-Obsolete'!
SystemOrganization addCategory: #'MorphicExtras-Palettes'!
SystemOrganization addCategory: #'MorphicExtras-PartsBin'!
SystemOrganization addCategory: #'MorphicExtras-Postscript Canvases'!
SystemOrganization addCategory: #'MorphicExtras-Postscript Filters'!
SystemOrganization addCategory: #'MorphicExtras-SoundInterface'!
SystemOrganization addCategory: #'MorphicExtras-SqueakPage'!
SystemOrganization addCategory: #'MorphicExtras-Support'!
SystemOrganization addCategory: #'MorphicExtras-Text Support'!
SystemOrganization addCategory: #'MorphicExtras-Undo'!
SystemOrganization addCategory: #'MorphicExtras-WebCam'!
SystemOrganization addCategory: #'MorphicExtras-Widgets'!
+ SystemOrganization addCategory: #'MorphicExtras-Games'!
+ SystemOrganization addCategory: #'MorphicExtras-Games-Chess'!
+ SystemOrganization addCategory: #'MorphicExtras-Games-Chess960'!
Item was added:
+ Morph subclass: #CalendarMorph
+ instanceVariableNames: 'date stepTime shouldUpdate'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Demo'!
+
+ !CalendarMorph commentStamp: 'sw 1/25/2012 21:09' prior: 0!
+ CalendarMorph, by Ricardo Moran, 2011, with some changes by Scott Wallace, January 2012.
+
+ A CalendarMorph is single-month calendar that is scriptable using tiles in its viewer. It always has a 'selected' date, for which the correct month and year are shown; the actual day corresponding to the selected date is highlighted on the calendar.
+ !
Item was added:
+ ----- Method: CalendarMorph class>>additionsToViewerCategories (in category 'viewer categories') -----
+ additionsToViewerCategories
+ "Answer definitions for viewer categories of a Calendar."
+
+ ^ #(
+
+ (#'calendar' (
+ (slot date 'Shows the selected date' String readOnly Player getDate Player unused )
+ (slot day 'Shows the selected day and lets you modify it' Number readWrite Player getDay Player setDay: )
+ (slot month 'Shows the selected month and lets you modify it' Number readWrite Player getMonth Player setMonth: )
+ (slot year 'Shows the selected year and lets you modify it' Number readWrite Player getYear Player setYear: )
+
+ (slot dayName 'Shows the name of the selected day' String readOnly Player getDayName Player unused )
+ (slot monthName 'Shows the name of the selected month' String readOnly Player getMonthName Player unused )
+ (slot dateFormat 'Lets you choose a format for displaying the date' DateFormat readWrite Player getDateFormat Player setDateFormat: )
+
+ (command goToToday 'Show the current month and highlight the current day on it')
+ (slot julianDay 'The Julian day of the selected date' Number readWrite Player getJulianDay Player setJulianDay:)
+ )))!
Item was added:
+ ----- Method: CalendarMorph class>>assureDateFormatEstablished (in category 'class initialization') -----
+ assureDateFormatEstablished
+ "Make certain that there is a DateFormat vocabulary in the system's list."
+
+ Vocabulary addStandardVocabulary: (SymbolListType new vocabularyName: #DateFormat;
+ symbols: #(#'dd/mm/yyyy' #'yyyy/mm/dd' #'mm/dd/yyyy')).!
Item was added:
+ ----- Method: CalendarMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ "Answer a description for use in parts bins"
+
+ ^ self partName: 'Calendar' translatedNoop
+ categories: {'Just for Fun' translatedNoop}
+ documentation: 'A scriptable calendar' translatedNoop!
Item was added:
+ ----- Method: CalendarMorph class>>initialize (in category 'class initialization') -----
+ initialize
+ "Class initialization."
+
+ self assureDateFormatEstablished!
Item was added:
+ ----- Method: CalendarMorph>>addDays: (in category 'actions') -----
+ addDays: aNumber
+ [self date: (date addDays: aNumber)]
+ on: Error
+ do: ["Nothing"]!
Item was added:
+ ----- Method: CalendarMorph>>addMonths: (in category 'actions') -----
+ addMonths: aNumber
+ [self date: (date addMonths: aNumber)]
+ on: Error
+ do: ["Nothing"]!
Item was added:
+ ----- Method: CalendarMorph>>buildMonthRow (in category 'building') -----
+ buildMonthRow
+ ^ self newRow
+ addMorphBack: ((self newButtonWithContents: '<-') actionSelector: #previousMonth; target: self);
+ addMorphBack: AlignmentMorph newVariableTransparentSpacer;
+ addMorphBack: (date month name translated asMorph color: self labelsDefaultColor);
+ addMorphBack: AlignmentMorph newVariableTransparentSpacer;
+ addMorphBack: ((self newButtonWithContents: '->') actionSelector: #nextMonth; target: self)!
Item was added:
+ ----- Method: CalendarMorph>>buildYearRow (in category 'building') -----
+ buildYearRow
+ ^ self newRow
+ addMorphBack: ((self newButtonWithContents: '<-') actionSelector: #previousYear; target: self);
+ addMorphBack: AlignmentMorph newVariableTransparentSpacer;
+ addMorphBack: (date year name asMorph color: self labelsDefaultColor);
+ addMorphBack: AlignmentMorph newVariableTransparentSpacer;
+ addMorphBack: ((self newButtonWithContents: '->') actionSelector: #nextYear; target: self)!
Item was added:
+ ----- Method: CalendarMorph>>color: (in category 'accessing') -----
+ color: aColor
+ super color: aColor.
+ shouldUpdate := true!
Item was added:
+ ----- Method: CalendarMorph>>date (in category 'accessing') -----
+ date
+ ^ date!
Item was added:
+ ----- Method: CalendarMorph>>date: (in category 'accessing') -----
+ date: aDate
+ date := aDate.
+ shouldUpdate := true!
Item was added:
+ ----- Method: CalendarMorph>>dayInitialsRow (in category 'building') -----
+ dayInitialsRow
+ | newRow |
+ newRow := self newRow.
+ Week dayNames
+ do: [:dayName|
+ newRow addMorphBack: (TextMorph new
+ contentsWrapped: dayName translated first asString;
+ textColor: self labelsDefaultColor;
+ autoFit: false;
+ width: 30 px;
+ centered;
+ lock)]
+ separatedBy: [newRow addMorphBack: AlignmentMorph newVariableTransparentSpacer].
+ ^newRow !
Item was added:
+ ----- Method: CalendarMorph>>fillStyle: (in category 'accessing') -----
+ fillStyle: aFillStyle
+ super fillStyle: aFillStyle.
+ shouldUpdate := true!
Item was added:
+ ----- Method: CalendarMorph>>incrementStepTime (in category 'stepping') -----
+ incrementStepTime
+ stepTime := (stepTime + 1) min: self maximumStepTime!
Item was added:
+ ----- Method: CalendarMorph>>initialColor (in category 'initialize') -----
+ initialColor
+ "Answer the color to use for a new Calendar."
+
+ ^ Color r: 0.516 g: 0.677 b: 1.0
+
+ "Note: Richo's initial implementation was to use a randomly-chosen color for each new Calendar, for which the code in this method would be:
+
+ ^ Color random
+
+ ... but in this version, a standard, sedate color is used for each new calendar. The user can of course change the color using the standard halo recolor tool"!
Item was added:
+ ----- Method: CalendarMorph>>initialize (in category 'initialize') -----
+ initialize
+ "One-time initialization of a new calendar."
+
+ super initialize.
+ date := Date today.
+ stepTime := self minimumStepTime.
+ shouldUpdate := false.
+ self layoutPolicy: TableLayout new;
+ listDirection: #topToBottom;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ color: self initialColor;
+ cornerStyle: #rounded;
+ initializeSubmorphs!
Item was added:
+ ----- Method: CalendarMorph>>initializeSubmorphs (in category 'initialize') -----
+ initializeSubmorphs
+ | weekRow dateButton |
+ self addMorphBack: self buildYearRow;
+ addMorphBack: self buildMonthRow;
+ addMorphBack: self dayInitialsRow.
+ date month weeks
+ do: [:week |
+ weekRow := self newRow.
+ week dates
+ do: [:aDate |
+ dateButton := self newDateButtonWithContents: aDate dayOfMonth asString.
+ dateButton actionSelector: #date:;
+ target: self;
+ arguments: {aDate}.
+ date = aDate
+ ifTrue: [dateButton
+ color: (self color
+ mixed: 0.5
+ with: (self color adjustSaturation: 1 brightness: 1))].
+ date month ~= aDate month
+ ifTrue: [dateButton color: self color.
+ (dateButton findA: StringMorph)
+ color: Color gray].
+ weekRow addMorphBack: dateButton]
+ separatedBy: [weekRow addMorphBack: AlignmentMorph newVariableTransparentSpacer].
+ self addMorphBack: weekRow]!
Item was added:
+ ----- Method: CalendarMorph>>labelsDefaultColor (in category 'building') -----
+ labelsDefaultColor
+ ^ self color makeForegroundColor !
Item was added:
+ ----- Method: CalendarMorph>>localeChanged (in category 'update') -----
+ localeChanged
+ self update!
Item was added:
+ ----- Method: CalendarMorph>>maximumStepTime (in category 'stepping') -----
+ maximumStepTime
+ ^ 200!
Item was added:
+ ----- Method: CalendarMorph>>minimumStepTime (in category 'stepping') -----
+ minimumStepTime
+ ^ 20!
Item was added:
+ ----- Method: CalendarMorph>>newButtonWithContents: (in category 'building') -----
+ newButtonWithContents: aString
+
+ ^ SimpleButtonMorph new
+ label: aString;
+ color: (self color mixed: 0.5 with: Color gray);
+ borderStyle: (BorderStyle raised width: 2 px);
+ yourself!
Item was added:
+ ----- Method: CalendarMorph>>newDateButtonWithContents: (in category 'building') -----
+ newDateButtonWithContents: aString
+
+ ^ SimpleButtonMorph new
+ label: aString;
+ cornerStyle: #square;
+ color: self color muchLighter;
+ borderStyle: (BorderStyle raised width: 2 px);
+ width: 30 px;
+ yourself!
Item was added:
+ ----- Method: CalendarMorph>>newRow (in category 'building') -----
+ newRow
+ ^ AlignmentMorph newRow
+ vResizing: #shrinkWrap;
+ color: Color transparent!
Item was added:
+ ----- Method: CalendarMorph>>nextMonth (in category 'actions') -----
+ nextMonth
+ self addMonths: 1!
Item was added:
+ ----- Method: CalendarMorph>>nextYear (in category 'actions') -----
+ nextYear
+ self addMonths: 12!
Item was added:
+ ----- Method: CalendarMorph>>previousMonth (in category 'actions') -----
+ previousMonth
+ self addMonths: -1!
Item was added:
+ ----- Method: CalendarMorph>>previousYear (in category 'actions') -----
+ previousYear
+ self addMonths: -12!
Item was added:
+ ----- Method: CalendarMorph>>step (in category 'stepping') -----
+ step
+ shouldUpdate
+ ifTrue: [self update.
+ stepTime := self minimumStepTime.
+ shouldUpdate := false]
+ ifFalse: [self incrementStepTime]!
Item was added:
+ ----- Method: CalendarMorph>>stepTime (in category 'stepping') -----
+ stepTime
+ ^ stepTime !
Item was added:
+ ----- Method: CalendarMorph>>update (in category 'update') -----
+ update
+ self submorphsDo: [:m | m delete].
+ self initializeSubmorphs !
Item was added:
+ ChessBoard subclass: #Chess960Board
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess960'!
+
+ !Chess960Board commentStamp: 'spfa 6/2/2020 15:13' prior: 0!
+ Chess960Board can handle Fisher-style random starting positions in home ranks!
Item was added:
+ ----- Method: Chess960Board>>initialize (in category 'initialize') -----
+ initialize
+ generator ifNil:[generator := Chess960MoveGenerator new initialize].
+ searchAgent ifNil:[searchAgent := ChessPlayerAI new initialize].
+ self resetGame.
+ !
Item was added:
+ ----- Method: Chess960Board>>initializeNewBoard (in category 'initialize') -----
+ initializeNewBoard
+
+ | conf |
+
+ self resetGame.
+ conf := Chess960Configuration new.
+ whitePlayer addWhitePieces: conf.
+ blackPlayer addBlackPieces: conf.
+ !
Item was added:
+ ----- Method: Chess960Board>>resetGame (in category 'initialize') -----
+ resetGame
+ hashKey := hashLock := 0.
+ whitePlayer := Chess960Player new initialize.
+ blackPlayer := Chess960Player new initialize.
+ whitePlayer opponent: blackPlayer.
+ whitePlayer board: self.
+ blackPlayer opponent: whitePlayer.
+ blackPlayer board: self.
+ activePlayer := whitePlayer.
+ searchAgent reset: self.
+ userAgent ifNotNil:[userAgent gameReset].!
Item was added:
+ Object subclass: #Chess960Configuration
+ instanceVariableNames: 'positions king leftRook rightRook'
+ classVariableNames: ''
+ poolDictionaries: 'ChessConstants'
+ category: 'MorphicExtras-Games-Chess960'!
+
+ !Chess960Configuration commentStamp: 'spfa 6/2/2020 15:13' prior: 0!
+ A Chess960Configuration is a Fisher-style random starting arrangement of pieces in the home ranks!
Item was added:
+ ----- Method: Chess960Configuration class>>new (in category 'as yet unclassified') -----
+ new
+
+ | rand positions k |
+
+ rand := Random new.
+ positions := Array new: 8.
+ positions at: (rand nextInt: 4) * 2 - 1 put: Bishop.
+ positions at: (rand nextInt: 4) * 2 put: Bishop.
+ positions at: (k := (((1 to: 8) select: [:n | (positions at: n) isNil]) copyFrom: 2 to: 5) atRandom: rand) put: King.
+ positions at: (((1 to: k-1) select: [:n | (positions at: n) isNil]) atRandom: rand) put: Rook.
+ positions at: (((k+1 to: 8) select: [:n | (positions at: n) isNil]) atRandom: rand) put: Rook.
+ positions at: (((1 to: 8) select: [:n | (positions at: n) isNil]) atRandom: rand) put: Queen.
+ positions at: ((1 to: 8) detect: [:n | (positions at: n) isNil]) put: Knight.
+ positions at: ((1 to: 8) detect: [:n | (positions at: n) isNil]) put: Knight.
+
+ ^ self basicNew positions: positions
+ !
Item was added:
+ ----- Method: Chess960Configuration>>initialKingPosition (in category 'positions') -----
+ initialKingPosition
+
+ ^ king ifNil: [king := positions indexOf: King]!
Item was added:
+ ----- Method: Chess960Configuration>>initialLeftRookPosition (in category 'positions') -----
+ initialLeftRookPosition
+
+ ^ leftRook ifNil: [leftRook := positions indexOf: Rook]!
Item was added:
+ ----- Method: Chess960Configuration>>initialRightRookPosition (in category 'positions') -----
+ initialRightRookPosition
+
+ ^ rightRook ifNil: [rightRook := positions indexOf: Rook startingAt: self initialKingPosition]!
Item was added:
+ ----- Method: Chess960Configuration>>positions (in category 'positions') -----
+ positions
+
+ ^ positions!
Item was added:
+ ----- Method: Chess960Configuration>>positions: (in category 'positions') -----
+ positions: anArray
+
+ positions := anArray.
+ king := leftRook := rightRook := nil!
Item was added:
+ ChessMorph subclass: #Chess960Morph
+ instanceVariableNames: 'images message squareSize'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess960'!
+
+ !Chess960Morph commentStamp: 'spfa 6/2/2020 15:10' prior: 0!
+ Chess960Morph is a nicer, scalable, skin for ChessMorph.
+ It also can play Fischer random chess (use the '960' button)
+
+ Chess960Morph new openInWorld
+
+ (Chess960Morph new squareSize: 100) openInWorld
+ !
Item was added:
+ ----- Method: Chess960Morph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Chess 960' translatedNoop
+ categories: {'Games' translatedNoop}
+ documentation: 'A fine game of chess. Revised by Stéphane Rollandin (spfa).' translatedNoop!
Item was added:
+ ----- Method: Chess960Morph>>addButtonRow (in category 'initialize') -----
+ addButtonRow
+
+ | r m |
+ r := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color transparent.
+ r cellInset: 2.
+ r addMorphBack: (self buttonName: ' New ' translated action: #newGame).
+ r addMorphBack: (self buttonName: ' 960 ' translated action: #new960Game).
+ r addMorphBack: (self buttonName: ' Help ' translated action: #findBestMove).
+ r addMorphBack: (self buttonName: ' Play ' translated action: #thinkAndMove).
+ r addMorphBack: (self buttonName: ' Auto ' translated action: #autoPlay).
+ r addMorphBack: (self buttonName: ' Undo ' translated action: #undoMove).
+ r addMorphBack: (self buttonName: ' Redo ' translated action: #redoMove).
+ r addMorphBack: (self buttonName: ' Quit ' translated action: #delete).
+ r disableLayout: true.
+ r align: r bounds topLeft with: self layoutBounds topLeft.
+ self addMorphFront: r.
+ m := UpdatingStringMorph on: self selector: #statusString.
+ m useStringFormat.
+ m disableTableLayout: true.
+ m stepTime: 50.
+ m align: m bounds topLeft with: r fullBounds bottomLeft.
+ self addMorphFront: m.
+ m
+ font: self textFont;
+ color: self statusColor;
+ maximumWidth: self width - self squareSize;
+ position: self position + (self squareSize @ self squareSize * 0.6)!
Item was added:
+ ----- Method: Chess960Morph>>addSquares (in category 'initialize') -----
+ addSquares
+ | white black border square index |
+ white := self whiteColor.
+ black := self blackColor.
+ border := self highColor.
+ index := 0.
+ #(
+ ( ' ' 'a' 'b' 'c' 'd' 'e' 'f' 'g' 'h' ' ')
+ ( '1' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
+ ( '2' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
+ ( '3' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
+ ( '4' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
+ ( '5' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
+ ( '6' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
+ ( '7' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
+ ( '8' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
+ ( ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ')
+ ) do:[:file|
+ file do:[:sq|
+ square := self newSquare.
+ square borderWidth: 0.
+ (sq = 'W' or:[sq = 'B']) ifTrue:[
+ square color: (sq = 'W' ifTrue:[white] ifFalse:[black]).
+ square borderColor: border.
+ square setProperty: #squarePosition toValue: (index := index + 1).
+ square setNameTo:
+ (String with: ($a asInteger + (index - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (index -1 bitShift: -3)) asCharacter).
+ square on: #mouseEnter send: #showMoves:from: to: self.
+ square on: #mouseEnterDragging send: #dragSquareEnter:from: to: self.
+ square on: #mouseLeaveDragging send: #dragSquareLeave:from: to: self.
+ ] ifFalse:["decoration"
+ square color: Color transparent.
+ sq = ' ' ifFalse:[
+ square addMorph: ((StringMorph contents: sq font: self textFont)
+ color: self labelsColor).
+ ].
+ ].
+ square extent: self squareSize @ self squareSize.
+ self addMorphBack: square.
+ square submorphs ifNotEmpty: [square submorphs first center: square center]
+ ]].
+ !
Item was added:
+ ----- Method: Chess960Morph>>blackColor (in category 'theme') -----
+ blackColor
+
+ " Color earth paler duller."
+ "^ Color grass duller"
+ ^ Color r: 0.343 g: 0.576 b: 0.207!
Item was added:
+ ----- Method: Chess960Morph>>buttonColor (in category 'theme') -----
+ buttonColor
+
+ " ^ Color lightBlue3 whiter "
+ ^ Color r: 0.667 g: 0.792 b: 0.833!
Item was added:
+ ----- Method: Chess960Morph>>buttonName:action: (in category 'initialize') -----
+ buttonName: aString action: aSymbol
+
+ ^ SimpleButtonMorph new
+ target: self;
+ label: aString;
+ actionSelector: aSymbol;
+ color: self buttonColor;
+ borderWidth: 1;
+ borderRaised.
+ !
Item was added:
+ ----- Method: Chess960Morph>>defaultBounds (in category 'initialization') -----
+ defaultBounds
+ "answer the default bounds for the receiver"
+ ^ 0 @ 0 corner: (self squareSize * 10 + 10) @ (self squareSize * 10 + 10)!
Item was added:
+ ----- Method: Chess960Morph>>defaultColor (in category 'theme') -----
+ defaultColor
+
+ "^ Color paleTeal duller duller"
+ ^ Color r: 0.467 g: 0.631 b: 0.71!
Item was added:
+ ----- Method: Chess960Morph>>findBestMove (in category 'playing') -----
+ findBestMove
+ | move |
+ board ifNil: [^ self].
+ board searchAgent isThinking ifTrue:[^self].
+
+ "tmp - board should be nil when the game is over"
+ ((1 to: 64) allSatisfy: [:n |
+ (board activePlayer pieces at: n) isZero
+ or: [(board activePlayer findValidMovesAt: n) isEmpty]])
+ ifTrue: [message := (board activePlayer isWhitePlayer
+ ifTrue: ['white'] ifFalse: ['black']), ' lost'.
+ ^ self].
+
+ Cursor wait showWhile:[move := board searchAgent think].
+ message := 'I suggest ' translated, move moveString.
+ ^move
+ !
Item was added:
+ ----- Method: Chess960Morph>>finishedGame: (in category 'as yet unclassified') -----
+ finishedGame: result
+
+ super finishedGame: result.
+ message := #('black won' 'draw' 'white won') at: result * 2 + 1!
Item was added:
+ ----- Method: Chess960Morph>>highColor (in category 'theme') -----
+ highColor
+
+ " ^ Color lightGold"
+ ^ Color r: 0.992 g: 0.863 b: 0.361!
Item was added:
+ ----- Method: Chess960Morph>>images (in category 'theme') -----
+ images
+
+ ^ images ifNil: [images := ChessPieceMorphWC piecesWithHeight: self squareSize - 5]!
Item was added:
+ ----- Method: Chess960Morph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ self bounds: self defaultBounds.
+ self beSticky!
Item was added:
+ ----- Method: Chess960Morph>>labelsColor (in category 'theme') -----
+ labelsColor
+
+ " ^ Color armyGreen"
+ ^ Color r: 0.294 g: 0.365 b: 0.086!
Item was added:
+ ----- Method: Chess960Morph>>movedPiece:from:to: (in category 'game callbacks') -----
+ movedPiece: piece from: sourceSquare to: destSquare
+ | sourceMorph destMorph sourcePos destPos w startTime nowTime deltaTime |
+ sourceMorph := (self atSquare: sourceSquare) firstSubmorph.
+ destMorph := self atSquare: destSquare.
+ animateMove ifTrue:[
+ sourcePos := sourceMorph boundsInWorld center.
+ destPos := destMorph boundsInWorld center.
+ (w := self world) ifNotNil:[
+ w addMorphFront: sourceMorph.
+ deltaTime := (sourcePos dist: destPos) * 3 asInteger.
+ startTime := Time millisecondClockValue.
+ [nowTime := Time millisecondClockValue.
+ nowTime - startTime < deltaTime] whileTrue:[
+ sourceMorph center: sourcePos + (destPos - sourcePos * (nowTime - startTime) // deltaTime) asIntegerPoint.
+ w displayWorldSafely].
+ sourceMorph removeDropShadow.
+ ].
+ ].
+ destMorph removeAllMorphs.
+ destMorph addMorphCentered: sourceMorph.
+ animateMove := false.
+ message := nil.!
Item was added:
+ ----- Method: Chess960Morph>>new960Game (in category 'initialize') -----
+ new960Game
+ board := Chess960Board new.
+ board initialize.
+ board userAgent: self.
+ board initializeNewBoard.
+ history := OrderedCollection new.
+ redoList := OrderedCollection new.
+ message := nil
+ !
Item was added:
+ ----- Method: Chess960Morph>>newPiece:white: (in category 'initialize') -----
+ newPiece: piece white: isWhite
+
+ | index selector m |
+ index := piece.
+ isWhite ifFalse:[index := index + 6].
+ selector := #(
+ whitePawn
+ whiteKnight
+ whiteBishop
+ whiteRook
+ whiteQueen
+ whiteKing
+
+ blackPawn
+ blackKnight
+ blackBishop
+ blackRook
+ blackQueen
+ blackKing) at: index.
+ m := ChessPieceMorph new image: (self images at: selector).
+ m setProperty: #isWhite toValue: isWhite.
+ m setProperty: #piece toValue: piece.
+ ^m!
Item was added:
+ ----- Method: Chess960Morph>>reinstallPieces (in category 'resizing') -----
+ reinstallPieces
+
+ board whitePlayer pieces withIndexDo: [:pc :n |
+ pc isZero ifFalse: [
+ self addedPiece: pc at: n white: true]].
+
+ board blackPlayer pieces withIndexDo: [:pc :n |
+ pc isZero ifFalse: [
+ self addedPiece: pc at: n white: false]].!
Item was added:
+ ----- Method: Chess960Morph>>setExtentFromHalo: (in category 'miscellaneous') -----
+ setExtentFromHalo: anExtent
+
+ self squareSize: (anExtent x - 10) //10.!
Item was added:
+ ----- Method: Chess960Morph>>showMovesAt: (in category 'events') -----
+ showMovesAt: square
+ | list |
+ board ifNil:[^self].
+ board searchAgent isThinking ifTrue:[^self].
+ self squaresDo:[:m| m borderWidth: 0].
+ list := board activePlayer findValidMovesAt: square.
+ list isEmpty ifTrue:[^self].
+ (self atSquare: square) borderWidth: 2.
+ list do:[:move|
+ (self atSquare: (move triggerSquareIn: board)) borderWidth: 5.
+ ].!
Item was added:
+ ----- Method: Chess960Morph>>squareSize (in category 'resizing') -----
+ squareSize
+
+ ^ squareSize ifNil: [70]!
Item was added:
+ ----- Method: Chess960Morph>>squareSize: (in category 'resizing') -----
+ squareSize: anInteger
+
+ | ss |
+
+ ss := anInteger max: 48.
+
+ squareSize := ss.
+ images := nil.
+ submorphs do: #delete.
+ self extent: (ss * 10 + 10) @ (ss * 10 + 10) .
+ self addSquares.
+ self addButtonRow.
+ self reinstallPieces!
Item was added:
+ ----- Method: Chess960Morph>>statusColor (in category 'theme') -----
+ statusColor
+
+ " ^ Color reallyLightBlue "
+ ^ Color r: 0.831 g: 1 b: 1!
Item was added:
+ ----- Method: Chess960Morph>>statusString (in category 'other stuff') -----
+ statusString
+
+ ^ message ifNil: [super statusString]!
Item was added:
+ ----- Method: Chess960Morph>>swappedPieceOn:withPieceOn: (in category 'game callbacks') -----
+ swappedPieceOn: aSquare withPieceOn: bSquare
+ | aMorph bMorph |
+
+ aMorph := (self atSquare: aSquare) firstSubmorph.
+ bMorph := (self atSquare: bSquare) firstSubmorph.
+
+ (self atSquare: aSquare) removeAllMorphs.
+ (self atSquare: aSquare) addMorphCentered: bMorph.
+
+ (self atSquare: bSquare) removeAllMorphs.
+ (self atSquare: bSquare) addMorphCentered: aMorph.
+
+ message := nil.!
Item was added:
+ ----- Method: Chess960Morph>>textFont (in category 'theme') -----
+ textFont
+
+ | ps |
+
+ ps := self squareSize < 80 ifTrue: [12] ifFalse: [15].
+
+ ^ TTCFont familyName: 'BitstreamVeraSans' pointSize: ps emphasis: 1
+ !
Item was added:
+ ----- Method: Chess960Morph>>whiteColor (in category 'theme') -----
+ whiteColor
+
+ " ^ Color ivory"
+ ^ Color r: 1 g: 1 b: 0.94!
Item was added:
+ ChessMoveGenerator subclass: #Chess960MoveGenerator
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess960'!
+
+ !Chess960MoveGenerator commentStamp: 'spfa 6/1/2020 14:56' prior: 0!
+ Chess960MoveGenerator implements the specific castling checks and moves for Chess960!
Item was added:
+ ----- Method: Chess960MoveGenerator>>canCastleBlackKingSide (in category 'support') -----
+ canCastleBlackKingSide
+
+ (castlingStatus bitAnd: CastlingEnableKingSide) = 0 ifFalse:[^false].
+
+ (myPlayer rightCastlingField inject: 0 into: [:sum :s|
+ sum + (myPieces at: s) + (itsPieces at: s)]) = (King + Rook)
+ ifFalse:[^false].
+
+ myPlayer rightCastlingWalk in: [:w |
+ (self checkRookMoversAttacksAlong: w) ifTrue: [^false].
+ (self checkBishopMoversAttacksAlong: w) ifTrue: [^ false].
+ (self checkKnightAttacksAlong: w) ifTrue: [^ false].
+ (self checkPawnsAttacksAlong: w) ifTrue: [^ false].
+ (self checkKingAttacksAlong: w) ifTrue: [^ false]].
+
+ (self checkAttack: (myPlayer initialKingSquare - 1 to: A8 by: -1) fromPieces: RookMovers)
+ ifTrue: [^false].
+ (self checkAttack: {H8} fromPieces: RookMovers) ifTrue: [^false].
+
+ ^true.
+
+
+
+
+ !
Item was added:
+ ----- Method: Chess960MoveGenerator>>canCastleBlackQueenSide (in category 'support') -----
+ canCastleBlackQueenSide
+
+ (castlingStatus bitAnd: CastlingEnableQueenSide) = 0 ifFalse:[^false].
+
+ (myPlayer leftCastlingField inject: 0 into: [:sum :s|
+ sum + (myPieces at: s) + (itsPieces at: s)]) = (King + Rook)
+ ifFalse:[^false].
+
+ myPlayer leftCastlingWalk in: [:w |
+ (self checkRookMoversAttacksAlong: w) ifTrue: [^false].
+ (self checkBishopMoversAttacksAlong: w) ifTrue: [^ false].
+ (self checkKnightAttacksAlong: w) ifTrue: [^ false].
+ (self checkPawnsAttacksAlong: w) ifTrue: [^ false].
+ (self checkKingAttacksAlong: w) ifTrue: [^ false]].
+
+ (self checkAttack: (myPlayer initialKingSquare +1 to: H8) fromPieces: RookMovers)
+ ifTrue: [^false].
+ (self checkAttack: {B8 . A8} fromPieces: RookMovers) ifTrue: [^false].
+
+
+ ^true.
+
+
+
+
+ !
Item was added:
+ ----- Method: Chess960MoveGenerator>>canCastleWhiteKingSide (in category 'support') -----
+ canCastleWhiteKingSide
+
+ (castlingStatus bitAnd: CastlingEnableKingSide) = 0 ifFalse:[^false].
+
+ (myPlayer rightCastlingField inject: 0 into: [:sum :s|
+ sum + (myPieces at: s) + (itsPieces at: s)]) = (King + Rook)
+ ifFalse:[^false].
+
+ myPlayer rightCastlingWalk in: [:w |
+ (self checkRookMoversAttacksAlong: w) ifTrue: [^false].
+ (self checkBishopMoversAttacksAlong: w) ifTrue: [^ false].
+ (self checkKnightAttacksAlong: w) ifTrue: [^ false].
+ (self checkPawnsAttacksAlong: w) ifTrue: [^ false].
+ (self checkKingAttacksAlong: w) ifTrue: [^ false]].
+
+ (self checkAttack: (myPlayer initialKingSquare - 1 to: A1 by: -1) fromPieces: RookMovers)
+ ifTrue: [^false].
+ (self checkAttack: {H1} fromPieces: RookMovers) ifTrue: [^false].
+
+ ^true.
+
+
+
+
+ !
Item was added:
+ ----- Method: Chess960MoveGenerator>>canCastleWhiteQueenSide (in category 'support') -----
+ canCastleWhiteQueenSide
+
+ (castlingStatus bitAnd: CastlingEnableQueenSide) = 0 ifFalse:[^false].
+
+ (myPlayer leftCastlingField inject: 0 into: [:sum :s|
+ sum + (myPieces at: s) + (itsPieces at: s)]) = (King + Rook)
+ ifFalse:[^false].
+
+ myPlayer leftCastlingWalk in: [:w |
+ (self checkRookMoversAttacksAlong: w) ifTrue: [^false].
+ (self checkBishopMoversAttacksAlong: w) ifTrue: [^ false].
+ (self checkKnightAttacksAlong: w) ifTrue: [^ false].
+ (self checkPawnsAttacksAlong: w) ifTrue: [^ false].
+ (self checkKingAttacksAlong: w) ifTrue: [^ false]].
+
+ (self checkAttack: (myPlayer initialKingSquare + 1 to: H1) fromPieces: RookMovers)
+ ifTrue: [^false].
+ (self checkAttack: {B1 . A1} fromPieces: RookMovers) ifTrue: [^false].
+
+ ^true.
+
+
+
+
+ !
Item was added:
+ ----- Method: Chess960MoveGenerator>>checkBishopMoversAttacksAlong: (in category 'support') -----
+ checkBishopMoversAttacksAlong: anArray
+
+ "anArray contains consecutive, ordered squares that are all either in rank 8 or in rank 1"
+
+ anArray do: [:s |
+ (self checkBishopMoversAttacksOn: s) ifTrue: [^ true]].
+
+ ^ false!
Item was added:
+ ----- Method: Chess960MoveGenerator>>checkBishopMoversAttacksOn: (in category 'support') -----
+ checkBishopMoversAttacksOn: aSquare
+
+ "aSquare is either in rank 8 or in rank 1"
+
+ | leftDiagonal rightDiagonal |
+
+ myPlayer isWhitePlayer ifFalse: [
+ leftDiagonal := (1 to: aSquare - A8) collect: [:n | aSquare - (n * 7)].
+ rightDiagonal := (1 to: H8 - aSquare) collect: [:n | aSquare - (n * 9)]
+ ]
+ ifTrue: [
+ leftDiagonal := (1 to: aSquare - A1) collect: [:n | aSquare + (n * 7)].
+ rightDiagonal := (1 to: H1 - aSquare) collect: [:n | aSquare + (n * 9)]
+ ].
+
+ ^ (self checkAttack: leftDiagonal fromPieces: BishopMovers)
+ or: [self checkAttack: rightDiagonal fromPieces: BishopMovers]!
Item was added:
+ ----- Method: Chess960MoveGenerator>>checkKingAttacksAlong: (in category 'support') -----
+ checkKingAttacksAlong: anArray
+
+ "anArray contains consecutive, ordered squares that are all either in rank 8 or in rank 1"
+
+ | kpos |
+
+ "somewhat overkill because some positions can never be reached by opponent king"
+ kpos := Array streamContents: [:str |
+ str nextPut: anArray first - 1.
+ str nextPutAll: anArray.
+ str nextPut: anArray last + 1].
+
+ ^ self checkUnprotectedAttack:
+ (kpos + (myPlayer isWhitePlayer ifTrue: [8] ifFalse: [-8]))
+ fromPiece: King!
Item was added:
+ ----- Method: Chess960MoveGenerator>>checkKnightAttacksAlong: (in category 'support') -----
+ checkKnightAttacksAlong: anArray
+
+ "anArray contains consecutive, ordered squares that are all either in rank 8 or in rank 1"
+
+ | kpos1 kpos2 |
+
+ "rank at distance 1"
+ kpos1 := (anArray - 2) union: (anArray + 2).
+
+ myPlayer isWhitePlayer ifTrue: [
+ kpos1 min = 0 ifTrue: [kpos1 := kpos1 copyWithout: 0].
+ kpos1 max = 9 ifTrue: [kpos1 := kpos1 copyWithout: 9]].
+
+ (self checkUnprotectedAttack:
+ (kpos1 + (myPlayer isWhitePlayer ifTrue: [8] ifFalse: [-8]))
+ fromPiece: Knight) ifTrue: [^ true].
+
+ "rank at distance 2 - same logic as for pawns at distance 1"
+ kpos2 := Array streamContents: [:str |
+ str nextPut: anArray min - 1.
+ anArray size > 1 ifTrue: [str nextPutAll: anArray].
+ str nextPut: anArray max + 1].
+
+ ^ self checkUnprotectedAttack:
+ (kpos2 + (myPlayer isWhitePlayer ifTrue: [16] ifFalse: [-16]))
+ fromPiece: Knight!
Item was added:
+ ----- Method: Chess960MoveGenerator>>checkPawnsAttacksAlong: (in category 'support') -----
+ checkPawnsAttacksAlong: anArray
+
+ "anArray contains consecutive, ordered squares that are all either in rank 8 or in rank 1"
+
+ | ppos |
+
+ ppos := Array streamContents: [:str |
+ str nextPut: anArray first - 1.
+ "If the king does not move, castling is not prevented by a pawn in same file"
+ anArray size > 1 ifTrue: [str nextPutAll: anArray].
+ str nextPut: anArray last + 1].
+
+ ^ self checkUnprotectedAttack:
+ (ppos + (myPlayer isWhitePlayer ifTrue: [8] ifFalse: [-8]))
+ fromPiece: Pawn!
Item was added:
+ ----- Method: Chess960MoveGenerator>>checkRookMoversAttacksAlong: (in category 'support') -----
+ checkRookMoversAttacksAlong: anArray
+
+ "anArray contains consecutive, ordered squares that are all either in rank 8 or in rank 1"
+
+ anArray first > 8 ifTrue: [ "black"
+ anArray do: [:s |
+ (self checkAttack: {s-8. s-16. s-24. s-32. s-40. s-48. s-56} fromPieces: RookMovers)
+ ifTrue: [^ true]].
+ ^ false].
+
+ "white"
+ anArray do: [:s |
+ (self checkAttack: {s+8. s+16. s+24. s+32. s+40. s+48. s+56} fromPieces: RookMovers)
+ ifTrue: [^ true]].
+ ^ false
+ !
Item was added:
+ ----- Method: Chess960MoveGenerator>>moveBlackKingAt: (in category 'moves-general') -----
+ moveBlackKingAt: square
+ | capture |
+ (KingMoves at: square) do:[:destSquare|
+ (myPieces at: destSquare) = 0 ifTrue:[
+ capture := itsPieces at: destSquare.
+ (forceCaptures and:[capture = 0]) ifFalse:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ move: King from: square to: destSquare capture: capture.
+ capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
+ ].
+ ].
+ ].
+ forceCaptures ifTrue:[^self].
+ "now consider castling"
+ self canCastleBlackKingSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ moveCastlingKingSide: King from: square to: G8
+ ].
+ self canCastleBlackQueenSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ moveCastlingQueenSide: King from: square to: C8
+ ].!
Item was added:
+ ----- Method: Chess960MoveGenerator>>moveWhiteKingAt: (in category 'moves-general') -----
+ moveWhiteKingAt: square
+ | capture |
+ (KingMoves at: square) do:[:destSquare|
+ (myPieces at: destSquare) = 0 ifTrue:[
+ capture := itsPieces at: destSquare.
+ (forceCaptures and:[capture = 0]) ifFalse:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ move: King from: square to: destSquare capture: capture.
+ capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
+ ].
+ ].
+ ].
+ forceCaptures ifTrue:[^self].
+ "now consider castling"
+ self canCastleWhiteKingSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ moveCastlingKingSide: King from: square to: G1.
+ ].
+ self canCastleWhiteQueenSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ moveCastlingQueenSide: King from: square to: C1.
+ ].!
Item was added:
+ ChessPlayer subclass: #Chess960Player
+ instanceVariableNames: 'configuration'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess960'!
+
+ !Chess960Player commentStamp: 'spfa 6/2/2020 15:16' prior: 0!
+ Chess960Player represents a Chess960 player (doh)!
Item was added:
+ ----- Method: Chess960Player>>addBlackPieces: (in category 'adding/removing') -----
+ addBlackPieces: aChess960Configuration
+
+ self configuration: aChess960Configuration.
+
+ configuration positions withIndexDo: [:p :n | self addPiece: p at: 56+n].
+ 49 to: 56 do:[:i| self addPiece: Pawn at: i].!
Item was added:
+ ----- Method: Chess960Player>>addWhitePieces: (in category 'adding/removing') -----
+ addWhitePieces: aChess960Configuration
+
+ self configuration: aChess960Configuration.
+
+ configuration positions withIndexDo: [:p :n | self addPiece: p at: n].
+ 9 to: 16 do:[:i| self addPiece: Pawn at: i].
+ !
Item was added:
+ ----- Method: Chess960Player>>applyCastleKingSideMove: (in category 'moving') -----
+ applyCastleKingSideMove: move
+
+ (pieces at: move destinationSquare) isZero "rook" ifFalse: [
+ castlingRookSquare := self isWhitePlayer ifTrue: [F1] ifFalse: [F8].
+ move sourceSquare = castlingRookSquare
+ ifTrue: [
+ self swapPiecesIn: move sourceSquare and: move destinationSquare]
+ ifFalse: [
+ self movePiece: Rook from: self initialRightRookSquare to: castlingRookSquare.
+ self movePiece: King from: move sourceSquare to: move destinationSquare].
+ castlingStatus := castlingStatus bitOr: CastlingDone.
+ ^ self].
+
+ self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.
+ self movePiece: Rook
+ from: self initialRightRookSquare
+ to: ((castlingRookSquare := self isWhitePlayer ifTrue: [F1] ifFalse: [F8])).
+ pieces at: castlingRookSquare put: King.
+ castlingStatus := castlingStatus bitOr: CastlingDone.!
Item was added:
+ ----- Method: Chess960Player>>applyCastleQueenSideMove: (in category 'moving') -----
+ applyCastleQueenSideMove: move
+
+ (pieces at: move destinationSquare) isZero "rook or king" ifFalse: [
+ castlingRookSquare := self isWhitePlayer ifTrue: [D1] ifFalse: [D8].
+ move sourceSquare = castlingRookSquare
+ ifTrue: [
+ self swapPiecesIn: move sourceSquare and: move destinationSquare]
+ ifFalse: [
+ self movePiece: Rook
+ from: self initialLeftRookSquare to: castlingRookSquare.
+ self movePiece: King from: move sourceSquare to: move destinationSquare].
+ castlingStatus := castlingStatus bitOr: CastlingDone.
+ ^ self].
+
+ self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.
+ self movePiece: Rook
+ from: self initialLeftRookSquare
+ to: (castlingRookSquare := self isWhitePlayer ifTrue: [D1] ifFalse: [D8]).
+ pieces at: castlingRookSquare put: King.
+ castlingStatus := castlingStatus bitOr: CastlingDone.!
Item was added:
+ ----- Method: Chess960Player>>configuration (in category 'configuration') -----
+ configuration
+
+ ^ configuration!
Item was added:
+ ----- Method: Chess960Player>>configuration: (in category 'configuration') -----
+ configuration: aChess960Configuration
+
+ configuration := aChess960Configuration!
Item was added:
+ ----- Method: Chess960Player>>copyPlayer: (in category 'copying') -----
+ copyPlayer: aPlayer
+
+ super copyPlayer: aPlayer.
+ configuration := aPlayer configuration!
Item was added:
+ ----- Method: Chess960Player>>initialKingSquare (in category 'configuration') -----
+ initialKingSquare
+
+ ^ self isWhitePlayer ifTrue: [self configuration initialKingPosition]
+ ifFalse: [self configuration initialKingPosition + 56]!
Item was added:
+ ----- Method: Chess960Player>>initialLeftRookSquare (in category 'configuration') -----
+ initialLeftRookSquare
+
+ ^ self isWhitePlayer ifTrue: [self configuration initialLeftRookPosition]
+ ifFalse: [self configuration initialLeftRookPosition + 56]!
Item was added:
+ ----- Method: Chess960Player>>initialRightRookSquare (in category 'configuration') -----
+ initialRightRookSquare
+
+ ^ self isWhitePlayer ifTrue: [self configuration initialRightRookPosition]
+ ifFalse: [self configuration initialRightRookPosition + 56]!
Item was added:
+ ----- Method: Chess960Player>>leftCastlingField (in category 'configuration') -----
+ leftCastlingField
+
+ "The squares walked by both the king and the left rook when castling to the left - they must be clear of other pieces"
+
+ ^ self isWhitePlayer
+ ifTrue: [(C1 to: self initialKingSquare) union: (self initialLeftRookSquare to: D1)]
+ ifFalse: [(C8 to: self initialKingSquare) union: (self initialLeftRookSquare to: D8)]
+ !
Item was added:
+ ----- Method: Chess960Player>>leftCastlingWalk (in category 'configuration') -----
+ leftCastlingWalk
+
+ "The squares walked by the king when castling to the left - they must not be under check"
+
+ | ks |
+
+ ks := self initialKingSquare.
+
+ ^ self isWhitePlayer
+ ifTrue: [ks > C1 ifTrue: [C1 to: ks] ifFalse: [ks to: C1]]
+ ifFalse: [ks > C8 ifTrue: [C8 to: ks] ifFalse: [ks to: C8]] !
Item was added:
+ ----- Method: Chess960Player>>movePiece:from:to: (in category 'adding/removing') -----
+ movePiece: piece from: sourceSquare to: destSquare
+
+ sourceSquare = destSquare ifTrue: [^ self].
+ super movePiece: piece from: sourceSquare to: destSquare!
Item was added:
+ ----- Method: Chess960Player>>rightCastlingField (in category 'configuration') -----
+ rightCastlingField
+
+ "The squares walked by both the king and the right rook when castling to the left - they must be clear of other pieces"
+
+ ^ self isWhitePlayer
+ ifTrue: [(self initialKingSquare to: G1) union: (F1 to: self initialRightRookSquare)]
+ ifFalse: [(self initialKingSquare to: G8) union: (F8 to: self initialRightRookSquare)]!
Item was added:
+ ----- Method: Chess960Player>>rightCastlingWalk (in category 'configuration') -----
+ rightCastlingWalk
+
+ "The squares walked by the king when castling to the right - they must not be under check"
+
+ | ks |
+
+ ks := self initialKingSquare.
+
+ ^ self isWhitePlayer
+ ifTrue: [ks > G1 ifTrue: [G1 to: ks] ifFalse: [ks to: G1]]
+ ifFalse: [ks > G8 ifTrue: [G8 to: ks] ifFalse: [ks to: G8]] !
Item was added:
+ ----- Method: Chess960Player>>swapPiecesIn:and: (in category 'adding/removing') -----
+ swapPiecesIn: aSquare and: bSquare
+
+ "Only applies to specific castling moves"
+
+ | score pa pb |
+
+ pa := pieces at: aSquare.
+ pb := pieces at: bSquare.
+
+ score := PieceCenterScores at: pa.
+ positionalValue := positionalValue - (score at: aSquare).
+ positionalValue := positionalValue + (score at: bSquare).
+
+ score := PieceCenterScores at: pb.
+ positionalValue := positionalValue - (score at: bSquare).
+ positionalValue := positionalValue + (score at: aSquare).
+
+ pieces at: aSquare put: pb.
+ pieces at: bSquare put: pa.
+ board updateHash: pa at: aSquare from: self.
+ board updateHash: pa at: bSquare from: self.
+ board updateHash: pb at: bSquare from: self.
+ board updateHash: pb at: aSquare from: self.
+
+ self userAgent ifNotNil:[self userAgent swappedPieceOn: aSquare withPieceOn: bSquare].!
Item was added:
+ ----- Method: Chess960Player>>undoCastleKingSideMove: (in category 'undo') -----
+ undoCastleKingSideMove: move
+ self prepareNextMove. "in other words, remove extra kings"
+ self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
+
+ self isWhitePlayer ifTrue: [
+ self movePiece: Rook from: F1 to: self initialRightRookPosition.
+ ] ifFalse: [
+ self movePiece: Rook from: F8 to: self initialRightRookPosition + 56.
+ ]
+
+ !
Item was added:
+ ----- Method: Chess960Player>>undoCastleQueenSideMove: (in category 'undo') -----
+ undoCastleQueenSideMove: move
+ self prepareNextMove. "in other words, remove extra kings"
+ self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
+
+ self isWhitePlayer ifTrue: [
+ self movePiece: Rook from: D1 to: self initialLeftRookPosition.
+ ] ifFalse: [
+ self movePiece: Rook from: D8 to: self initialLeftRookPosition + 56.
+ ]
+
+ !
Item was added:
+ ----- Method: Chess960Player>>updateCastlingStatus: (in category 'moving') -----
+ updateCastlingStatus: move
+
+ "Cannot castle when king has moved"
+ (move movingPiece = King)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableAll].
+
+ "See if a rook has moved"
+ (move movingPiece = Rook) ifFalse:[^self].
+
+ (move sourceSquare = self initialLeftRookSquare)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableQueenSide].
+
+ (move sourceSquare = self initialRightRookSquare)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableKingSide].!
Item was added:
+ Object subclass: #ChessBoard
+ instanceVariableNames: 'whitePlayer blackPlayer activePlayer userAgent searchAgent generator hashKey hashLock'
+ classVariableNames: 'HashKeys HashLocks'
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess'!
+
+ !ChessBoard commentStamp: '<historical>' prior: 0!
+ This class represents the chess board itself.!
Item was added:
+ ----- Method: ChessBoard class>>initialize (in category 'class initialization') -----
+ initialize
+ "ChessGame initialize"
+ self initializeHashKeys.
+ !
Item was added:
+ ----- Method: ChessBoard class>>initializeHashKeys (in category 'class initialization') -----
+ initializeHashKeys
+ "ChessGame initialize"
+ | random |
+ HashKeys := Array new: 12.
+ 1 to: HashKeys size do:[:i| HashKeys at: i put: (WordArray new: 64)].
+ HashLocks := Array new: 12.
+ 1 to: HashLocks size do:[:i| HashLocks at: i put: (WordArray new: 64)].
+ random := Random seed: 23648646.
+ 1 to: 12 do:[:i|
+ 1 to: 64 do:[:j|
+ (HashKeys at: i) at: j put: (random nextInt: 16r3FFFFFFF "SmallInteger maxVal on 32bits VM")- 1.
+ (HashLocks at: i) at: j put: (random nextInt: 16r3FFFFFFF "SmallInteger maxVal on 32bits VM") - 1.
+ ].
+ ].
+
+ !
Item was added:
+ ----- Method: ChessBoard>>activePlayer (in category 'accessing') -----
+ activePlayer
+ ^activePlayer!
Item was added:
+ ----- Method: ChessBoard>>blackPlayer (in category 'accessing') -----
+ blackPlayer
+ ^blackPlayer!
Item was added:
+ ----- Method: ChessBoard>>copyBoard: (in category 'copying') -----
+ copyBoard: aBoard
+ "Copy all volatile state from the given board"
+
+ whitePlayer copyPlayer: aBoard whitePlayer.
+ blackPlayer copyPlayer: aBoard blackPlayer.
+ activePlayer := aBoard activePlayer isWhitePlayer
+ ifTrue: [whitePlayer]
+ ifFalse: [blackPlayer].
+ hashKey := aBoard hashKey.
+ hashLock := aBoard hashLock.
+ userAgent := nil!
Item was added:
+ ----- Method: ChessBoard>>generator (in category 'accessing') -----
+ generator
+ ^generator!
Item was added:
+ ----- Method: ChessBoard>>hashKey (in category 'hashing') -----
+ hashKey
+ ^hashKey!
Item was added:
+ ----- Method: ChessBoard>>hashLock (in category 'hashing') -----
+ hashLock
+ ^hashLock!
Item was added:
+ ----- Method: ChessBoard>>initialize (in category 'initialize') -----
+ initialize
+ generator ifNil:[generator := ChessMoveGenerator new initialize].
+ searchAgent ifNil:[searchAgent := ChessPlayerAI new initialize].
+ self resetGame.
+ !
Item was added:
+ ----- Method: ChessBoard>>initializeNewBoard (in category 'initialize') -----
+ initializeNewBoard
+ self resetGame.
+ whitePlayer addWhitePieces.
+ blackPlayer addBlackPieces.
+ !
Item was added:
+ ----- Method: ChessBoard>>movePieceFrom:to: (in category 'moving') -----
+ movePieceFrom: sourceSquare to: destSquare
+ | move |
+ searchAgent isThinking ifTrue:[^self].
+ move := (activePlayer findPossibleMovesAt: sourceSquare) contents
+ detect:[:any| any destinationSquare = destSquare
+ or: [(any triggerSquareIn: self) = destSquare]].
+ self nextMove: move.
+ searchAgent activePlayer: activePlayer.!
Item was added:
+ ----- Method: ChessBoard>>nextMove: (in category 'moving') -----
+ nextMove: aMove
+ activePlayer applyMove: aMove.
+ userAgent
+ ifNotNil: [userAgent completedMove: aMove white: activePlayer isWhitePlayer].
+ activePlayer := activePlayer == whitePlayer
+ ifTrue: [blackPlayer]
+ ifFalse: [whitePlayer].
+ activePlayer prepareNextMove !
Item was added:
+ ----- Method: ChessBoard>>nullMove (in category 'moving') -----
+ nullMove
+ activePlayer := activePlayer == whitePlayer
+ ifTrue: [blackPlayer]
+ ifFalse: [whitePlayer].
+ activePlayer prepareNextMove!
Item was added:
+ ----- Method: ChessBoard>>postCopy (in category 'copying') -----
+ postCopy
+ whitePlayer == activePlayer ifTrue:[
+ whitePlayer := whitePlayer copy.
+ blackPlayer := blackPlayer copy.
+ activePlayer := whitePlayer.
+ ] ifFalse:[
+ whitePlayer := whitePlayer copy.
+ blackPlayer := blackPlayer copy.
+ activePlayer := blackPlayer.
+ ].
+ whitePlayer opponent: blackPlayer.
+ blackPlayer opponent: whitePlayer.
+ whitePlayer board: self.
+ blackPlayer board: self.
+ self userAgent: nil.!
Item was added:
+ ----- Method: ChessBoard>>printOn: (in category 'printing') -----
+ printOn: aStream
+ super printOn: aStream.
+ aStream
+ nextPut: $(;
+ print: hashKey; space; print: hashLock;
+ nextPut: $).!
Item was added:
+ ----- Method: ChessBoard>>resetGame (in category 'initialize') -----
+ resetGame
+ hashKey := hashLock := 0.
+ whitePlayer := ChessPlayer new initialize.
+ blackPlayer := ChessPlayer new initialize.
+ whitePlayer opponent: blackPlayer.
+ whitePlayer board: self.
+ blackPlayer opponent: whitePlayer.
+ blackPlayer board: self.
+ activePlayer := whitePlayer.
+ searchAgent reset: self.
+ userAgent ifNotNil:[userAgent gameReset].!
Item was added:
+ ----- Method: ChessBoard>>searchAgent (in category 'accessing') -----
+ searchAgent
+ ^searchAgent!
Item was added:
+ ----- Method: ChessBoard>>searchAgent: (in category 'accessing') -----
+ searchAgent: anAgent
+ searchAgent := anAgent.!
Item was added:
+ ----- Method: ChessBoard>>statusString (in category 'accessing') -----
+ statusString
+ ^searchAgent statusString!
Item was added:
+ ----- Method: ChessBoard>>undoMove: (in category 'moving') -----
+ undoMove: aMove
+ activePlayer := activePlayer == whitePlayer
+ ifTrue: [blackPlayer]
+ ifFalse: [whitePlayer].
+ activePlayer undoMove: aMove.
+ userAgent
+ ifNotNil: [userAgent undoMove: aMove white: activePlayer isWhitePlayer]!
Item was added:
+ ----- Method: ChessBoard>>updateHash:at:from: (in category 'hashing') -----
+ updateHash: piece at: square from: player
+ | index |
+ index := player == whitePlayer ifTrue: [piece] ifFalse: [piece + 6].
+ hashKey := hashKey bitXor: ((HashKeys at: index) at: square).
+ hashLock := hashLock bitXor: ((HashLocks at: index) at: square)!
Item was added:
+ ----- Method: ChessBoard>>userAgent (in category 'accessing') -----
+ userAgent
+ ^userAgent!
Item was added:
+ ----- Method: ChessBoard>>userAgent: (in category 'accessing') -----
+ userAgent: anObject
+ userAgent := anObject.!
Item was added:
+ ----- Method: ChessBoard>>whitePlayer (in category 'accessing') -----
+ whitePlayer
+ ^whitePlayer!
Item was added:
+ SharedPool subclass: #ChessConstants
+ instanceVariableNames: ''
+ classVariableNames: 'A1 A2 A3 A4 A5 A6 A7 A8 B1 B2 B3 B4 B5 B6 B7 B8 Bishop BishopMovers BishopMoves C1 C2 C3 C4 C5 C6 C7 C8 CastlingDisableAll CastlingDisableKingSide CastlingDisableQueenSide CastlingDone CastlingEnableKingSide CastlingEnableQueenSide D1 D2 D3 D4 D5 D6 D7 D8 E1 E2 E3 E4 E5 E6 E7 E8 EmptySquare F1 F2 F3 F4 F5 F6 F7 F8 G1 G2 G3 G4 G5 G6 G7 G8 H1 H2 H3 H4 H5 H6 H7 H8 King KingMoves Knight KnightMoves Pawn PieceCenterScores PieceValues Queen Rook RookMovers RookMoves'
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess'!
Item was added:
+ ----- Method: ChessConstants class>>initialize (in category 'pool initialization') -----
+ initialize
+ "ChessConstants initialize"
+ self initializePieceConstants.
+ self initializeCastlingConstants.
+ self initializePieceValues.
+ self initializeMoves.
+ self initializeCenterScores.
+ self initializeBishopMovers.
+ self initializeRookMovers.
+ self initializeSquareConstants.!
Item was added:
+ ----- Method: ChessConstants class>>initializeBishopMovers (in category 'pool initialization') -----
+ initializeBishopMovers.
+ BishopMovers := Set new.
+ BishopMovers add:Bishop.
+ BishopMovers add:Queen.!
Item was added:
+ ----- Method: ChessConstants class>>initializeBishopMoves (in category 'pool initialization') -----
+ initializeBishopMoves
+ "ChessPlayer initialize"
+ | index moveList1 moveList2 moveList3 moveList4 px py |
+ BishopMoves := Array new: 64 withAll: #().
+ 0 to: 7 do:[:j|
+ 0 to: 7 do:[:i|
+ index := (j * 8) + i + 1.
+ moveList1 := moveList2 := moveList3 := moveList4 := #().
+ 1 to: 7 do:[:k|
+ px := i + k. py := j - k.
+ ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList1 := moveList1 copyWith: (py * 8) + px + 1].
+ px := i - k. py := j - k.
+ ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList2 := moveList2 copyWith: (py * 8) + px + 1].
+ px := i + k. py := j + k.
+ ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList3 := moveList3 copyWith: (py * 8) + px + 1].
+ px := i - k. py := j + k.
+ ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList4 := moveList4 copyWith: (py * 8) + px + 1].
+ ].
+ BishopMoves at: index put: {moveList1. moveList2. moveList3. moveList4}.
+ ].
+ ].!
Item was added:
+ ----- Method: ChessConstants class>>initializeCastlingConstants (in category 'pool initialization') -----
+ initializeCastlingConstants
+ CastlingDone := 1.
+
+ CastlingDisableKingSide := 2.
+ CastlingDisableQueenSide := 4.
+ CastlingDisableAll := CastlingDisableQueenSide bitOr: CastlingDisableKingSide.
+
+ CastlingEnableKingSide := CastlingDone bitOr: CastlingDisableKingSide.
+ CastlingEnableQueenSide := CastlingDone bitOr: CastlingDisableQueenSide.
+ !
Item was added:
+ ----- Method: ChessConstants class>>initializeCenterScores (in category 'pool initialization') -----
+ initializeCenterScores
+ "ChessPlayer initialize"
+ PieceCenterScores := Array new: 6.
+ 1 to: 6 do:[:i| PieceCenterScores at: i put: (ByteArray new: 64)].
+ PieceCenterScores at: Knight put:
+ #(
+ -4 0 0 0 0 0 0 -4
+ -4 0 2 2 2 2 0 -4
+ -4 2 3 2 2 3 2 -4
+ -4 1 2 5 5 2 2 -4
+ -4 1 2 5 5 2 2 -4
+ -4 2 3 2 2 3 2 -4
+ -4 0 2 2 2 2 0 -4
+ -4 0 0 0 0 0 0 -4
+ ).
+ PieceCenterScores at: Bishop put:
+ #(
+ -2 -2 -2 -2 -2 -2 -2 -2
+ -2 0 0 0 0 0 0 -2
+ -2 0 1 1 1 1 0 -2
+ -2 0 1 2 2 1 0 -2
+ -2 0 1 2 2 1 0 -2
+ -2 0 1 1 1 1 0 -2
+ -2 0 0 0 0 0 0 -2
+ -2 -2 -2 -2 -2 -2 -2 -2
+ ).
+ PieceCenterScores at: Queen put:
+ #(
+ -3 0 0 0 0 0 0 -3
+ -2 0 0 0 0 0 0 -2
+ -2 0 1 1 1 1 0 -2
+ -2 0 1 2 2 1 0 -2
+ -2 0 1 2 2 1 0 -2
+ -2 0 1 1 1 1 0 -2
+ -2 0 0 0 0 0 0 -2
+ -3 0 0 0 0 0 0 -3
+ ).!
Item was added:
+ ----- Method: ChessConstants class>>initializeKingMoves (in category 'pool initialization') -----
+ initializeKingMoves
+ "ChessPlayer initialize"
+ | index px py moveList |
+ KingMoves := Array new: 64 withAll: #().
+ 0 to: 7 do:[:j|
+ 0 to: 7 do:[:i|
+ index := (j * 8) + i + 1.
+ moveList := #().
+ #( (-1 -1) (0 -1) (1 -1) (-1 0) (1 0) (-1 1) (0 1) (1 1)) do:[:spec|
+ px := i + spec first.
+ py := j + spec last.
+ ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList := moveList copyWith: (py * 8) + px + 1]].
+ KingMoves at: index put: moveList
+ ].
+ ].!
Item was added:
+ ----- Method: ChessConstants class>>initializeKnightMoves (in category 'pool initialization') -----
+ initializeKnightMoves
+ "ChessPlayer initialize"
+ | index px py moveList |
+ KnightMoves := Array new: 64 withAll: #().
+ 0 to: 7 do:[:j|
+ 0 to: 7 do:[:i|
+ index := (j * 8) + i + 1.
+ moveList := #().
+ #( (-2 -1) (-1 -2) (1 -2) (2 -1) (-2 1) (-1 2) (1 2) (2 1)) do:[:spec|
+ px := i + spec first.
+ py := j + spec last.
+ ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList := moveList copyWith: (py * 8) + px + 1]].
+ KnightMoves at: index put: moveList
+ ].
+ ].!
Item was added:
+ ----- Method: ChessConstants class>>initializeMoves (in category 'pool initialization') -----
+ initializeMoves
+ "ChessPlayer initialize"
+ self initializeKnightMoves.
+ self initializeRookMoves.
+ self initializeBishopMoves.
+ self initializeKingMoves.!
Item was added:
+ ----- Method: ChessConstants class>>initializePieceConstants (in category 'pool initialization') -----
+ initializePieceConstants
+ EmptySquare := 0.
+ Pawn := 1.
+ Knight := 2.
+ Bishop := 3.
+ Rook := 4.
+ Queen := 5.
+ King := 6.!
Item was added:
+ ----- Method: ChessConstants class>>initializePieceValues (in category 'pool initialization') -----
+ initializePieceValues
+ PieceValues := Array new: 6.
+ PieceValues at: Pawn put: 100.
+ PieceValues at: Knight put: 300.
+ PieceValues at: Bishop put: 350.
+ PieceValues at: Rook put: 500.
+ PieceValues at: Queen put: 900.
+ PieceValues at: King put: 2000.
+ !
Item was added:
+ ----- Method: ChessConstants class>>initializeRookMovers (in category 'pool initialization') -----
+ initializeRookMovers.
+ RookMovers := Set new.
+ RookMovers add:Rook.
+ RookMovers add:Queen.!
Item was added:
+ ----- Method: ChessConstants class>>initializeRookMoves (in category 'pool initialization') -----
+ initializeRookMoves
+ "ChessPlayer initialize"
+ | index moveList1 moveList2 moveList3 moveList4 px py |
+ RookMoves := Array new: 64 withAll: #().
+ 0 to: 7 do:[:j|
+ 0 to: 7 do:[:i|
+ index := (j * 8) + i + 1.
+ moveList1 := moveList2 := moveList3 := moveList4 := #().
+ 1 to: 7 do:[:k|
+ px := i + k. py := j.
+ ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList1 := moveList1 copyWith: (py * 8) + px + 1].
+ px := i. py := j + k.
+ ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList2 := moveList2 copyWith: (py * 8) + px + 1].
+ px := i - k. py := j.
+ ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList3 := moveList3 copyWith: (py * 8) + px + 1].
+ px := i. py := j - k.
+ ((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList4 := moveList4 copyWith: (py * 8) + px + 1].
+ ].
+ RookMoves at: index put: {moveList1. moveList2. moveList3. moveList4}.
+ ].
+ ].!
Item was added:
+ ----- Method: ChessConstants class>>initializeSquareConstants (in category 'pool initialization') -----
+ initializeSquareConstants
+ A1:=1. B1:=2. C1:=3. D1:=4. E1:=5. F1:=6. G1:=7. H1:=8.
+ A2:=9. B2:=10. C2:=11. D2:=12. E2:=13. F2:=14. G2:=15. H2:=16.
+ A3:=17. B3:=18. C3:=19. D3:=20. E3:=21. F3:=22. G3:=23. H3:=24.
+ A4:=25. B4:=26. C4:=27. D4:=28. E4:=29. F4:=30. G4:=31. H4:=32.
+ A5:=33. B5:=34. C5:=35. D5:=36. E5:=37. F5:=38. G5:=39. H5:=40.
+ A6:=41. B6:=42. C6:=43. D6:=44. E6:=45. F6:=46. G6:=47. H6:=48.
+ A7:=49. B7:=50. C7:=51. D7:=52. E7:=53. F7:=54. G7:=55. H7:=56.
+ A8:=57. B8:=58. C8:=59. D8:=60. E8:=61. F8:=62. G8:=63. H8:=64.!
Item was added:
+ Object variableWordSubclass: #ChessHistoryTable
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess'!
+
+ !ChessHistoryTable commentStamp: '<historical>' prior: 0!
+ This class is a history table for our 'killer heuristic'. It remembers moves that have proven effective in the past and is later used to prioritize newly generated moves according to the effectiveness of the particular move in the past.!
Item was added:
+ ----- Method: ChessHistoryTable class>>new (in category 'instance creation') -----
+ new
+ ^self new: 4096+64!
Item was added:
+ ----- Method: ChessHistoryTable>>addMove: (in category 'accessing') -----
+ addMove: aMove
+ | index |
+ index := (aMove sourceSquare bitShift: 6) + aMove destinationSquare.
+ self at: index put: (self at: index + 1)!
Item was added:
+ ----- Method: ChessHistoryTable>>atAllPut: (in category 'initialize') -----
+ atAllPut: aPositiveInteger
+ "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays."
+
+ <primitive: 145>
+ self errorImproperStore.!
Item was added:
+ ----- Method: ChessHistoryTable>>clear (in category 'initialize') -----
+ clear
+ self atAllPut: 0.!
Item was added:
+ ----- Method: ChessHistoryTable>>sorts:before: (in category 'sorting') -----
+ sorts: move1 before: move2
+ ^(self at: (move1 sourceSquare bitShift: 6) + move1 destinationSquare) >
+ (self at: (move2 sourceSquare bitShift: 6) + move2 destinationSquare)!
Item was added:
+ BorderedMorph subclass: #ChessMorph
+ instanceVariableNames: 'board history redoList animateMove autoPlay'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess'!
+
+ !ChessMorph commentStamp: '<historical>' prior: 0!
+ This class defines the user interface for a fine game of chess.!
Item was added:
+ ----- Method: ChessMorph class>>blackBishopImage (in category 'accessing') -----
+ blackBishopImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 0 0 0 21053440 0 0 21053440 0 0 4538368 0 0 88489984 0 0 357978112 0 0 357994496 0 0 1431675904 0 1 1452647424 0 1 1452631040 0 5 1789487360 0 5 1789483264 0 5 1452628224 0 21 1452627200 0 21 1452626944 0 21 1431655424 0 21 1431655424 0 21 1431655424 0 21 1431654400 0 21 1431654400 0 5 1431654400 0 5 1431650304 0 1 1431650304 0 1 2863284224 0 1 2863284224 0 0 1431633920 0 0 445644800 0 1 1431650304 0 1 1789476864 0 1 1789476864 0 1 1431650304 0 0 20971520 0 0 89128960 0 0 357826560 0 21840 1414858069 0 349525 1410684245 1342177280 344085 1074091009 1342177280 262144 0 268435456 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph class>>blackKingImage (in category 'accessing') -----
+ blackKingImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 0 0 0 0 0 0 4194304 0 0 22020096 0 0 4194304 0 0 89391104 0 0 111411200 0 1398016 107216981 1426063360 22369600 107218261 1430257664 22456660 107222362 2772434944 89740885 111416741 1498415104 90527125 1162892885 1448083456 93672805 1095850325 1448083456 362108249 1431656790 2522087424 362190169 1435854230 2522087424 362190422 1452643686 2522087424 362112598 1431672169 1448345600 362112597 2505463146 2522087424 93760085 2505463145 1448083456 93678165 2526434665 1448083456 93673045 1704351141 1498415104 90527317 1700353429 1498415104 23418261 1700353429 1497366528 22631829 1499027029 1497366528 22631829 1503221333 1698693120 5657957 1503222101 1694498816 1463653 1499026773 2483027968 1414485 1499026774 1409286144 354986 2841291433 1342177280 87381 1431655765 1073741824 21845 1431655765 0 5802 2863311508 0 6485 1431655780 0 6485 1521046884 0 6485 1431655780 0 6826 2863311524 0 5461 1431655764 0 0 0 0 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph class>>blackKnightImage (in category 'accessing') -----
+ blackKnightImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 0 0 0 268435456 0 1 335544320 0 1 335544320 0 1 1430257664 0 0 1431568384 0 1 1431650304 0 21 1432704000 0 342 2774160704 0 1370 1767216464 0 5461 2505402708 0 21845 1431656021 0 87381 1431655829 0 349525 1431655781 1073741824 1398101 1431672149 1342177280 1398101 1431672153 1342177280 5592405 1431983446 1409286144 5592405 1343576406 1409286144 22369600 1402197 2483027968 26543360 5920085 2768240640 22287360 5593685 1694498816 22040576 23766357 1694498816 81920 89478485 1698693120 0 89478485 1698693120 0 357913941 1765801984 0 1431655765 1765801984 0 1431655765 1766850560 1 1431655765 1498415104 5 1431655765 1498415104 21 1431655765 1498415104 21 1431655765 1498415104 21 1431655765 1498415104 85 1431655765 1498415104 341 1431655765 1498415104 341 1431655765 1498415104 1365 1431655765 1498415104 1365 1431655765 1431306240 1365 1431655765 1431306240 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph class>>blackPawnImage (in category 'accessing') -----
+ blackPawnImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 1
+ fromArray: #( 0 0 15360 0 32256 0 32256 0 32256 0 32256 0 32256 0 15360 0 65280 0 262080 0 65280 0 32256 0 32256 0 65280 0 65280 0 65280 0 130944 0 262080 0 262080 0 524256 0 524256 0 524256 0 524256 0 524256 0 524256 0 524256 0 262080 0 262080 0 262080 0 130944 0 65280 0 65280 0 524256 0 4194300 0 8388606 0 16777215 0 33554431 2147483648 33554431 2147483648 33554431 2147483648 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) ))!
Item was added:
+ ----- Method: ChessMorph class>>blackQueenImage (in category 'accessing') -----
+ blackQueenImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 0 0 0 0 0 0 5242880 0 0 5242880 0 0 1048576 0 320 4194324 0 320 5242900 0 64 5242896 0 64 5242896 0 64 5242896 0 80 5242960 0 83886160 5242960 0 83886160 5242960 1310720 16777300 5243216 1310720 4194388 22282576 1048576 4194388 22282576 4194304 5242964 22282576 4194304 5505109 22283600 20971520 1310805 22283600 88080384 1376341 22283600 88080384 1392725 1096029520 356515840 1392725 1096029520 356515840 1396821 1096029520 1430257664 1397845 1431655761 1426063360 349269 1431655761 1426063360 349525 1431655765 1426063360 349525 1431655765 1426063360 349525 1431655765 1426063360 349525 1521112405 1426063360 88746 2773854890 1409286144 91477 1453938005 2483027968 27285 1436898666 2415919104 23125 1521112410 1342177280 6826 2773854890 1073741824 5461 1431655765 1073741824 21845 1431655765 1342177280 21845 1431655765 1342177280 0 0 0 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph class>>blackRookImage (in category 'accessing') -----
+ blackRookImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 357826560 0 349184 357826645 1073741824 349184 357826645 1073741824 349184 357826645 1073741824 349525 1431655765 1073741824 436906 2863311530 1073741824 349526 1431721301 1073741824 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1706 2863311504 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1706 2863311504 0 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1366 1431721296 0 1706 2863311504 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1365 1448432976 0 1706 2863311504 0 23210 2863311525 0 27306 2863311529 0 87381 1431655765 1073741824 436906 2863311530 2415919104 436906 2863311530 2415919104 349525 1431655765 1342177280 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Chess' translatedNoop
+ categories: {'Games' translatedNoop}
+ documentation: 'A fine game of chess' translatedNoop!
Item was added:
+ ----- Method: ChessMorph class>>whiteBishopImage (in category 'accessing') -----
+ whiteBishopImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 0 0 0 16842752 0 0 88424448 0 0 88424448 0 0 89473024 0 0 378966016 0 0 1520865280 0 1 1789240320 0 1 2842256384 0 5 2842321920 0 6 2505462784 0 22 2505479168 0 26 2842338304 0 26 2842338304 0 26 2842338304 0 26 2863309824 0 26 2863309824 0 26 2863309824 0 26 2863309824 0 26 2863305728 0 22 2863304704 0 6 2863288320 0 5 2863284224 0 1 1431650304 0 1 1431650304 0 1 1768505344 0 1 1768505344 0 1 1768505344 0 1 1431650304 0 5 2863284224 0 5 1431654400 0 0 104857600 0 0 374341632 0 0 1498677248 0 87381 1701139797 1073741824 1419946 2488969898 1409286144 349525 1343575381 1342177280 1310720 0 335544320 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph class>>whiteKingImage (in category 'accessing') -----
+ whiteKingImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 0 0 0 22020096 0 0 93585408 0 0 111411200 0 0 93585408 0 0 362020864 0 1397760 447021077 1409286144 5940480 425263450 2768240640 23767376 429458858 2839543808 94721684 425268885 1448083456 110536037 426072410 2794455040 379234921 1499818410 2777939968 442149466 1431676586 2846097408 443198102 2526451305 1772355584 443116133 2842319449 1772355584 443111785 2841270937 2846097408 443193769 1785293465 2577661952 442866090 1789504149 1503920128 443110826 1785309845 2846097408 376083882 1499048598 2845048832 106603946 2573838938 2777677824 110799274 2594548330 2794455040 110799210 2594613610 2794455040 93760106 2523310506 2521825280 27699802 2774968746 2587885568 23440026 2795939242 1497366528 6908570 2795939497 1694498816 5925546 2795940521 2751463424 1463637 1453675861 2483027968 371301 2506447274 1342177280 87641 2590415189 1073741824 26261 1431655845 0 21850 2774182229 0 21930 2505484885 0 21866 2842339669 0 22165 1431655829 0 21850 2863311189 0 21845 143165576
5 0 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph class>>whiteKnightImage (in category 'accessing') -----
+ whiteKnightImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 1073741824 0 16 1342177280 0 20 1342177280 0 5 1430257664 0 6 2857713664 0 6 2862956544 0 22 2863223808 0 346 2863306048 0 1445 1789569360 0 22166 1521134164 0 91813 1789569685 0 367274 2863245989 1073741824 1469098 2862983845 1342177280 1682090 2863049385 1342177280 5679786 2863048362 1409286144 22718890 2861996714 1409286144 27961706 2775210410 2499805184 95070809 1432708522 2499805184 111503701 22455978 2503999488 378889472 27957930 2773483520 374969344 94988970 2773483520 88428544 106343082 2773483520 84295680 359312042 2840592384 344064 1521134250 2840592384 1 1789569706 2840592384 1 2863311530 2840854528 5 2863311530 2857631744 22 2863311530 2857631744 26 2863311530 2857631744 90 2863311530 2857631744 106 2863311530 2857631744 362 2863311530 2857631744 1450 2863311530 2857631744 1706 2863311530 2857631744 5802 2863311530 2857631744 6826 2863311530 2857631744 23210 2863311530 2857631744 21845 1431655765 1431568384 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph class>>whitePawnImage (in category 'accessing') -----
+ whitePawnImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 357826560 0 0 446955520 0 0 1520762880 0 0 1789460480 0 0 1520762880 0 0 378798080 0 0 1431633920 0 1 1789476864 0 21 2863289344 0 85 1431655680 0 0 446955520 0 0 1520762880 0 0 1789460480 0 0 1789460480 0 1 1789476864 0 5 2863288320 0 6 2863304704 0 22 2863305728 0 26 2863309824 0 90 2863310080 0 106 2863311104 0 106 2863311104 0 106 2863311104 0 90 2863310080 0 26 2863309824 0 26 2863309824 0 22 2863305728 0 6 2863304704 0 5 2863288320 0 1 1789476864 0 0 1789460480 0 341 1520784704 0 1450 2505484880 0 22186 2863311509 0 92842 2863311529 1073741824 109226 2863311530 1073741824 109226 2863311530 1073741824 87381 1431655765 1073741824 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph class>>whiteQueenImage (in category 'accessing') -----
+ whiteQueenImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 0 0 0 5242880 0 0 22282240 0 0 5242880 0 64 5242896 0 336 5242964 0 336 5242964 0 64 5242896 0 64 5242896 0 80 5242960 0 80 22282320 0 83886160 27525200 1310720 352321620 27525456 1376256 88080484 27525520 1376256 20971620 27525520 5242880 5242981 27526544 5242880 5505129 27526800 22020096 6553705 27526800 93323264 6619241 1101272720 105906176 6881386 1168448144 373293056 5849194 1185487504 440401920 1724522 1453939344 1514143744 1740906 2527685265 1782579200 1741930 2527685265 2856321024 1746282 2863311509 2856321024 1747306 2863311510 2856321024 1485482 2863311530 2839543808 436906 2863311530 2835349504 436906 2505403050 2835349504 365909 1515869525 1694498816 87466 2773854885 1409286144 21850 2841029205 1342177280 21866 2505403029 1342177280 21845 1521112405 1342177280 27306 2863311530 2415919104 27306 2863311530 2415919104 92842 2863311530 2483027968 87381 1431655765 1409286144 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph class>>whiteRookImage (in category 'accessing') -----
+ whiteRookImage
+ ^((ColorForm
+ extent: 40@40
+ depth: 2
+ fromArray: #( 0 0 0 0 357892096 0 87360 447283221 1409286144 109120 447283226 2751463424 109120 447283226 2751463424 109141 1521046874 2751463424 109226 2863311530 2751463424 87381 1431655765 1409286144 426 1789553316 0 426 1789553316 0 426 1789553316 0 426 1789553316 0 426 1789553316 0 341 1431655764 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 341 1431655764 0 426 1789553316 0 426 1789553316 0 426 1789553316 0 426 1789553316 0 426 1789553316 0 341 1431655764 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 426 2859117220 0 5461 1431655765 0 23210 2863311529 1073741824 27306 2863311530 1073741824 87381 1431655765 1342177280 371370 2863311530 2483027968 436906 2863311530 2751463424 349525 1431655765 1409286144 0 0 0)
+ offset: 0@0)
+ colorsFromArray: #(#( ) #(0.0 0.0 0.032) #(1.0 1.0 1.0) #( ) ))!
Item was added:
+ ----- Method: ChessMorph>>acceptDroppingMorph:event: (in category 'layout') -----
+ acceptDroppingMorph: aMorph event: anEvent
+ | destSquare sourceSquare |
+ sourceSquare := aMorph valueOfProperty: #chessBoardSourceSquare.
+ aMorph removeProperty: #chessBoardSourceSquare.
+ destSquare := self asSquare: aMorph center.
+ "!!!!!! ACTUAL MOVE HAPPENS INDIRECTLY !!!!!!"
+ (self atSquare: sourceSquare) addMorphCentered: aMorph.
+ destSquare ifNil:[^self].
+ self movePieceFrom: sourceSquare to: destSquare.
+ self showMovesAt: destSquare.!
Item was added:
+ ----- Method: ChessMorph>>addButtonRow (in category 'initialize') -----
+ addButtonRow
+
+ | r m |
+ r := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color transparent.
+ r cellInset: 2.
+ r addMorphBack: (self buttonName: ' New ' translated action: #newGame).
+ r addMorphBack: (self buttonName: ' Help ' translated action: #findBestMove).
+ r addMorphBack: (self buttonName: ' Play ' translated action: #thinkAndMove).
+ r addMorphBack: (self buttonName: ' Auto ' translated action: #autoPlay).
+ r addMorphBack: (self buttonName: ' Undo ' translated action: #undoMove).
+ r addMorphBack: (self buttonName: ' Redo ' translated action: #redoMove).
+ r addMorphBack: (self buttonName: ' Quit ' translated action: #delete).
+ r disableLayout: true.
+ r align: r bounds topLeft with: self layoutBounds topLeft.
+ self addMorphFront: r.
+ m := UpdatingStringMorph on: self selector: #statusString.
+ m useStringFormat.
+ m disableTableLayout: true.
+ m align: m bounds topLeft with: r fullBounds bottomLeft.
+ self addMorphFront: m.!
Item was added:
+ ----- Method: ChessMorph>>addSquares (in category 'initialize') -----
+ addSquares
+ | white black square index |
+ white := Color white.
+ black := Color lightGray.
+ index := 0.
+ #(
+ ( ' ' 'a' 'b' 'c' 'd' 'e' 'f' 'g' 'h' ' ')
+ ( '1' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
+ ( '2' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
+ ( '3' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
+ ( '4' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
+ ( '5' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
+ ( '6' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
+ ( '7' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
+ ( '8' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
+ ( ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ')
+ ) do:[:file|
+ file do:[:sq|
+ square := self newSquare.
+ square borderWidth: 0.
+ (sq = 'W' or:[sq = 'B']) ifTrue:[
+ square color: (sq = 'W' ifTrue:[white] ifFalse:[black]).
+ square borderColor: Color red.
+ square setProperty: #squarePosition toValue: (index := index + 1).
+ square setNameTo:
+ (String with: ($a asInteger + (index - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (index -1 bitShift: -3)) asCharacter).
+ square on: #mouseEnter send: #showMoves:from: to: self.
+ square on: #mouseEnterDragging send: #dragSquareEnter:from: to: self.
+ square on: #mouseLeaveDragging send: #dragSquareLeave:from: to: self.
+ ] ifFalse:["decoration"
+ square color: Color transparent.
+ sq = ' ' ifFalse:[
+ square addMorphCentered: (StringMorph contents: sq asUppercase font: Preferences windowTitleFont emphasis: 1).
+ ].
+ ].
+ square extent: 40@40.
+ self addMorphBack: square.
+ ]].
+ !
Item was added:
+ ----- Method: ChessMorph>>addedPiece:at:white: (in category 'game callbacks') -----
+ addedPiece: piece at: square white: isWhite
+ | m |
+ m := self newPiece: piece white: isWhite.
+ m on: #mouseDown send: #dragPiece:from: to: self.
+ m setProperty: #chessBoard toValue: self.
+ (self atSquare: square) removeAllMorphs; addMorphCentered: m.!
Item was added:
+ ----- Method: ChessMorph>>areasRemainingToFill: (in category 'drawing') -----
+ areasRemainingToFill: x
+ ^x areasOutside: self bounds!
Item was added:
+ ----- Method: ChessMorph>>asSquare: (in category 'geometry') -----
+ asSquare: aPoint
+ self squaresDo:[:sq| (sq bounds containsPoint: aPoint) ifTrue:[^sq valueOfProperty: #squarePosition]].
+ ^nil!
Item was added:
+ ----- Method: ChessMorph>>atSquare: (in category 'geometry') -----
+ atSquare: square
+ ^submorphs detect:[:any| (any valueOfProperty: #squarePosition) = square] ifNone:[nil]!
Item was added:
+ ----- Method: ChessMorph>>autoPlay (in category 'playing') -----
+ autoPlay
+ autoPlay := autoPlay not.
+ autoPlay ifTrue:[self thinkAndMove].!
Item was added:
+ ----- Method: ChessMorph>>buttonFillStyle (in category 'initialize') -----
+ buttonFillStyle
+
+ | fill |
+ fill := GradientFillStyle ramp: {
+ 0.0 -> (Color r: 0.05 g: 0.5 b: 1.0).
+ 1.0 -> (Color r: 0.85 g: 0.95 b: 1.0)}.
+ fill origin: (0@0).
+ fill direction: 40@10.
+ fill radial: false.
+ ^ fill
+ !
Item was added:
+ ----- Method: ChessMorph>>buttonName:action: (in category 'initialize') -----
+ buttonName: aString action: aSymbol
+
+ ^ SimpleButtonMorph new
+ target: self;
+ label: aString;
+ actionSelector: aSymbol;
+ color: (Color gray: 0.8); "old color"
+ fillStyle: self buttonFillStyle;
+ borderWidth: 1;
+ borderRaised.
+ !
Item was added:
+ ----- Method: ChessMorph>>completedMove:white: (in category 'game callbacks') -----
+ completedMove: aMove white: aBool
+ board ifNil:[^self].
+ history addLast: aMove.
+ self validateGamePosition.!
Item was added:
+ ----- Method: ChessMorph>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ ^ Color transparent!
Item was added:
+ ----- Method: ChessMorph>>defaultBorderStyle (in category 'initialization') -----
+ defaultBorderStyle
+ ^ BorderStyle raised!
Item was added:
+ ----- Method: ChessMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 5!
Item was added:
+ ----- Method: ChessMorph>>defaultBounds (in category 'initialization') -----
+ defaultBounds
+ "answer the default bounds for the receiver"
+ ^ 0 @ 0 corner: 410 @ 410!
Item was added:
+ ----- Method: ChessMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the receiver's default color"
+ | result |
+ result := GradientFillStyle ramp: {0.0
+ -> (Color
+ r: 0.05
+ g: 0.5
+ b: 1.0). 1.0
+ -> (Color
+ r: 0.85
+ g: 0.95
+ b: 1.0)}.
+ result origin: self bounds origin;
+ direction: self extent.
+ result radial: false.
+ ^ result!
Item was added:
+ ----- Method: ChessMorph>>dragPiece:from: (in category 'drag and drop') -----
+ dragPiece: evt from: aMorph
+ board searchAgent isThinking ifTrue:[^self].
+ self submorphsDo:[:m| m borderWidth: 0].
+ aMorph setProperty: #chessBoardSourceSquare toValue: (aMorph owner valueOfProperty: #squarePosition).
+ evt hand grabMorph: aMorph.!
Item was added:
+ ----- Method: ChessMorph>>dragSquareEnter:from: (in category 'drag and drop') -----
+ dragSquareEnter: evt from: aMorph
+ "Note: #wantsDroppedMorph: will validate move"
+ board ifNil:[^self].
+ evt hand hasSubmorphs ifFalse:[^self].
+ (self wantsDroppedMorph: evt hand firstSubmorph event: evt) ifFalse:[^self].
+ aMorph borderWidth: 1.!
Item was added:
+ ----- Method: ChessMorph>>dragSquareLeave:from: (in category 'drag and drop') -----
+ dragSquareLeave: evt from: aMorph
+ board ifNil:[^self].
+ evt hand hasSubmorphs ifFalse:[^self].
+ aMorph borderWidth: 0.!
Item was added:
+ ----- Method: ChessMorph>>findBestMove (in category 'playing') -----
+ findBestMove
+ | move |
+ board searchAgent isThinking ifTrue:[^self].
+ Cursor wait showWhile:[move := board searchAgent think].
+ self inform: 'I suggest: ' translated, move printString.
+ ^move!
Item was added:
+ ----- Method: ChessMorph>>finishedGame: (in category 'game callbacks') -----
+ finishedGame: result
+ "
+ 0 - white lost
+ 0.5 - draw
+ 1 - white won
+ "
+ board := nil.!
Item was added:
+ ----- Method: ChessMorph>>gameReset (in category 'game callbacks') -----
+ gameReset
+ self squaresDo:[:m| m removeAllMorphs; borderWidth: 0]!
Item was added:
+ ----- Method: ChessMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ animateMove := false.
+ autoPlay := false.
+
+ self cornerStyle: #square.
+ self layoutPolicy: TableLayout new.
+ self listDirection: #leftToRight;
+ wrapDirection: #bottomToTop.
+ self addSquares.
+ self addButtonRow.
+ self newGame!
Item was added:
+ ----- Method: ChessMorph>>movePieceFrom:to: (in category 'playing') -----
+ movePieceFrom: sourceSquare to: destSquare
+ board ifNil:[^self].
+ board searchAgent isThinking ifTrue:[^self].
+ board movePieceFrom: sourceSquare to: destSquare.
+ board searchAgent startThinking.!
Item was added:
+ ----- Method: ChessMorph>>movedPiece:from:to: (in category 'game callbacks') -----
+ movedPiece: piece from: sourceSquare to: destSquare
+ | sourceMorph destMorph sourcePos destPos w startTime nowTime deltaTime |
+ sourceMorph := (self atSquare: sourceSquare) firstSubmorph.
+ destMorph := self atSquare: destSquare.
+ animateMove ifTrue:[
+ sourcePos := sourceMorph boundsInWorld center.
+ destPos := destMorph boundsInWorld center.
+ (w := self world) ifNotNil:[
+ w addMorphFront: sourceMorph.
+ sourceMorph addDropShadow.
+ sourceMorph shadowColor: (Color black alpha: 0.5).
+ deltaTime := (sourcePos dist: destPos) * 10 asInteger.
+ startTime := Time millisecondClockValue.
+ [nowTime := Time millisecondClockValue.
+ nowTime - startTime < deltaTime] whileTrue:[
+ sourceMorph center: sourcePos + (destPos - sourcePos * (nowTime - startTime) // deltaTime) asIntegerPoint.
+ w displayWorldSafely].
+ sourceMorph removeDropShadow.
+ ].
+ ].
+ destMorph removeAllMorphs.
+ destMorph addMorphCentered: sourceMorph.
+ animateMove := false.!
Item was added:
+ ----- Method: ChessMorph>>newGame (in category 'playing') -----
+ newGame
+ board ifNil:[board := ChessBoard new].
+ board initialize.
+ board userAgent: self.
+ board initializeNewBoard.
+ history := OrderedCollection new.
+ redoList := OrderedCollection new.
+ !
Item was added:
+ ----- Method: ChessMorph>>newPiece:white: (in category 'initialize') -----
+ newPiece: piece white: isWhite
+ | index selector m |
+ index := piece.
+ isWhite ifFalse:[index := index + 6].
+ selector := #(
+ whitePawnImage
+ whiteKnightImage
+ whiteBishopImage
+ whiteRookImage
+ whiteQueenImage
+ whiteKingImage
+
+ blackPawnImage
+ blackKnightImage
+ blackBishopImage
+ blackRookImage
+ blackQueenImage
+ blackKingImage) at: index.
+ m := ChessPieceMorph new image: (self class perform: selector).
+ m setProperty: #isWhite toValue: isWhite.
+ m setProperty: #piece toValue: piece.
+ ^m!
Item was added:
+ ----- Method: ChessMorph>>newSquare (in category 'initialize') -----
+ newSquare
+ ^BorderedMorph new "or anyone alike"!
Item was added:
+ ----- Method: ChessMorph>>redoMove (in category 'playing') -----
+ redoMove
+ "Redo the last undone move"
+ redoList isEmpty ifTrue:[^self].
+ board nextMove: redoList removeLast.
+ !
Item was added:
+ ----- Method: ChessMorph>>removedPiece:at: (in category 'game callbacks') -----
+ removedPiece: piece at: square
+ animateMove ifFalse:[
+ (self atSquare: square) removeAllMorphs.
+ ].!
Item was added:
+ ----- Method: ChessMorph>>replacedPiece:with:at:white: (in category 'game callbacks') -----
+ replacedPiece: oldPiece with: newPiece at: square white: isWhite
+ self removedPiece: oldPiece at: square.
+ self addedPiece: newPiece at: square white: isWhite!
Item was added:
+ ----- Method: ChessMorph>>rotateBoard (in category 'other stuff') -----
+ rotateBoard
+ self listDirection = #leftToRight
+ ifTrue:[^self listDirection: #topToBottom; wrapDirection: #leftToRight].
+ self listDirection = #topToBottom
+ ifTrue:[^self listDirection: #rightToLeft; wrapDirection: #topToBottom].
+ self listDirection = #rightToLeft
+ ifTrue:[^self listDirection: #bottomToTop; wrapDirection: #rightToLeft].
+ self listDirection = #bottomToTop
+ ifTrue:[^self listDirection: #leftToRight; wrapDirection: #bottomToTop].
+ !
Item was added:
+ ----- Method: ChessMorph>>showMoves:from: (in category 'events') -----
+ showMoves: evt from: aMorph
+ | square |
+ square := aMorph valueOfProperty: #squarePosition.
+ square ifNotNil:[^self showMovesAt: square].!
Item was added:
+ ----- Method: ChessMorph>>showMovesAt: (in category 'events') -----
+ showMovesAt: square
+ | list |
+ board ifNil:[^self].
+ board searchAgent isThinking ifTrue:[^self].
+ self squaresDo:[:m| m borderWidth: 0].
+ list := board activePlayer findValidMovesAt: square.
+ list isEmpty ifTrue:[^self].
+ (self atSquare: square) borderWidth: 1.
+ list do:[:move|
+ (self atSquare: (move triggerSquareIn: board)) borderWidth: 1.
+ ].!
Item was added:
+ ----- Method: ChessMorph>>squaresDo: (in category 'geometry') -----
+ squaresDo: aBlock
+ ^submorphs do:[:m| (m hasProperty: #squarePosition) ifTrue:[aBlock value: m]].!
Item was added:
+ ----- Method: ChessMorph>>statusString (in category 'other stuff') -----
+ statusString
+ board ifNil:[^''].
+ ^board statusString!
Item was added:
+ ----- Method: ChessMorph>>step (in category 'stepping') -----
+ step
+ | move |
+ board searchAgent isThinking ifTrue:[
+ move := board searchAgent thinkStep.
+ move ifNotNil:[
+ animateMove := true.
+ board movePieceFrom: move sourceSquare
+ to: move destinationSquare].
+ ] ifFalse:[
+ autoPlay ifTrue:[board searchAgent startThinking].
+ ].!
Item was added:
+ ----- Method: ChessMorph>>stepTime (in category 'testing') -----
+ stepTime
+ ^0!
Item was added:
+ ----- Method: ChessMorph>>thinkAndMove (in category 'playing') -----
+ thinkAndMove
+ board searchAgent isThinking ifTrue:[^self].
+ board searchAgent startThinking.!
Item was added:
+ ----- Method: ChessMorph>>undoMove (in category 'playing') -----
+ undoMove
+ "Undo the last move"
+ board ifNil:[^self].
+ history isEmpty ifTrue:[^self].
+ board undoMove: history removeLast.
+ !
Item was added:
+ ----- Method: ChessMorph>>undoMove:white: (in category 'game callbacks') -----
+ undoMove: aMove white: aBool
+ board ifNil:[^self].
+ redoList addLast: aMove.
+ self validateGamePosition.!
Item was added:
+ ----- Method: ChessMorph>>validateGamePosition (in category 'game callbacks') -----
+ validateGamePosition
+ "This method does nothing but validating what you see (on screen) is what you get (from the board)."
+ | square piece isWhite p |
+ 1 to: 64 do:[:idx|
+ square := self atSquare: idx.
+ square hasSubmorphs
+ ifTrue:[piece := square firstSubmorph valueOfProperty: #piece.
+ isWhite := square firstSubmorph valueOfProperty: #isWhite]
+ ifFalse:[piece := 0. isWhite := nil].
+ p := board whitePlayer pieceAt: idx.
+ idx = board whitePlayer castlingRookSquare ifTrue:[p := ChessPlayer rook].
+ isWhite == true ifTrue:[
+ p = piece ifFalse:[self error:'White broken'].
+ ] ifFalse:[p = 0 ifFalse:[self error:'White broken']].
+ p := board blackPlayer pieceAt: idx.
+ idx = board blackPlayer castlingRookSquare ifTrue:[p := ChessPlayer rook].
+ isWhite == false ifTrue:[
+ p = piece ifFalse:[self error:'White broken'].
+ ] ifFalse:[p = 0 ifFalse:[self error:'White broken']].
+ ].!
Item was added:
+ ----- Method: ChessMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
+ wantsDroppedMorph: aMorph event: anEvent
+ | sourceSquare destSquare |
+ (aMorph valueOfProperty: #chessBoard) == self ifFalse:[^false].
+ board ifNil:[^true].
+ sourceSquare := aMorph valueOfProperty: #chessBoardSourceSquare.
+ destSquare := self asSquare: aMorph bounds center.
+ destSquare ifNil:[^false].
+ ^board activePlayer isValidMoveFrom: sourceSquare to: destSquare!
Item was added:
+ Object subclass: #ChessMove
+ instanceVariableNames: 'movingPiece capturedPiece sourceSquare destinationSquare type value bestMove'
+ classVariableNames: 'BasicMoveMask EvalTypeAccurate EvalTypeLowerBound EvalTypeUpperBound ExtractPromotionShift MoveCaptureEnPassant MoveCaptureOrdinary MoveCastlingKingSide MoveCastlingQueenSide MoveDoublePush MoveNormal MovePromotionBishop MovePromotionKnight MovePromotionQueen MovePromotionRook MoveResign MoveStaleMate NoPromotionMask NullMove PromotionMask PromotionShift'
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess'!
+
+ !ChessMove commentStamp: '<historical>' prior: 0!
+ I represent a particular move in the chess game.!
Item was added:
+ ----- Method: ChessMove class>>basicMoveMask (in category 'accessing') -----
+ basicMoveMask
+ ^BasicMoveMask!
Item was added:
+ ----- Method: ChessMove class>>decodeFrom: (in category 'accessing') -----
+ decodeFrom: encodedMove
+ ^self new moveEncoded: encodedMove!
Item was added:
+ ----- Method: ChessMove class>>initialize (in category 'class initialization') -----
+ initialize
+ "ChessMove initialize"
+ MoveNormal := 1.
+ MoveDoublePush := 2.
+ MoveCaptureEnPassant := 3.
+ MoveCastlingKingSide := 4.
+ MoveCastlingQueenSide := 5.
+ MoveResign := 6.
+ MoveStaleMate := 7.
+
+ BasicMoveMask := 15.
+ PromotionShift := 4.
+ ExtractPromotionShift := 0 - PromotionShift.
+
+ EvalTypeAccurate := 0.
+ EvalTypeUpperBound := 1.
+ EvalTypeLowerBound := 2.
+
+ NullMove := 0.
+
+ !
Item was added:
+ ----- Method: ChessMove>>= (in category 'comparing') -----
+ = aMove
+ movingPiece = aMove movingPiece ifFalse:[^false].
+ capturedPiece = aMove capturedPiece ifFalse:[^false].
+ type = aMove type ifFalse:[^false].
+ sourceSquare = aMove sourceSquare ifFalse:[^false].
+ destinationSquare = aMove destinationSquare ifFalse:[^false].
+ ^true!
Item was added:
+ ----- Method: ChessMove>>bestMove (in category 'accessing') -----
+ bestMove
+ ^nil!
Item was added:
+ ----- Method: ChessMove>>captureEnPassant:from:to: (in category 'initialize') -----
+ captureEnPassant: aPiece from: startSquare to: endSquare
+ movingPiece := capturedPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ type := MoveCaptureEnPassant.!
Item was added:
+ ----- Method: ChessMove>>capturedPiece (in category 'accessing') -----
+ capturedPiece
+ ^capturedPiece!
Item was added:
+ ----- Method: ChessMove>>capturedPiece: (in category 'accessing') -----
+ capturedPiece: aValue
+ ^capturedPiece := aValue!
Item was added:
+ ----- Method: ChessMove>>checkMate: (in category 'initialize') -----
+ checkMate: aPiece
+ movingPiece := aPiece.
+ sourceSquare := 0.
+ destinationSquare := 0.
+ type := MoveResign.
+ capturedPiece := 0.!
Item was added:
+ ----- Method: ChessMove>>destinationSquare (in category 'accessing') -----
+ destinationSquare
+ ^destinationSquare!
Item was added:
+ ----- Method: ChessMove>>destinationSquare: (in category 'accessing') -----
+ destinationSquare: aValue
+ ^destinationSquare := aValue!
Item was added:
+ ----- Method: ChessMove>>doublePush:from:to: (in category 'initialize') -----
+ doublePush: aPiece from: startSquare to: endSquare
+ movingPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ type := MoveDoublePush.
+ capturedPiece := 0.!
Item was added:
+ ----- Method: ChessMove>>encodedMove (in category 'accessing') -----
+ encodedMove
+ "Return an integer encoding enough of a move for printing"
+ ^destinationSquare +
+ (sourceSquare bitShift: 8) +
+ (movingPiece bitShift: 16) +
+ (capturedPiece bitShift: 24)!
Item was added:
+ ----- Method: ChessMove>>hash (in category 'comparing') -----
+ hash
+ ^((movingPiece hash bitXor: capturedPiece hash) bitXor:
+ (sourceSquare hash bitXor: destinationSquare hash)) bitXor: type hash!
Item was added:
+ ----- Method: ChessMove>>init (in category 'initialize') -----
+ init
+ movingPiece := sourceSquare := destinationSquare := 1.
+ type := MoveNormal.
+ capturedPiece := 0.!
Item was added:
+ ----- Method: ChessMove>>move:from:to: (in category 'initialize') -----
+ move: aPiece from: startSquare to: endSquare
+ movingPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ type := MoveNormal.
+ capturedPiece := 0.!
Item was added:
+ ----- Method: ChessMove>>move:from:to:capture: (in category 'initialize') -----
+ move: aPiece from: startSquare to: endSquare capture: capture
+ movingPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ capturedPiece := capture.
+ type := MoveNormal.
+ !
Item was added:
+ ----- Method: ChessMove>>moveCastlingKingSide:from:to: (in category 'initialize') -----
+ moveCastlingKingSide: aPiece from: startSquare to: endSquare
+ movingPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ type := MoveCastlingKingSide.
+ capturedPiece := 0.!
Item was added:
+ ----- Method: ChessMove>>moveCastlingQueenSide:from:to: (in category 'initialize') -----
+ moveCastlingQueenSide: aPiece from: startSquare to: endSquare
+ movingPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ type := MoveCastlingQueenSide.
+ capturedPiece := 0.!
Item was added:
+ ----- Method: ChessMove>>moveEncoded: (in category 'initialize') -----
+ moveEncoded: encodedMove
+ destinationSquare := encodedMove bitAnd: 255.
+ sourceSquare := (encodedMove bitShift: -8) bitAnd: 255.
+ movingPiece := (encodedMove bitShift: -16) bitAnd: 255.
+ capturedPiece := (encodedMove bitShift: -24) bitAnd: 255.
+ type := MoveNormal.
+ !
Item was added:
+ ----- Method: ChessMove>>moveString (in category 'printing') -----
+ moveString
+ ^String streamContents:[:aStream|
+ aStream nextPutAll: (#('' 'N' 'B' 'R' 'Q' 'K') at: movingPiece).
+ aStream nextPutAll: (String with: ($a asInteger + (sourceSquare - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (sourceSquare -1 bitShift: -3)) asCharacter).
+ capturedPiece = 0 ifTrue:[
+ aStream nextPutAll: '-'.
+ ] ifFalse:[
+ aStream nextPutAll: 'x'.
+ aStream nextPutAll: (#('' 'N' 'B' 'R' 'Q' 'K') at: capturedPiece).
+ ].
+ aStream nextPutAll: (String with: ($a asInteger + (destinationSquare - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (destinationSquare -1 bitShift: -3)) asCharacter).
+ ].!
Item was added:
+ ----- Method: ChessMove>>moveType (in category 'accessing') -----
+ moveType
+ ^type!
Item was added:
+ ----- Method: ChessMove>>moveType: (in category 'accessing') -----
+ moveType: aType
+ ^type := aType!
Item was added:
+ ----- Method: ChessMove>>movingPiece (in category 'accessing') -----
+ movingPiece
+ ^movingPiece!
Item was added:
+ ----- Method: ChessMove>>movingPiece: (in category 'accessing') -----
+ movingPiece: aValue
+ ^movingPiece := aValue!
Item was added:
+ ----- Method: ChessMove>>printOn: (in category 'printing') -----
+ printOn: aStream
+ super printOn: aStream.
+ aStream nextPutAll:'('.
+ aStream nextPutAll: (#('' 'N' 'B' 'R' 'Q' 'K') at: movingPiece).
+ aStream nextPutAll: (String with: ($a asInteger + (sourceSquare - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (sourceSquare -1 bitShift: -3)) asCharacter).
+ capturedPiece = 0 ifTrue:[
+ aStream nextPutAll: '-'.
+ ] ifFalse:[
+ aStream nextPutAll: 'x'.
+ aStream nextPutAll: (#('' 'N' 'B' 'R' 'Q' 'K') at: capturedPiece).
+ ].
+ aStream nextPutAll: (String with: ($a asInteger + (destinationSquare - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (destinationSquare -1 bitShift: -3)) asCharacter).
+ aStream nextPutAll:')'.!
Item was added:
+ ----- Method: ChessMove>>promote:to: (in category 'initialize') -----
+ promote: move to: promotion
+ movingPiece := move movingPiece.
+ capturedPiece := move capturedPiece.
+ sourceSquare := move sourceSquare.
+ destinationSquare := move destinationSquare.
+ type := move moveType.
+ type := type bitOr: (promotion bitShift: PromotionShift).
+ !
Item was added:
+ ----- Method: ChessMove>>promotion (in category 'accessing') -----
+ promotion
+ ^type bitShift: ExtractPromotionShift!
Item was added:
+ ----- Method: ChessMove>>sourceSquare (in category 'accessing') -----
+ sourceSquare
+ ^sourceSquare!
Item was added:
+ ----- Method: ChessMove>>sourceSquare: (in category 'accessing') -----
+ sourceSquare: aValue
+ ^sourceSquare := aValue!
Item was added:
+ ----- Method: ChessMove>>staleMate: (in category 'initialize') -----
+ staleMate: aPiece
+ movingPiece := aPiece.
+ sourceSquare := 0.
+ destinationSquare := 0.
+ type := MoveStaleMate.
+ capturedPiece := 0.!
Item was added:
+ ----- Method: ChessMove>>triggerSquareIn: (in category 'accessing') -----
+ triggerSquareIn: aChessBoard
+
+ type = MoveCastlingKingSide ifTrue: [^ aChessBoard activePlayer initialRightRookSquare].
+ type = MoveCastlingQueenSide ifTrue: [^ aChessBoard activePlayer initialLeftRookSquare].
+
+ ^destinationSquare!
Item was added:
+ ----- Method: ChessMove>>value (in category 'accessing') -----
+ value
+ ^value!
Item was added:
+ ----- Method: ChessMove>>value: (in category 'accessing') -----
+ value: newValue
+ value := newValue!
Item was added:
+ Object subclass: #ChessMoveGenerator
+ instanceVariableNames: 'myPlayer myPieces itsPieces castlingStatus enpassantSquare forceCaptures moveList firstMoveIndex lastMoveIndex streamList streamListIndex attackSquares kingAttack'
+ classVariableNames: 'EmptyPieceMap'
+ poolDictionaries: 'ChessConstants'
+ category: 'MorphicExtras-Games-Chess'!
+
+ !ChessMoveGenerator commentStamp: '<historical>' prior: 0!
+ This class generates moves for any given board. It's speed is critical - for each new position all moves need to be generated in that position. It may be worthwhile to make give this class a little plugin support at some time.!
Item was added:
+ ----- Method: ChessMoveGenerator>>attackSquares (in category 'public') -----
+ attackSquares
+ ^attackSquares!
Item was added:
+ ----- Method: ChessMoveGenerator>>blackPawnCaptureAt:direction: (in category 'moves-pawns') -----
+ blackPawnCaptureAt: square direction: dir
+ | destSquare move piece |
+ destSquare := square-8-dir.
+ piece := itsPieces at: destSquare.
+ piece = 0 ifFalse:[
+ (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ move: Pawn from: square to: destSquare capture: piece.
+ piece = King ifTrue:[kingAttack := move].
+ destSquare <= 8 "a promotion"
+ ifTrue:[self promotePawn: move].
+ ].
+ "attempt an en-passant capture"
+ enpassantSquare = destSquare ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ captureEnPassant: Pawn from: square to: destSquare.
+ ].!
Item was added:
+ ----- Method: ChessMoveGenerator>>blackPawnPushAt: (in category 'moves-pawns') -----
+ blackPawnPushAt: square
+ | destSquare move |
+ "Try to push this pawn"
+ destSquare := square-8.
+ (myPieces at: destSquare) = 0 ifFalse:[^self].
+ (itsPieces at: destSquare) = 0 ifFalse:[^self].
+ (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ move: Pawn from: square to: destSquare.
+ destSquare <= 8 "a promotion (can't be double-push so get out)"
+ ifTrue:[^self promotePawn: move].
+
+ "Try to double-push if possible"
+ square > 48 ifFalse:[^self].
+ destSquare := square-16.
+ (myPieces at: destSquare) = 0 ifFalse:[^self].
+ (itsPieces at: destSquare) = 0 ifFalse:[^self].
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ doublePush: Pawn from: square to: destSquare.!
Item was added:
+ ----- Method: ChessMoveGenerator>>canCastleBlackKingSide (in category 'support') -----
+ canCastleBlackKingSide
+ (castlingStatus bitAnd: CastlingEnableKingSide) = 0 ifFalse:[^false].
+ "Quickly check if all the squares are zero"
+ ((myPieces at: G8) + (myPieces at: F8) + (itsPieces at: G8) + (itsPieces at: F8) = 0) ifFalse:[^false].
+ "Check for castling squares under attack.. See canCastleBlackQueenSide for details"
+ (self checkAttack:{G7. G6. G5. G4. G3. G2. G1} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{F7. F6. F5. F4. F3. F2. F1} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{E7. E6. E5. E4. E3. E2. E1.} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{D8. C8. B8. A8} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{F7. E6. D5. C4. B3. A2} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{E7. D6. C5. B4. A3} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{D7. C6. B5. A4} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{F7. G6. H5} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{G7. H6} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{H7} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkUnprotectedAttack:{H7. G7. E7. D7. C7. H6. G6. F6. E6. D6} fromPiece:Knight) ifTrue:[^false].
+ (self checkUnprotectedAttack:{H7. G7. F7. E7. D7} fromPiece:Pawn) ifTrue:[^false].
+ (self checkUnprotectedAttack:{G7} fromPiece:King) ifTrue:[^false].
+
+ ^true.
+
+
+
+
+ !
Item was added:
+ ----- Method: ChessMoveGenerator>>canCastleBlackQueenSide (in category 'support') -----
+ canCastleBlackQueenSide
+ (castlingStatus bitAnd: CastlingEnableQueenSide) = 0 ifFalse:[^false].
+ "Quickly check if all the squares are zero"
+ ((myPieces at: B8) + (myPieces at: C8) + (myPieces at: D8) +
+ (itsPieces at: B8) + (itsPieces at: C8) + (itsPieces at: D8)
+ = 0) ifFalse:[^false].
+ "Check to see if any of the squares involved in castling are under attack. First
+ check for vertical (rook-like) attacks"
+ (self checkAttack:{B7. B6. B5. B4. B3. B2. B1} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{C7. C6. C5. C4. C3. C2. C1} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{D7. D6. D5. D4. D3. D2. D1} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{E7. E6. E5. E4. E3. E2. E1} fromPieces:RookMovers) ifTrue:[^false].
+ "Check for a rook attack from the baseline"
+ (self checkAttack:{F8. G8. H8} fromPieces:RookMovers) ifTrue:[^false].
+ "Check for bishop attacks from the diagonals"
+ (self checkAttack:{C7. D6. E5. F4. G3. H2} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{D7. E6. F5. G4. H3} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{E7. F6. G5. H4} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{F7. G6. H5} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{A7} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{B7. A6} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{C7. B6. A5} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{D7. C6. B5. A4} fromPieces:BishopMovers) ifTrue:[^false].
+ "Check for a knight attack"
+ (self checkUnprotectedAttack:{A7. B7. C7. D7. E7. F7. G7. A6. B6. C6. D6. E6. F6} fromPiece:Knight) ifTrue:[^false].
+ "check for a pawn attack"
+ (self checkUnprotectedAttack:{A7. B7. C7. D7. E7. F7} fromPiece:Pawn) ifTrue:[^false].
+ "check for a king attack"
+ (self checkUnprotectedAttack:{B7. C7. } fromPiece:King) ifTrue:[^false].
+ ^true.
+ !
Item was added:
+ ----- Method: ChessMoveGenerator>>canCastleWhiteKingSide (in category 'support') -----
+ canCastleWhiteKingSide
+ (castlingStatus bitAnd: CastlingEnableKingSide) = 0 ifFalse: [^false].
+ "Quickly check if all the squares are zero"
+ ((myPieces at:G1) + (myPieces at:F1) + (itsPieces at:G1) + (itsPieces at:F1) = 0) ifFalse:[^false].
+ "Check for castling squares under attack.. See canCastleBlackQueenSide for details"
+ (self checkAttack:{G2. G3. G4. G5. G6. G7. G8} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{F2. F3. F4. F5. F6. F7. F8} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{E2. E3. E4. E5. E6. E7. E8} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{A1. A2. A3. A4} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{F2. E3. D4. C5. B6. A7} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{E2. D3. C4. B5. A6} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{D2. C3. B4. A5} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{F2. G3. H4} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{G2. H3} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{H2} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkUnprotectedAttack:{H2. G2. E2. D2. C2. H3. G3. F3. E3. D3} fromPiece:Knight) ifTrue:[^false].
+ (self checkUnprotectedAttack:{H2. G2. F2. E2. D2} fromPiece:Pawn) ifTrue:[^false].
+ (self checkUnprotectedAttack:{G2} fromPiece:King) ifTrue:[^false].
+ ^true.!
Item was added:
+ ----- Method: ChessMoveGenerator>>canCastleWhiteQueenSide (in category 'support') -----
+ canCastleWhiteQueenSide
+ (castlingStatus bitAnd: CastlingEnableQueenSide) = 0 ifFalse: [^false].
+ "Quickly check if all the squares are zero"
+ ((myPieces at:B1) + (myPieces at:C1) + (myPieces at:D1) +
+ (itsPieces at:B1) + (itsPieces at:C1) + (itsPieces at:D1) = 0) ifFalse:[^false].
+ "Check for castling squares under attack.. See canCastleBlackQueenSide for details"
+ (self checkAttack:{B2. B3. B4. B5. B6. B7. B8} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{C2. C3. C4. C5. C6. C7. C8} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{D2. D3. D4. D5. D6. D7. D8} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{E2. E3. E4. E5. E6. E7. E8} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{F1. G1. H1} fromPieces:RookMovers) ifTrue:[^false].
+ (self checkAttack:{C2. D3. E4. F5. G6. H7} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{D2. E3. F4. G5. H6} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{E2. F3. G4. H5} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{F2. G3. H4} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{A2} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{B2. A3} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{C2. B3. A4} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkAttack:{D2. C3. B4. A5} fromPieces:BishopMovers) ifTrue:[^false].
+ (self checkUnprotectedAttack:{A2. B2. C2. D2. E2. F2. G2. A3. B3. C3. D3. E3. F3} fromPiece:Knight) ifTrue:[^false].
+ (self checkUnprotectedAttack:{A2. B2. C2. D2. E2. F2} fromPiece:Pawn) ifTrue:[^false].
+ (self checkUnprotectedAttack:{B2. C2} fromPiece:King) ifTrue:[^false].
+ ^true.!
Item was added:
+ ----- Method: ChessMoveGenerator>>checkAttack:fromPieces: (in category 'support') -----
+ checkAttack:squares fromPieces:pieces
+ "check for an unprotected attack along squares by one of pieces. Squares is a list of
+ squares such that any piece in pieces can attack unless blocked by another piece.
+ E.g., a Bishop of Queen on the file B7 C6 D5 E4 F3 G2 H1 can attack A8 unless blocked by
+ another piece. To find out if A8 is under attack along B7 C6 D5 E4 F3 G2 H1, use
+ checkAttack:{B7. C6.D5. E4. F3. G2. H1} fromPieces:BishopMovers. Note the order is important;
+ squares must be listed in increasing distance from the square of interest"
+
+ squares do:[:sqr|
+ "invariant: no piece has been seen on this file at all"
+ "one of my pieces blocks any attack"
+ (myPieces at:sqr) = 0 ifFalse:[^false].
+ "One of its pieces blocks an attack unless it is the kind of piece that can move along this
+ file: a Bishop or Queen for a diagonal and a Rook or Queen for a Horizontal or
+ Verrtical File"
+ (itsPieces at:sqr) = 0 ifFalse:[
+ ^pieces includes:(itsPieces at:sqr).
+ ].
+
+ ].
+ "no pieces along file, no attack"
+ ^false.
+
+
+ !
Item was added:
+ ----- Method: ChessMoveGenerator>>checkUnprotectedAttack:fromPiece: (in category 'support') -----
+ checkUnprotectedAttack:squares fromPiece:piece
+ "check to see if my opponent has a piece of type piece on any of squares. In general, this
+ is used because that piece could launch an attack on me from those squares".
+ squares do:[:sqr|
+ (itsPieces at:sqr) = piece ifTrue:[^true].
+ ].
+ ^false.
+
+
+ !
Item was added:
+ ----- Method: ChessMoveGenerator>>findAllPossibleMovesFor: (in category 'public') -----
+ findAllPossibleMovesFor: player
+ "Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
+
+ | piece actions square |
+ myPlayer := player.
+ myPieces := player pieces.
+ itsPieces := player opponent pieces.
+ castlingStatus := player castlingStatus.
+ enpassantSquare := player opponent enpassantSquare.
+ firstMoveIndex = lastMoveIndex ifFalse: [self error: 'I am confused'].
+ kingAttack := nil.
+ myPlayer isWhitePlayer ifTrue:[
+ actions := #(moveWhitePawnAt: moveKnightAt: moveBishopAt:
+ moveRookAt: moveQueenAt: moveWhiteKingAt:)
+ ] ifFalse:[
+ actions := #(moveBlackPawnAt: moveKnightAt: moveBishopAt:
+ moveRookAt: moveQueenAt: moveBlackKingAt:)
+ ].
+ square := 0.
+ [square < 64] whileTrue:[
+ "Note: The following is only to skip empty fields efficiently.
+ It could well be replaced by going through each field and test it
+ for zero but this is *much* faster."
+ square := self skipEmptySquaresIn: myPieces
+ using: EmptyPieceMap
+ startingAt: square + 1.
+ square = 0 ifTrue: [^self moveList].
+ piece := myPieces at: square.
+ self perform: (actions at: piece) with: square.
+ kingAttack ifNotNil: [^self moveList].
+ ].
+ ^self moveList!
Item was added:
+ ----- Method: ChessMoveGenerator>>findAttackSquaresFor: (in category 'public') -----
+ findAttackSquaresFor: player
+ "Mark all the fields of a board that are attacked by the given player.
+ The pieces attacking a field are encoded as (1 << Piece) so that we can
+ record all types of pieces that attack the square."
+
+ | move square piece attack list |
+ forceCaptures := false.
+ attackSquares ifNil: [attackSquares := ByteArray new: 64].
+ attackSquares atAllPut: 0.
+ list := self findAllPossibleMovesFor: player.
+
+ [move := list next.
+ move isNil] whileFalse:
+ [square := move destinationSquare.
+ piece := move movingPiece.
+ attack := attackSquares at: square.
+ attack := attack bitOr: (1 bitShift: piece).
+ attackSquares at: square put: attack].
+ self recycleMoveList: list.
+ ^attackSquares!
Item was added:
+ ----- Method: ChessMoveGenerator>>findPossibleMovesFor: (in category 'public') -----
+ findPossibleMovesFor: player
+ "Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
+ forceCaptures := false.
+ ^self findAllPossibleMovesFor: player.!
Item was added:
+ ----- Method: ChessMoveGenerator>>findPossibleMovesFor:at: (in category 'public') -----
+ findPossibleMovesFor: player at: square
+ "Find all possible moves at the given square. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
+ | piece action |
+ forceCaptures := false.
+ myPlayer := player.
+ myPieces := player pieces.
+ itsPieces := player opponent pieces.
+ castlingStatus := player castlingStatus.
+ enpassantSquare := player opponent enpassantSquare.
+ firstMoveIndex = lastMoveIndex ifFalse:[self error:'I am confused'].
+ kingAttack := nil.
+ piece := myPieces at: square.
+ piece = 0 ifFalse:[
+ action := #(movePawnAt:
+ moveKnightAt:
+ moveBishopAt:
+ moveRookAt:
+ moveQueenAt:
+ moveKingAt:) at: piece.
+ self perform: action with: square.
+ ].
+ ^self moveList!
Item was added:
+ ----- Method: ChessMoveGenerator>>findQuiescenceMovesFor: (in category 'public') -----
+ findQuiescenceMovesFor: player
+ "Find all the quiescence moves (that is moves capturing pieces)"
+ forceCaptures := true.
+ ^self findAllPossibleMovesFor: player.!
Item was added:
+ ----- Method: ChessMoveGenerator>>initialize (in category 'initialize') -----
+ initialize
+ EmptyPieceMap ifNil:[
+ EmptyPieceMap := ByteArray new: 256.
+ 2 to: 7 do:[:i| EmptyPieceMap at: i put: 1]].
+
+ streamList := Array new: 100. "e.g., 100 plies"
+ 1 to: streamList size do:[:i| streamList at: i put: (ChessMoveList on: #())].
+ moveList := Array new: streamList size * 30. "avg. 30 moves per ply"
+ 1 to: moveList size do:[:i| moveList at: i put: (ChessMove new init)].
+ firstMoveIndex := lastMoveIndex := streamListIndex := 0.!
Item was added:
+ ----- Method: ChessMoveGenerator>>kingAttack (in category 'public') -----
+ kingAttack
+ ^kingAttack!
Item was added:
+ ----- Method: ChessMoveGenerator>>moveBishopAt: (in category 'moves-general') -----
+ moveBishopAt: square
+ | moves |
+ moves := BishopMoves at: square.
+ 1 to: moves size do:[:i|
+ self movePiece: Bishop along: (moves at: i) at: square.
+ ].
+ !
Item was added:
+ ----- Method: ChessMoveGenerator>>moveBlackKingAt: (in category 'moves-general') -----
+ moveBlackKingAt: square
+ | capture |
+ (KingMoves at: square) do:[:destSquare|
+ (myPieces at: destSquare) = 0 ifTrue:[
+ capture := itsPieces at: destSquare.
+ (forceCaptures and:[capture = 0]) ifFalse:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ move: King from: square to: destSquare capture: capture.
+ capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
+ ].
+ ].
+ ].
+ forceCaptures ifTrue:[^self].
+ "now consider castling"
+ self canCastleBlackKingSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ moveCastlingKingSide: King from: square to: square+2.
+ ].
+ self canCastleBlackQueenSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ moveCastlingQueenSide: King from: square to: square-2.
+ ].!
Item was added:
+ ----- Method: ChessMoveGenerator>>moveBlackPawnAt: (in category 'moves-pawns') -----
+ moveBlackPawnAt: square
+ "Pawns only move in one direction so check for which direction to use"
+ forceCaptures ifFalse:[self blackPawnPushAt: square].
+ (square bitAnd: 7) = 1
+ ifFalse:[self blackPawnCaptureAt: square direction: 1].
+ (square bitAnd: 7) = 0
+ ifFalse:[self blackPawnCaptureAt: square direction: -1].
+ !
Item was added:
+ ----- Method: ChessMoveGenerator>>moveKingAt: (in category 'moves-general') -----
+ moveKingAt: square
+ myPlayer isWhitePlayer
+ ifTrue:[^self moveWhiteKingAt: square]
+ ifFalse:[^self moveBlackKingAt: square]!
Item was added:
+ ----- Method: ChessMoveGenerator>>moveKnightAt: (in category 'moves-general') -----
+ moveKnightAt: square
+ | capture moves destSquare |
+ moves := KnightMoves at: square.
+ 1 to: moves size do:[:i|
+ destSquare := moves at: i.
+ (myPieces at: destSquare) = 0 ifTrue:[
+ capture := itsPieces at: destSquare.
+ (forceCaptures and:[capture = 0]) ifFalse:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ move: Knight from: square to: destSquare capture: capture.
+ capture = King ifTrue:[kingAttack := (moveList at: lastMoveIndex)].
+ ].
+ ].
+ ].!
Item was added:
+ ----- Method: ChessMoveGenerator>>moveList (in category 'public') -----
+ moveList
+ | list |
+ kingAttack ifNotNil:[
+ lastMoveIndex := firstMoveIndex.
+ ^nil].
+ list := streamList at: (streamListIndex := streamListIndex + 1).
+ list on: moveList from: firstMoveIndex+1 to: lastMoveIndex.
+ firstMoveIndex := lastMoveIndex.
+ ^list!
Item was added:
+ ----- Method: ChessMoveGenerator>>movePawnAt: (in category 'moves-general') -----
+ movePawnAt: square
+ "Pawns only move in one direction so check for which direction to use"
+ myPlayer isWhitePlayer
+ ifTrue:[^self moveWhitePawnAt: square]
+ ifFalse:[^self moveBlackPawnAt: square]!
Item was added:
+ ----- Method: ChessMoveGenerator>>movePiece:along:at: (in category 'moves-general') -----
+ movePiece: piece along: rayList at: square
+ | destSquare capture |
+ 1 to: rayList size do:[:i|
+ destSquare := rayList at: i.
+ (myPieces at: destSquare) = 0 ifFalse:[^self].
+ capture := itsPieces at: destSquare.
+ (forceCaptures and:[capture = 0]) ifFalse:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ move: piece from: square to: destSquare capture: capture.
+ capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
+ ].
+ capture = 0 ifFalse:[^self].
+ ].!
Item was added:
+ ----- Method: ChessMoveGenerator>>moveQueenAt: (in category 'moves-general') -----
+ moveQueenAt: square
+ | moves |
+ moves := RookMoves at: square.
+ 1 to: moves size do:[:i|
+ self movePiece: Queen along: (moves at: i) at: square.
+ ].
+ moves := BishopMoves at: square.
+ 1 to: moves size do:[:i|
+ self movePiece: Queen along: (moves at: i) at: square.
+ ].!
Item was added:
+ ----- Method: ChessMoveGenerator>>moveRookAt: (in category 'moves-general') -----
+ moveRookAt: square
+ | moves |
+ moves := RookMoves at: square.
+ 1 to: moves size do:[:i|
+ self movePiece: Rook along: (moves at: i) at: square.
+ ].
+ !
Item was added:
+ ----- Method: ChessMoveGenerator>>moveWhiteKingAt: (in category 'moves-general') -----
+ moveWhiteKingAt: square
+ | capture |
+ (KingMoves at: square) do:[:destSquare|
+ (myPieces at: destSquare) = 0 ifTrue:[
+ capture := itsPieces at: destSquare.
+ (forceCaptures and:[capture = 0]) ifFalse:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ move: King from: square to: destSquare capture: capture.
+ capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
+ ].
+ ].
+ ].
+ forceCaptures ifTrue:[^self].
+ "now consider castling"
+ self canCastleWhiteKingSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ moveCastlingKingSide: King from: square to: square+2.
+ ].
+ self canCastleWhiteQueenSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ moveCastlingQueenSide: King from: square to: square-2.
+ ].!
Item was added:
+ ----- Method: ChessMoveGenerator>>moveWhitePawnAt: (in category 'moves-pawns') -----
+ moveWhitePawnAt: square
+ "Pawns only move in one direction so check for which direction to use"
+ forceCaptures ifFalse:[self whitePawnPushAt: square].
+ (square bitAnd: 7) = 0
+ ifFalse:[self whitePawnCaptureAt: square direction: 1].
+ (square bitAnd: 7) = 1
+ ifFalse:[self whitePawnCaptureAt: square direction: -1].
+ !
Item was added:
+ ----- Method: ChessMoveGenerator>>profileGenerationFor: (in category 'public') -----
+ profileGenerationFor: player
+ | list |
+ Smalltalk garbageCollect.
+ MessageTally spyOn:[
+ 1 to: 100000 do:[:i|
+ list := self findPossibleMovesFor: player.
+ self recycleMoveList: list].
+ ].
+ !
Item was added:
+ ----- Method: ChessMoveGenerator>>promotePawn: (in category 'moves-pawns') -----
+ promotePawn: move
+ "Duplicate the given move and embed all promotion types"
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1)) promote: move to: Knight.
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1)) promote: move to: Bishop.
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1)) promote: move to: Rook.
+ move promote: move to: Queen.!
Item was added:
+ ----- Method: ChessMoveGenerator>>recycleMoveList: (in category 'public') -----
+ recycleMoveList: aChessMoveList
+ (streamList at: streamListIndex) == aChessMoveList ifFalse:[^self error:'I am confused'].
+ streamListIndex := streamListIndex - 1.
+ firstMoveIndex := lastMoveIndex := aChessMoveList startIndex - 1.
+ !
Item was added:
+ ----- Method: ChessMoveGenerator>>skipEmptySquaresIn:using:startingAt: (in category 'private') -----
+ skipEmptySquaresIn: pieces using: aMap startingAt: startIndex
+ "Find the first empty (zero) square in pieces. The method is layed out so we can (re)use the a particularly effective String primitive (which requires the map argument) but the failure code will do the more natural search for zero instead of the actual primitive equivalent."
+ <primitive: 'primitiveFindFirstInString' module: 'MiscPrimitivePlugin'>
+ startIndex to: pieces size do:[:index|
+ (pieces at: index) = 0 ifFalse:[^index].
+ ].
+ ^0!
Item was added:
+ ----- Method: ChessMoveGenerator>>whitePawnCaptureAt:direction: (in category 'moves-pawns') -----
+ whitePawnCaptureAt: square direction: dir
+ | destSquare move piece |
+ destSquare := square+8+dir.
+ piece := itsPieces at: destSquare.
+ piece = 0 ifFalse:[
+ (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ move: Pawn from: square to: destSquare capture: piece.
+ piece = King ifTrue:[kingAttack := move].
+ destSquare > 56 "a promotion"
+ ifTrue:[self promotePawn: move].
+ ].
+ "attempt an en-passant capture"
+ enpassantSquare = destSquare ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ captureEnPassant: Pawn from: square to: destSquare.
+ ].!
Item was added:
+ ----- Method: ChessMoveGenerator>>whitePawnPushAt: (in category 'moves-pawns') -----
+ whitePawnPushAt: square
+ "Pawns only move in one direction so check for which direction to use"
+ | destSquare move |
+ "Try to push this pawn"
+ destSquare := square+8.
+
+ (myPieces at: destSquare) = 0 ifFalse:[^self].
+ (itsPieces at: destSquare) = 0 ifFalse:[^self].
+ (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ move: Pawn from: square to: destSquare.
+ destSquare > 56 "a promotion (can't be double-push so get out)"
+ ifTrue:[^self promotePawn: move].
+
+ "Try to double-push if possible"
+ square <= 16 ifFalse:[^self].
+ destSquare := square+16.
+ (myPieces at: destSquare) = 0 ifFalse:[^self].
+ (itsPieces at: destSquare) = 0 ifFalse:[^self].
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
+ doublePush: Pawn from: square to: destSquare.!
Item was added:
+ ReadStream subclass: #ChessMoveList
+ instanceVariableNames: 'startIndex'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess'!
+
+ !ChessMoveList commentStamp: '<historical>' prior: 0!
+ An optimized representation of a set of moves - mainly there to avoid excessive allocation (and garbage collections) in a few critical places.!
Item was added:
+ ----- Method: ChessMoveList>>contents (in category 'accessing') -----
+ contents
+ ^collection copyFrom: startIndex to: readLimit!
Item was added:
+ ----- Method: ChessMoveList>>on:from:to: (in category 'private') -----
+ on: aCollection from: firstIndex to: lastIndex
+ startIndex := firstIndex.
+ ^super on: aCollection from: firstIndex to: lastIndex.
+ !
Item was added:
+ ----- Method: ChessMoveList>>sortUsing: (in category 'sorting') -----
+ sortUsing: historyTable
+
+ ^collection
+ quickSortFrom: startIndex
+ to: readLimit
+ by: [ :a :b | historyTable sorts: a before: b ]!
Item was added:
+ ----- Method: ChessMoveList>>startIndex (in category 'accessing') -----
+ startIndex
+ ^startIndex!
Item was added:
+ ImageMorph subclass: #ChessPieceMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess'!
Item was added:
+ ----- Method: ChessPieceMorph>>wantsToBeDroppedInto: (in category 'dropping/grabbing') -----
+ wantsToBeDroppedInto: aMorph
+ ^aMorph isKindOf: ChessMorph!
Item was added:
+ ChessPieceMorph subclass: #ChessPieceMorphWC
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess960'!
+
+ !ChessPieceMorphWC commentStamp: 'spfa 5/31/2020 10:36' prior: 0!
+ ChessPieceMorphWC class side provides scalable images from Wikimedia Commons!
Item was added:
+ ----- Method: ChessPieceMorphWC class>>pieceExtent (in category 'forms library') -----
+ pieceExtent
+
+ ^ 314 @ 302!
Item was added:
+ ----- Method: ChessPieceMorphWC class>>pieces (in category 'forms library') -----
(excessive size, no diff calculated)
Item was added:
+ ----- Method: ChessPieceMorphWC class>>piecesWithExtent: (in category 'forms library') -----
+ piecesWithExtent: aPoint
+
+ | form dict ng og pg i ib iw |
+
+ form := self pieces.
+ dict := Dictionary new.
+ ng := #( whiteKing blackKing whiteQueen blackQueen whiteBishop blackBishop whiteKnight blackKnight whiteRook blackRook whitePawn blackPawn).
+
+ og := #(55 55 10 10 0 0 0 0 0 0 0 0).
+ pg := #(0 0 0 0 20 20 50 50 90 90 120 120).
+
+ i := 0.
+ 0 to: 5 do: [:n |
+ ib := (i := i + 1) * 2 - 1.
+ iw := i * 2.
+ dict at: (ng at: ib)
+ put: ((form contentsOfArea: (315 * n + (pg at: ib) @0
+ corner: 315 * n + 314 - (og at: ib) @ 302))
+ scaledToSize: aPoint).
+ dict at: (ng at: iw)
+ put: ((form contentsOfArea: (315 * n + (pg at: iw) @327
+ corner: 315 * n + 314 - (og at: iw) @ 629))
+ scaledToSize: aPoint)].
+
+ ^ dict!
Item was added:
+ ----- Method: ChessPieceMorphWC class>>piecesWithHeight: (in category 'forms library') -----
+ piecesWithHeight: anInteger
+
+ ^ self piecesWithExtent: self pieceExtent x * anInteger / self pieceExtent y @ anInteger!
Item was added:
+ Object subclass: #ChessPlayer
+ instanceVariableNames: 'board pieces opponent castlingRookSquare enpassantSquare castlingStatus materialValue numPawns positionalValue'
+ classVariableNames: ''
+ poolDictionaries: 'ChessConstants'
+ category: 'MorphicExtras-Games-Chess'!
+
+ !ChessPlayer commentStamp: '<historical>' prior: 0!
+ This class represents a player in the game, including its pieces and the current value of the player's position.!
Item was added:
+ ----- Method: ChessPlayer class>>king (in category 'accessing') -----
+ king
+ ^King!
Item was added:
+ ----- Method: ChessPlayer class>>rook (in category 'accessing') -----
+ rook
+ ^Rook!
Item was added:
+ ----- Method: ChessPlayer>>addBlackPieces (in category 'adding/removing') -----
+ addBlackPieces
+ self initialize.
+ 49 to: 56 do:[:i| self addPiece: Pawn at: i].
+ self addPiece: Rook at: 57.
+ self addPiece: Knight at: 58.
+ self addPiece: Bishop at: 59.
+ self addPiece: Queen at: 60.
+ self addPiece: King at: 61.
+ self addPiece: Bishop at: 62.
+ self addPiece: Knight at: 63.
+ self addPiece: Rook at: 64.
+ !
Item was added:
+ ----- Method: ChessPlayer>>addPiece:at: (in category 'adding/removing') -----
+ addPiece: piece at: square
+ pieces at: square put: piece.
+ materialValue := materialValue + (PieceValues at: piece).
+ positionalValue := positionalValue + ((PieceCenterScores at: piece) at: square).
+ piece = Pawn ifTrue:[numPawns := numPawns + 1].
+ board updateHash: piece at: square from: self.
+ self userAgent ifNotNil:[self userAgent addedPiece: piece at: square white: self isWhitePlayer].!
Item was added:
+ ----- Method: ChessPlayer>>addWhitePieces (in category 'adding/removing') -----
+ addWhitePieces
+ self addPiece: Rook at: 1.
+ self addPiece: Knight at: 2.
+ self addPiece: Bishop at: 3.
+ self addPiece: Queen at: 4.
+ self addPiece: King at: 5.
+ self addPiece: Bishop at: 6.
+ self addPiece: Knight at: 7.
+ self addPiece: Rook at: 8.
+ 9 to: 16 do:[:i| self addPiece: Pawn at: i].
+ !
Item was added:
+ ----- Method: ChessPlayer>>applyCastleKingSideMove: (in category 'moving') -----
+ applyCastleKingSideMove: move
+ self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.
+ self movePiece: Rook from: move sourceSquare+3 to: (castlingRookSquare := move sourceSquare+1).
+ pieces at: castlingRookSquare put: King.
+ castlingStatus := castlingStatus bitOr: CastlingDone.!
Item was added:
+ ----- Method: ChessPlayer>>applyCastleQueenSideMove: (in category 'moving') -----
+ applyCastleQueenSideMove: move
+ self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.
+ self movePiece: Rook from: move sourceSquare-4 to: (castlingRookSquare := move sourceSquare-1).
+ pieces at: castlingRookSquare put: King.
+ castlingStatus := castlingStatus bitOr: CastlingDone.!
Item was added:
+ ----- Method: ChessPlayer>>applyDoublePushMove: (in category 'moving') -----
+ applyDoublePushMove: move
+ enpassantSquare := (move sourceSquare + move destinationSquare) bitShift: -1.
+ "Above means: the field between start and destination"
+ ^self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.!
Item was added:
+ ----- Method: ChessPlayer>>applyEnpassantMove: (in category 'moving') -----
+ applyEnpassantMove: move
+ | capturedSquare |
+ capturedSquare := move destinationSquare - (self isWhitePlayer ifTrue:[8] ifFalse:[-8]).
+ opponent removePiece: move capturedPiece at: capturedSquare.
+ self userAgent ifNotNil:[(self userAgent atSquare: capturedSquare) removeAllMorphs].
+ ^self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare!
Item was added:
+ ----- Method: ChessPlayer>>applyMove: (in category 'moving') -----
+ applyMove: move
+ "Apply the given move"
+ | action |
+ "Apply basic move"
+ action := #(
+ applyNormalMove:
+ applyDoublePushMove:
+ applyEnpassantMove:
+ applyCastleKingSideMove:
+ applyCastleQueenSideMove:
+ applyResign:
+ applyStaleMate:
+ ) at: (move moveType bitAnd: ChessMove basicMoveMask).
+ self perform: action with: move.
+
+ "Promote if necessary"
+ self applyPromotion: move.
+
+ "Maintain castling status"
+ self updateCastlingStatus: move.
+ !
Item was added:
+ ----- Method: ChessPlayer>>applyNormalMove: (in category 'moving') -----
+ applyNormalMove: move
+ | piece |
+ (piece := move capturedPiece) = EmptySquare
+ ifFalse:[opponent removePiece: piece at: move destinationSquare].
+ ^self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.!
Item was added:
+ ----- Method: ChessPlayer>>applyPromotion: (in category 'moving') -----
+ applyPromotion: move
+ | piece |
+ piece := move promotion.
+ piece = 0 ifFalse:[self replacePiece: move movingPiece with: piece at: move destinationSquare].!
Item was added:
+ ----- Method: ChessPlayer>>applyResign: (in category 'moving') -----
+ applyResign: move
+ "Give up."
+ self userAgent ifNotNil:[
+ self isWhitePlayer
+ ifTrue:[self userAgent finishedGame: 0]
+ ifFalse:[self userAgent finishedGame: 1].
+ ].!
Item was added:
+ ----- Method: ChessPlayer>>applyStaleMate: (in category 'moving') -----
+ applyStaleMate: move
+ "Itsa draw."
+ self userAgent ifNotNil:[self userAgent finishedGame: 0.5].!
Item was added:
+ ----- Method: ChessPlayer>>board (in category 'accessing') -----
+ board
+ ^board!
Item was added:
+ ----- Method: ChessPlayer>>board: (in category 'accessing') -----
+ board: aBoard
+ board := aBoard!
Item was added:
+ ----- Method: ChessPlayer>>canCastleKingSide (in category 'testing') -----
+ canCastleKingSide
+ (castlingStatus bitAnd: CastlingEnableKingSide) = 0 ifFalse: [^false].
+ self isWhitePlayer
+ ifTrue:
+ [(pieces sixth) = 0 ifFalse: [^false].
+ pieces seventh = 0 ifFalse: [^false].
+ (opponent pieceAt: 6) = 0 ifFalse: [^false].
+ (opponent pieceAt: 7) = 0 ifFalse: [^false]]
+ ifFalse:
+ [(pieces at: 62) = 0 ifFalse: [^false].
+ (pieces at: 63) = 0 ifFalse: [^false].
+ (opponent pieceAt: 62) = 0 ifFalse: [^false].
+ (opponent pieceAt: 63) = 0 ifFalse: [^false]].
+ ^true!
Item was added:
+ ----- Method: ChessPlayer>>canCastleQueenSide (in category 'testing') -----
+ canCastleQueenSide
+ (castlingStatus bitAnd: CastlingEnableQueenSide) = 0 ifFalse: [^false].
+ self isWhitePlayer
+ ifTrue:
+ [pieces second = 0 ifFalse: [^false].
+ (pieces third) = 0 ifFalse: [^false].
+ pieces fourth = 0 ifFalse: [^false].
+ (opponent pieceAt: 2) = 0 ifFalse: [^false].
+ (opponent pieceAt: 3) = 0 ifFalse: [^false].
+ (opponent pieceAt: 4) = 0 ifFalse: [^false]]
+ ifFalse:
+ [(pieces at: 58) = 0 ifFalse: [^false].
+ (pieces at: 59) = 0 ifFalse: [^false].
+ (pieces at: 60) = 0 ifFalse: [^false].
+ (opponent pieceAt: 58) = 0 ifFalse: [^false].
+ (opponent pieceAt: 59) = 0 ifFalse: [^false].
+ (opponent pieceAt: 60) = 0 ifFalse: [^false]].
+ ^true!
Item was added:
+ ----- Method: ChessPlayer>>castlingRookSquare (in category 'accessing') -----
+ castlingRookSquare
+ ^castlingRookSquare!
Item was added:
+ ----- Method: ChessPlayer>>castlingStatus (in category 'accessing') -----
+ castlingStatus
+ ^castlingStatus!
Item was added:
+ ----- Method: ChessPlayer>>copyPlayer: (in category 'copying') -----
+ copyPlayer: aPlayer
+ "Copy all the volatile state from aPlayer"
+ castlingRookSquare := aPlayer castlingRookSquare.
+ enpassantSquare := aPlayer enpassantSquare.
+ castlingStatus := aPlayer castlingStatus.
+ materialValue := aPlayer materialValue.
+ numPawns := aPlayer numPawns.
+ positionalValue := aPlayer positionalValue.
+ pieces replaceFrom: 1 to: pieces size with: aPlayer pieces startingAt: 1.!
Item was added:
+ ----- Method: ChessPlayer>>enpassantSquare (in category 'accessing') -----
+ enpassantSquare
+ ^enpassantSquare!
Item was added:
+ ----- Method: ChessPlayer>>evaluate (in category 'evaluation') -----
+ evaluate
+ ^self evaluateMaterial + self evaluatePosition!
Item was added:
+ ----- Method: ChessPlayer>>evaluateMaterial (in category 'evaluation') -----
+ evaluateMaterial
+ "Compute the board's material balance, from the point of view of the side
+ player. This is an exact clone of the eval function in CHESS 4.5"
+ | total diff value pawns |
+ self materialValue = opponent materialValue ifTrue:[^0]. "both sides are equal"
+ total := self materialValue + opponent materialValue.
+ diff := self materialValue - opponent materialValue.
+
+ pawns := numPawns.
+ pawns < 0 ifTrue: ["happens - a bug somewhere" pawns := 0].
+
+ value := (2400 min: diff) +
+ ((diff * (12000 - total) * pawns) // (6400 * (pawns + 1))).
+ ^value!
Item was added:
+ ----- Method: ChessPlayer>>evaluatePosition (in category 'evaluation') -----
+ evaluatePosition
+ "Compute the board's positional balance, from the point of view of the side player."
+ ^positionalValue - opponent positionalValue!
Item was added:
+ ----- Method: ChessPlayer>>findPossibleMoves (in category 'moves-general') -----
+ findPossibleMoves
+ "Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
+ | moveList moves |
+ moveList := board generator findPossibleMovesFor: self.
+ moveList ifNil:[^nil].
+ moves := moveList contents collect:[:move| move copy].
+ board generator recycleMoveList: moveList.
+ ^moves!
Item was added:
+ ----- Method: ChessPlayer>>findPossibleMovesAt: (in category 'moves-general') -----
+ findPossibleMovesAt: square
+ "Find all possible moves at the given square. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
+ | moveList moves |
+ moveList := board generator findPossibleMovesFor: self at: square.
+ moveList ifNil:[^nil].
+ moves := moveList contents collect:[:move| move copy].
+ board generator recycleMoveList: moveList.
+ ^moves!
Item was added:
+ ----- Method: ChessPlayer>>findQuiescenceMoves (in category 'moves-general') -----
+ findQuiescenceMoves
+ "Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
+ | moveList moves |
+ moveList := board generator findQuiescenceMovesFor: self.
+ moveList ifNil:[^nil].
+ moves := moveList contents collect:[:move| move copy].
+ board generator recycleMoveList: moveList.
+ ^moves!
Item was added:
+ ----- Method: ChessPlayer>>findValidMoves (in category 'moves-general') -----
+ findValidMoves
+ "Find all the valid moves"
+ | moveList |
+ moveList := self findPossibleMoves ifNil:[^nil].
+ ^moveList select:[:move| self isValidMove: move].!
Item was added:
+ ----- Method: ChessPlayer>>findValidMovesAt: (in category 'moves-general') -----
+ findValidMovesAt: square
+ "Find all the valid moves"
+ | moveList |
+ moveList := (self findPossibleMovesAt: square) ifNil:[^nil].
+ ^moveList select:[:move| self isValidMove: move].!
Item was added:
+ ----- Method: ChessPlayer>>initialLeftRookSquare (in category 'configuration') -----
+ initialLeftRookSquare
+
+ ^ self isWhitePlayer ifTrue: [A1] ifFalse: [A8]!
Item was added:
+ ----- Method: ChessPlayer>>initialRightRookSquare (in category 'configuration') -----
+ initialRightRookSquare
+
+ ^ self isWhitePlayer ifTrue: [H1] ifFalse: [H8]!
Item was added:
+ ----- Method: ChessPlayer>>initialize (in category 'initialize') -----
+ initialize
+ "ChessPlayer initialize"
+ pieces := ByteArray new: 64.
+ materialValue := 0.
+ positionalValue := 0.
+ numPawns := 0.
+ enpassantSquare := 0.
+ castlingRookSquare := 0.
+ castlingStatus := 0.!
Item was added:
+ ----- Method: ChessPlayer>>isValidMove: (in category 'testing') -----
+ isValidMove: move
+ "Is the given move actually valid for the receiver?
+ If the receiver's king can't be taken after applying the move, it is."
+ | copy |
+ copy := board copy.
+ copy nextMove: move.
+ ^copy activePlayer findPossibleMoves notNil!
Item was added:
+ ----- Method: ChessPlayer>>isValidMoveFrom:to: (in category 'testing') -----
+ isValidMoveFrom: sourceSquare to: destSquare
+ | move |
+ move := (self findValidMovesAt: sourceSquare)
+ detect:[:any| (any triggerSquareIn: board) = destSquare] ifNone:[nil].
+ ^move notNil!
Item was added:
+ ----- Method: ChessPlayer>>isWhitePlayer (in category 'testing') -----
+ isWhitePlayer
+ ^board whitePlayer == self!
Item was added:
+ ----- Method: ChessPlayer>>materialValue (in category 'accessing') -----
+ materialValue
+ ^materialValue!
Item was added:
+ ----- Method: ChessPlayer>>movePiece:from:to: (in category 'adding/removing') -----
+ movePiece: piece from: sourceSquare to: destSquare
+ | score |
+ score := PieceCenterScores at: piece.
+ positionalValue := positionalValue - (score at: sourceSquare).
+ positionalValue := positionalValue + (score at: destSquare).
+ pieces at: sourceSquare put: 0.
+ pieces at: destSquare put: piece.
+ board updateHash: piece at: sourceSquare from: self.
+ board updateHash: piece at: destSquare from: self.
+ self userAgent ifNotNil:[self userAgent movedPiece: piece from: sourceSquare to: destSquare].!
Item was added:
+ ----- Method: ChessPlayer>>numPawns (in category 'accessing') -----
+ numPawns
+ ^numPawns!
Item was added:
+ ----- Method: ChessPlayer>>opponent (in category 'accessing') -----
+ opponent
+ ^opponent!
Item was added:
+ ----- Method: ChessPlayer>>opponent: (in category 'accessing') -----
+ opponent: aPlayer
+ opponent := aPlayer!
Item was added:
+ ----- Method: ChessPlayer>>pieceAt: (in category 'accessing') -----
+ pieceAt: square
+ "Return the piece at the given square"
+ ^pieces at: square!
Item was added:
+ ----- Method: ChessPlayer>>pieces (in category 'accessing') -----
+ pieces
+ ^pieces!
Item was added:
+ ----- Method: ChessPlayer>>positionalValue (in category 'evaluation') -----
+ positionalValue
+ "Evaluate our current position"
+ ^positionalValue!
Item was added:
+ ----- Method: ChessPlayer>>postCopy (in category 'copying') -----
+ postCopy
+
+ pieces := pieces copy!
Item was added:
+ ----- Method: ChessPlayer>>prepareNextMove (in category 'initialize') -----
+ prepareNextMove
+ "Clear enpassant square and reset any pending extra kings"
+ enpassantSquare := 0.
+ castlingRookSquare = 0 ifFalse:[pieces at: castlingRookSquare put: Rook].
+ castlingRookSquare := 0.
+ !
Item was added:
+ ----- Method: ChessPlayer>>removePiece:at: (in category 'adding/removing') -----
+ removePiece: piece at: square
+
+ (pieces at: square) = piece ifFalse: ["fix"
+ "Happens at time - some moves have a capturedPiece absent from the board"
+ ^self].
+
+ pieces at: square put: 0.
+ materialValue := materialValue - (PieceValues at: piece).
+ positionalValue := positionalValue - ((PieceCenterScores at: piece) at: square).
+ piece = Pawn ifTrue:[numPawns := numPawns - 1].
+ board updateHash: piece at: square from: self.
+ self userAgent ifNotNil:[self userAgent removedPiece: piece at: square].
+ !
Item was added:
+ ----- Method: ChessPlayer>>replacePiece:with:at: (in category 'adding/removing') -----
+ replacePiece: oldPiece with: newPiece at: square
+ pieces at: square put: newPiece.
+ materialValue := materialValue - (PieceValues at: oldPiece) + (PieceValues at: newPiece).
+ positionalValue := positionalValue - ((PieceCenterScores at: oldPiece) at: square).
+ positionalValue := positionalValue + ((PieceCenterScores at: newPiece) at: square).
+
+ oldPiece = Pawn ifTrue:[numPawns := numPawns - 1].
+ newPiece = Pawn ifTrue:[numPawns := numPawns + 1].
+ board updateHash: oldPiece at: square from: self.
+ board updateHash: newPiece at: square from: self.
+ self userAgent ifNotNil:[self userAgent replacedPiece: oldPiece with: newPiece at: square white: self isWhitePlayer].!
Item was added:
+ ----- Method: ChessPlayer>>undoCastleKingSideMove: (in category 'undo') -----
+ undoCastleKingSideMove: move
+ self prepareNextMove. "in other words, remove extra kings"
+ self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
+ self movePiece: Rook from: move sourceSquare+1 to: move sourceSquare+3.!
Item was added:
+ ----- Method: ChessPlayer>>undoCastleQueenSideMove: (in category 'undo') -----
+ undoCastleQueenSideMove: move
+ self prepareNextMove. "in other words, remove extra kings"
+ self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
+ self movePiece: Rook from: move sourceSquare-1 to: move sourceSquare-4.
+ !
Item was added:
+ ----- Method: ChessPlayer>>undoDoublePushMove: (in category 'undo') -----
+ undoDoublePushMove: move
+ enpassantSquare := 0.
+ self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.!
Item was added:
+ ----- Method: ChessPlayer>>undoEnpassantMove: (in category 'undo') -----
+ undoEnpassantMove: move
+ self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
+ opponent addPiece: move capturedPiece at: move destinationSquare -
+ (self isWhitePlayer ifTrue:[8] ifFalse:[-8]).
+ !
Item was added:
+ ----- Method: ChessPlayer>>undoMove: (in category 'undo') -----
+ undoMove: move
+ "Undo the given move"
+ | action |
+ self undoPromotion: move.
+ "Apply basic move"
+ action := #(
+ undoNormalMove:
+ undoDoublePushMove:
+ undoEnpassantMove:
+ undoCastleKingSideMove:
+ undoCastleQueenSideMove:
+ undoResign:
+ undoStaleMate:
+ ) at: (move moveType bitAnd: ChessMove basicMoveMask).
+ self perform: action with: move.!
Item was added:
+ ----- Method: ChessPlayer>>undoNormalMove: (in category 'undo') -----
+ undoNormalMove: move
+ | piece |
+ self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
+ (piece := move capturedPiece) = EmptySquare
+ ifFalse:[opponent addPiece: piece at: move destinationSquare].
+ !
Item was added:
+ ----- Method: ChessPlayer>>undoPromotion: (in category 'undo') -----
+ undoPromotion: move
+ | piece |
+ piece := move promotion.
+ piece = 0 ifFalse:[self replacePiece: piece with: move movingPiece at: move destinationSquare].!
Item was added:
+ ----- Method: ChessPlayer>>undoResign: (in category 'undo') -----
+ undoResign: move!
Item was added:
+ ----- Method: ChessPlayer>>undoStaleMate: (in category 'undo') -----
+ undoStaleMate: move!
Item was added:
+ ----- Method: ChessPlayer>>updateCastlingStatus: (in category 'moving') -----
+ updateCastlingStatus: move
+
+ "Cannot castle when king has moved"
+ (move movingPiece = King)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableAll].
+
+ "See if a rook has moved"
+ (move movingPiece = Rook) ifFalse:[^self].
+
+ self isWhitePlayer ifTrue:[
+ (move sourceSquare = 1)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableQueenSide].
+ (move sourceSquare = 8)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableKingSide].
+ ] ifFalse:[
+ (move sourceSquare = 57)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableQueenSide].
+ (move sourceSquare = 64)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableKingSide].
+ ].!
Item was added:
+ ----- Method: ChessPlayer>>userAgent (in category 'accessing') -----
+ userAgent
+ ^board userAgent!
Item was added:
+ Object subclass: #ChessPlayerAI
+ instanceVariableNames: 'board boardList boardListIndex player historyTable transTable generator random variations activeVariation bestVariation nodesVisited ttHits stamp alphaBetaCuts startTime ply myMove myProcess stopThinking bestMove'
+ classVariableNames: 'AlphaBetaGiveUp AlphaBetaIllegal AlphaBetaMaxVal AlphaBetaMinVal ValueAccurate ValueBoundary ValueLowerBound ValueThreshold ValueUpperBound'
+ poolDictionaries: 'ChessConstants'
+ category: 'MorphicExtras-Games-Chess'!
+
+ !ChessPlayerAI commentStamp: '<historical>' prior: 0!
+ I am the AI that will beat you eventually. Well, maybe not today ... BUT MY TIME WILL COME!!!!!!!
Item was added:
+ ----- Method: ChessPlayerAI class>>initialize (in category 'class initialization') -----
+ initialize
+ "ChessPlayerAI initialize"
+ AlphaBetaGiveUp := -29990.
+ AlphaBetaIllegal := -31000.
+ AlphaBetaMaxVal := 30000.
+ AlphaBetaMinVal := -30000.
+ ValueAccurate := 2.
+ ValueBoundary := 4.
+ ValueLowerBound := 4.
+ ValueUpperBound := 5.
+ ValueThreshold := 200.!
Item was added:
+ ----- Method: ChessPlayerAI>>activePlayer: (in category 'initialize') -----
+ activePlayer: aPlayer
+ player := aPlayer.
+ board := player board.
+ generator := board generator.
+ self reset.!
Item was added:
+ ----- Method: ChessPlayerAI>>copyVariation: (in category 'searching') -----
+ copyVariation: move
+ | av mv count |
+ count := 0.
+ av := variations at: ply + 1.
+ ply < 9
+ ifTrue:
+ [mv := variations at: ply + 2.
+ count := mv first.
+ av
+ replaceFrom: 3
+ to: count + 2
+ with: mv
+ startingAt: 2].
+ av at: 1 put: count + 1.
+ av at: 2 put: move encodedMove!
Item was added:
+ ----- Method: ChessPlayerAI>>initialize (in category 'initialize') -----
+ initialize
+ historyTable := ChessHistoryTable new.
+ "NOTE: transposition table is initialized only when we make the first move. It costs a little to do all the entries and the garbage collections so we do it only when we *really* need it."
+ transTable := nil.
+ random := Random new.
+ nodesVisited := ttHits := alphaBetaCuts := stamp := 0.
+ variations := Array new: 11.
+ 1 to: variations size do:[:i|
+ variations at: i put: (Array new: variations size).
+ (variations at: i) atAllPut: 0].
+ bestVariation := Array new: variations size.
+ bestVariation atAllPut: 0.
+ activeVariation := Array new: variations size.
+ activeVariation atAllPut: 0.
+ self reset.!
Item was added:
+ ----- Method: ChessPlayerAI>>initializeTranspositionTable (in category 'initialize') -----
+ initializeTranspositionTable
+ "Initialize the transposition table. Note: For now we only use 64k entries since they're somewhat space intensive. If we should get a serious speedup at some point we may want to increase the transposition table - 256k seems like a good idea; but right now 256k entries cost us roughly 10MB of space. So we use only 64k entries (2.5MB of space).
+ If you have doubts about the size of the transition table (e.g., if you think it's too small or too big) then modify the value below and have a look at ChessTranspositionTable>>clear which can print out some valuable statistics.
+ "
+ transTable := ChessTranspositionTable new: 16. "1 << 16 entries"!
Item was added:
+ ----- Method: ChessPlayerAI>>isThinking (in category 'thinking') -----
+ isThinking
+ ^myProcess notNil!
Item was added:
+ ----- Method: ChessPlayerAI>>mtdfSearch:score:depth: (in category 'searching') -----
+ mtdfSearch: theBoard score: estimate depth: depth
+ "An implementation of the MTD(f) algorithm. See:
+ http://www.cs.vu.nl/~aske/mtdf.html
+ "
+
+ | beta move value low high goodMove |
+ value := estimate.
+ low := AlphaBetaMinVal.
+ high := AlphaBetaMaxVal.
+ [low >= high] whileFalse:
+ [beta := value = low ifTrue: [value + 1] ifFalse: [beta := value].
+ move := self
+ searchMove: theBoard
+ depth: depth
+ alpha: beta - 1
+ beta: beta.
+ stopThinking ifTrue: [^move].
+ move ifNil: [^move].
+ value := move value.
+ value < beta
+ ifTrue: [high := value]
+ ifFalse:
+ ["NOTE: It is important that we do *NOT* return a move from a search which didn't reach the beta goal (e.g., value < beta). This is because all it means is that we didn't reach beta and the move returned is not the move 'closest' to beta but just one that triggered cut-off. In other words, if we'd take a move which value is less than beta it could mean that this move is a *LOT* worse than beta."
+
+ low := value.
+ goodMove := move.
+ activeVariation
+ replaceFrom: 1
+ to: activeVariation size
+ with: (variations first)
+ startingAt: 1]].
+ ^goodMove!
Item was added:
+ ----- Method: ChessPlayerAI>>negaScout:depth:alpha:beta: (in category 'searching') -----
+ negaScout: theBoard depth: depth alpha: initialAlpha beta: initialBeta
+ "Modified version to return the move rather than the score"
+ | move score alpha bestScore moveList newBoard beta goodMove a b notFirst |
+ self
+ assert: [initialAlpha < initialBeta].
+ ply < 10
+ ifTrue: [(variations at: ply + 1)
+ at: 1
+ put: 0].
+ ply := 0.
+ alpha := initialAlpha.
+ beta := initialBeta.
+ bestScore := AlphaBetaMinVal.
+ "Generate new moves"
+ moveList := generator findPossibleMovesFor: theBoard activePlayer.
+ moveList
+ ifNil: [^ nil].
+ moveList size = 0
+ ifTrue: [generator recycleMoveList: moveList.
+ ^ nil].
+ "Sort move list according to history heuristics"
+ moveList sortUsing: historyTable.
+ "And search"
+ a := alpha.
+ b := beta.
+ notFirst := false.
+ [(move := moveList next) isNil]
+ whileFalse: [newBoard := (boardList at: ply + 1)
+ copyBoard: theBoard.
+ newBoard nextMove: move.
+ "Search recursively"
+ "Search recursively"
+ ply := ply + 1.
+ score := 0
+ - (self
+ ngSearch: newBoard
+ depth: depth - 1
+ alpha: 0 - b
+ beta: 0 - a).
+ (notFirst
+ and: [score > a
+ and: [score < beta
+ and: [depth > 1]]])
+ ifTrue: [score := 0
+ - (self
+ ngSearch: newBoard
+ depth: depth - 1
+ alpha: 0 - beta
+ beta: 0 - score)].
+ notFirst := true.
+ ply := ply - 1.
+ stopThinking
+ ifTrue: [generator recycleMoveList: moveList.
+ ^ move].
+ score = AlphaBetaIllegal
+ ifFalse: [score > bestScore
+ ifTrue: [ply < 10
+ ifTrue: [self copyVariation: move].
+ goodMove := move copy.
+ goodMove value: score.
+ activeVariation
+ replaceFrom: 1
+ to: activeVariation size
+ with: variations first
+ startingAt: 1.
+ bestScore := score].
+ "See if we can cut off the search"
+ score > a
+ ifTrue: [a := score.
+ a >= beta
+ ifTrue: [transTable
+ storeBoard: theBoard
+ value: score
+ type: (ValueBoundary
+ bitOr: (ply bitAnd: 1))
+ depth: depth
+ stamp: stamp.
+ historyTable addMove: move.
+ alphaBetaCuts := alphaBetaCuts + 1.
+ generator recycleMoveList: moveList.
+ ^ goodMove]].
+ b := a + 1]].
+ transTable
+ storeBoard: theBoard
+ value: bestScore
+ type: (ValueAccurate
+ bitOr: (ply bitAnd: 1))
+ depth: depth
+ stamp: stamp.
+ generator recycleMoveList: moveList.
+ ^ goodMove!
Item was added:
+ ----- Method: ChessPlayerAI>>ngSearch:depth:alpha:beta: (in category 'searching') -----
+ ngSearch: theBoard depth: depth alpha: initialAlpha beta: initialBeta
+ "A basic alpha-beta algorithm; based on negaMax rather than from the text books"
+
+ | move score alpha entry bestScore moveList newBoard beta a b notFirst |
+ self assert: [initialAlpha < initialBeta].
+ ply < 10 ifTrue: [(variations at: ply + 1) at: 1 put: 0].
+ depth = 0
+ ifTrue:
+ [^self
+ quiesce: theBoard
+ alpha: initialAlpha
+ beta: initialBeta].
+ nodesVisited := nodesVisited + 1.
+ "See if there's already something in the transposition table. If so, skip the entire search."
+ entry := transTable lookupBoard: theBoard.
+ alpha := initialAlpha.
+ beta := initialBeta.
+ (entry isNil or: [entry depth < depth])
+ ifFalse:
+ [ttHits := ttHits + 1.
+ (entry valueType bitAnd: 1) = (ply bitAnd: 1)
+ ifTrue: [beta := entry value max: initialBeta]
+ ifFalse: [alpha := 0 - entry value max: initialAlpha].
+ beta > initialBeta ifTrue: [^beta].
+ alpha >= initialBeta ifTrue: [^alpha]].
+ bestScore := AlphaBetaMinVal.
+
+ "Generate new moves"
+ moveList := generator findPossibleMovesFor: theBoard activePlayer.
+ moveList ifNil: [^0 - AlphaBetaIllegal].
+ moveList isEmpty
+ ifTrue:
+ [generator recycleMoveList: moveList.
+ ^bestScore].
+
+ "Sort move list according to history heuristics"
+ moveList sortUsing: historyTable.
+
+ "And search"
+ a := alpha.
+ b := beta.
+ notFirst := false.
+ [(move := moveList next) isNil] whileFalse:
+ [newBoard := (boardList at: ply + 1) copyBoard: theBoard.
+ newBoard nextMove: move.
+ "Search recursively"
+ ply := ply + 1.
+ score := 0 - (self
+ ngSearch: newBoard
+ depth: depth - 1
+ alpha: 0 - b
+ beta: 0 - a).
+ (notFirst and: [score > a and: [score < beta and: [depth > 1]]])
+ ifTrue:
+ [score := 0 - (self
+ ngSearch: newBoard
+ depth: depth - 1
+ alpha: 0 - beta
+ beta: 0 - score)].
+ notFirst := true.
+ ply := ply - 1.
+ stopThinking
+ ifTrue:
+ [generator recycleMoveList: moveList.
+ ^score].
+ score = AlphaBetaIllegal
+ ifFalse:
+ [score > bestScore
+ ifTrue:
+ [ply < 10 ifTrue: [self copyVariation: move].
+ bestScore := score].
+ score > a
+ ifTrue:
+ [a := score.
+ a >= beta
+ ifTrue:
+ [transTable
+ storeBoard: theBoard
+ value: score
+ type: (ValueBoundary bitOr: (ply bitAnd: 1))
+ depth: depth
+ stamp: stamp.
+ historyTable addMove: move.
+ alphaBetaCuts := alphaBetaCuts + 1.
+ generator recycleMoveList: moveList.
+ ^score]].
+ b := a + 1]].
+ transTable
+ storeBoard: theBoard
+ value: bestScore
+ type: (ValueAccurate bitOr: (ply bitAnd: 1))
+ depth: depth
+ stamp: stamp.
+ generator recycleMoveList: moveList.
+ ^bestScore!
Item was added:
+ ----- Method: ChessPlayerAI>>quiesce:alpha:beta: (in category 'searching') -----
+ quiesce: theBoard alpha: initialAlpha beta: initialBeta
+ "A variant of alpha-beta considering only captures and null moves to obtain a quiet position, e.g. one that is unlikely to change heavily in the very near future."
+
+ | move score alpha entry bestScore moveList newBoard beta |
+ self assert: [initialAlpha < initialBeta].
+ ply < 10 ifTrue: [(variations at: ply + 1) at: 1 put: 0].
+ nodesVisited := nodesVisited + 1.
+ "See if there's already something in the transposition table."
+ entry := transTable lookupBoard: theBoard.
+ alpha := initialAlpha.
+ beta := initialBeta.
+ entry isNil
+ ifFalse:
+ [ttHits := ttHits + 1.
+ (entry valueType bitAnd: 1) = (ply bitAnd: 1)
+ ifTrue: [beta := entry value max: initialBeta]
+ ifFalse: [alpha := 0 - entry value max: initialAlpha].
+ beta > initialBeta ifTrue: [^beta].
+ alpha >= initialBeta ifTrue: [^alpha]].
+ ply < 2
+ ifTrue:
+ ["Always generate moves if ply < 2 so that we don't miss a move that
+ would bring the king under attack (e.g., make an invalid move)."
+
+ moveList := generator findQuiescenceMovesFor: theBoard activePlayer.
+ moveList ifNil: [^0 - AlphaBetaIllegal]].
+
+ "Evaluate the current position, assuming that we have a non-capturing move."
+ bestScore := theBoard activePlayer evaluate.
+ "TODO: What follows is clearly not the Right Thing to do. The score we just evaluated doesn't take into account that we may be under attack at this point. I've seen it happening various times that the static evaluation triggered a cut-off which was plain wrong in the position at hand.
+ There seem to be three ways to deal with the problem. #1 is just deepen the search. If we go one ply deeper we will most likely find the problem (although that's not entirely certain). #2 is to improve the evaluator function and make it so that the current evaluator is only an estimate saying if it's 'likely' that a non-capturing move will do. The more sophisticated evaluator should then take into account which pieces are under attack. Unfortunately that could make the AI play very passive, e.g., avoiding situations where pieces are under attack even if these attacks are outweighed by other factors. #3 would be to insert a null move here to see *if* we are under attack or not (I've played with this) but for some reason the resulting search seemed to explode rapidly. I'm uncertain if that's due to the transposition table being too small (I don't *really* think so but it may be) or if I've just got something else wrong."
+ bestScore > alpha
+ ifTrue:
+ [alpha := bestScore.
+ bestScore >= beta
+ ifTrue:
+ [moveList ifNotNil: [generator recycleMoveList: moveList].
+ ^bestScore]].
+
+ "Generate new moves"
+ moveList ifNil:
+ [moveList := generator findQuiescenceMovesFor: theBoard activePlayer.
+ moveList ifNil: [^0 - AlphaBetaIllegal]].
+ moveList isEmpty
+ ifTrue:
+ [generator recycleMoveList: moveList.
+ ^bestScore].
+
+ "Sort move list according to history heuristics"
+ moveList sortUsing: historyTable.
+
+ "And search"
+ [(move := moveList next) isNil] whileFalse:
+ [newBoard := (boardList at: ply + 1) copyBoard: theBoard.
+ newBoard nextMove: move.
+ "Search recursively"
+ ply := ply + 1.
+ score := 0 - (self
+ quiesce: newBoard
+ alpha: 0 - beta
+ beta: 0 - alpha).
+ stopThinking
+ ifTrue:
+ [generator recycleMoveList: moveList.
+ ^score].
+ ply := ply - 1.
+ score = AlphaBetaIllegal
+ ifFalse:
+ [score > bestScore
+ ifTrue:
+ [ply < 10 ifTrue: [self copyVariation: move].
+ bestScore := score].
+ "See if we can cut off the search"
+ score > alpha
+ ifTrue:
+ [alpha := score.
+ score >= beta
+ ifTrue:
+ [transTable
+ storeBoard: theBoard
+ value: score
+ type: (ValueBoundary bitOr: (ply bitAnd: 1))
+ depth: 0
+ stamp: stamp.
+ historyTable addMove: move.
+ alphaBetaCuts := alphaBetaCuts + 1.
+ generator recycleMoveList: moveList.
+ ^bestScore]]]].
+ transTable
+ storeBoard: theBoard
+ value: bestScore
+ type: (ValueAccurate bitOr: (ply bitAnd: 1))
+ depth: 0
+ stamp: stamp.
+ generator recycleMoveList: moveList.
+ ^bestScore!
Item was added:
+ ----- Method: ChessPlayerAI>>reset (in category 'initialize') -----
+ reset
+ transTable ifNotNil:[transTable clear].
+ historyTable clear.
+ !
Item was added:
+ ----- Method: ChessPlayerAI>>reset: (in category 'initialize') -----
+ reset: aBoard
+ self reset.
+ boardList ifNil:[
+ boardList := Array new: 100.
+ 1 to: boardList size do:[:i| boardList at: i put: (aBoard copy userAgent: nil)].
+ boardListIndex := 0].
+ board := aBoard.!
Item was added:
+ ----- Method: ChessPlayerAI>>search:depth:alpha:beta: (in category 'searching') -----
+ search: theBoard depth: depth alpha: initialAlpha beta: initialBeta
+ "A basic alpha-beta algorithm; based on negaMax rather than from the text books"
+
+ | move score alpha entry bestScore moveList newBoard beta |
+ self assert: [initialAlpha < initialBeta].
+ ply < 10 ifTrue: [(variations at: ply + 1) at: 1 put: 0].
+ depth = 0
+ ifTrue:
+ [^self
+ quiesce: theBoard
+ alpha: initialAlpha
+ beta: initialBeta].
+ nodesVisited := nodesVisited + 1.
+ "See if there's already something in the transposition table. If so, skip the entire search."
+ entry := transTable lookupBoard: theBoard.
+ alpha := initialAlpha.
+ beta := initialBeta.
+ (entry isNil or: [entry depth < depth])
+ ifFalse:
+ [ttHits := ttHits + 1.
+ (entry valueType bitAnd: 1) = (ply bitAnd: 1)
+ ifTrue: [beta := entry value max: initialBeta]
+ ifFalse: [alpha := 0 - entry value max: initialAlpha].
+ beta > initialBeta ifTrue: [^beta].
+ alpha >= initialBeta ifTrue: [^alpha]].
+ bestScore := AlphaBetaMinVal.
+
+ "Generate new moves"
+ moveList := generator findPossibleMovesFor: theBoard activePlayer.
+ moveList ifNil: [^0 - AlphaBetaIllegal].
+ moveList isEmpty
+ ifTrue:
+ [generator recycleMoveList: moveList.
+ ^bestScore].
+
+ "Sort move list according to history heuristics"
+ moveList sortUsing: historyTable.
+
+ "And search"
+ [(move := moveList next) isNil] whileFalse:
+ [newBoard := (boardList at: ply + 1) copyBoard: theBoard.
+ newBoard nextMove: move.
+ "Search recursively"
+ ply := ply + 1.
+ score := 0 - (self
+ search: newBoard
+ depth: depth - 1
+ alpha: 0 - beta
+ beta: 0 - alpha).
+ stopThinking
+ ifTrue:
+ [generator recycleMoveList: moveList.
+ ^score].
+ ply := ply - 1.
+ score = AlphaBetaIllegal
+ ifFalse:
+ [score > bestScore
+ ifTrue:
+ [ply < 10 ifTrue: [self copyVariation: move].
+ bestScore := score].
+ "See if we can cut off the search"
+ score > alpha
+ ifTrue:
+ [alpha := score.
+ score >= beta
+ ifTrue:
+ [transTable
+ storeBoard: theBoard
+ value: score
+ type: (ValueBoundary bitOr: (ply bitAnd: 1))
+ depth: depth
+ stamp: stamp.
+ historyTable addMove: move.
+ alphaBetaCuts := alphaBetaCuts + 1.
+ generator recycleMoveList: moveList.
+ ^bestScore]]]].
+ transTable
+ storeBoard: theBoard
+ value: bestScore
+ type: (ValueAccurate bitOr: (ply bitAnd: 1))
+ depth: depth
+ stamp: stamp.
+ generator recycleMoveList: moveList.
+ ^bestScore!
Item was added:
+ ----- Method: ChessPlayerAI>>searchMove:depth:alpha:beta: (in category 'searching') -----
+ searchMove: theBoard depth: depth alpha: initialAlpha beta: initialBeta
+ "Modified version to return the move rather than the score"
+
+ | move score alpha bestScore moveList newBoard beta goodMove |
+ self assert: [initialAlpha < initialBeta].
+ ply < 10 ifTrue: [(variations at: ply + 1) at: 1 put: 0].
+ ply := 0.
+ alpha := initialAlpha.
+ beta := initialBeta.
+ bestScore := AlphaBetaMinVal.
+
+ "Generate new moves"
+ moveList := generator findPossibleMovesFor: theBoard activePlayer.
+ moveList ifNil: [^nil].
+ moveList isEmpty
+ ifTrue:
+ [generator recycleMoveList: moveList.
+ ^nil].
+
+ "Sort move list according to history heuristics"
+ moveList sortUsing: historyTable.
+
+ "And search"
+ [(move := moveList next) isNil] whileFalse:
+ [newBoard := (boardList at: ply + 1) copyBoard: theBoard.
+ newBoard nextMove: move.
+ "Search recursively"
+ ply := ply + 1.
+ score := 0 - (self
+ search: newBoard
+ depth: depth - 1
+ alpha: 0 - beta
+ beta: 0 - alpha).
+ stopThinking
+ ifTrue:
+ [generator recycleMoveList: moveList.
+ ^move].
+ ply := ply - 1.
+ score = AlphaBetaIllegal
+ ifFalse:
+ [score > bestScore
+ ifTrue:
+ [ply < 10 ifTrue: [self copyVariation: move].
+ goodMove := move copy.
+ goodMove value: score.
+ bestScore := score].
+ "See if we can cut off the search"
+ score > alpha
+ ifTrue:
+ [alpha := score.
+ score >= beta
+ ifTrue:
+ [transTable
+ storeBoard: theBoard
+ value: score
+ type: (ValueBoundary bitOr: (ply bitAnd: 1))
+ depth: depth
+ stamp: stamp.
+ historyTable addMove: move.
+ alphaBetaCuts := alphaBetaCuts + 1.
+ generator recycleMoveList: moveList.
+ ^goodMove]]]].
+ transTable
+ storeBoard: theBoard
+ value: bestScore
+ type: (ValueAccurate bitOr: (ply bitAnd: 1))
+ depth: depth
+ stamp: stamp.
+ generator recycleMoveList: moveList.
+ ^goodMove!
Item was added:
+ ----- Method: ChessPlayerAI>>startThinking (in category 'thinking') -----
+ startThinking
+ self isThinking ifTrue:[^self].
+ self activePlayer: board activePlayer.
+ self thinkStep.!
Item was added:
+ ----- Method: ChessPlayerAI>>statusString (in category 'accessing') -----
+ statusString
+ | av count |
+ ^String streamContents:[:s|
+ (myMove == #none or:[myMove == nil]) ifFalse:[
+ s print: myMove value / 100.0; space.
+ ].
+ av := bestVariation.
+ count := av at: 1.
+ count > 0 ifFalse:[
+ av := activeVariation.
+ count := av at: 1].
+ count > 0 ifFalse:[
+ s nextPutAll:'***'.
+ av := variations at: 1.
+ count := av at: 1.
+ count > 3 ifTrue:[count := 3]].
+ 2 to: count + 1 do:[:index|
+ s nextPutAll: (ChessMove decodeFrom: (av at: index)) moveString.
+ s space].
+
+ s nextPut:$[.
+ s print: nodesVisited.
+ " s nextPut:$|.
+ s print: ttHits.
+ s nextPut: $|.
+ s print: alphaBetaCuts.
+ " s nextPut:$].
+
+ ].!
Item was added:
+ ----- Method: ChessPlayerAI>>think (in category 'thinking') -----
+ think
+ | move |
+ self isThinking ifTrue: [^nil].
+ self startThinking.
+ [(move := self thinkStep) isNil] whileTrue.
+ ^move!
Item was added:
+ ----- Method: ChessPlayerAI>>thinkProcess (in category 'thinking') -----
+ thinkProcess
+ | score theMove depth |
+ stopThinking := false.
+ score := board activePlayer evaluate.
+ depth := 1.
+ stamp := stamp + 1.
+ ply := 0.
+ historyTable clear.
+ transTable clear.
+ startTime := Time millisecondClockValue.
+ nodesVisited := ttHits := alphaBetaCuts := 0.
+ bestVariation at: 1 put: 0.
+ activeVariation at: 1 put: 0.
+ [nodesVisited < 50000] whileTrue:
+ ["whats this ? (aoy) false ifTrue:[] ????!!"
+
+ theMove := false
+ ifTrue:
+ [self
+ mtdfSearch: board
+ score: score
+ depth: depth]
+ ifFalse:
+ [self
+ negaScout: board
+ depth: depth
+ alpha: AlphaBetaMinVal
+ beta: AlphaBetaMaxVal].
+ theMove ifNil: [^myProcess := nil].
+ stopThinking ifTrue: [^myProcess := nil].
+ myMove := theMove.
+ bestVariation
+ replaceFrom: 1
+ to: bestVariation size
+ with: activeVariation
+ startingAt: 1.
+ score := theMove value.
+ depth := depth + 1].
+ myProcess := nil!
Item was added:
+ ----- Method: ChessPlayerAI>>thinkStep (in category 'thinking') -----
+ thinkStep
+ transTable ifNil: [self initializeTranspositionTable].
+ myProcess isNil
+ ifTrue:
+ [myMove := #none.
+ false
+ ifTrue:
+ [self thinkProcess.
+ ^myMove].
+ myProcess := [self thinkProcess] forkAt: Processor userBackgroundPriority.
+ myProcess suspend.
+ ^nil].
+ myProcess resume.
+ (Delay forMilliseconds: 50) wait.
+ myProcess ifNil: [^myMove == #none ifTrue: [nil] ifFalse: [myMove]].
+ myProcess suspend.
+ "Do we have a valid move?"
+ myMove == #none ifTrue: [^nil]. "no"
+ "Did we time out?"
+ Time millisecondClockValue - startTime > self timeToThink
+ ifTrue:
+ ["Yes. Abort and return current move."
+
+ stopThinking := true.
+ myProcess resume.
+ [myProcess isNil] whileFalse: [(Delay forMilliseconds: 10) wait].
+ ^myMove == #none ifTrue: [nil] ifFalse: [myMove]].
+ "Keep thinking"
+ ^nil!
Item was added:
+ ----- Method: ChessPlayerAI>>timeToThink (in category 'thinking') -----
+ timeToThink
+ "Return the number of milliseconds we're allowed to think"
+ ^5000!
Item was added:
+ Object subclass: #ChessTTEntry
+ instanceVariableNames: 'value valueType depth hashLock timeStamp'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess'!
+
+ !ChessTTEntry commentStamp: '<historical>' prior: 0!
+ This class represents an entry in the transposition table, storing the value (plus some maintenance information) of some position.!
Item was added:
+ ----- Method: ChessTTEntry>>clear (in category 'accessing') -----
+ clear
+ value := valueType := timeStamp := depth := -1.!
Item was added:
+ ----- Method: ChessTTEntry>>depth (in category 'accessing') -----
+ depth
+ ^depth!
Item was added:
+ ----- Method: ChessTTEntry>>depth: (in category 'accessing') -----
+ depth: aNumber
+ depth := aNumber!
Item was added:
+ ----- Method: ChessTTEntry>>hashLock (in category 'accessing') -----
+ hashLock
+ ^hashLock!
Item was added:
+ ----- Method: ChessTTEntry>>hashLock: (in category 'accessing') -----
+ hashLock: aNumber
+ hashLock := aNumber!
Item was added:
+ ----- Method: ChessTTEntry>>timeStamp (in category 'accessing') -----
+ timeStamp
+ ^timeStamp!
Item was added:
+ ----- Method: ChessTTEntry>>timeStamp: (in category 'accessing') -----
+ timeStamp: aNumber
+ timeStamp := aNumber!
Item was added:
+ ----- Method: ChessTTEntry>>value (in category 'accessing') -----
+ value
+ ^value!
Item was added:
+ ----- Method: ChessTTEntry>>value: (in category 'accessing') -----
+ value: newValue
+ value := newValue!
Item was added:
+ ----- Method: ChessTTEntry>>valueType (in category 'accessing') -----
+ valueType
+ ^valueType!
Item was added:
+ ----- Method: ChessTTEntry>>valueType: (in category 'accessing') -----
+ valueType: newType
+ valueType := newType!
Item was added:
+ Object subclass: #ChessTranspositionTable
+ instanceVariableNames: 'array used collisions'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games-Chess'!
+
+ !ChessTranspositionTable commentStamp: '<historical>' prior: 0!
+ The transposition table is a lookup cache for positions in a game that occur through transpositions in move. As an example, the same position is obtained by the moves:
+ 1. e2-e4 Nb8-c6
+ 2. d2-d4
+ and
+ 1. d2-d4 Nb8-c6
+ 2. e2-e4
+ An extremely large number of search branches can be cut off immediately by recognizing that the current position is just the transposition of another one. The transposition table is one of the techniques that actually make modern chess programs good enough to compete with or even beat humans.
+ !
Item was added:
+ ----- Method: ChessTranspositionTable class>>new: (in category 'instance creation') -----
+ new: bits
+ ^self basicNew initialize: bits!
Item was added:
+ ----- Method: ChessTranspositionTable>>clear (in category 'initialize') -----
+ clear
+ "Set the following to true for printing information about the fill rate and number of collisions. The transposition table should have *plenty* of free space (it should rarely exceed 30% fill rate) and *very* few collisions (those require us to evaluate positions repeatedly that we've evaluated before -- bad idea!!)"
+
+ | entry |
+ false
+ ifTrue:
+ [used position > 0
+ ifTrue:
+ ['entries used: ' , used position printString , ' ('
+ , (used position * 100 // array size) printString , '%) '
+ displayAt: 0 @ 0].
+ collisions > 0
+ ifTrue:
+ ['collisions: ' , collisions printString , ' ('
+ , (collisions * 100 // array size) printString , '%) '
+ displayAt: 0 @ 15]].
+ used position: 0.
+ [(entry := used next) isNil] whileFalse: [entry clear].
+ used resetToStart.
+ collisions := 0!
Item was added:
+ ----- Method: ChessTranspositionTable>>initialize: (in category 'initialize') -----
+ initialize: nBits
+ "Initialize the receiver using 1<<nBits entries. See also ChessPlayerAI>>initializeTranspositionTable."
+ | entry |
+ array := Array new: 1 << nBits.
+ used := ReadWriteStream on: (Array new: 50000). "<- will grow if not sufficient!!"
+ entry := ChessTTEntry new clear.
+ 1 to: array size do:[:i| array at: i put: entry shallowCopy].
+ collisions := 0.
+ Smalltalk garbageCollect. "We *really* want them old here"!
Item was added:
+ ----- Method: ChessTranspositionTable>>lookupBoard: (in category 'lookup') -----
+ lookupBoard: aBoard
+ | key entry |
+ key := aBoard hashKey bitAnd: array size - 1.
+ entry := array at: key + 1.
+ entry ifNil:[^nil].
+ entry valueType = -1 ifTrue:[^nil].
+ entry hashLock = aBoard hashLock ifFalse:[^nil].
+ ^entry!
Item was added:
+ ----- Method: ChessTranspositionTable>>storeBoard:value:type:depth:stamp: (in category 'initialize') -----
+ storeBoard: aBoard value: value type: valueType depth: depth stamp: timeStamp
+ | key entry |
+ key := aBoard hashKey bitAnd: array size - 1.
+ entry := array at: key + 1.
+ entry valueType = -1
+ ifTrue:[used nextPut: entry]
+ ifFalse:[entry hashLock = aBoard hashLock ifFalse:[collisions := collisions + 1]].
+ (entry valueType = -1
+ or:[entry depth <= depth
+ or:[entry timeStamp < timeStamp]]) ifFalse:[^self].
+ entry hashLock: aBoard hashLock.
+ entry value: value.
+ entry valueType: valueType.
+ entry depth: depth.
+ entry timeStamp: timeStamp.
+ !
Item was added:
+ EllipseMorph subclass: #ChineseCheckerPiece
+ instanceVariableNames: 'boardLoc myBoard'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !ChineseCheckerPiece commentStamp: '<historical>' prior: 0!
+ I represent a player piece for Chinese Checkers. Mostly I act as an ellipse, but my special methods ensure that I cannot be picked up or dropped except in the proper circumstances.
+
+ Structure:
+ myBoard a ChineseCheckers morph
+ boardLoc my current logical position on the board.
+ !
Item was added:
+ ----- Method: ChineseCheckerPiece class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^ false!
Item was added:
+ ----- Method: ChineseCheckerPiece>>boardLoc (in category 'accessing') -----
+ boardLoc
+
+ ^ boardLoc!
Item was added:
+ ----- Method: ChineseCheckerPiece>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ ^ true!
Item was added:
+ ----- Method: ChineseCheckerPiece>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: newOwner event: evt
+
+ newOwner == myBoard ifFalse:
+ ["Only allow dropping into my board."
+ ^self rejectDropMorphEvent: evt].
+ ^super justDroppedInto: newOwner event: evt!
Item was added:
+ ----- Method: ChineseCheckerPiece>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+
+ ((owner isKindOf: ChineseCheckers)
+ and: [owner okToPickUpPieceAt: boardLoc])
+ ifTrue: [evt hand grabMorph: self]!
Item was added:
+ ----- Method: ChineseCheckerPiece>>setBoard:loc: (in category 'accessing') -----
+ setBoard: aBoard loc: aBoardLoc
+
+ myBoard := aBoard.
+ boardLoc := aBoardLoc!
Item was added:
+ BorderedMorph subclass: #ChineseCheckers
+ instanceVariableNames: 'board sixDeltas teams homes autoPlay whoseMove plannedMove plannedMovePhase colors movePhase animateMoves pathMorphs'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !ChineseCheckers commentStamp: '<historical>' prior: 0!
+ An implementation of Chinese Checkers by Dan Ingalls. April 9, 2000.
+
+ board: A 19x19 rhombic array, addressed by row@col points, in which is imbedded the familiar six-pointed layout of cells. A cell outside the board is nil (-).
+ - - - - - - - - - - - - - - - - - - -
+ - - - - - - - - - - - - - 5 - - - - -
+ - - - - - - - - - - - - 5 5 - - - - -
+ - - - - - - - - - - - 5 5 5 - - - - -
+ - - - - - - - - - - 5 5 5 5 - - - - -
+ - - - - - 6 6 6 6 0 0 0 0 0 4 4 4 4 -
+ - - - - - 6 6 6 0 0 0 0 0 0 4 4 4 - -
+ - - - - - 6 6 0 0 0 0 0 0 0 4 4 - - -
+ - - - - - 6 0 0 0 0 0 0 0 0 4 - - - -
+ - - - - - 0 0 0 0 0 0 0 0 0 - - - - -
+ - - - - 1 0 0 0 0 0 0 0 0 3 - - - - -
+ - - - 1 1 0 0 0 0 0 0 0 3 3 - - - - -
+ - - 1 1 1 0 0 0 0 0 0 3 3 3 - - - - -
+ - 1 1 1 1 0 0 0 0 0 3 3 3 3 - - - - -
+ - - - - - 2 2 2 2 - - - - - - - - - -
+ - - - - - 2 2 2 - - - - - - - - - - -
+ - - - - - 2 2 - - - - - - - - - - - -
+ - - - - - 2 - - - - - - - - - - - - -
+ - - - - - - - - - - - - - - - - - - -
+ Cells within the board contain 0 if empty, or a team number (1..6) if occupied by a piece of that team. An extra border of nils around the whole reduces bounds checking to a nil test.
+
+ sixDeltas: An array giving the x@y deltas for the 6 valid steps in CCW order from a given cell. For team 1 they are: in fr, fl, l, bl, br, r. To get, eg fl for a given team, use (sixDeltas atWrap: team+1).
+
+ teams: An array of six teams, each of which is an array of the x@y locations of the 10 pieces.
+
+ homes: The x@y coordinates of the six home points, namely 14@2, 18@6, 14@14, 6@18, 2@14, 6@6. The goal, or farthest point in destination triangle, is thus (homes atWrap: teamNo+3).
+
+ autoPlay: An array of booleans, parallel to teams, where true means that Squeak will make the moves for the corresponding team.
+
+ whoseMove: A team number specifying whose turn it is next. Set to 0 when game is over.
+
+ plannedMove: If not nil, it means the board is in a state where it is animating the next move to be made so that it can be seen.
+
+ movePhase: Holds the state of display of the planned move so that, eg, it can appear one jump at a time. Advances from 1 to (plannedMove size * 2).
+
+ A move is an array of locs which are the path of the move.
+
+ Once the morph is open, the menu command 'reset...' allows you to reset the board and change the number of players. The circle at turnIndicatorLoc indicates the color of the team whose turn it is. If it is a human, play waits for drag and drop of a piece of that color.
+
+ The current strategy is very simple: generate all moves, score them and pick the best. Beyond this, it will look ahead a number of moves, but this becomes very expensive without pruning. Pruning would help the speed of play, especially in the end game where we look a little deeper. A more effective strategy would consider opponents' possible moves as well, but this is left as an exercise for the serious programmer.!
Item was added:
+ ----- Method: ChineseCheckers class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'ChineseCheckers' translatedNoop
+ categories: {'Games' translatedNoop}
+ documentation: 'Halma - the classic board game of Chinese Checkers, written by Dan Ingalls' translatedNoop!
Item was added:
+ ----- Method: ChineseCheckers>>acceptDroppingMorph:event: (in category 'layout') -----
+ acceptDroppingMorph: aPiece event: evt
+
+ | dropLoc |
+ dropLoc := self boardLocAt: evt cursorPoint.
+ dropLoc = aPiece boardLoc ifTrue: "Null move"
+ [^ aPiece rejectDropMorphEvent: evt].
+ (plannedMove := (self allMovesFrom: aPiece boardLoc)
+ detect: [:move | move last = dropLoc]
+ ifNone: [nil])
+ ifNil: [^ aPiece rejectDropMorphEvent: evt. "Not a valid move"].
+
+ super acceptDroppingMorph: aPiece event: evt.
+ movePhase := 1. "Start the animation if any."
+ !
Item was added:
+ ----- Method: ChineseCheckers>>addCustomMenuItems:hand: (in category 'menus') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ "Include our modest command set in the ctrl-menu"
+
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu addLine.
+ self addMenuItemsTo: aCustomMenu hand: aHandMorph!
Item was added:
+ ----- Method: ChineseCheckers>>addMenuItemsTo:hand: (in category 'menu') -----
+ addMenuItemsTo: aMenu hand: aHandMorph
+
+ aMenu add: 'new game' translated target: self action: #newGame.
+ aMenu add: 'reset...' translated target: self action: #reset.
+ animateMoves
+ ifTrue: [aMenu add: 'don''t animate moves' translated target: self action: #dontAnimateMoves]
+ ifFalse: [aMenu add: 'animate moves' translated target: self action: #animateMoves]
+
+ !
Item was added:
+ ----- Method: ChineseCheckers>>allMovesFrom: (in category 'moves') -----
+ allMovesFrom: boardLoc "boardLoc must be occupied"
+ | team stepMoves jumpDict |
+ team := self at: boardLoc.
+ stepMoves := (sixDeltas collect: [:d | boardLoc + d])
+ select: [:p | (self at: p) notNil and: [(self at: p) = 0]].
+ jumpDict := Dictionary new.
+ jumpDict at: boardLoc put: (Array with: boardLoc).
+ self jumpFor: team from: boardLoc havingVisited: jumpDict.
+ jumpDict removeKey: boardLoc.
+ ^ (stepMoves collect: [:p | {boardLoc. p}]) , jumpDict values
+ reject:
+ [:move | "Don't include any moves that land in other homes."
+ (self distFrom: move last to: self boardCenter) >= 5 "In a home..."
+ and: [(self distFrom: move last to: (homes atWrap: team+3)) > 3 "...not my goal..."
+ and: [(self distFrom: move last to: (homes at: team)) > 3 "...nor my home"]]]!
Item was added:
+ ----- Method: ChineseCheckers>>animateMoves (in category 'menu') -----
+ animateMoves
+
+ animateMoves := true!
Item was added:
+ ----- Method: ChineseCheckers>>at: (in category 'accessing') -----
+ at: p
+ ^ (board at: p x) at: p y!
Item was added:
+ ----- Method: ChineseCheckers>>at:put: (in category 'accessing') -----
+ at: p put: x
+ ^ (board at: p x) at: p y put: x!
Item was added:
+ ----- Method: ChineseCheckers>>bestMove:forTeam: (in category 'moves') -----
+ bestMove: ply forTeam: team
+ | score bestScore bestMove |
+ bestScore := -999.
+ (teams at: team) do:
+ [:boardLoc |
+ (self allMovesFrom: boardLoc) do:
+ [:move |
+ score := self score: move for: team.
+ (score > -99 and: [ply > 0]) ifTrue:
+ [score := score "Add 0.7 * score of next move (my guess)"
+ + (0 max: ((self score: ((self copyBoard makeMove: move)
+ bestMove: ply - 1 forTeam: team) for: team) * 0.7))].
+ score > bestScore ifTrue:
+ [bestScore := score. bestMove := move]]].
+ ^ bestMove!
Item was added:
+ ----- Method: ChineseCheckers>>board:teams: (in category 'initialization') -----
+ board: b teams: t
+ board := b.
+ teams := t!
Item was added:
+ ----- Method: ChineseCheckers>>boardCenter (in category 'board geometry') -----
+ boardCenter
+ ^ 10@10!
Item was added:
+ ----- Method: ChineseCheckers>>boardLocAt: (in category 'board geometry') -----
+ boardLocAt: cellPoint
+
+ | dx dy row col |
+ dx := self width/15.0. dy := dx * 0.8660254037844385 "(Float pi / 3) sin".
+ row := (cellPoint y - self position y) // dy + 1.
+ col := (cellPoint x - self position x) / (dx/2.0) + 16 - row // 2.
+ ^ row @ col!
Item was added:
+ ----- Method: ChineseCheckers>>cellPointAt: (in category 'board geometry') -----
+ cellPointAt: boardLoc
+ | dx dy row col |
+ dx := self width/15.0. dy := dx * 0.8660254037844385 "(Float pi / 3) sin".
+ row := boardLoc x.
+ col := boardLoc y.
+ ^ self position + ((col*2+row-16*dx//2)@(row-1*dy)) asIntegerPoint!
Item was added:
+ ----- Method: ChineseCheckers>>checkDoneAfter: (in category 'moves') -----
+ checkDoneAfter: move
+
+ | team locsAfterMove |
+ (team := self at: move first) = 0 ifTrue: [^ false].
+ (locsAfterMove := (teams at: team) copy) replaceAll: move first with: move last.
+ ^ self testDone: locsAfterMove for: team!
Item was added:
+ ----- Method: ChineseCheckers>>copyBoard (in category 'initialization') -----
+ copyBoard
+ "Return a copy of the board for the purpose of looking ahead one or more moves."
+
+ ^ self copy
+ board: (board collect: [:row | row copy])
+ teams: (teams collect: [:team | team copy])!
Item was added:
+ ----- Method: ChineseCheckers>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color
+ r: 0.6
+ g: 0.4
+ b: 0.0!
Item was added:
+ ----- Method: ChineseCheckers>>distFrom:to: (in category 'board geometry') -----
+ distFrom: a to: b
+ "The six possible moves are: 1@0, 1@ -1, 0@1, 0@ -1, -1@0, -1@1."
+ | dx dy |
+ dx := b x - a x.
+ dy := b y - a y.
+ dx abs >= dy abs
+ ifTrue: ["Major change is in x-coord..."
+ dx >= 0
+ ifTrue: [(dy between: (0-dx) and: 0)
+ ifTrue: [^ dx "no lateral motion"].
+ ^ dx + ((0-dx) - dy max: dy - 0) "added lateral dist"]
+ ifFalse: ["Reverse sign and rerun same code"
+ ^ self distFrom: b to: a]]
+ ifFalse: ["Transpose and re-run same code"
+ ^ self distFrom: a transposed to: b transposed]!
Item was added:
+ ----- Method: ChineseCheckers>>dontAnimateMoves (in category 'menu') -----
+ dontAnimateMoves
+
+ animateMoves := false!
Item was added:
+ ----- Method: ChineseCheckers>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ | row1 row2 offset dotExtent |
+ super drawOn: aCanvas. "Draw square board"
+
+ "Only draw rows in the clipping region"
+ dotExtent := (self width//25) asPoint.
+ offset := self pieceSize - dotExtent + 1 // 2. "Offset of smaller dots rel to larger"
+ row1 := (self boardLocAt: aCanvas clipRect topLeft) x max: 1.
+ row2 := (self boardLocAt: aCanvas clipRect bottomRight) x min: board size.
+ row1 to: row2 do:
+ [:row | (board at: row) withIndexDo:
+ [:cell :i | cell ifNotNil:
+ [aCanvas fillOval: ((self cellPointAt: (row@i)) + offset extent: dotExtent)
+ color: (colors at: cell+1)]]]!
Item was added:
+ ----- Method: ChineseCheckers>>endGameFor: (in category 'moves') -----
+ endGameFor: team
+ "Return true if we are in the end game (all players within 1 of home triangle)."
+
+ | goalLoc |
+ goalLoc := homes atWrap: team+3. "Farthest cell across the board"
+ (teams at: team)
+ do: [:boardLoc | (self distFrom: boardLoc to: goalLoc) > 4 ifTrue: [^ false]].
+ ^ true!
Item was added:
+ ----- Method: ChineseCheckers>>extent: (in category 'geometry') -----
+ extent: newExtent
+
+ | extraY |
+ extraY := (newExtent x / 15.0 * 1.25) asInteger.
+ super extent: (newExtent x) @ (newExtent x + extraY).
+ self submorphsDo:
+ [:m | (m isKindOf: ChineseCheckerPiece) ifTrue:
+ [m position: (self cellPointAt: m boardLoc); extent: self pieceSize]]!
Item was added:
+ ----- Method: ChineseCheckers>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ "Prevent stray clicks from picking up the whole game in MVC."
+
+ ^ Smalltalk isMorphic not or: [evt yellowButtonPressed]!
Item was added:
+ ----- Method: ChineseCheckers>>initialize (in category 'initialization') -----
+ initialize
+ "Default creation is for one person against Squeak."
+ super initialize.
+ ""
+ self extent: 382 @ 413.
+
+ animateMoves := true.
+ self teams: #(2 5 ) autoPlay: {false. true}!
Item was added:
+ ----- Method: ChineseCheckers>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ "Default creation is for one person against Squeak."
+
+ super initializeToStandAlone.
+ self extent: 382@413.
+ self color: (Color r: 0.6 g: 0.4 b: 0.0).
+ self borderWidth: 2.
+ animateMoves := true.
+ self teams: #(2 5) autoPlay: {false. true}.
+ !
Item was added:
+ ----- Method: ChineseCheckers>>jumpFor:from:havingVisited: (in category 'moves') -----
+ jumpFor: team from: loc havingVisited: dict
+ "Recursively explore all jumps from loc, leaving in dict
+ the prior position from which we got there"
+
+ "Fasten seatbelts..."
+ ((((sixDeltas
+ collect: [:d | loc + d])
+ select: [:p | (self at: p) notNil and: [(self at: p) > 0]])
+ collect: [:p | p + (p - loc)])
+ select: [:p | (self at: p) notNil and: [(self at: p) = 0]])
+ do: [:p | (dict includesKey: p) ifFalse:
+ [dict at: p put: ((dict at: loc) copyWith: p).
+ self jumpFor: team from: p havingVisited: dict]]!
Item was added:
+ ----- Method: ChineseCheckers>>makeMove: (in category 'moves') -----
+ makeMove: move
+ | team |
+ team := self at: move first.
+ self at: move last put: team.
+ self at: move first put: 0.
+ (teams at: team) replaceAll: move first with: move last!
Item was added:
+ ----- Method: ChineseCheckers>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+
+ | menu |
+ evt yellowButtonPressed ifFalse: [^ self].
+ menu := MenuMorph new defaultTarget: self.
+ self addMenuItemsTo: menu hand: evt hand.
+ menu popUpEvent: evt in: self world.
+ !
Item was added:
+ ----- Method: ChineseCheckers>>newGame (in category 'menu') -----
+ newGame
+ "Reset the board, with same teams."
+
+ | teamNumbers |
+ teamNumbers := (1 to: 6) reject: [:i | (teams at: i) isEmpty].
+ self teams: teamNumbers
+ autoPlay: (teamNumbers collect: [:i | autoPlay at: i]).
+ !
Item was added:
+ ----- Method: ChineseCheckers>>nextTurn (in category 'game sequence') -----
+ nextTurn
+
+ (self testDone: (teams at: whoseMove) for: whoseMove) ifTrue:
+ [(self pieceAt: self turnIndicatorLoc) extent: self width asPoint//6; borderWidth: 2.
+ ^ whoseMove := 0. "Game over."].
+
+ [whoseMove := whoseMove\\6 + 1.
+ (teams at: whoseMove) isEmpty] "Turn passes to the next player"
+ whileTrue: [].
+ (self pieceAt: self turnIndicatorLoc) color: (colors at: whoseMove+1)!
Item was added:
+ ----- Method: ChineseCheckers>>okToPickUpPieceAt: (in category 'drag and drop') -----
+ okToPickUpPieceAt: boardLoc
+
+ ^ (self at: boardLoc) = whoseMove and: [(autoPlay at: whoseMove) not]!
Item was added:
+ ----- Method: ChineseCheckers>>pieceAt: (in category 'drag and drop') -----
+ pieceAt: boardLoc
+
+ self submorphsDo:
+ [:m | ((m isMemberOf: ChineseCheckerPiece) and: [m boardLoc = boardLoc])
+ ifTrue: [^ m]].
+ ^ nil!
Item was added:
+ ----- Method: ChineseCheckers>>pieceSize (in category 'board geometry') -----
+ pieceSize
+
+ ^ self width asPoint // 20!
Item was added:
+ ----- Method: ChineseCheckers>>printOn: (in category 'printing') -----
+ printOn: s
+ "For testing only"
+
+ 1 to: board size
+ do:
+ [:row |
+ s
+ cr;
+ next: row put: $ .
+ (board at: row) do:
+ [:cell |
+ s
+ space;
+ nextPut: (cell isNil ifTrue: [$-] ifFalse: [cell printString last])]]!
Item was added:
+ ----- Method: ChineseCheckers>>reset (in category 'menu') -----
+ reset
+ "Reset the board, choosing anew how many teams."
+
+ | nPlayers nHumans |
+ nPlayers := (SelectionMenu
+ selections: (1 to: 6))
+ startUpWithCaption: 'How many players?' translated.
+ nPlayers ifNil: [nPlayers := 2].
+ nHumans := (SelectionMenu
+ selections: (0 to: nPlayers))
+ startUpWithCaption: 'How many humans?' translated.
+ nHumans ifNil: [nHumans := 1].
+ self teams: (#((1) (2 5) (2 4 6) (1 2 4 5) (1 2 3 4 6) (1 2 3 4 5 6)) at: nPlayers)
+ autoPlay: ((1 to: nPlayers) collect: [:i | i > nHumans]).
+ !
Item was added:
+ ----- Method: ChineseCheckers>>score:for: (in category 'moves') -----
+ score: move for: team
+ "Return the decrease in distance toward this team's goal"
+
+ | goal closerToGoal wasBack nowBack |
+ goal := homes atWrap: team+3.
+ wasBack := self distFrom: move first to: goal.
+ nowBack := self distFrom: move last to: goal.
+ closerToGoal := wasBack - nowBack.
+ closerToGoal < -1 ifTrue: [^ -99]. "Quick rejection if move backward more than 1"
+ (nowBack <= 3 and: [self checkDoneAfter: move]) ifTrue: [^ 999].
+ "Reward closerToGoal, but add bias to move those left far behind."
+ ^ (closerToGoal*5) + wasBack!
Item was added:
+ ----- Method: ChineseCheckers>>showNextMoveSegment (in category 'game sequence') -----
+ showNextMoveSegment
+ "Display the current move in progress. Starts with movePhase = 1.
+ Increments movePhase at each tick. Ends by setting movePhase to 0."
+
+ | dot p1 p2 delta secondPhase line |
+ delta := self width//40.
+ movePhase <= plannedMove size
+ ifTrue:
+ ["First we trace the move with dots and lines..."
+ movePhase = 1 ifTrue: [pathMorphs := OrderedCollection new].
+ p1 := self cellPointAt: (plannedMove at: movePhase).
+ dot := (ImageMorph new image: (Form dotOfSize: 7)) position: p1 + delta - (7//2).
+ self addMorph: dot. pathMorphs addLast: dot.
+ movePhase > 1 ifTrue:
+ [p2 := self cellPointAt: (plannedMove at: movePhase-1).
+ line := PolygonMorph vertices: {p2 + delta. p1 + delta} color: Color black
+ borderWidth: 3 borderColor: Color black.
+ self addMorph: line. pathMorphs addLast: line]]
+ ifFalse:
+ ["...then we erase the path while moving the piece."
+ secondPhase := movePhase - plannedMove size.
+ pathMorphs removeFirst delete.
+ secondPhase > 1 ifTrue:
+ [pathMorphs removeFirst delete.
+ self makeMove: {plannedMove at: secondPhase - 1. plannedMove at: secondPhase}.
+ (self pieceAt: (plannedMove at: secondPhase - 1))
+ position: (self cellPointAt: (plannedMove at: secondPhase));
+ setBoard: self loc: (plannedMove at: secondPhase).
+ self changed]].
+
+ (movePhase := movePhase + 1) > (plannedMove size * 2)
+ ifTrue: [movePhase := 0 "End of animated move"].
+
+ !
Item was added:
+ ----- Method: ChineseCheckers>>step (in category 'game sequence') -----
+ step
+ whoseMove = 0 ifTrue: [^self]. "Game over."
+ plannedMove isNil
+ ifTrue:
+ [(autoPlay at: whoseMove) ifFalse: [^self]. "Waiting for a human."
+ plannedMove := (self endGameFor: whoseMove)
+ ifTrue:
+ ["Look deeper at the end."
+
+ self bestMove: 2 forTeam: whoseMove]
+ ifFalse: [self bestMove: 1 forTeam: whoseMove].
+ movePhase := 1 "Start the animated move"].
+ animateMoves
+ ifTrue:
+ ["Display the move in phases..."
+
+ movePhase > 0 ifTrue: [^self showNextMoveSegment]]
+ ifFalse:
+ ["... or skip the entire animated move if requested."
+
+ self makeMove: plannedMove.
+ (self pieceAt: plannedMove first)
+ position: (self cellPointAt: plannedMove last);
+ setBoard: self loc: plannedMove last.
+ self changed.
+ movePhase := 0].
+ plannedMove := nil. "End the animated move"
+ self nextTurn!
Item was added:
+ ----- Method: ChineseCheckers>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^ 200!
Item was added:
+ ----- Method: ChineseCheckers>>teams:autoPlay: (in category 'initialization') -----
+ teams: teamsPlaying autoPlay: ifAuto
+ "Initialize board, teams, steps, jumps"
+ | p q teamInPlay |
+ colors := (#(gray) , #(red green blue cyan magenta yellow white) shuffled)
+ collect: [:c | Color perform: c]. "New set of colors each time."
+ self removeAllMorphs. "eg, from previous game."
+ board := (1 to: 19) collect: [:i | Array new: 19].
+ sixDeltas := {0@1. -1@1. -1@0. 0@ -1. 1@ -1. 1@0}.
+ homes := {14@2. 18@6. 14@14. 6@18. 2@14. 6@6}.
+ teams := (1 to: 6) collect: [:i | OrderedCollection new].
+ autoPlay := (1 to: 6) collect: [:i | false].
+ 1 to: 6 do:
+ [:team | p:= homes at: team.
+ (teamInPlay := teamsPlaying includes: team) ifTrue:
+ [autoPlay at: team put: (ifAuto at: (teamsPlaying indexOf: team))].
+ "Place empty cells in rhombus extending out from each
+ home, and occupied cells in active home triangles."
+ 1 to: 5 do: [:i | q := p.
+ 1 to: 5 do: [:j |
+ (teamInPlay and: [j <= (5 - i)])
+ ifTrue: [self at: q put: team.
+ (teams at: team) add: q.
+ self addMorph:
+ ((ChineseCheckerPiece
+ newBounds: ((self cellPointAt: q) extent: self pieceSize)
+ color: (colors at: team+1))
+ setBoard: self loc: q)]
+ ifFalse: [self at: q put: 0].
+ q := q + (sixDeltas at: team). "right,forward"].
+ p := p + (sixDeltas atWrap: team+1). "left,forward"].
+ teams at: team put: (teams at: team) asArray].
+ whoseMove := teamsPlaying first.
+ self addMorph:
+ ((ChineseCheckerPiece
+ newBounds: ((self cellPointAt: self turnIndicatorLoc) extent: self pieceSize)
+ color: (colors at: whoseMove+1))
+ setBoard: self loc: self turnIndicatorLoc).
+ plannedMove := nil.
+ self changed!
Item was added:
+ ----- Method: ChineseCheckers>>testDone:for: (in category 'moves') -----
+ testDone: teamLocs for: team
+ "Return true if we are done (all players in home triangle)."
+
+ | goalLoc |
+ goalLoc := homes atWrap: team+3.
+ teamLocs
+ do: [:boardLoc | (self distFrom: boardLoc to: goalLoc) > 3 ifTrue: [^ false]].
+ ^ true!
Item was added:
+ ----- Method: ChineseCheckers>>turnIndicatorLoc (in category 'board geometry') -----
+ turnIndicatorLoc
+
+ ^ 16@11!
Item was added:
+ ----- Method: ChineseCheckers>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
+ wantsDroppedMorph: aPiece event: evt
+
+ ^ aPiece isKindOf: ChineseCheckerPiece
+ !
Item was added:
+ WordGamePanelMorph subclass: #CipherPanel
+ instanceVariableNames: 'originalText quote originalMorphs decodingMorphs'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !CipherPanel commentStamp: '<historical>' prior: 0!
+ The CipherPanel, as its name suggests, is a tool for decoding simple substitution codes, such as are presented on the puzzle pages of many Sunday newspapers. Most of the capability is inherited from the two WordGame classes used. To try it out, choose newMorph/Games/CipherPanel in a morphic project, or execute, in any project:
+
+ CipherPanel new openInWorld
+ !
Item was added:
+ ----- Method: CipherPanel class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Cipher' translatedNoop
+ categories: {'Games' translatedNoop}
+ documentation: 'The Cipher Panel: A playground for cryptograms, by Dan Ingalls' translatedNoop!
Item was added:
+ ----- Method: CipherPanel class>>encode: (in category 'as yet unclassified') -----
+ encode: aString
+ "CipherPanel encode: 'Now is the time for all good men to come to the aid of their country.'"
+
+ | dict repeat |
+ dict := Dictionary new.
+ repeat := true.
+ [repeat] whileTrue:
+ [repeat := false.
+ ($A to: $Z) with: ($A to: $Z) shuffled do:
+ [:a :b | a = b ifTrue: [repeat := true].
+ dict at: a put: b]].
+ ^ aString asUppercase collect: [:a | dict at: a ifAbsent: [a]]!
Item was added:
+ ----- Method: CipherPanel class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^ true!
Item was added:
+ ----- Method: CipherPanel class>>new (in category 'instance creation') -----
+ new
+ "NOTE: Use newFromQuote: rather than new to create new CipherPanels"
+
+ ^ self newFromQuote: self sampleString
+
+ " Here are some other examples...
+ World addMorph: (CipherPanel newFromQuote: 'BPFFXY LZY PK ROY RPBY PG XPAY HOYG EJCM SXJROYK FJG''R APR QCR PR''K EJC HOJ GYYF ROY LXRYMLRPJGK. KJCMSY CGNGJHG')
+
+ World addMorph: (CipherPanel newFromQuote: 'Y FRV TRK HJRH QVL QS HJL BPLRHLTH WZLRTXPLT YV ZYSL YT OQYVB MJRH WLQWZL TRK KQX FRVVQH OQ.')
+
+ World addMorph: (CipherPanel newFromQuote: 'XI''H SAZRG: SDCIZCIZT EZDEAZ TD CDI SGZRIZ EGDPGZHH.')
+
+ World addMorph: (CipherPanel newFromQuote: 'PY MOJ WPMMWJ MZGYR ZL MOJ GZSWH PM''R YZ RZZYJS HZYJ MOBY RBPH.')
+
+ World addMorph: (CipherPanel newFromQuote: 'PYSLHYA DJP VBHHLXYAA BPY BGNBMA PLUVQ LX AQMGY; QVY HPLXSLHBG LXUPYCLYXQA BPY NBPK BXC DPLYXCGM AKLGYA.')
+
+ World addMorph: (CipherPanel newFromQuote: 'U HWVS RJ AHOST RLO FOOQOST TJUSM AJIO LOVNC WUXRUSM VST HWVCUSM LVSTZVWW. -- TVNUT WORROEIVS VXROE LUA KGUSRGHWO-ZCHVAA LOVER JHOEVRUJS')
+ "!
Item was added:
+ ----- Method: CipherPanel class>>newFromQuote: (in category 'as yet unclassified') -----
+ newFromQuote: encodedString
+ "Use this to creat new panels instead of new."
+
+ ^ super new encodedQuote: encodedString!
Item was added:
+ ----- Method: CipherPanel class>>randomComment (in category 'as yet unclassified') -----
+ randomComment
+ "CipherPanel randomComment"
+ "Generate cryptic puzzles from method comments in the system"
+ | c s |
+ s := 'none'.
+ [s = 'none']
+ whileTrue: [s := ((c := SystemNavigation new allClasses atRandom) selectors
+ collect: [:sel | (c firstCommentAt: sel) asString])
+ detect: [:str | str size between: 100 and: 200]
+ ifNone: ['none' translated]].
+ ^ s!
Item was added:
+ ----- Method: CipherPanel class>>sampleString (in category 'as yet unclassified') -----
+ sampleString
+ ^
+ 'E SGJC OSCVC LICGNV, ENGRCV, JEVEMAV. E SGJC OSEV QGVVEMA XMI [SMWWDHMML] ... EO''V HMALCIXKW OM SGJC VMNCOSEAR OSGO EAVQEICV GAL LIEJCV DMK. -- ZGIZIG VOICEVGAL'!
Item was added:
+ ----- Method: CipherPanel class>>tedsHack (in category 'as yet unclassified') -----
+ tedsHack
+ "Generate cryptic puzzles from method comments in the system"
+ (self newFromQuote: (self encode: (self randomComment))) openInWorld
+
+ "CipherPanel tedsHack"!
Item was added:
+ ----- Method: CipherPanel>>addMenuItemsTo:hand: (in category 'menu') -----
+ addMenuItemsTo: aMenu hand: aHandMorph
+ aMenu
+ add: 'show cipher help' translated
+ target: self
+ action: #showHelpWindow.
+ aMenu
+ add: 'show cipher hints' translated
+ target: self
+ action: #showHintsWindow.
+ aMenu
+ add: 'clear cipher typing' translated
+ target: self
+ action: #clearTyping.
+ aMenu
+ add: 'enter a new cipher' translated
+ target: self
+ action: #enterANewCipher.
+ aMenu
+ add: 'quote from Squeak' translated
+ target: self
+ action: #squeakCipher!
Item was added:
+ ----- Method: CipherPanel>>buttonRow (in category 'menu') -----
+ buttonRow
+ | row aButton |
+ row := AlignmentMorph newRow color: self color;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap.
+ #('show help' 'show hints' 'clear typing' 'enter a new cipher' 'quote from Squeak' ) translatedNoop
+ with: #(#showHelpWindow #showHintsWindow #clearTyping #enterANewCipher #squeakCipher )
+ do: [:label :selector |
+ aButton := SimpleButtonMorph new target: self.
+ aButton color: Color transparent;
+ borderWidth: 1 px;
+ borderColor: Color black.
+ aButton actionSelector: selector.
+ aButton label: label translated.
+ row addMorphBack: aButton.
+ row addTransparentSpacerOfSize: 3 px @ 0].
+ ^ row!
Item was added:
+ ----- Method: CipherPanel>>cipherStats (in category 'menu') -----
+ cipherStats
+
+ | letterCounts digraphs d digraphCounts |
+ letterCounts := (quote copyWithout: Character space) asBag sortedCounts.
+ digraphs := Bag new.
+ quote withIndexDo:
+ [:c :i |
+ i < quote size ifTrue:
+ [d := quote at: i+1.
+ (c ~= Character space and: [d ~= Character space]) ifTrue:
+ [digraphs add: (String with: c with: d)]]].
+ digraphCounts := digraphs sortedCounts.
+ ^ String streamContents:
+ [:strm |
+ 1 to: 10 do:
+ [:i |
+ strm cr; tab; nextPut: (letterCounts at: i) value.
+ strm tab; print: (letterCounts at: i) key.
+ (digraphCounts at: i) key > 1 ifTrue:
+ [strm tab; tab; tab; nextPutAll: (digraphCounts at: i) value.
+ strm tab; print: (digraphCounts at: i) key]]]!
Item was added:
+ ----- Method: CipherPanel>>clearTyping (in category 'defaults') -----
+ clearTyping
+ self isClean
+ ifTrue: [^ self].
+ (self confirm: 'Are you sure you want to discard all typing?' translated)
+ ifFalse: [^ self].
+ super clearTyping!
Item was added:
+ ----- Method: CipherPanel>>encodedQuote: (in category 'initialization') -----
+ encodedQuote: aString
+ "World addMorph: CipherPanel new"
+ | morph prev |
+ aString isEmpty
+ ifTrue: [^ self].
+ (letterMorphs isNil
+ or: [self isClean])
+ ifFalse: [(self confirm: 'Are you sure you want to discard all typing?' translated)
+ ifFalse: [^ self]].
+ haveTypedHere := false.
+ quote := aString asUppercase.
+ prev := nil.
+ originalMorphs := quote asArray
+ withIndexCollect: [:c :i | WordGameLetterMorph new plain indexInQuote: i id1: nil;
+
+ setLetter: (quote at: i)].
+ letterMorphs := OrderedCollection new.
+ decodingMorphs := quote asArray
+ withIndexCollect: [:c :i | (quote at: i) isLetter
+ ifTrue: [morph := WordGameLetterMorph new underlined indexInQuote: i id1: nil.
+ morph
+ on: #mouseDown
+ send: #mouseDownEvent:letterMorph:
+ to: self.
+ morph
+ on: #keyStroke
+ send: #keyStrokeEvent:letterMorph:
+ to: self.
+ letterMorphs addLast: morph.
+ morph predecessor: prev.
+ prev
+ ifNotNil: [prev successor: morph].
+ prev := morph]
+ ifFalse: [WordGameLetterMorph new plain indexInQuote: i id1: nil;
+
+ setLetter: (quote at: i)]].
+ self color: originalMorphs first color.
+ self extent: 500 px @ 500 px.!
Item was added:
+ ----- Method: CipherPanel>>enterANewCipher (in category 'menu') -----
+ enterANewCipher
+ self clearTyping;
+ encodedQuote: (FillInTheBlank request: 'Type a cipher text to work on here below...' translated)!
Item was added:
+ ----- Method: CipherPanel>>extent: (in category 'geometry') -----
+ extent: newExtent
+ "Lay out with word wrap, alternating bewteen decoded and encoded lines."
+ "Currently not tolerant of narrow (less than a word) margins"
+
+ | w h relLoc topLeft thisWord i m corner row firstWord |
+ self removeAllMorphs.
+ w := originalMorphs first width - 1 px. h := originalMorphs first height * 2 + 10 px.
+ topLeft := self position + self borderWidth + (0 @ 10 px).
+ thisWord := OrderedCollection new.
+ i := 1. firstWord := true. relLoc := 0@0. corner := topLeft.
+ [i <= originalMorphs size] whileTrue:
+ [m := originalMorphs at: i.
+ thisWord addLast: ((decodingMorphs at: i) position: topLeft + relLoc).
+ thisWord addLast: (m position: topLeft + relLoc + (0@m height)).
+ (m letter = Character space or: [i = originalMorphs size])
+ ifTrue: [self addAllMorphs: thisWord.
+ corner := corner max: thisWord last bounds bottomRight.
+ thisWord reset. firstWord := false].
+ relLoc := relLoc + (w@0).
+ (relLoc x + w) > newExtent x
+ ifTrue: [firstWord
+ ifTrue: ["No spaces -- force a line break"
+ thisWord removeLast; removeLast.
+ self addAllMorphs: thisWord.
+ corner := corner max: thisWord last bounds bottomRight]
+ ifFalse: [i := i - (thisWord size//2) + 1].
+ thisWord reset. firstWord := true.
+ relLoc := 0@(relLoc y + h)]
+ ifFalse: [i := i + 1]].
+ row := self buttonRow. row fullBounds.
+ self addMorph: row.
+ super extent: (corner - topLeft) + (self borderWidth * 2) + (0 @ row height + 10 px).
+ row align: row bounds bottomCenter with: self bounds bottomCenter - (0 @ 2 px).!
Item was added:
+ ----- Method: CipherPanel>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ super initializeToStandAlone.
+ self encodedQuote: self class sampleString!
Item was added:
+ ----- Method: CipherPanel>>keyCharacter:atIndex:nextFocus: (in category 'defaults') -----
+ keyCharacter: aLetter atIndex: indexInQuote nextFocus: nextFocus
+
+ | encodedLetter |
+ encodedLetter := quote at: indexInQuote.
+ originalMorphs with: decodingMorphs do:
+ [:e :d | e letter = encodedLetter ifTrue: [d setLetter: aLetter color: Color red]].
+ !
Item was added:
+ ----- Method: CipherPanel>>showHelpWindow (in category 'menu') -----
+ showHelpWindow
+
+ 'The Cipher Panel displays an encrypted message. The encryption is a simple substitution code; each letter of the alphabet has been changed to a different one.
+
+ You can solve the cipher by clicking above any letter in the message, and typing the letter you think it should be. The Cipher Panel automatically makes the same substitution anywhere else that letter occurs in the encoded message.
+
+ If you are having trouble, you can use the command menu to ''show cipher hints''. That will display how many of each letter occurs, which is often a help in solving ciphers.' translated
+ editWithLabel: 'About the Cipher Panel' translated.!
Item was added:
+ ----- Method: CipherPanel>>showHintsWindow (in category 'menu') -----
+ showHintsWindow
+
+ ('Most bodies of english text follow a general pattern of letter usage. The following are the most common letters, in approximate order of frequency:
+ E T A O N I R S H
+ The following are the most common digraphs:
+ EN ER RE NT TH ON IN
+
+ The message you are trying to decode has the following specific statistics: {1}
+
+ Good luck!!' translated format: {self cipherStats})
+ editWithLabel: 'Some Useful Statistics' translated.!
Item was added:
+ ----- Method: CipherPanel>>squeakCipher (in category 'menu') -----
+ squeakCipher
+ self encodedQuote: (CipherPanel encode: (CipherPanel randomComment))!
Item was added:
+ WordGamePanelMorph subclass: #CrosticPanel
+ instanceVariableNames: 'crosticPanel quotePanel cluesCol2 answers quote clues cluesPanel'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !CrosticPanel commentStamp: '<historical>' prior: 0!
+ The CrosticPanel, as its name suggests, is a tool for decoding acrostic puzzles, such as are presented on the puzzle pages of some Sunday newspapers. Much of the capability is inherited from the two WordGame classes used. To try it out, choose newMorph/Games/CrosticPanel in a morphic project, or execute, in any project:
+
+ CrosticPanel new openInWorld
+
+ The instance variables of this class include...
+ letterMorphs (in superclass) a collection of all the letterMorphs in this panel
+ quote a string, being the entire quote in uppercase with no blanks
+ clues a collection of the clue strings
+ answers a collection of the answer indices.
+ For each answer, this is an array of the indices into the quote string.
+
+ The final structure of a CrosticPanel is as follows
+ self a CrosticPanel the overall holder
+ quotePanel a CrosticQuotePanel holds the grid of letters from the quote
+ cluesPanel an AlignmentMorph holds most of the clue rows
+ cluesCol2 an AlignmentMorph holds the rest of the clue rows
+
+ Each clue row is a horizontal AlignmentMorph with a textMorph and another alignmentMorph full of the letterMorphs for the answer.
+ !
Item was added:
+ ----- Method: CrosticPanel class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Crostic' translatedNoop
+ categories: {'Games' translatedNoop}
+ documentation: 'The Crostic Panel: A classic word diagram game, by Dan Ingalls' translatedNoop!
Item was added:
+ ----- Method: CrosticPanel class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^ true!
Item was added:
+ ----- Method: CrosticPanel class>>new (in category 'instance creation') -----
+ new
+ "NOTE: Use newFromFile: rather than new to create new CrosticPanels"
+
+ ^ self newFromFile: (ReadStream on: self sampleFile)!
Item was added:
+ ----- Method: CrosticPanel class>>newFromFile: (in category 'instance creation') -----
+ newFromFile: aStream
+ "World addMorph: CrosticPanel new"
+ "World addMorph: (CrosticPanel newFromFile: (FileStream
+ readOnlyFileNamed: 'first.crostic'))"
+ | quoteWithBlanks citation clue numberLine numbers clues answers indexableQuote quotePanel crosticPanel buttonRow quoteWidth |
+ aStream next asciiValue = 31 & (aStream next asciiValue = 139)
+ ifTrue: ["It's gzipped..."
+ aStream skip: -2.
+ ^ self newFromFile: aStream asUnZippedStream ascii].
+ aStream skip: -2.
+ quoteWithBlanks := aStream nextLine.
+ quoteWithBlanks := quoteWithBlanks asUppercase
+ select: [:c | c isLetter
+ or: [' -' includes: c]].
+ indexableQuote := quoteWithBlanks
+ select: [:c | c isLetter].
+ citation := aStream nextLine.
+ aStream nextLine.
+ clues := OrderedCollection new.
+ answers := OrderedCollection new.
+ [aStream atEnd]
+ whileFalse: [clue := aStream nextLine.
+ "Transcript cr; show: clue."
+ clues addLast: clue.
+ numberLine := aStream nextLine.
+ numbers := Scanner new scanTokens: numberLine.
+ answers addLast: numbers].
+ aStream close.
+ "Consistency check:"
+ (citation asUppercase
+ select: [:c | c isLetter])
+ = (String
+ withAll: (answers
+ collect: [:a | indexableQuote at: a first]))
+ ifFalse: [self error: 'mal-formed crostic file' translated].
+ crosticPanel := super new.
+ quotePanel := CrosticQuotePanel new
+ quote: quoteWithBlanks
+ answers: answers
+ cluesPanel: crosticPanel.
+ crosticPanel color: quotePanel firstSubmorph color;
+
+ quote: indexableQuote
+ clues: clues
+ answers: answers
+ quotePanel: quotePanel.
+ buttonRow := crosticPanel buttonRow.
+ quoteWidth := crosticPanel width + quotePanel firstSubmorph width max: buttonRow width.
+ quotePanel extent: quoteWidth @ 9999.
+ crosticPanel addMorph: quotePanel.
+ ^ crosticPanel breakColumnAndResizeWithButtons: buttonRow!
Item was added:
+ ----- Method: CrosticPanel class>>oldStyle (in category 'as yet unclassified') -----
+ oldStyle
+ "return true if we should cross-index all the cells (takes more space)."
+
+ ^ false!
Item was added:
+ ----- Method: CrosticPanel class>>sampleFile (in category 'as yet unclassified') -----
+ sampleFile
+ "If you want to enter a new acrostic, follow this format exactly with regard to CRs and the like, and store it in a file. Do not double the string quotes as here -- that is only because they are embedded in a string. Finally, compress the file in the fileList (so it will be easy to transport and hard to read), and name it 'yourName.crostic' so that the 'open' button on the panel will recognize it."
+ ^
+ 'Men and women do not feel the same way about dirt. Women for some hormonal reason can see individual dirt molecules, whereas men tend not to notice them until they join together into clumps large enough to support commercial agriculture.
+ Dave Barry''s Guide to Marriage
+
+ Boccaccio''s collection of tales
+ 74 19 175 156 9 122 84 113 104
+ Wooden instrument of Swiss herders
+ 67 184 153 103 14 142 148 54 3
+ Evening service
+ 76 99 154 171 89 194 69
+ Russian-born American anarchist (2 wds)
+ 159 102 177 25 186 134 128 82 50 62 11
+ Apple-polish (2 wds)
+ 32 190 129 126 179 157 79 170
+ Visual-gesture means of communication
+ 4 178 27 168 150 185 114
+ Postponed contest
+ 173 58 77 65 8 124 85
+ Groundbreaking invention
+ 98 15 116 162 112 37 92 155 70 187
+ Material used to make English longbows
+ 132 195 28
+ Gracile
+ 48 191 145 152
+ Have the effrontery; experience a high (2 wds)
+ 164 61 137 33 17 45
+ Florentine painter who experimented with perspective
+ 91 181 189 2 20 81 167
+ Sondheim opus (3 wds)
+ 72 109 147 13 192 165 93 40 115 138 6 63
+ Spanish rake
+ 108 56 44 133 193 29 125
+ Emergence as of an adult butterfly
+ 106 149 59 41 24 135 87 68
+ Type of rifle (hyph)
+ 111 7 143 73 39 30 105 95 53
+ Free of charge (3 wds)
+ 176 107 120 130 160 22 46 34 94 71
+ Pie filling
+ 86 75 136 118 43
+ Master filmmaker
+ 31 151 174 51 163 144
+ Longtime sportswriter for the NY Herald tribune (2 wds)
+ 60 140 12 101 55 188 166 121
+ Birthplace of Erasmus
+ 47 64 141 21 10 180 36 80 1
+ Mae West classic (3 wds)
+ 127 123 161 110 183 5 139 97 88
+ Element that glows blue in the dark
+ 100 90 35 182 146 117 169 26
+ Sturm und Drang writer
+ 158 172 119 16 52 23
+ Starfish or sea cucumber
+ 18 66 96 83 57 49 78 131 38 42
+ '!
Item was added:
+ ----- Method: CrosticPanel>>addMenuItemsTo:hand: (in category 'menu') -----
+ addMenuItemsTo: aMenu hand: aHandMorph
+ aMenu
+ add: 'show crostic help' translated
+ target: self
+ action: #showHelpWindow.
+ aMenu
+ add: 'show crostic hints' translated
+ target: self
+ action: #showHintsWindow.
+ aMenu
+ add: 'show crostic errors' translated
+ target: self
+ action: #showErrors.
+ aMenu
+ add: 'clear crostic typing' translated
+ target: self
+ action: #clearTyping.
+ aMenu
+ add: 'open crostic file...' translated
+ target: self
+ action: #openFile!
Item was added:
+ ----- Method: CrosticPanel>>breakColumnAndResizeWithButtons: (in category 'initialization') -----
+ breakColumnAndResizeWithButtons: buttonRow
+ | indexToSplit yToSplit |
+ "The column of clues has been laid out, and the crostic panel has been resized to that width and embedded as a submorph. This method breaks the clues in two, placing the long part to the left of the crostic and the short one below it."
+
+ yToSplit := cluesPanel height + quotePanel height // 2 + self top.
+ indexToSplit := cluesPanel submorphs findFirst: [:m | m bottom > yToSplit].
+ cluesCol2 := AlignmentMorph newColumn color: self color;
+ hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0;
+ cellPositioning: #topLeft.
+ cluesCol2 addAllMorphs: (cluesPanel submorphs copyFrom: indexToSplit + 1
+ to: cluesPanel submorphs size).
+ cluesPanel position: self position + self borderWidth + (0 @ 4).
+ quotePanel position: self position + (quotePanel width @ 0).
+ cluesCol2 position: self position + quotePanel extent + (0 @ 4).
+ self addMorph: cluesCol2.
+ self addMorph: buttonRow.
+ buttonRow align: buttonRow topLeft with: cluesCol2 bottomLeft.
+ self extent: 100@100; bounds: ((self fullBounds topLeft - self borderWidth asPoint)
+ corner: (self fullBounds bottomRight - (2@0))).
+ !
Item was added:
+ ----- Method: CrosticPanel>>buttonRow (in category 'menu') -----
+ buttonRow
+ | row aButton |
+ row := AlignmentMorph newRow color: self color;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap.
+ #('show help' 'show errors' 'show hints' 'clear' 'open...' ) translatedNoop
+ with: #(#showHelpWindow #showErrors #showHintsWindow #clearTyping #openFile )
+ do: [:label :selector |
+ aButton := SimpleButtonMorph new target: self.
+ aButton color: Color transparent;
+ borderWidth: 1 px;
+ borderColor: Color black.
+ aButton actionSelector: selector.
+ aButton label: label translated.
+ row addMorphBack: aButton.
+ row addTransparentSpacerOfSize: 3 px @ 0].
+ ^ row!
Item was added:
+ ----- Method: CrosticPanel>>clearTyping (in category 'defaults') -----
+ clearTyping
+ self isClean
+ ifTrue: [^ self].
+ (self confirm: 'Are you sure you want to discard all typing?' translated)
+ ifFalse: [^ self].
+ super clearTyping.
+ quotePanel clearTyping!
Item was added:
+ ----- Method: CrosticPanel>>highlight: (in category 'defaults') -----
+ highlight: morph
+
+ self unhighlight.
+ quotePanel unhighlight.
+ morph startOfWord morphsInWordDo:
+ [:m | m color: Color lightGreen.
+ (quotePanel letterMorphs at: m indexInQuote) color: Color lightMagenta].
+ morph color: Color green.
+ (quotePanel letterMorphs at: morph indexInQuote) color: Color magenta.
+ !
Item was added:
+ ----- Method: CrosticPanel>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ | aStream quoteWithBlanks indexableQuote citation clue numberLine numbers buttonRow quoteWidth |
+ super initializeToStandAlone.
+ aStream := ReadStream on: self class sampleFile.
+ quoteWithBlanks := aStream nextLine.
+ quoteWithBlanks := quoteWithBlanks asUppercase
+ select: [:c | c isLetter
+ or: [' -' includes: c]].
+ indexableQuote := quoteWithBlanks
+ select: [:c | c isLetter].
+ citation := aStream nextLine.
+ aStream nextLine.
+ clues := OrderedCollection new.
+ answers := OrderedCollection new.
+ [aStream atEnd]
+ whileFalse: [clue := aStream nextLine.
+ "Transcript cr; show: clue."
+ clues addLast: clue.
+ numberLine := aStream nextLine.
+ numbers := Scanner new scanTokens: numberLine.
+ answers addLast: numbers].
+ aStream close.
+ "Consistency check:"
+ (citation asUppercase
+ select: [:c | c isLetter])
+ = (String
+ withAll: (answers
+ collect: [:a | indexableQuote at: a first]))
+ ifFalse: [self error: 'mal-formed crostic file' translated].
+ quotePanel := CrosticQuotePanel new
+ quote: quoteWithBlanks
+ answers: answers
+ cluesPanel: self.
+ self color: quotePanel firstSubmorph color;
+
+ quote: indexableQuote
+ clues: clues
+ answers: answers
+ quotePanel: quotePanel.
+ buttonRow := self buttonRow.
+ quoteWidth := self width + quotePanel firstSubmorph width max: buttonRow width.
+ quotePanel extent: quoteWidth @ 9999.
+ self addMorph: quotePanel.
+ self breakColumnAndResizeWithButtons: buttonRow!
Item was added:
+ ----- Method: CrosticPanel>>keyCharacter:atIndex:nextFocus: (in category 'defaults') -----
+ keyCharacter: aLetter atIndex: indexInQuote nextFocus: nextFocus
+
+ (self letterMorphs at: indexInQuote) setLetter: aLetter.
+ (quotePanel letterMorphs at: indexInQuote) setLetter: aLetter.
+ self highlight: nextFocus
+ !
Item was added:
+ ----- Method: CrosticPanel>>lostFocus (in category 'defaults') -----
+ lostFocus
+
+ self unhighlight.
+ quotePanel unhighlight!
Item was added:
+ ----- Method: CrosticPanel>>openFile (in category 'menu') -----
+ openFile
+ | fileName crostic file |
+
+ fileName := FileChooserDialog openOn: FileDirectory default suffixList: { 'crostic' } label: 'Select a Crostic file...' translated.
+ fileName ifNil: [^nil].
+
+ file := FileStream readOnlyFileNamed: fileName.
+ crostic := CrosticPanel newFromFile: file.
+ file close.
+ (self isClean
+ or: [self confirm: 'Is it OK to discard this crostic?' translated])
+ ifTrue: [self world
+ addMorphFront: (crostic position: self position).
+ self delete]
+ ifFalse: [self world addMorphFront: crostic]!
Item was added:
+ ----- Method: CrosticPanel>>quote:clues:answers:quotePanel: (in category 'initialization') -----
+ quote: indexableQuote clues: clueStrings answers: answerIndices quotePanel: panel
+
+ | row clue answer answerMorph letterMorph prev clueText clueStyle |
+ quote := indexableQuote.
+ quotePanel := panel.
+ clues := clueStrings.
+ answers := answerIndices.
+ cluesPanel := AlignmentMorph newColumn color: self color;
+ hResizing: #shrinkWrap; vResizing: #shrinkWrap;
+ cellPositioning: #topLeft; layoutInset: 1 px.
+ letterMorphs := Array new: quotePanel letterMorphs size.
+ clueStyle := nil.
+ 1 to: clues size do:
+ [:i | clue := clues at: i. answer := answers at: i.
+ row := AlignmentMorph newRow cellPositioning: #bottomLeft.
+ clueText := (TextMorph newBounds: (0 @ 0 extent: 120 px @ 20 px) color: Color black)
+ string: (CrosticPanel oldStyle
+ ifTrue: [(($A to: $Z) at: i) asString , '. ' , clue]
+ ifFalse: [clue])
+ fontName: 'ComicPlain' size: 13 px.
+ clueStyle ifNil: ["Make up a special style with decreased leading"
+ clueStyle := clueText textStyle copy.
+ clueStyle gridForFont: 1 withLead: -2].
+ clueText text: clueText asText textStyle: clueStyle. "All clues share same style"
+ clueText composeToBounds.
+ row addMorphBack: clueText.
+ answerMorph := AlignmentMorph newRow layoutInset: 0.
+ prev := nil.
+ answer do:
+ [:n | letterMorph := WordGameLetterMorph new underlined
+ indexInQuote: n
+ id1: (CrosticPanel oldStyle ifTrue: [n printString] ifFalse: [nil]);
+ setLetter: Character space.
+ letterMorph on: #mouseDown send: #mouseDownEvent:letterMorph: to: self.
+ letterMorph on: #keyStroke send: #keyStrokeEvent:letterMorph: to: self.
+ letterMorph predecessor: prev.
+ prev ifNotNil: [prev successor: letterMorph].
+ prev := letterMorph.
+ letterMorphs at: n put: letterMorph.
+ answerMorph addMorphBack: letterMorph].
+ answerMorph color: answerMorph firstSubmorph color.
+ row addMorphBack: answerMorph.
+ row fullBounds.
+ row color: answerMorph firstSubmorph color.
+ cluesPanel addMorphBack: row].
+ self addMorph: cluesPanel.
+ self bounds: cluesPanel fullBounds.!
Item was added:
+ ----- Method: CrosticPanel>>showErrors (in category 'menu') -----
+ showErrors
+
+ letterMorphs do:
+ [:m | (m letter ~= Character space and: [m letter ~= (quote at: m indexInQuote)])
+ ifTrue: [m color: Color red.
+ (quotePanel letterMorphs at: m indexInQuote) color: Color red]]!
Item was added:
+ ----- Method: CrosticPanel>>showHelpWindow (in category 'menu') -----
+ showHelpWindow
+
+ 'The Crostic Panel presents an acrostic puzzle for solution. As you type in answers for the clues, the letters also get entered in the text of the hidden quote. Conversely, as you guess words in the quote, those letters will fill in missing places in your answers. In addition, the first letters of all the answers together form the author''s name and title of the work from which the quote is taken.
+
+ If you wish to make up other acrostic puzzles, follow the obvious file format in the sampleFile method. If you wish to print an acrostic to work it on paper, then change the oldStyle method to return true, and it will properly cross-index all the cells.
+
+ Have fun!!' translated
+ editWithLabel: 'About the Crostic Panel' translated.!
Item was added:
+ ----- Method: CrosticPanel>>showHintsWindow (in category 'menu') -----
+ showHintsWindow
+ | hints |
+ (self confirm: 'As hints, you will be given the five longest answers.
+ Do you really want to do this?' translated)
+ ifFalse: [^ self].
+ hints := (answers sorted: [:x :y | x size > y size]) first: 5.
+ (('The five longest answers are...
+ ' translated
+ , (String
+ streamContents: [:strm |
+ hints
+ do: [:hint | strm cr;
+ nextPutAll: (hint
+ collect: [:i | quote at: i])].
+ strm cr; cr]) , 'Good luck!!' translated))
+ editWithLabel: 'Crostic Hints' translated.!
Item was added:
+ WordGamePanelMorph subclass: #CrosticQuotePanel
+ instanceVariableNames: 'cluesPanel'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
Item was added:
+ ----- Method: CrosticQuotePanel>>extent: (in category 'geometry') -----
+ extent: newExtent
+
+ | w h nAcross relLoc topLeft |
+ w := self firstSubmorph width - 1 px. h := self firstSubmorph height - 1 px.
+ nAcross := newExtent x - (self borderWidth - 1 px * 2) - 1 px // w.
+ topLeft := self position + self borderWidth - 1 px.
+ submorphs withIndexDo:
+ [:m :i |
+ relLoc := (i-1 \\ nAcross * w) @ (i-1 // nAcross * h).
+ m position: topLeft + relLoc].
+ super extent: ((w * nAcross + 1) @ (submorphs size - 1 // nAcross + 1 * h+1))
+ + (self borderWidth - 1 px * 2).!
Item was added:
+ ----- Method: CrosticQuotePanel>>highlight: (in category 'defaults') -----
+ highlight: morph
+
+ self unhighlight.
+ cluesPanel unhighlight.
+ morph startOfWord morphsInWordDo:
+ [:m | m color: Color lightGreen.
+ (cluesPanel letterMorphs at: m indexInQuote) color: Color lightMagenta].
+ morph color: Color green.
+ (cluesPanel letterMorphs at: morph indexInQuote) color: Color magenta.
+ !
Item was added:
+ ----- Method: CrosticQuotePanel>>keyCharacter:atIndex:nextFocus: (in category 'defaults') -----
+ keyCharacter: aLetter atIndex: indexInQuote nextFocus: nextFocus
+
+ (self letterMorphs at: indexInQuote) setLetter: aLetter.
+ (cluesPanel letterMorphs at: indexInQuote) setLetter: aLetter.
+ self highlight: nextFocus
+ !
Item was added:
+ ----- Method: CrosticQuotePanel>>lostFocus (in category 'defaults') -----
+ lostFocus
+
+ self unhighlight.
+ cluesPanel unhighlight!
Item was added:
+ ----- Method: CrosticQuotePanel>>quote:answers:cluesPanel: (in category 'initialization') -----
+ quote: quoteWithBlanks answers: theAnswers cluesPanel: panel
+
+ | n morph prev clueIxs |
+ cluesPanel := panel.
+ self color: Color gray.
+ clueIxs := Array new: quoteWithBlanks size.
+ theAnswers withIndexDo: [:a :i | a do: [:j | clueIxs at: j put: i]].
+ letterMorphs := OrderedCollection new.
+ prev := nil.
+ self addAllMorphs: (quoteWithBlanks asArray collect:
+ [:c |
+ c isLetter
+ ifTrue: [n := letterMorphs size + 1.
+ morph := WordGameLetterMorph new boxed.
+ CrosticPanel oldStyle
+ ifTrue: [morph indexInQuote: n id1: n printString.
+ morph id2: (($A to: $Z) at: (clueIxs at: n)) asString]
+ ifFalse: [morph indexInQuote: n id1: nil].
+ morph setLetter: Character space.
+ morph on: #mouseDown send: #mouseDownEvent:letterMorph: to: self.
+ morph on: #keyStroke send: #keyStrokeEvent:letterMorph: to: self.
+ letterMorphs addLast: morph]
+ ifFalse: [morph := WordGameLetterMorph new boxed indexInQuote: nil id1: nil.
+ CrosticPanel oldStyle ifTrue: [morph extent: 26 px @ 24 px "Oops"]].
+ morph predecessor: prev.
+ prev ifNotNil: [prev successor: morph].
+ prev := morph]).!
Item was added:
+ RectangleMorph subclass: #DoubleClickExample
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Demo'!
+
+ !DoubleClickExample commentStamp: '<historical>' prior: 0!
+ Illustrates the double-click capabilities of Morphic.
+
+ If you have a kind of morph you wish to have respond specially to a double-click, it should:
+
+ (1) Respond "true" to #handlesMouseDown:
+
+ (2) In its mouseDown: method, send #waitForClicksOrDrag:event: to the hand.
+
+ (3) Reimplement #click: to react to single-clicked mouse-down.
+
+ (4) Reimplement #doubleClick: to make the appropriate response to a double-click.
+
+ (5) Reimplement #drag: to react to non-clicks. This message is sent continuously until the button is released. You can check the event argument to react differently on the first, intermediate, and last calls.!
Item was added:
+ ----- Method: DoubleClickExample class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'DoubleClick' translatedNoop
+ categories: #()
+ documentation: 'An example of how to use double-click in moprhic' translatedNoop!
Item was added:
+ ----- Method: DoubleClickExample>>balloonText (in category 'accessing') -----
+ balloonText
+ ^ 'Double-click on me to change my color;
+ single-click on me to change border color;
+ hold mouse down within me and then move it to grow
+ (if I''m red) or shrink (if I''m blue).' translated
+ !
Item was added:
+ ----- Method: DoubleClickExample>>click: (in category 'event handling') -----
+ click: evt
+ self showBalloon: 'click' hand: evt hand.
+ self borderColor: (self borderColor = Color black ifTrue: [Color yellow] ifFalse: [Color black])
+ !
Item was added:
+ ----- Method: DoubleClickExample>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color red!
Item was added:
+ ----- Method: DoubleClickExample>>doubleClick: (in category 'event handling') -----
+ doubleClick: evt
+ self showBalloon: 'doubleClick' hand: evt hand.
+ self color: ((color = Color blue) ifTrue: [Color red] ifFalse: [Color blue])
+ !
Item was added:
+ ----- Method: DoubleClickExample>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ ^ true!
Item was added:
+ ----- Method: DoubleClickExample>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ "Do nothing upon mouse-down except inform the hand to watch for a double-click; wait until an ensuing click:, doubleClick:, or drag: message gets dispatched"
+
+ evt hand waitForClicksOrDrag: self event: evt!
Item was added:
+ ----- Method: DoubleClickExample>>startDrag: (in category 'event handling') -----
+ startDrag: evt
+ "We'll get a mouseDown first, some mouseMoves, and a mouseUp event last"
+ | oldCenter |
+ evt isMouseDown ifTrue:
+ [self showBalloon: 'drag (mouse down)' hand: evt hand.
+ self world displayWorld.
+ (Delay forMilliseconds: 750) wait].
+ evt isMouseUp ifTrue:
+ [self showBalloon: 'drag (mouse up)' hand: evt hand].
+ (evt isMouseUp or: [evt isMouseDown]) ifFalse:
+ [self showBalloon: 'drag (mouse still down)' hand: evt hand].
+ (self containsPoint: evt cursorPoint)
+ ifFalse: [^ self].
+
+ oldCenter := self center.
+ color = Color red
+ ifTrue:
+ [self extent: self extent + (1@1)]
+ ifFalse:
+ [self extent: ((self extent - (1@1)) max: (16@16))].
+ self center: oldCenter!
Item was removed:
- Model subclass: #FancyMailComposition
- instanceVariableNames: 'messageText theLinkToInclude to subject'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'MorphicExtras-EToy-Download'!
Item was removed:
- ----- Method: FancyMailComposition>>addAttachment (in category 'actions') -----
- addAttachment
-
- self changed: #acceptChanges.
-
- (FileChooserDialog openOn: FileDirectory default pattern: nil label: 'Choose attachment') ifNotNil:
- [:fileName |
- FileStream readOnlyFileNamed: fileName do:
- [:file |
- file binary.
- self messageText:
- ((MailMessage from: self messageText asString)
- addAttachmentFrom: file withName: (FileDirectory localNameFor: fileName);
- text)]]!
Item was removed:
- ----- Method: FancyMailComposition>>breakLines:atWidth: (in category 'private') -----
- breakLines: aString atWidth: width
- "break lines in the given string into shorter lines"
- | result atAttachment |
-
- result := WriteStream on: (String new: (aString size * 50 // 49)).
-
- atAttachment := false.
- aString asString linesDo: [ :line | | start end |
- (line beginsWith: '====') ifTrue: [ atAttachment := true ].
- atAttachment ifTrue: [
- "at or after an attachment line; no more wrapping for the rest of the message"
- result nextPutAll: line. result cr ]
- ifFalse: [
- (line beginsWith: '>') ifTrue: [
- "it's quoted text; don't wrap it"
- result nextPutAll: line. result cr. ]
- ifFalse: [
- "regular old line. Wrap it to multiple lines"
- start := 1.
- "output one shorter line each time through this loop"
- [ start + width <= line size ] whileTrue: [
-
- "find the end of the line"
- end := start + width - 1.
- [end >= start and: [ (line at: (end+1)) isSeparator not ]] whileTrue: [
- end := end - 1 ].
- end < start ifTrue: [
- "a word spans the entire width!!"
- end := start + width - 1 ].
-
- "copy the line to the output"
- result nextPutAll: (line copyFrom: start to: end).
- result cr.
-
- "get ready for next iteration"
- start := end+1.
- (line at: start) isSeparator ifTrue: [ start := start + 1 ].
- ].
-
- "write out the final part of the line"
- result nextPutAll: (line copyFrom: start to: line size).
- result cr.
- ].
- ].
- ].
-
- ^result contents!
Item was removed:
- ----- Method: FancyMailComposition>>buildButtonsWith: (in category 'toolbuilder') -----
- buildButtonsWith: builder
-
- | panel |
- panel := builder pluggablePanelSpec new.
- panel
- layout: #horizontal;
- children: OrderedCollection new.
-
- panel children addLast: (builder pluggableButtonSpec new
- model: self;
- label: 'send later';
- help: 'add this to the queue of messages to be sent';
- action: #submit;
- color: Color white;
- yourself).
-
- panel children addLast: (builder pluggableButtonSpec new
- model: self;
- label: 'send now';
- help: 'send this message immediately';
- action: #sendNow;
- color: Color white;
- yourself).
-
- panel children addLast: (builder pluggableButtonSpec new
- model: self;
- label: 'add attachment';
- help: 'send a file with the message';
- action: #addAttachment;
- color: Color white;
- yourself).
-
- ^ panel!
Item was removed:
- ----- Method: FancyMailComposition>>buildMessageTextWith: (in category 'toolbuilder') -----
- buildMessageTextWith: builder
-
- ^ builder pluggableTextSpec new
- model: self;
- getText: #messageText;
- setText: #messageText:;
- menu: #menuGet:shifted:;
- yourself!
Item was removed:
- ----- Method: FancyMailComposition>>buildTextFieldsWith: (in category 'toolbuilder') -----
- buildTextFieldsWith: builder
-
- | panel |
- panel := builder pluggablePanelSpec new.
- panel
- layout: #vertical;
- children: OrderedCollection new.
-
- panel children addLast: (builder pluggableInputFieldSpec new
- model: self;
- help: 'To';
- getText: #to;
- setText: #to:;
- yourself).
-
- panel children addLast: (builder pluggableInputFieldSpec new
- model: self;
- help: 'Subject';
- getText: #subject;
- setText: #subject:;
- yourself).
-
- ^ panel!
Item was removed:
- ----- Method: FancyMailComposition>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
-
- ^ builder build: (self buildWindowWith: builder specs: {
- (0 @ 0 corner: 1 @ 0.1) -> [self buildButtonsWith: builder].
- (0 @ 0.1 corner: 1 @ 0.3) -> [self buildTextFieldsWith: builder].
- (0 @ 0.3 corner: 1 @ 1) -> [self buildMessageTextWith: builder]. })!
Item was removed:
- ----- Method: FancyMailComposition>>celeste:to:subject:initialText:theLinkToInclude: (in category 'initialization') -----
- celeste: aCeleste to: argTo subject: argSubject initialText: aText theLinkToInclude: linkText
- "self new celeste: Celeste current to: 'danielv(a)netvision.net.il' subject: 'Mysubj' initialText: 'atext' theLinkToInclude: 'linkText'"
-
- to := argTo.
- subject := argSubject.
- messageText := aText.
- theLinkToInclude := linkText.!
Item was removed:
- ----- Method: FancyMailComposition>>completeTheMessage (in category 'actions') -----
- completeTheMessage
-
- | newText strm |
- self changed: #acceptChanges.
-
- newText := String new: 200.
- strm := WriteStream on: newText.
- strm
- nextPutAll: 'Content-Type: text/html'; cr;
- nextPutAll: 'From: ', MailSender userName; cr;
- nextPutAll: 'To: ',to; cr;
- nextPutAll: 'Subject: ',subject; cr;
-
- cr;
- nextPutAll: '<HTML><BODY><BR>';
- nextPutAll: messageText asStringToHtml;
- nextPutAll: '<BR><BR>',theLinkToInclude,'<BR></BODY></HTML>'.
- ^strm contents!
Item was removed:
- ----- Method: FancyMailComposition>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
-
- ^ Color veryLightGray!
Item was removed:
- ----- Method: FancyMailComposition>>forgetIt (in category 'user interface') -----
- forgetIt
-
- self changed: #close.!
Item was removed:
- ----- Method: FancyMailComposition>>menuGet:shifted: (in category 'interface') -----
- menuGet: aMenu shifted: shifted
-
- aMenu addList: {
- {'find...(f)' translated. #find}.
- {'find selection again (g)' translated. #findAgain}.
- #-.
- {'accept (s)' translated. #accept}.
- {'send message' translated. #submit}}.
-
- ^aMenu.!
Item was removed:
- ----- Method: FancyMailComposition>>messageText (in category 'accessing') -----
- messageText
- "return the current text"
- ^messageText.
- !
Item was removed:
- ----- Method: FancyMailComposition>>messageText: (in category 'accessing') -----
- messageText: aText
- "change the current text"
- messageText := aText.
- self changed: #messageText.
- ^true!
Item was removed:
- ----- Method: FancyMailComposition>>open (in category 'user interface') -----
- open
-
- self flag: #refactor. "FancyMailComposition should probably be removed in favour of MailComposition."
- ^ ToolBuilder open: self!
Item was removed:
- ----- Method: FancyMailComposition>>sendMailMessage: (in category 'MailSender interface') -----
- sendMailMessage: aMailMessage
- self messageText: aMailMessage text!
Item was removed:
- ----- Method: FancyMailComposition>>sendNow (in category 'actions') -----
- sendNow
-
- self submit: true
- !
Item was removed:
- ----- Method: FancyMailComposition>>smtpServer (in category 'MailSender interface') -----
- smtpServer
- ^MailSender smtpServer!
Item was removed:
- ----- Method: FancyMailComposition>>subject (in category 'accessing') -----
- subject
-
- ^ subject
-
- !
Item was removed:
- ----- Method: FancyMailComposition>>subject: (in category 'accessing') -----
- subject: x
-
- subject := x.
- self changed: #subject.
- ^true!
Item was removed:
- ----- Method: FancyMailComposition>>submit (in category 'actions') -----
- submit
-
- self submit: false!
Item was removed:
- ----- Method: FancyMailComposition>>submit: (in category 'actions') -----
- submit: sendNow
-
- | message |
-
- messageText := self breakLines: self completeTheMessage atWidth: 999.
- message := MailMessage from: messageText.
- SMTPClient
- deliverMailFrom: message from
- to: (Array with: message to)
- text: message text
- usingServer: self smtpServer.
- self forgetIt.
- !
Item was removed:
- ----- Method: FancyMailComposition>>to (in category 'accessing') -----
- to
-
- ^to!
Item was removed:
- ----- Method: FancyMailComposition>>to: (in category 'accessing') -----
- to: x
-
- to := x.
- self changed: #to.
- ^true
- !
Item was removed:
- ----- Method: FancyMailComposition>>windowTitle (in category 'user interface') -----
- windowTitle
-
- ^ 'Mister Postman'!
Item was added:
+ MagnifierMorph subclass: #FishEyeMorph
+ instanceVariableNames: 'gridNum d clipRects toRects quads savedExtent'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Demo'!
Item was added:
+ ----- Method: FishEyeMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'FishEye' translatedNoop
+ categories: #()
+ documentation: 'An extreme-wide-angle lens' translatedNoop!
Item was added:
+ ----- Method: FishEyeMorph>>calculateTransform (in category 'initialization') -----
+ calculateTransform
+ | stepX stepY rect tx ty arrayX arrayY |
+ (gridNum x = 0 or: [gridNum y = 0]) ifTrue: [^self].
+ stepX := srcExtent x // gridNum x.
+ stepY := srcExtent y // gridNum y.
+
+ arrayX := (1 to: gridNum y + 1) collect: [:j | Float32Array new: gridNum x + 1].
+ arrayY := (1 to: gridNum y + 1) collect: [:j | Float32Array new: gridNum x + 1].
+
+ 0 to: gridNum y do: [:j |
+ 0 to: gridNum x do: [:i |
+ (arrayX at: (j + 1)) at: (i + 1) put: i*stepX.
+ (arrayY at: (j + 1)) at: (i + 1) put: j*stepY.
+ ].
+ ].
+
+ 0 to: gridNum y do: [:j |
+ self transformX: (arrayX at: (j+1)).
+ self transformY: (arrayY at: (j+1)).
+ ].
+
+ 0 to: gridNum y do: [:j |
+ arrayX at: (j+1) put: ((1 to: gridNum x +1) collect: [:i | ((arrayX at: (j+1)) at: i) asInteger]).
+ arrayY at: (j+1) put: ((1 to: gridNum x +1) collect: [:i | ((arrayY at: (j+1)) at: i) asInteger]).
+ ].
+
+
+ clipRects := (1 to: gridNum y) collect: [:j | Array new: gridNum x].
+ toRects := (1 to: gridNum y) collect: [:j | Array new: gridNum x].
+ quads := (1 to: gridNum y) collect: [:j | Array new: gridNum x].
+ 0 to: gridNum y - 1 do: [:j |
+ 0 to: gridNum x- 1 do: [:i |
+ rect := (((arrayX at: (j+1)) at: (i+1))@((arrayY at: (j+1)) at: (i+1)))
+ corner: ((arrayX at: (j+2)) at: (i+2))@((arrayY at: (j+2)) at: (i+2)).
+ (clipRects at: j+1) at: i+1 put: rect.
+
+ rect width >= stepX ifTrue: [rect := rect expandBy: (1@0)].
+ rect height >= stepY ifTrue: [rect := rect expandBy: (0@1)].
+ (toRects at: j+1) at: i+1 put: rect.
+
+ tx := (i)*stepX.
+ ty := (j)*stepY.
+ (quads at: j+1) at: i+1
+ put: {(tx)@(ty). (tx)@(ty+stepY). (tx+stepX)@(ty+stepY). (tx+stepX)@(ty)}.
+ ].
+ ].
+
+ !
Item was added:
+ ----- Method: FishEyeMorph>>chooseMagnification (in category 'menus') -----
+ chooseMagnification
+ self inform: 'Magnification is fixed, sorry.' translated!
Item was added:
+ ----- Method: FishEyeMorph>>chooseMagnification: (in category 'menu') -----
+ chooseMagnification: evt
+ !
Item was added:
+ ----- Method: FishEyeMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "Round to a number divisible by grid. Note that the superclass has its own implementation."
+ | g gridSize |
+ gridSize := self gridSizeFor: aPoint.
+ "self halt."
+ g := (aPoint - (2 * self borderWidth)) // gridSize.
+ srcExtent := g * gridSize.
+ gridNum := g.
+ ^super extent: self defaultExtent!
Item was added:
+ ----- Method: FishEyeMorph>>g:max:focus: (in category 'initialization') -----
+ g: aFloatArray max: max focus: focus
+ | dNormX array |
+
+ dNormX := aFloatArray - focus.
+
+ array := dNormX / max.
+ array *= d.
+ array += 1.0.
+ array := 1.0 / array.
+ dNormX *= (d+1.0).
+ array *= dNormX.
+ ^array += focus.
+ !
Item was added:
+ ----- Method: FishEyeMorph>>gridSizeFor: (in category 'private') -----
+ gridSizeFor: aPoint
+ "returns appropriate size for specified argument"
+ | g |
+ g := aPoint x min: aPoint y.
+ g <= 256 ifTrue: [^8].
+ ^16.!
Item was added:
+ ----- Method: FishEyeMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ "magnification should be always 1"
+ magnification := 1.
+ d := 1.3.
+ self extent: 130 @ 130!
Item was added:
+ ----- Method: FishEyeMorph>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ super initializeToStandAlone.
+ "magnification should be always 1"
+ magnification := 1.
+ d := 1.3.
+ self extent: 130@130.
+ !
Item was added:
+ ----- Method: FishEyeMorph>>magnifiedForm (in category 'magnifying') -----
+ magnifiedForm
+ | warp warpForm fromForm |
+
+ savedExtent ~= srcExtent ifTrue: [
+ savedExtent := srcExtent.
+ self calculateTransform].
+
+ warpForm := Form extent: srcExtent depth: Display depth.
+ fromForm := super magnifiedForm.
+
+ warp := (WarpBlt current toForm: warpForm)
+ sourceForm: fromForm;
+ colorMap: nil;
+ cellSize: 2;
+ combinationRule: Form over.
+
+ 1 to: gridNum y do: [:j |
+ 1 to: gridNum x do: [:i |
+ warp
+ clipRect: ((clipRects at: j) at: i);
+ copyQuad: ((quads at: j) at: i)
+ toRect: ((toRects at: j) at: i).
+ ].
+ ].
+ ^warpForm
+ !
Item was added:
+ ----- Method: FishEyeMorph>>transformX: (in category 'initialization') -----
+ transformX: aFloatArray
+ | focus gridNum2 subArray dMaxX |
+
+ focus := srcExtent x asFloat / 2.
+
+ gridNum2 := (aFloatArray findFirst: [:x | x > focus]) - 1.
+
+ dMaxX := 0.0 - focus.
+ subArray := self g: (aFloatArray copyFrom: 1 to: gridNum2) max: dMaxX focus: focus.
+
+ aFloatArray replaceFrom: 1 to: gridNum2 with: subArray startingAt: 1.
+
+
+ dMaxX := focus. " = (size - focus)"
+ subArray := self g: (aFloatArray copyFrom: gridNum2 + 1 to: gridNum x + 1)
+ max: dMaxX focus: focus.
+
+ aFloatArray replaceFrom: gridNum2 + 1 to: gridNum x + 1 with: subArray startingAt: 1.
+ !
Item was added:
+ ----- Method: FishEyeMorph>>transformY: (in category 'initialization') -----
+ transformY: aFloatArray
+ | focus subArray dMaxY |
+ focus := srcExtent y asFloat / 2.
+ dMaxY := (aFloatArray first) <= focus
+ ifTrue: [0.0 - focus]
+ ifFalse: [focus].
+ subArray := self
+ g: (aFloatArray copyFrom: 1 to: gridNum x + 1)
+ max: dMaxY
+ focus: focus.
+ aFloatArray
+ replaceFrom: 1
+ to: gridNum x + 1
+ with: subArray
+ startingAt: 1!
Item was added:
+ AlignmentMorph subclass: #FreeCell
+ instanceVariableNames: 'board cardsRemainingDisplay elapsedTimeDisplay gameNumberDisplay lastGameLost state autoMoveRecursionCount myFillStyle'
+ classVariableNames: 'Statistics'
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
Item was added:
+ ----- Method: FreeCell class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'FreeCell' translatedNoop
+ categories: {'Games' translatedNoop}
+ documentation: 'A unique solitaire card game' translatedNoop!
Item was added:
+ ----- Method: FreeCell class>>initialize (in category 'class initialization') -----
+ initialize
+
+ Statistics := FreeCellStatistics new.!
Item was added:
+ ----- Method: FreeCell>>autoMovingHome (in category 'actions') -----
+ autoMovingHome
+
+ elapsedTimeDisplay pause.
+ autoMoveRecursionCount := autoMoveRecursionCount + 1.!
Item was added:
+ ----- Method: FreeCell>>board (in category 'accessing') -----
+ board
+
+ board ifNil:
+ [board := FreeCellBoard new
+ target: self;
+ actionSelector: #boardAction:].
+ ^board!
Item was added:
+ ----- Method: FreeCell>>boardAction: (in category 'actions') -----
+ boardAction: actionSymbol
+
+ actionSymbol = #cardMovedHome ifTrue: [^self cardMovedHome].
+ actionSymbol = #autoMovingHome ifTrue: [^self autoMovingHome].!
Item was added:
+ ----- Method: FreeCell>>buildButton:target:label:selector: (in category 'private') -----
+ buildButton: aButton target: aTarget label: aLabel selector: aSelector
+ "wrap a button or switch in an alignmentMorph to provide some space around the button"
+
+ | a |
+ aButton
+ target: aTarget;
+ label: aLabel;
+ actionSelector: aSelector;
+ borderStyle: (BorderStyle raised width: 2 px);
+ color: Color gray.
+ a := AlignmentMorph newColumn
+ wrapCentering: #center; cellPositioning: #topCenter;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ color: Color transparent;
+ layoutInset: 1 px.
+ a addMorph: aButton.
+ ^ a!
Item was added:
+ ----- Method: FreeCell>>cardMovedHome (in category 'actions') -----
+ cardMovedHome
+
+ cardsRemainingDisplay value: (cardsRemainingDisplay value - 1).
+ autoMoveRecursionCount := autoMoveRecursionCount - 1 max: 0.
+ cardsRemainingDisplay value = 0
+ ifTrue: [self gameWon]
+ ifFalse: [autoMoveRecursionCount = 0 ifTrue: [elapsedTimeDisplay continue]].!
Item was added:
+ ----- Method: FreeCell>>colorNearBottom (in category 'visual properties') -----
+ colorNearBottom
+
+ ^Color r: 0.0 g: 0.455 b: 0.18!
Item was added:
+ ----- Method: FreeCell>>colorNearTop (in category 'visual properties') -----
+ colorNearTop
+
+ ^ (Color r: 0.304 g: 0.833 b: 0.075)!
Item was added:
+ ----- Method: FreeCell>>currentGame (in category 'accessing') -----
+ currentGame
+
+ ^self board cardDeck seed!
Item was added:
+ ----- Method: FreeCell>>defaultBackgroundColor (in category 'user interface') -----
+ defaultBackgroundColor
+
+ ^Color r: 0.365 g: 1.0 b: 0.09!
Item was added:
+ ----- Method: FreeCell>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 2 px!
Item was added:
+ ----- Method: FreeCell>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ self colorNearTop!
Item was added:
+ ----- Method: FreeCell>>fillStyle (in category 'visual properties') -----
+ fillStyle
+
+ myFillStyle ifNil: [
+ myFillStyle := GradientFillStyle ramp: {
+ 0.0 -> self colorNearTop.
+ 1.0 -> self colorNearBottom
+ }.
+ ].
+ ^myFillStyle
+ origin: self position;
+ direction: (self width // 2)@self height
+ !
Item was added:
+ ----- Method: FreeCell>>gameLost (in category 'actions') -----
+ gameLost
+
+ state := #lost.
+ elapsedTimeDisplay stop.
+ cardsRemainingDisplay highlighted: true; flash: true.
+ Statistics gameLost: self currentGame!
Item was added:
+ ----- Method: FreeCell>>gameWon (in category 'actions') -----
+ gameWon
+
+ state := #won.
+ elapsedTimeDisplay stop; highlighted: true; flash: true.
+ Statistics gameWon: self currentGame!
Item was added:
+ ----- Method: FreeCell>>help (in category 'actions') -----
+ help
+
+ self helpText editWithLabel: 'FreeCell Help'.!
Item was added:
+ ----- Method: FreeCell>>helpText (in category 'accessing') -----
+ helpText
+ ^ 'The objective of FreeCell is to move all of the cards to the four "home cells" in the upper right corner. Each home cell will hold one suit and must be filled sequentially starting with the Ace.
+
+ There are four "free cells" in the upper left corner that can each hold one card. Cards can be moved from the bottom of a stack to a free cell or to another stack.
+
+ When moving a card to another stack, it must have a value that is one less than the exposed card and of a different color.' translated!
Item was added:
+ ----- Method: FreeCell>>inAutoMove (in category 'actions') -----
+ inAutoMove
+ "Return true if an automove sequence is in progress"
+
+ ^ autoMoveRecursionCount > 0!
Item was added:
+ ----- Method: FreeCell>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ Statistics newSession.
+ autoMoveRecursionCount := 0.
+ self listDirection: #topToBottom.
+ self wrapCentering: #center;
+ cellPositioning: #topCenter.
+ self vResizing: #shrinkWrap.
+ self hResizing: #shrinkWrap.
+ self
+ addMorph: self makeControls;
+ addMorph: self board;
+ newGame!
Item was added:
+ ----- Method: FreeCell>>makeCardsRemainingDisplay (in category 'initialization') -----
+ makeCardsRemainingDisplay
+ cardsRemainingDisplay := LedMorph new digits: 2;
+ extent: 10 px * 2 @ 15 px.
+ ^ self wrapPanel: cardsRemainingDisplay label: 'Cards Left: ' translated!
Item was added:
+ ----- Method: FreeCell>>makeControlBar (in category 'initialization') -----
+ makeControlBar
+
+ ^AlignmentMorph newRow
+ color: self colorNearBottom;
+ borderStyle: (BorderStyle inset width: 2 px);
+ layoutInset: 0;
+ hResizing: #spaceFill; vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter;
+ yourself.!
Item was added:
+ ----- Method: FreeCell>>makeControls (in category 'initialization') -----
+ makeControls
+
+ ^self makeControlBar
+ addMorph: AlignmentMorph newVariableTransparentSpacer;
+ addMorph: self makeUndoButton;
+ addMorph: self makeHelpButton;
+ addMorph: self makeQuitButton;
+ addMorph: self makeStatisticsButton;
+ addMorph: self makeGameNumberDisplay;
+ addMorph: self makePickGameButton;
+ addMorph: self makeSameGameButton;
+ addMorph: self makeNewGameButton;
+ addMorph: self makeElapsedTimeDisplay;
+ addMorph: self makeCardsRemainingDisplay;
+ yourself.!
Item was added:
+ ----- Method: FreeCell>>makeElapsedTimeDisplay (in category 'initialization') -----
+ makeElapsedTimeDisplay
+ elapsedTimeDisplay := LedTimerMorph new digits: 3;
+ extent: 10 px * 3 @ 15 px.
+ ^ self wrapPanel: elapsedTimeDisplay label: 'Elapsed Time: ' translated!
Item was added:
+ ----- Method: FreeCell>>makeGameNumberDisplay (in category 'initialization') -----
+ makeGameNumberDisplay
+ gameNumberDisplay := LedMorph new digits: 5;
+ extent: 10 px * 5 @ 15 px.
+ ^ self wrapPanel: gameNumberDisplay label: 'Game #: ' translated!
Item was added:
+ ----- Method: FreeCell>>makeHelpButton (in category 'initialization') -----
+ makeHelpButton
+ ^ self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'Help' translated
+ selector: #help!
Item was added:
+ ----- Method: FreeCell>>makeNewGameButton (in category 'initialization') -----
+ makeNewGameButton
+ ^ self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'New game' translated
+ selector: #newGame!
Item was added:
+ ----- Method: FreeCell>>makePickGameButton (in category 'initialization') -----
+ makePickGameButton
+ ^ self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'Pick game' translated
+ selector: #pickGame!
Item was added:
+ ----- Method: FreeCell>>makeQuitButton (in category 'initialization') -----
+ makeQuitButton
+ ^ self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'Quit' translated
+ selector: #quit!
Item was added:
+ ----- Method: FreeCell>>makeSameGameButton (in category 'initialization') -----
+ makeSameGameButton
+ ^ self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'Same game' translated
+ selector: #sameGame!
Item was added:
+ ----- Method: FreeCell>>makeStatisticsButton (in category 'initialization') -----
+ makeStatisticsButton
+ ^ self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'Statistics' translated
+ selector: #statistics!
Item was added:
+ ----- Method: FreeCell>>makeUndoButton (in category 'initialization') -----
+ makeUndoButton
+ ^ self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'Undo' translated
+ selector: #undo!
Item was added:
+ ----- Method: FreeCell>>modelSleep (in category 'user interface') -----
+ modelSleep
+ "When fixing #contains: calls beware of reinventing #includes:"
+ (#(newGame sameGame pickGame won lost ) includes: state)
+ ifTrue: [elapsedTimeDisplay pause]!
Item was added:
+ ----- Method: FreeCell>>modelWakeUp (in category 'user interface') -----
+ modelWakeUp
+ "Maybe less performant but more readable"
+ (#(won lost) includes: state)
+ ifFalse: [elapsedTimeDisplay resume]!
Item was added:
+ ----- Method: FreeCell>>newGame (in category 'actions') -----
+ newGame
+ Collection initialize.
+ self newGameNumber: nil.
+ state := #newGame!
Item was added:
+ ----- Method: FreeCell>>newGameNumber: (in category 'actions') -----
+ newGameNumber: aSeedOrNil
+ cardsRemainingDisplay value ~~ 0 ifTrue: [self gameLost].
+ cardsRemainingDisplay flash: false; highlighted: false; value: 52.
+ elapsedTimeDisplay flash: false; highlighted: false.
+ "board handles nil case"
+ self board pickGame: aSeedOrNil.
+ elapsedTimeDisplay reset; start.
+ gameNumberDisplay value: self currentGame!
Item was added:
+ ----- Method: FreeCell>>openInWindowLabeled:inWorld: (in category 'initialization') -----
+ openInWindowLabeled: aString inWorld: aWorld
+
+ ^(super openInWindowLabeled: aString inWorld: aWorld)
+ model: self;
+ yourself!
Item was added:
+ ----- Method: FreeCell>>pickGame (in category 'actions') -----
+ pickGame
+ | seed |
+ seed := self promptForSeed.
+ seed isNil ifTrue: [^ self].
+ self newGameNumber: seed.
+ state := #pickGame!
Item was added:
+ ----- Method: FreeCell>>promptForSeed (in category 'actions') -----
+ promptForSeed
+ | ss ii hh |
+ [hh := board hardness
+ ifNil: [0].
+ ss := FillInTheBlank request: 'Pick a game number between 1 and 32000.
+ or
+ set the hardness of the next game by typing ''H 30''.
+ Above 100 is very hard. Zero is standard game.
+ Current hardness is: ' translated , hh printString.
+ "Let the user cancel."
+ ss isEmpty
+ ifTrue: [^ nil].
+ ss := ss withoutQuoting.
+ ss first asLowercase == $h
+ ifTrue: ["Set the hardness"
+ [ii := ss numericSuffix]
+ on: Error
+ do: [ii := 0].
+ board hardness: ii.
+ ^ nil].
+ [ii := ss asNumber asInteger]
+ on: Error
+ do: [ii := 0].
+ ii between: 1 and: 32000] whileFalse.
+ ^ ii!
Item was added:
+ ----- Method: FreeCell>>quit (in category 'actions') -----
+ quit
+ cardsRemainingDisplay value ~~ 0 ifTrue: [self gameLost].
+
+ self owner == self world
+ ifTrue: [self delete]
+ ifFalse: [self owner delete].
+ Statistics close!
Item was added:
+ ----- Method: FreeCell>>sameGame (in category 'actions') -----
+ sameGame
+ self newGameNumber: self currentGame.
+ state := #sameGame.
+
+ !
Item was added:
+ ----- Method: FreeCell>>statistics (in category 'actions') -----
+ statistics
+
+ Statistics display!
Item was added:
+ ----- Method: FreeCell>>undo (in category 'actions') -----
+ undo
+
+ ^ self commandHistory undoOrRedoCommand!
Item was added:
+ ----- Method: FreeCell>>wrapPanel:label: (in category 'private') -----
+ wrapPanel: anLedPanel label: aLabel
+ "wrap an LED panel in an alignmentMorph with a label to its left"
+
+ | a |
+ a := AlignmentMorph newRow
+ wrapCentering: #center; cellPositioning: #leftCenter;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ borderWidth: 0;
+ layoutInset: 5 px;
+ color: Color transparent.
+ a addMorph: anLedPanel.
+ a addMorph: (StringMorph contents: aLabel).
+ ^ a!
Item was added:
+ AlignmentMorph subclass: #FreeCellBoard
+ instanceVariableNames: 'cardDeck lastCardDeck freeCells homeCells stacks target actionSelector hardness'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !FreeCellBoard commentStamp: '<historical>' prior: 0!
+ The model of a freecell game. Holds the stacks of cards.
+ cardDeck
+ lastCardDeck
+ freeCells
+ homeCells
+ stacks array of CardDecks of the columns of cards.
+ ----
+ Hardness: a number from 1 to 10000.
+ After dealing, count down the number. For each count, go to next column, pick a ramdom card (with same generator as deck) and move it one place in its stack. This is a kind of bubble sort. Interesting that the slowness of bubble sort is a plus -- gives fine gradation in the hardness.
+ Moving a card: Move red cards to deep half, black to shallow (or vice versa). Within a color, put low cards deep and high cards shallow.
+ If speed is an issue, move several steps at once, decrementing counter.
+
+ (May make it easier? If running columns, need a way to make harder in other ways.)!
Item was added:
+ ----- Method: FreeCellBoard class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: FreeCellBoard>>acceptCard:onStack: (in category 'actions') -----
+ acceptCard: aCard onStack: aDeck
+ " assumes that number of cards was check at drag time, need to reduce count if dropping
+ into an empty stack"
+ aCard hasSubmorphs
+ ifTrue: [
+ aDeck ifEmpty: [
+ (aCard submorphCount+1) > (self maxDraggableStackSize: true)
+ ifTrue: [^false]]]
+ ifFalse: [^ nil].
+ ^nil.
+
+ !
Item was added:
+ ----- Method: FreeCellBoard>>acceptSingleCard:on: (in category 'actions') -----
+ acceptSingleCard: aCard on: aDeck
+ "Home cells and free cells don't accept multiple cards on a home cell,
+ defer to deck for other cases"
+ aCard hasSubmorphs
+ ifTrue: [^ false]
+ ifFalse: [^ nil]!
Item was added:
+ ----- Method: FreeCellBoard>>actionSelector: (in category 'accessing') -----
+ actionSelector: aSymbolOrString
+
+ (nil = aSymbolOrString or:
+ ['nil' = aSymbolOrString or:
+ [aSymbolOrString isEmpty]])
+ ifTrue: [^ actionSelector := nil].
+
+ actionSelector := aSymbolOrString asSymbol.
+ !
Item was added:
+ ----- Method: FreeCellBoard>>addHardness (in category 'hardness') -----
+ addHardness
+ | cnt rand pileInd pile |
+ "post process the layout of cards to make it harder. See class comment."
+
+ hardness ifNil: [^ self].
+ cnt := hardness.
+ rand := Random new seed: cardDeck seed. "Same numbers but different purpose"
+ pileInd := 1.
+ [(cnt := cnt - 1) > 0] whileTrue: [
+ pile := stacks atWrap: (pileInd := pileInd + 1).
+ cnt := cnt - (self makeHarder: pile rand: rand toDo: cnt)]. "mostly 0, but moves cards"!
Item was added:
+ ----- Method: FreeCellBoard>>autoMoveCardsHome (in category 'private') -----
+ autoMoveCardsHome
+ | first |
+
+ first := false.
+ (self stacks, self freeCells) do: [:deck |
+ self homeCells do: [ :homeCell |
+ deck hasCards ifTrue: [
+ (homeCell repelCard: deck topCard) ifFalse: [
+ (self isPlayableCardInHomeCells: deck topCard) ifTrue: [
+ first ifFalse: [ " trigger autoMoving event on first move."
+ first := true.
+ self performActionSelector: #autoMovingHome
+ ].
+ self visiblyMove: deck topCard to: homeCell.
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ !
Item was added:
+ ----- Method: FreeCellBoard>>captureStateBeforeGrab (in category 'undo') -----
+ captureStateBeforeGrab
+
+ self removeProperty: #stateBeforeGrab.
+ self setProperty: #stateBeforeGrab toValue: self capturedState
+ !
Item was added:
+ ----- Method: FreeCellBoard>>capturedState (in category 'undo') -----
+ capturedState
+
+ self valueOfProperty: #stateBeforeGrab ifPresentDo: [:st | ^ st].
+ ^ { freeCells collect: [:deck | deck submorphs].
+ homeCells collect: [:deck | deck submorphs].
+ stacks collect: [:deck | deck submorphs] }
+ !
Item was added:
+ ----- Method: FreeCellBoard>>cardCell (in category 'layout') -----
+ cardCell
+
+ ^PlayingCardDeck new
+ layout: #pile;
+ listDirection: #topToBottom;
+ enableDragNDrop;
+ color: Color transparent;
+ borderColor: (Color gray alpha: 0.5);
+ borderWidth: 2 px;
+ layoutBounds: (0@0 extent: PlayingCardMorph width @ PlayingCardMorph height);
+ yourself!
Item was added:
+ ----- Method: FreeCellBoard>>cardDeck (in category 'accessing') -----
+ cardDeck
+ ^cardDeck!
Item was added:
+ ----- Method: FreeCellBoard>>cardMoved (in category 'actions') -----
+ cardMoved
+ "Free cells and stacks do nothing special here - yet - th 12/15/1999
+ 16:15 "
+ self autoMoveCardsHome!
Item was added:
+ ----- Method: FreeCellBoard>>cardMovedHome (in category 'actions') -----
+ cardMovedHome
+
+ self autoMoveCardsHome.
+ self performActionSelector: #cardMovedHome.!
Item was added:
+ ----- Method: FreeCellBoard>>cellsRow (in category 'layout') -----
+ cellsRow
+ | row |
+
+ row := (AlignmentMorph newRow)
+ vResizing: #shrinkWrap;
+ hResizing: #shrinkWrap;
+ color: Color transparent;
+ addAllMorphs: self freeCells;
+ addMorphBack: self cellsRowSpacer;
+ addAllMorphs: self homeCells;
+ yourself.
+ ^row!
Item was added:
+ ----- Method: FreeCellBoard>>cellsRowSpacer (in category 'layout') -----
+ cellsRowSpacer
+ | column |
+
+ column := (AlignmentMorph newColumn)
+ vResizing: #rigid;
+ hResizing: #rigid;
+ color: Color transparent;
+ extent: PlayingCardMorph cardSize;
+ yourself.
+ ^column!
Item was added:
+ ----- Method: FreeCellBoard>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color green!
Item was added:
+ ----- Method: FreeCellBoard>>doubleClickInStack:OnCard: (in category 'actions') -----
+ doubleClickInStack: aDeck OnCard: aCard
+
+ "if there is an empty free cell, move the card there. otherwise try for an empty stack"
+
+ aCard == aDeck topCard ifFalse: [^self].
+ freeCells do: [:freeCell |
+ freeCell ifEmpty: [
+ self visiblyMove: aCard to: freeCell.
+ ^ aCard
+ ]
+ ].
+ stacks do: [ :each |
+ each ifEmpty: [
+ self visiblyMove: aCard to: each.
+ ^ aCard
+ ]
+ ].
+ !
Item was added:
+ ----- Method: FreeCellBoard>>dragCard:fromHome: (in category 'actions') -----
+ dragCard: aCard fromHome: aCardDeck
+
+ ^nil "don't allow any cards to be dragged from a home cell"!
Item was added:
+ ----- Method: FreeCellBoard>>dragCard:fromStack: (in category 'actions') -----
+ dragCard: aCard fromStack: aCardDeck
+ | i cards |
+
+ cards := aCardDeck cards.
+ i := cards indexOf: aCard ifAbsent: [^ nil].
+ i > (self maxDraggableStackSize: false) ifTrue: [^ nil].
+ [i > 1] whileTrue:
+ [(aCardDeck inStackingOrder: (cards at: i-1)
+ onTopOf: (cards at: i)) ifFalse: [^ nil].
+ i := i-1].
+ ^ aCard!
Item was added:
+ ----- Method: FreeCellBoard>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ "we don't have anything to draw, but we need a color so the inset border of one of our submorphs will work"
+ !
Item was added:
+ ----- Method: FreeCellBoard>>freeCell (in category 'layout') -----
+ freeCell
+ | freeCell |
+ freeCell := self cardCell.
+ freeCell stackingPolicy: #single;
+ emptyDropPolicy: #any;
+ target: self;
+ cardDroppedSelector: #cardMoved;
+ acceptCardSelector: #acceptSingleCard:on:.
+ ^ freeCell!
Item was added:
+ ----- Method: FreeCellBoard>>freeCells (in category 'layout') -----
+ freeCells
+
+ ^freeCells ifNil: [freeCells := (1 to: 4) collect: [:i | self freeCell]]!
Item was added:
+ ----- Method: FreeCellBoard>>hardness (in category 'accessing') -----
+ hardness
+ ^ hardness!
Item was added:
+ ----- Method: FreeCellBoard>>hardness: (in category 'accessing') -----
+ hardness: integer
+ hardness := integer "or nil"!
Item was added:
+ ----- Method: FreeCellBoard>>homeCell (in category 'layout') -----
+ homeCell
+ | homeCell |
+ homeCell := self cardCell.
+ homeCell stackingPolicy: #straight;
+ stackingOrder: #ascending;
+ emptyDropPolicy: #inOrder;
+ target: self;
+ cardDroppedSelector: #cardMovedHome;
+ cardDraggedSelector: #dragCard:fromHome:;
+ acceptCardSelector: #acceptSingleCard:on:.
+ ^ homeCell!
Item was added:
+ ----- Method: FreeCellBoard>>homeCells (in category 'layout') -----
+ homeCells
+
+ ^homeCells ifNil: [homeCells := (1 to: 4) collect: [:i | self homeCell]]!
Item was added:
+ ----- Method: FreeCellBoard>>inAutoMove (in category 'actions') -----
+ inAutoMove
+ "Return true if an automove sequence is in progress"
+
+ ^ owner inAutoMove!
Item was added:
+ ----- Method: FreeCellBoard>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ self listDirection: #topToBottom;
+ hResizing: #shrinkWrap;
+ vResizing: #rigid;
+ height: 500 px;
+ layout!
Item was added:
+ ----- Method: FreeCellBoard>>isPlayableCardInHomeCells: (in category 'private') -----
+ isPlayableCardInHomeCells: aPlayingCard
+ | unplayedOther topsThisColor topsOtherColor unplayedSame |
+ " are all cards that could be played on this card if it stayed on the stack present in the
+ home cells?"
+
+ aPlayingCard cardNumber <= 2 ifTrue: [^true]. "special case for Aces and 2's"
+ topsThisColor := OrderedCollection new.
+ topsOtherColor := OrderedCollection new.
+ self homeCells do: [ :deck |
+ deck hasCards ifTrue: [
+ (aPlayingCard suitColor == deck topCard suitColor
+ ifTrue: [topsThisColor] ifFalse: [topsOtherColor]) add: deck topCard cardNumber.
+ ]
+ ].
+ unplayedOther := topsOtherColor size < 2 ifTrue: [1] ifFalse: [topsOtherColor min + 1].
+ unplayedSame := topsThisColor size < 2 ifTrue: [1] ifFalse: [topsThisColor min + 1].
+ unplayedOther > (aPlayingCard cardNumber - 1) ifTrue: [^true].
+ unplayedOther < (aPlayingCard cardNumber - 1) ifTrue: [^false].
+ ^unplayedSame >= (unplayedOther - 1)
+ !
Item was added:
+ ----- Method: FreeCellBoard>>layout (in category 'layout') -----
+ layout
+
+ self
+ addMorphBack: self cellsRow;
+ addMorphBack: self stacksRow.
+ !
Item was added:
+ ----- Method: FreeCellBoard>>makeHarder:rand:toDo: (in category 'hardness') -----
+ makeHarder: pile rand: rand toDo: cnt
+ | deepColor ind thisPile thisCard otherCard |
+ "Move cards in a stack to make it harder. Pick a card from the pile. Only consider moving it deeper (toward last of pile)."
+
+ deepColor := stacks first cards last suitColor.
+ ind := ((pile cards size - 1) atRandom: rand). "front card"
+ thisPile := pile cards. "submorphs array. We will stomp it."
+ thisCard := thisPile at: ind.
+ otherCard := thisPile at: ind+1.
+
+ "Move deepColor cards deeper, past cards of the other color"
+ (thisCard suitColor == deepColor) & (otherCard suitColor ~~ deepColor) ifTrue: [
+ thisPile at: ind put: otherCard.
+ thisPile at: ind+1 put: thisCard.
+ ^ 0]. "single moves for now. Make multiple when it's too slow this way"
+
+ "When colors the same, move low numbered cards deeper, past high cards"
+ (thisCard suitColor == otherCard suitColor) ifTrue: [
+ (thisCard cardNumber < otherCard cardNumber) ifTrue: [
+ thisPile at: ind put: otherCard.
+ thisPile at: ind+1 put: thisCard.
+ ^ 0]]. "single moves for now. Make multiple when it's too slow this way"
+ ^ 0!
Item was added:
+ ----- Method: FreeCellBoard>>maxDraggableStackSize: (in category 'private') -----
+ maxDraggableStackSize: dropIntoEmptyStack
+ "Note: dropIntoEmptyStack, means one less empty stack to work with.
+ This needs to be reevaluated at time of drop."
+ "Not super smart - doesn't use stacks that are buildable though not empty"
+
+ | nFree nEmptyStacks |
+ nFree := (freeCells select: [:d | d hasCards not]) size.
+ nEmptyStacks := (stacks select: [:d | d hasCards not]) size.
+ dropIntoEmptyStack ifTrue: [nEmptyStacks := nEmptyStacks - 1].
+ ^ (1 + nFree) * (2 raisedTo: nEmptyStacks)!
Item was added:
+ ----- Method: FreeCellBoard>>performActionSelector: (in category 'private') -----
+ performActionSelector: actionSymbol
+ (target notNil and: [actionSelector notNil])
+ ifTrue: [target perform: actionSelector with: actionSymbol]!
Item was added:
+ ----- Method: FreeCellBoard>>pickGame: (in category 'initialization') -----
+ pickGame: aSeedOrNil
+ | sorted msg |
+ cardDeck := PlayingCardDeck newDeck.
+ aSeedOrNil == 1
+ ifTrue: ["Special case of game 1 does a time profile playing the entire
+ (trivial) game."
+ sorted := cardDeck submorphs
+ sorted: [:a :b | a cardNumber >= b cardNumber].
+ cardDeck removeAllMorphs; addAllMorphs: sorted.
+ self resetBoard.
+ self world doOneCycle.
+ Utilities
+ informUser: 'Game #1 is a special case
+ for performance analysis' translated
+ during: [msg := self world firstSubmorph.
+ msg align: msg topRight with: owner bottomRight.
+ MessageTally
+ spyOn: [sorted last owner doubleClickOnCard: sorted last]]]
+ ifFalse: [aSeedOrNil
+ ifNotNil: [cardDeck seed: aSeedOrNil].
+ cardDeck shuffle.
+ self resetBoard]!
Item was added:
+ ----- Method: FreeCellBoard>>rememberUndoableAction:named: (in category 'undo') -----
+ rememberUndoableAction: aBlock named: caption
+
+ self inAutoMove ifTrue: [^ aBlock value].
+ ^ super rememberUndoableAction: aBlock named: caption!
Item was added:
+ ----- Method: FreeCellBoard>>resetBoard (in category 'initialization') -----
+ resetBoard
+
+ self purgeAllCommands.
+ self resetFreeCells;
+ resetHomeCells;
+ resetStacks;
+ addHardness;
+ changed.!
Item was added:
+ ----- Method: FreeCellBoard>>resetFreeCells (in category 'initialization') -----
+ resetFreeCells
+
+ freeCells do: [:deck | deck removeAllCards]!
Item was added:
+ ----- Method: FreeCellBoard>>resetHomeCells (in category 'initialization') -----
+ resetHomeCells
+
+ homeCells do: [:deck | deck removeAllCards]!
Item was added:
+ ----- Method: FreeCellBoard>>resetStacks (in category 'initialization') -----
+ resetStacks
+ | card stackStream stack |
+
+ stacks do: [:deck | deck removeAllCards].
+ stackStream := ReadStream on: stacks.
+ [card := cardDeck deal.
+ card notNil] whileTrue: [
+ stack := stackStream next ifNil: [stackStream reset; next].
+ stack addCard: card].
+ !
Item was added:
+ ----- Method: FreeCellBoard>>stack (in category 'card in a stack') -----
+ stack
+ ^ PlayingCardDeck new color: Color transparent;
+ layout: #stagger;
+ listDirection: #topToBottom;
+ enableDragNDrop;
+ stackingPolicy: #altStraight;
+ stackingOrder: #descending;
+ emptyDropPolicy: #any;
+ target: self;
+ cardDroppedSelector: #cardMoved;
+ cardDraggedSelector: #dragCard:fromStack:;
+ acceptCardSelector: #acceptCard:onStack:;
+ cardDoubleClickSelector: #doubleClickInStack:OnCard:!
Item was added:
+ ----- Method: FreeCellBoard>>stacks (in category 'layout') -----
+ stacks
+
+ ^stacks ifNil: [stacks:= (1 to: 8) collect: [:i | self stack]]!
Item was added:
+ ----- Method: FreeCellBoard>>stacksRow (in category 'layout') -----
+ stacksRow
+ | row |
+
+ row := (AlignmentMorph newRow)
+ vResizing: #spaceFill;
+ hResizing: #spaceFill;
+ wrapCentering: #topLeft;
+ cellPositioning: #topLeft;
+ color: Color transparent;
+ yourself.
+ self stacks do: [:stack |
+ row
+ addMorphBack: AlignmentMorph newVariableTransparentSpacer;
+ addMorphBack: stack].
+ row addMorphBack: AlignmentMorph newVariableTransparentSpacer.
+ ^row!
Item was added:
+ ----- Method: FreeCellBoard>>target: (in category 'accessing') -----
+ target: anObject
+
+ target := anObject!
Item was added:
+ ----- Method: FreeCellBoard>>undoFromCapturedState: (in category 'undo') -----
+ undoFromCapturedState: st
+ freeCells with: st first do: [:deck :morphs | deck removeAllMorphs; addAllMorphs: morphs].
+ homeCells with: st second do: [:deck :morphs | deck removeAllMorphs; addAllMorphs: morphs].
+ stacks with: st third do: [:deck :morphs | deck removeAllMorphs; addAllMorphs: morphs]!
Item was added:
+ ----- Method: FreeCellBoard>>visiblyMove:to: (in category 'private') -----
+ visiblyMove: aCard to: aCell
+ | p1 p2 nSteps |
+ self inAutoMove ifFalse: [self captureStateBeforeGrab].
+ owner owner addMorphFront: aCard.
+ p1 := aCard position.
+ p2 := aCell position.
+ nSteps := 10.
+ 1 to: nSteps-1 do: "Note final step happens with actual drop"
+ [:i | aCard position: ((p2*i) + (p1*(nSteps-i))) // nSteps.
+ self world displayWorld].
+ aCell acceptDroppingMorph: aCard event: nil!
Item was added:
+ Object subclass: #FreeCellStatistics
+ instanceVariableNames: 'sessionWins sessionLosses totalWins totalLosses streakWins streakLosses winsWithReplay lossesWithReplay lastGameWon lastGameLost currentCount currentType window statsMorph'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
Item was added:
+ ----- Method: FreeCellStatistics class>>includeInNewMorphMenu (in category 'instance creation') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: FreeCellStatistics>>buildButton:target:label:selector: (in category 'user interface') -----
+ buildButton: aButton target: aTarget label: aLabel selector: aSelector
+ "wrap a button or switch in an alignmentMorph to provide some space around the button"
+
+ | a |
+ aButton
+ target: aTarget;
+ label: aLabel;
+ actionSelector: aSelector;
+ borderStyle: (BorderStyle raised width: 2 px);
+ color: Color gray.
+ a := AlignmentMorph newColumn
+ wrapCentering: #center; cellPositioning: #topCenter;
+ hResizing: #spaceFill;
+ vResizing: #shrinkWrap;
+ color: Color transparent;
+ layoutInset: 1 px.
+ a addMorph: aButton.
+ ^ a!
Item was added:
+ ----- Method: FreeCellStatistics>>changed (in category 'updating') -----
+ changed
+
+ window ifNotNil: [
+ statsMorph ifNotNil: [statsMorph contents: self statsText]]!
Item was added:
+ ----- Method: FreeCellStatistics>>close (in category 'user interface') -----
+ close
+
+ window ifNotNil: [
+ window delete.
+ window := nil].!
Item was added:
+ ----- Method: FreeCellStatistics>>color (in category 'user interface') -----
+ color
+
+ ^Color green darker!
Item was added:
+ ----- Method: FreeCellStatistics>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color green!
Item was added:
+ ----- Method: FreeCellStatistics>>display (in category 'user interface') -----
+ display
+ | panel |
+
+ (window notNil and: [window owner notNil]) ifTrue: [window activate. ^nil].
+ panel := AlignmentMorph newColumn.
+ panel
+ wrapCentering: #center; cellPositioning: #topCenter;
+ hResizing: #rigid;
+ vResizing: #rigid;
+ extent: 250 px @ 150 px;
+ color: self color;
+ addMorphBack: self makeStatistics;
+ addMorphBack: self makeControls.
+ window := panel openInWindowLabeled: 'FreeCell Statistics' translated.!
Item was added:
+ ----- Method: FreeCellStatistics>>gameLost: (in category 'actions') -----
+ gameLost: gameNumber
+
+ "Don't count multiple losses of the same game"
+ gameNumber = lastGameLost ifTrue: [^ self].
+ lastGameLost := gameNumber.
+
+ sessionLosses := sessionLosses + 1.
+ totalLosses := totalLosses + 1.
+ lossesWithReplay := lossesWithReplay + 1.
+ currentType = #losses
+ ifTrue: [currentCount := currentCount + 1]
+ ifFalse:
+ [currentCount := 1.
+ currentType := #losses].
+ self updateStreak.
+ self changed!
Item was added:
+ ----- Method: FreeCellStatistics>>gameWon: (in category 'actions') -----
+ gameWon: gameNumber
+ sessionWins := sessionWins + 1.
+ totalWins := totalWins + 1.
+ gameNumber = lastGameWon ifFalse:
+ [gameNumber = lastGameLost ifTrue:
+ ["Finally won a game by replaying"
+ lossesWithReplay := lossesWithReplay - 1].
+ winsWithReplay := winsWithReplay + 1].
+ lastGameWon := gameNumber.
+ currentType = #wins
+ ifTrue: [currentCount := currentCount + 1]
+ ifFalse: [currentCount := 1.
+ currentType := #wins].
+ self updateStreak.
+ self changed!
Item was added:
+ ----- Method: FreeCellStatistics>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ self reset!
Item was added:
+ ----- Method: FreeCellStatistics>>makeControls (in category 'user interface') -----
+ makeControls
+ | row |
+
+ row := AlignmentMorph newRow.
+ row
+ wrapCentering: #center; cellPositioning: #leftCenter;
+ hResizing: #spaceFill;
+ vResizing: #shrinkWrap;
+ color: self color;
+ borderStyle: (BorderStyle inset width: 2 px);
+ addMorphBack: self makeOkButton;
+ addMorphBack: self makeResetButton.
+ ^row.!
Item was added:
+ ----- Method: FreeCellStatistics>>makeOkButton (in category 'user interface') -----
+ makeOkButton
+
+ ^self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'OK' translated
+ selector: #ok!
Item was added:
+ ----- Method: FreeCellStatistics>>makeResetButton (in category 'user interface') -----
+ makeResetButton
+
+ ^self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'Reset' translated
+ selector: #reset!
Item was added:
+ ----- Method: FreeCellStatistics>>makeStatistics (in category 'user interface') -----
+ makeStatistics
+ | row |
+
+ row := AlignmentMorph newRow.
+ row
+ wrapCentering: #center; cellPositioning: #leftCenter;
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ color: self color;
+ borderStyle: (BorderStyle inset width: 2 px);
+ addMorphBack: (AlignmentMorph newColumn
+ wrapCentering: #center; cellPositioning: #topCenter;
+ color: self color;
+ addMorph: (statsMorph := TextMorph new contents: self statsText)).
+ ^row.!
Item was added:
+ ----- Method: FreeCellStatistics>>newSession (in category 'actions') -----
+ newSession
+
+ sessionWins := 0.
+ sessionLosses := 0.
+ currentCount := 0.
+ currentType := nil.
+ self changed.!
Item was added:
+ ----- Method: FreeCellStatistics>>ok (in category 'actions') -----
+ ok
+
+ window delete.
+ window := nil.!
Item was added:
+ ----- Method: FreeCellStatistics>>print:type:on: (in category 'printing') -----
+ print: aNumber type: type on: aStream
+ "I moved the code from #printWins:on: and #printLosses:on: here because
+ it is basically
+ the same. I hope this increases the maintainability. - th 12/20/1999 20:37"
+ aStream print: aNumber.
+ type = #wins
+ ifTrue: [aNumber = 1
+ ifTrue: [aStream nextPutAll: ' win' translated]
+ ifFalse: [aStream nextPutAll: ' wins' translated]].
+ type = #losses
+ ifTrue: [aNumber = 1
+ ifTrue: [aStream nextPutAll: ' loss' translated]
+ ifFalse: [aStream nextPutAll: ' losses' translated]]!
Item was added:
+ ----- Method: FreeCellStatistics>>printOn: (in category 'printing') -----
+ printOn: aStream
+
+ self printSessionOn: aStream.
+ aStream cr.
+ self printTotalOn: aStream.
+ aStream cr.
+ self printReplaysOn: aStream.
+ aStream cr.
+ self printStreaksOn: aStream.!
Item was added:
+ ----- Method: FreeCellStatistics>>printReplaysOn: (in category 'printing') -----
+ printReplaysOn: aStream
+ | total |
+ aStream nextPutAll: 'With replays: ' translated;
+ tab.
+ self
+ print: winsWithReplay
+ type: #wins
+ on: aStream.
+ aStream nextPutAll: ', '.
+ self
+ print: lossesWithReplay
+ type: #losses
+ on: aStream.
+ total := winsWithReplay + lossesWithReplay.
+ total ~~ 0
+ ifTrue: [aStream nextPutAll: ', ';
+ print: (winsWithReplay / total * 100) asInteger;
+ nextPut: $%]!
Item was added:
+ ----- Method: FreeCellStatistics>>printSessionOn: (in category 'printing') -----
+ printSessionOn: aStream
+ | total |
+ aStream nextPutAll: 'This session: ' translated, String tab.
+ self
+ print: sessionWins
+ type: #wins
+ on: aStream.
+ aStream nextPutAll: ', '.
+ self
+ print: sessionLosses
+ type: #losses
+ on: aStream.
+ total := sessionWins + sessionLosses.
+ total ~~ 0
+ ifTrue: [aStream nextPutAll: ', ';
+ print: (sessionWins / total * 100) asInteger;
+ nextPut: $%]!
Item was added:
+ ----- Method: FreeCellStatistics>>printStreaksOn: (in category 'printing') -----
+ printStreaksOn: aStream
+ aStream nextPutAll: 'Streaks: ' translated;
+ tab;
+ tab.
+ self
+ print: streakWins
+ type: #wins
+ on: aStream.
+ aStream nextPutAll: ', '.
+ self
+ print: streakLosses
+ type: #losses
+ on: aStream.
+ aStream cr; tab; tab; tab; tab; nextPutAll: 'Current: ' translated.
+ self
+ print: currentCount
+ type: currentType
+ on: aStream!
Item was added:
+ ----- Method: FreeCellStatistics>>printTotalOn: (in category 'printing') -----
+ printTotalOn: aStream
+ | total |
+ aStream nextPutAll: 'Total: ' translated;
+ tab;
+ tab;
+ tab.
+ self
+ print: totalWins
+ type: #wins
+ on: aStream.
+ aStream nextPutAll: ', '.
+ self
+ print: totalLosses
+ type: #losses
+ on: aStream.
+ total := totalWins + totalLosses.
+ total ~~ 0
+ ifTrue: [aStream nextPutAll: ', ';
+ print: (totalWins / total * 100) asInteger;
+ nextPut: $%]!
Item was added:
+ ----- Method: FreeCellStatistics>>reset (in category 'actions') -----
+ reset
+
+ sessionWins := 0.
+ sessionLosses := 0.
+ totalWins := 0.
+ totalLosses := 0.
+ streakWins := 0.
+ streakLosses := 0.
+ winsWithReplay := 0.
+ lossesWithReplay := 0.
+ lastGameWon := 0.
+ lastGameLost := 0.
+ currentCount := 0.
+ currentType := nil.
+ self changed!
Item was added:
+ ----- Method: FreeCellStatistics>>statsText (in category 'user interface') -----
+ statsText
+
+ ^ String cr,self printString,String cr!
Item was added:
+ ----- Method: FreeCellStatistics>>stringMorphFromPrintOn: (in category 'user interface') -----
+ stringMorphFromPrintOn: aSelector
+
+ ^StringMorph new
+ contents: (String streamContents: [:s | self perform: aSelector with: s]);
+ yourself.!
Item was added:
+ ----- Method: FreeCellStatistics>>updateStreak (in category 'actions') -----
+ updateStreak
+ "I moved the code from #printWins:on: and #printLosses:on: here because
+ it is basically the same. I hope this increases the maintainability.
+ th 12/20/1999 20:41"
+ currentType = #losses ifTrue: [streakLosses := streakLosses max: currentCount].
+ currentType = #wins ifTrue: [streakWins := streakWins max: currentCount]!
Item was added:
+ RectangleMorph subclass: #HeadingMorph
+ instanceVariableNames: 'degrees magnitude'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Demo'!
Item was added:
+ ----- Method: HeadingMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 1!
Item was added:
+ ----- Method: HeadingMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color
+ r: 0.6
+ g: 1.0
+ b: 1.0!
Item was added:
+ ----- Method: HeadingMorph>>degrees (in category 'accessing') -----
+ degrees
+
+ ^ (degrees + 90.0) \\ 360.0!
Item was added:
+ ----- Method: HeadingMorph>>degrees: (in category 'accessing') -----
+ degrees: aNumber
+
+ degrees := (aNumber asFloat + 270.0) \\ 360.0.!
Item was added:
+ ----- Method: HeadingMorph>>drawArrowFrom:to:width:color:on: (in category 'drawing') -----
+ drawArrowFrom: p1 to: p2 width: w color: aColor on: aCanvas
+
+ | d p |
+ d := (p1 - p2) theta radiansToDegrees.
+ aCanvas line: p1 to: p2 width: w color: aColor.
+ p := p2 + (Point r: 5 degrees: d - 50).
+ aCanvas line: p to: p2 width: w color: aColor.
+ p := p2 + (Point r: 5 degrees: d + 50).
+ aCanvas line: p to: p2 width: w color: aColor.
+ !
Item was added:
+ ----- Method: HeadingMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ | x y r center box |
+ super drawOn: aCanvas.
+ box := self innerBounds.
+ 1 to: 9 do: [:i |
+ x := box left + ((box width * i) // 10).
+ aCanvas line: (x@box top) to: (x@(box bottom - 1)) color:
+ Color black.
+ y := box top + ((box height * i) // 10).
+ aCanvas line: (box left@y) to: ((box right - 1)@y) color:
+ Color black].
+
+ r := ((box width asFloat * magnitude asFloat) / 2.0) - 1.0.
+ center := box center.
+ self drawArrowFrom: center - (1@1)
+ to: center + ((r * degrees degreesToRadians cos)@0) - (1@1)
+ width: 3
+ color: (Color red)
+ on: aCanvas.
+ self drawArrowFrom: center - (1@1)
+ to: center + (0@(r * degrees degreesToRadians sin)) - (1@1)
+ width: 3
+ color: (Color red)
+ on: aCanvas.
+ self drawArrowFrom: center - (1@1)
+ to: center + (Point r: r degrees: degrees) - (1@1)
+ width: 3
+ color: Color black
+ on: aCanvas.
+ !
Item was added:
+ ----- Method: HeadingMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "Contrain extent to be square."
+
+ | d |
+ d := aPoint x min: aPoint y.
+ super extent: d@d.
+ !
Item was added:
+ ----- Method: HeadingMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ ^ true
+ !
Item was added:
+ ----- Method: HeadingMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ degrees := 90.0.
+ magnitude := 1.0.
+
+ self extent: 160 @ 160!
Item was added:
+ ----- Method: HeadingMorph>>magnitude (in category 'accessing') -----
+ magnitude
+
+ ^ magnitude!
Item was added:
+ ----- Method: HeadingMorph>>magnitude: (in category 'accessing') -----
+ magnitude: aNumber
+
+ magnitude := (aNumber asFloat max: 0.0) min: 1.0.!
Item was added:
+ ----- Method: HeadingMorph>>mouseDown: (in category 'events') -----
+ mouseDown: evt
+
+ | v |
+ self changed.
+ v := evt cursorPoint - bounds center.
+ degrees := v theta radiansToDegrees.
+ magnitude := (v r asFloat / (bounds width asFloat / 2.0)) min: 1.0.
+ !
Item was added:
+ ----- Method: HeadingMorph>>mouseMove: (in category 'events') -----
+ mouseMove: evt
+
+ self mouseDown: evt!
Item was added:
+ ImageMorph subclass: #ImageMorphWithSpotlight
+ instanceVariableNames: 'spotImage spotShape spotBuffer spotOn'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Demo'!
+
+ !ImageMorphWithSpotlight commentStamp: '<historical>' prior: 0!
+ This class implements an image that appears one way or another depending upon whether it lies within a spotlight shape that moves with the cursor. As delivered, the shape is a simple circle, the spotlighted appearance is that of a ColorForm, and the non-highlighted apperarance is a derived gray-scale form.
+
+ The implementation will space-efficient if supplied with a ColorForm, because the gray-scale derived form will share the same bitmap.
+
+ In general, any two images can be used -- one could be blurred, the other sharp -- and the masking form can be any shape.
+
+ At some point this class should be merged somehow with ScreeningMorph.!
Item was added:
+ ----- Method: ImageMorphWithSpotlight>>backgroundImage:spotImage:spotShape: (in category 'all') -----
+ backgroundImage: bkgndImage spotImage: anImage spotShape: formOfDepth1
+
+ "See class comment."
+ spotImage := anImage.
+ spotShape := formOfDepth1.
+ spotBuffer := Form extent: spotShape extent depth: spotImage depth.
+ super image: bkgndImage.
+ spotOn := false.!
Item was added:
+ ----- Method: ImageMorphWithSpotlight>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ super drawOn: aCanvas.
+ spotOn ifTrue:
+ [aCanvas paintImage: spotBuffer at: spotBuffer offset].
+ !
Item was added:
+ ----- Method: ImageMorphWithSpotlight>>image: (in category 'accessing') -----
+ image: anImage
+
+ "The spotlight will reveal the original form supplied
+ while the background form will be derived grayscale."
+ "See class comment."
+ self backgroundImage: anImage asGrayScale
+ spotImage: anImage
+ spotShape: (Form dotOfSize: 100)
+ !
Item was added:
+ ----- Method: ImageMorphWithSpotlight>>spotChanged (in category 'all') -----
+ spotChanged
+
+ self invalidRect:
+ ((spotBuffer offset extent: spotBuffer extent) "intersect: self bounds")!
Item was added:
+ ----- Method: ImageMorphWithSpotlight>>step (in category 'stepping') -----
+ step
+ | cp |
+ ((self bounds expandBy: spotBuffer extent // 2) containsPoint: (cp := self cursorPoint))
+ ifTrue:
+ [(cp - (spotBuffer extent // 2)) = spotBuffer offset ifTrue: [^ self]. "No change"
+ "Cursor has moved where its spotShape is visible"
+ spotOn := true.
+ self spotChanged.
+ spotBuffer offset: cp - (spotBuffer extent // 2).
+ self spotChanged.
+ (BitBlt current toForm: spotBuffer)
+ "clear the buffer"
+ fill: spotBuffer boundingBox fillColor: (Bitmap with: 0) rule: Form over;
+ "Clip anything outside the base form"
+ clipRect: (spotBuffer boundingBox
+ intersect: (self bounds translateBy: spotBuffer offset negated));
+ "Fill the spotBuffer with the spot image"
+ copyForm: spotImage to: self position - spotBuffer offset rule: Form over;
+ "Mask everything outside the spot shape to 0 (transparent)."
+ copyForm: spotShape to: spotShape offset negated rule: Form and
+ colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)]
+ ifFalse:
+ [spotOn ifTrue: [self spotChanged. spotOn := false]]!
Item was added:
+ ----- Method: ImageMorphWithSpotlight>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^ 20!
Item was added:
+ StringMorph subclass: #InfoStringMorph
+ instanceVariableNames: 'stepTime block'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Demo'!
+
+ !InfoStringMorph commentStamp: '<historical>' prior: 0!
+ A generalization of the clock morph
+
+ Try
+ InfoStringMorph new openInWorld
+ or
+ (InfoStringMorph on: [Smalltalk vmParameterAt: 9])
+ stepTime: 50;
+ openInWorld!
Item was added:
+ ----- Method: InfoStringMorph class>>on: (in category 'instance creation') -----
+ on: aBlock
+ ^ self new block: aBlock!
Item was added:
+ ----- Method: InfoStringMorph>>block (in category 'accessing') -----
+ block
+ ^ block!
Item was added:
+ ----- Method: InfoStringMorph>>block: (in category 'accessing') -----
+ block: aBlock
+ block := aBlock!
Item was added:
+ ----- Method: InfoStringMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ stepTime := 1000.
+ block := [Time now]!
Item was added:
+ ----- Method: InfoStringMorph>>step (in category 'stepping') -----
+ step
+ self contents: block value asString!
Item was added:
+ ----- Method: InfoStringMorph>>stepTime (in category 'testing') -----
+ stepTime
+ ^ stepTime!
Item was added:
+ ----- Method: InfoStringMorph>>stepTime: (in category 'accessing') -----
+ stepTime: anInteger
+ stepTime := anInteger!
Item was added:
+ AlignmentMorph subclass: #Mines
+ instanceVariableNames: 'board minesDisplay timeDisplay helpText level levelButton hiScoreDisplay'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
Item was added:
+ ----- Method: Mines class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Mines' translatedNoop
+ categories: {'Games' translatedNoop}
+ documentation: 'Find those mines' translatedNoop!
Item was added:
+ ----- Method: Mines>>board (in category 'access') -----
+ board
+
+ board ifNil:
+ [board := MinesBoard new
+ target: self;
+ actionSelector: #selection].
+ ^ board!
Item was added:
+ ----- Method: Mines>>buildButton:target:label:selector: (in category 'initialize') -----
+ buildButton: aButton target: aTarget label: aLabel selector: aSelector
+ "wrap a button or switch in an alignmentMorph to allow a row of buttons to fill space"
+
+ | a |
+ aButton
+ target: aTarget;
+ label: aLabel;
+ actionSelector: aSelector;
+ borderStyle: (BorderStyle raised width: 2);
+ color: color.
+ a := AlignmentMorph newColumn
+ wrapCentering: #center; cellPositioning: #topCenter;
+ hResizing: #spaceFill;
+ vResizing: #shrinkWrap;
+ color: color.
+ a addMorph: aButton.
+ ^ a
+
+ !
Item was added:
+ ----- Method: Mines>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ ^ Color transparent!
Item was added:
+ ----- Method: Mines>>defaultBorderStyle (in category 'initialization') -----
+ defaultBorderStyle
+ ^ BorderStyle raised!
Item was added:
+ ----- Method: Mines>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 2 px!
Item was added:
+ ----- Method: Mines>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color lightGray!
Item was added:
+ ----- Method: Mines>>help: (in category 'actions') -----
+ help: helpState
+
+ helpState
+ ifTrue: [self addMorphBack: self helpText]
+ ifFalse: [helpText delete]!
Item was added:
+ ----- Method: Mines>>helpString (in category 'access') -----
+ helpString
+ ^ 'Mines is a quick and dirty knock-off of the Minesweeper game found on Windows. I used this to teach myself Squeak. I liberally borrowed from the <SameGame> example, so the code should look pretty familiar, though like any project it has rapidly ...morphed... to reflect my own idiosyncracies. Note especially the lack of any idiomatic structure to the code - I simply haven''t learned them yet.
+
+ Mines is a very simple, yet extremely frustrating, game to play. The rules are just this: there are 99 mines laid down on the board. Find them without ""finding"" them. Your first tile is free - click anywhere. The tiles will tell you how many mines are right next to it, including the diagonals. If you uncover the number ''2'', you know that there are two mines hidden in the adjacent tiles. If you think you have found a mine, you can flag it by either ''shift'' clicking, or click with the ''yellow'' mouse button. Once you have flagged all of the mines adjacent to a numbered tile, you can click on the tile again to uncover the rest. Of course, you could be wrong about those too...
+
+ You win once you have uncovered all of the tiles that do not contain mines. Good luck...
+
+ David A. Smith
+ dastrs(a)bellsouth.net' translated!
Item was added:
+ ----- Method: Mines>>helpText (in category 'access') -----
+ helpText
+
+ helpText ifNil:
+ [helpText := PluggableTextMorph new
+ width: self width; "board width;"
+ editString: self helpString].
+ ^ helpText!
Item was added:
+ ----- Method: Mines>>hiScoreDisplay (in category 'access') -----
+ hiScoreDisplay
+
+ ^ hiScoreDisplay!
Item was added:
+ ----- Method: Mines>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+
+ super initialize.
+
+ level := 1.
+ self listDirection: #topToBottom;
+ wrapCentering: #center;
+ cellPositioning: #topCenter;
+ vResizing: #shrinkWrap;
+ hResizing: #shrinkWrap;
+ layoutInset: 3 px;
+ addMorph: self makeControls;
+ addMorph: self board.
+ helpText := nil.
+
+ self newGame!
Item was added:
+ ----- Method: Mines>>level (in category 'access') -----
+ level
+ ^level!
Item was added:
+ ----- Method: Mines>>makeControls (in category 'initialize') -----
+ makeControls
+ | row |
+ row := AlignmentMorph newRow color: color;
+ borderWidth: 2 px;
+ layoutInset: 3 px.
+ row borderStyle: BorderStyle inset.
+ row hResizing: #spaceFill;
+ vResizing: #shrinkWrap;
+ wrapCentering: #center;
+ cellPositioning: #leftCenter;
+ extent: 5 px @ 5 px.
+ row
+ addMorph: (self
+ buildButton: SimpleSwitchMorph new
+ target: self
+ label: ' Help ' translated
+ selector: #help:).
+ row
+ addMorph: (self
+ buildButton: (levelButton := SimpleButtonMorph new)
+ target: self
+ label: level asString translated
+ selector: #nextLevel).
+ row
+ addMorph: (self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: ' Quit ' translated
+ selector: #delete).
+ "row
+ addMorph: (self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: ' Hint ' translated
+ selector: #hint)."
+ row
+ addMorph: (self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: ' New game ' translated
+ selector: #newGame).
+ minesDisplay := LedMorph new digits: 2;
+ extent: 2 * 10 px @ 15 px.
+ row
+ addMorph: (self wrapPanel: minesDisplay label: 'Mines:' translated).
+ timeDisplay := LedTimerMorph new digits: 3; extent: 3 * 10 px @ 15 px.
+
+ row
+ addMorph: (self wrapPanel: timeDisplay label: 'Time:' translated).
+ hiScoreDisplay := LedMorph new digits: 3; extent: 3 * 10 px@ 15 px.
+ row
+ addMorph: (self wrapPanel: hiScoreDisplay label: 'Hi Score:' translated).
+ ^ row!
Item was added:
+ ----- Method: Mines>>minesDisplay (in category 'access') -----
+ minesDisplay
+
+ ^ minesDisplay!
Item was added:
+ ----- Method: Mines>>newGame (in category 'actions') -----
+ newGame
+ | boardSize |
+ boardSize := MinesBoard boardSizeAt: level.
+ timeDisplay value: 0; flash: false.
+ timeDisplay stop.
+ timeDisplay reset.
+ minesDisplay value: (boardSize at: 3).
+ hiScoreDisplay value: (boardSize at: 4).
+ levelButton label: (boardSize at: 5) asString.
+ self board resetBoard: level.!
Item was added:
+ ----- Method: Mines>>nextLevel (in category 'actions') -----
+ nextLevel
+ level := level + 1.
+ level = 4 ifTrue:[level := 1].
+ self newGame
+
+ !
Item was added:
+ ----- Method: Mines>>timeDisplay (in category 'access') -----
+ timeDisplay
+
+ ^ timeDisplay!
Item was added:
+ ----- Method: Mines>>wrapPanel:label: (in category 'initialize') -----
+ wrapPanel: anLedPanel label: aLabel
+ "wrap an LED panel in an alignmentMorph with a label to its left"
+
+ | a |
+ a := AlignmentMorph newRow
+ wrapCentering: #center; cellPositioning: #leftCenter;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ borderWidth: 0;
+ layoutInset: 3 px;
+ color: color lighter.
+ a addMorph: anLedPanel.
+ a addMorph: (StringMorph contents: aLabel).
+ ^ a
+ !
Item was added:
+ AlignmentMorph subclass: #MinesBoard
+ instanceVariableNames: 'protoTile rows columns flashCount tileCount target actionSelector arguments gameStart gameOver boardSize'
+ classVariableNames: 'BoardSizes'
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
Item was added:
+ ----- Method: MinesBoard class>>boardSizeAt: (in category 'accessing') -----
+ boardSizeAt: level
+ ^BoardSizes at: level!
Item was added:
+ ----- Method: MinesBoard class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: MinesBoard class>>initialize (in category 'class initialization') -----
+ initialize
+ "boardSizes are column, row, mines, highScore"
+ BoardSizes := Dictionary new.
+ BoardSizes at: 1 put:{8. 8. 10. 999. 'Beginner'}.
+ BoardSizes at: 2 put:{16. 16. 40. 999. 'Intermediate'}.
+ BoardSizes at: 3 put:{30. 16. 99. 999. 'Expert'}!
Item was added:
+ ----- Method: MinesBoard>>actionSelector (in category 'accessing') -----
+ actionSelector
+
+ ^ actionSelector!
Item was added:
+ ----- Method: MinesBoard>>actionSelector: (in category 'accessing') -----
+ actionSelector: aSymbolOrString
+
+ (nil = aSymbolOrString or:
+ ['nil' = aSymbolOrString or:
+ [aSymbolOrString isEmpty]])
+ ifTrue: [^ actionSelector := nil].
+
+ actionSelector := aSymbolOrString asSymbol.
+ !
Item was added:
+ ----- Method: MinesBoard>>adjustTiles (in category 'accessing') -----
+ adjustTiles
+ "reset tiles"
+
+ | newSubmorphs count r c |
+
+ submorphs do: "clear out all of the tiles."
+ [:m | m privateOwner: nil].
+
+ newSubmorphs := OrderedCollection new.
+
+ r := 0.
+ c := 0.
+ count := columns * rows.
+
+ 1 to: count do:
+ [:m |
+ newSubmorphs add:
+ (protoTile copy
+ position: self position + (self protoTile extent * (c @ r));
+ actionSelector: #tileClickedAt:newSelection:modifier:;
+ arguments: (Array with: (c+1) @ (r+1));
+ target: self;
+ privateOwner: self).
+ c := c + 1.
+ c >= columns ifTrue: [c := 0. r := r + 1]].
+ submorphs := newSubmorphs asArray.
+
+ !
Item was added:
+ ----- Method: MinesBoard>>blowUp (in category 'actions') -----
+ blowUp
+ owner timeDisplay stop.
+ self submorphsDo:
+ [:m |
+ m isMine ifTrue:
+ [m switchState: true.].
+ ].
+ flashCount := 2.
+ gameOver := true.!
Item was added:
+ ----- Method: MinesBoard>>clearMines: (in category 'actions') -----
+ clearMines: location
+
+ | al tile |
+
+ (self countFlags: location) = (self findMines: location) ifTrue:
+ [
+ {-1@ -1. -1@0. -1@1. 0@1. 1@1. 1@0. 1@ -1. 0@ -1} do:
+ [:offsetPoint |
+ al := location + offsetPoint.
+ ((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue: [
+ tile := self tileAt: al.
+ (tile mineFlag or: [tile switchState]) ifFalse:[
+ self stepOnTile: al].].].
+ ].!
Item was added:
+ ----- Method: MinesBoard>>countFlags: (in category 'actions') -----
+ countFlags: location
+
+ | al at flags |
+ flags := 0.
+ {-1@ -1. -1@0. -1@1. 0@1. 1@1. 1@0. 1@ -1. 0@ -1} do:
+ [:offsetPoint |
+ al := location + offsetPoint.
+ ((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue:
+ [at := self tileAt: al.
+ (at mineFlag ) ifTrue:
+ [flags := flags+1]]].
+ ^flags.!
Item was added:
+ ----- Method: MinesBoard>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ ^ Color transparent!
Item was added:
+ ----- Method: MinesBoard>>defaultBorderStyle (in category 'initialization') -----
+ defaultBorderStyle
+ ^ BorderStyle inset!
Item was added:
+ ----- Method: MinesBoard>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 2 px!
Item was added:
+ ----- Method: MinesBoard>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color lightGray!
Item was added:
+ ----- Method: MinesBoard>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "constrain the extent to be a multiple of the protoTile size during resizing"
+ super extent: (aPoint truncateTo: protoTile extent).!
Item was added:
+ ----- Method: MinesBoard>>findMines: (in category 'actions') -----
+ findMines: location
+
+ | al at mines |
+ mines := 0.
+ {-1@ -1. -1@0. -1@1. 0@1. 1@1. 1@0. 1@ -1. 0@ -1} do:
+ [:offsetPoint |
+ al := location + offsetPoint.
+ ((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue:
+ [at := self tileAt: al.
+ (at isMine ) ifTrue:
+ [mines := mines+1]]].
+ ^mines.!
Item was added:
+ ----- Method: MinesBoard>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ target := nil.
+ actionSelector := #selection.
+ arguments := #().
+ ""
+ self layoutPolicy: nil;
+ hResizing: #rigid;
+ vResizing: #rigid.
+ ""
+ boardSize := BoardSizes at: 1.
+
+ columns := self preferredColumns.
+ rows := self preferredRows.
+ flashCount := 0.
+ ""
+ self extent: self protoTile extent * (columns @ rows).
+ self adjustTiles.
+ self resetBoard: 1.!
Item was added:
+ ----- Method: MinesBoard>>preferredColumns (in category 'preferences') -----
+ preferredColumns
+
+ ^ boardSize at: 1!
Item was added:
+ ----- Method: MinesBoard>>preferredMines (in category 'preferences') -----
+ preferredMines
+
+ ^boardSize at:3!
Item was added:
+ ----- Method: MinesBoard>>preferredRows (in category 'preferences') -----
+ preferredRows
+
+ ^ boardSize at:2!
Item was added:
+ ----- Method: MinesBoard>>protoTile (in category 'accessing') -----
+ protoTile
+
+ protoTile ifNil: [protoTile := MinesTile new].
+ ^ protoTile!
Item was added:
+ ----- Method: MinesBoard>>protoTile: (in category 'accessing') -----
+ protoTile: aTile
+
+ protoTile := aTile!
Item was added:
+ ----- Method: MinesBoard>>resetBoard: (in category 'initialization') -----
+ resetBoard: aLevel
+
+ boardSize := BoardSizes at: aLevel.
+ columns := self preferredColumns.
+ rows := self preferredRows.
+ flashCount := 0.
+ ""
+ self extent: self protoTile extent * (columns @ rows).
+ self adjustTiles.
+
+ gameStart := false.
+ gameOver := false.
+
+ flashCount := 0.
+ tileCount := 0.
+ Collection initialize. "randomize the Collection class"
+ self purgeAllCommands.
+ self submorphsDo: "set tiles to original state."
+ [:m | m privateOwner: nil. "Don't propagate all these changes..."
+ m mineFlag: false.
+ m disabled: false.
+ m switchState: false.
+ m isMine: false.
+ m privateOwner: self].
+ self changed "Now note the change in bulk"!
Item was added:
+ ----- Method: MinesBoard>>selectTilesAdjacentTo: (in category 'actions') -----
+ selectTilesAdjacentTo: location
+
+ | al at mines |
+ " {-1@0. 0@ -1. 1@0. 0@1} do:"
+ {-1@ -1. -1@0. -1@1. 0@1. 1@1. 1@0. 1@ -1. 0@ -1} do:
+ [:offsetPoint |
+ al := location + offsetPoint.
+ ((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue:
+ [at := self tileAt: al.
+ (at switchState not and: [at disabled not]) ifTrue:
+ [
+ mines := (self tileAt: al) nearMines.
+ at mineFlag ifTrue: [at mineFlag: false.]. "just in case we flagged it as a mine."
+ at switchState: true.
+ tileCount := tileCount + 1.
+ mines=0 ifTrue: [self selectTilesAdjacentTo: al]]]]
+ !
Item was added:
+ ----- Method: MinesBoard>>setMines: (in category 'initialization') -----
+ setMines: notHere
+
+ | count total c r sm |
+ count := 0.
+ total := self preferredMines.
+ [count < total] whileTrue:[
+ c := columns atRandom.
+ r := rows atRandom.
+ c@r = notHere ifFalse: [
+ sm := self tileAt: c@r.
+ sm isMine ifFalse: [
+ "sm color: Color red lighter lighter lighter lighter."
+ sm isMine: true.
+ count := count + 1.]]
+ ].
+ 1 to: columns do: [ :col |
+ 1 to: rows do: [ :row |
+ (self tileAt: col @ row) nearMines: (self findMines: (col @ row))
+ ]].
+ !
Item was added:
+ ----- Method: MinesBoard>>step (in category 'stepping') -----
+ step
+
+ flashCount = 0 ifFalse: [
+ self submorphsDo:
+ [:m |
+ m color: m color negated.].
+ flashCount := flashCount - 1.
+ ].
+ !
Item was added:
+ ----- Method: MinesBoard>>stepOnTile: (in category 'actions') -----
+ stepOnTile: location
+
+ | mines tile score |
+ tile := self tileAt: location.
+ tile mineFlag ifFalse:[
+ tile isMine ifTrue: [tile color: Color gray darker darker. self blowUp. ^false.]
+ ifFalse:[
+ mines := self findMines: location.
+ tile switchState: true.
+ tileCount := tileCount + 1.
+ mines = 0 ifTrue:
+ [self selectTilesAdjacentTo: location]].
+ tileCount = ((columns*rows) - self preferredMines) ifTrue:[ gameOver := true. flashCount := 2. owner timeDisplay stop.
+ score := owner timeDisplay value.
+ ( score < (boardSize at:4))
+ ifTrue:[(BoardSizes at: owner level ) at: 4 put: score.
+ owner hiScoreDisplay value: score]].
+ ^ true.]
+ ifTrue: [^ false.]
+
+ !
Item was added:
+ ----- Method: MinesBoard>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^ 300!
Item was added:
+ ----- Method: MinesBoard>>target (in category 'accessing') -----
+ target
+
+ ^ target!
Item was added:
+ ----- Method: MinesBoard>>target: (in category 'accessing') -----
+ target: anObject
+
+ target := anObject!
Item was added:
+ ----- Method: MinesBoard>>tileAt: (in category 'accessing') -----
+ tileAt: aPoint
+
+ ^ submorphs at: (aPoint x + ((aPoint y - 1) * columns))!
Item was added:
+ ----- Method: MinesBoard>>tileClickedAt:newSelection:modifier: (in category 'actions') -----
+ tileClickedAt: location newSelection: isNewSelection modifier: mod
+ | tile |
+ "self halt."
+ gameOver ifTrue: [^ false].
+ tile := self tileAt: location.
+
+ isNewSelection ifFalse: [
+ mod ifTrue: [
+ tile mineFlag: ((tile mineFlag) not).
+ tile mineFlag ifTrue: [owner minesDisplay value: (owner minesDisplay value - 1)]
+ ifFalse: [owner minesDisplay value: (owner minesDisplay value + 1)].
+ ^ true.].
+
+ gameStart ifFalse: [
+ self setMines: location.
+ gameStart := true.
+ owner timeDisplay start.].
+ ^ self stepOnTile: location.
+ ]
+ ifTrue:[ self clearMines: location.].!
Item was added:
+ SimpleSwitchMorph subclass: #MinesTile
+ instanceVariableNames: 'switchState disabled oldSwitchState isMine nearMines palette mineFlag'
+ classVariableNames: 'PreferredColor'
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
Item was added:
+ ----- Method: MinesTile class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: MinesTile>>color: (in category 'accessing') -----
+ color: aColor
+ super color: aColor.
+ onColor := aColor.
+ offColor := aColor.
+ self changed!
Item was added:
+ ----- Method: MinesTile>>disabled (in category 'accessing') -----
+ disabled
+
+ ^ disabled
+ !
Item was added:
+ ----- Method: MinesTile>>disabled: (in category 'accessing') -----
+ disabled: aBoolean
+
+ disabled := aBoolean.
+ disabled
+ ifTrue:
+ [self color: owner color.
+ self borderColor: owner color]
+ ifFalse:
+ [self setSwitchState: self switchState]!
Item was added:
+ ----- Method: MinesTile>>doButtonAction: (in category 'accessing') -----
+ doButtonAction: modifier
+ "Perform the action of this button. The first argument of the message sent to the target is the current state of this switch,
+ the second argument is the modifier button state."
+
+ (target notNil and: [actionSelector notNil])
+ ifTrue:
+ [^target perform: actionSelector
+ withArguments: ((arguments copyWith: switchState) copyWith: modifier)]!
Item was added:
+ ----- Method: MinesTile>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ "Draw a rectangle with a solid, inset, or raised border.
+ Note: the raised border color *and* the inset border color are generated
+ from the receiver's own color, instead of having the inset border color
+ generated from the owner's color, as in BorderedMorph."
+
+ | font rct |
+ super drawOn: aCanvas.
+
+ self borderStyle style == #inset ifTrue: [
+ self isMine ifTrue: [
+ font := StrikeFont familyName: 'Atlanta' size: 22 px emphasized: 1.
+ rct := self bounds insetBy: ((self bounds width) - (font widthOfString: '*'))/2 @0.
+ rct := rct top: rct top + 1.
+ aCanvas drawString: '*' in: (rct translateBy: 1@1) font: font color: Color black.
+ ^ aCanvas drawString: '*' in: rct font: font color: Color red .].
+ self nearMines > 0 ifTrue: [
+ font := StrikeFont familyName: 'ComicBold' size: 22 px emphasized: 1.
+ rct := self bounds insetBy: ((self bounds width) - (font widthOfString: nearMines asString))/2 @0.
+ rct := rct top: rct top + 1.
+ aCanvas drawString: nearMines asString in: (rct translateBy: 1@1) font: font color: Color black.
+ ^ aCanvas drawString: nearMines asString in: rct font: font color: ((palette at: nearMines) ) .]].!
Item was added:
+ ----- Method: MinesTile>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+ self label: ''.
+ self borderWidth: 3 px.
+ bounds := 0@0 corner: 20 px@20 px.
+ offColor := self preferredColor.
+ onColor := self preferredColor.
+ switchState := false.
+ oldSwitchState := false.
+ disabled := false.
+ isMine := false.
+ nearMines := 0.
+ self useSquareCorners.
+ palette := (Color wheel: 8) asOrderedCollection reverse.
+ " flashColor := palette removeLast."
+ !
Item was added:
+ ----- Method: MinesTile>>isMine (in category 'accessing') -----
+ isMine
+
+ ^ isMine!
Item was added:
+ ----- Method: MinesTile>>isMine: (in category 'accessing') -----
+ isMine: aBoolean
+
+ isMine := aBoolean.
+ !
Item was added:
+ ----- Method: MinesTile>>mineFlag (in category 'accessing') -----
+ mineFlag
+
+ ^ mineFlag.
+ !
Item was added:
+ ----- Method: MinesTile>>mineFlag: (in category 'accessing') -----
+ mineFlag: boolean
+
+ mineFlag := boolean.
+ mineFlag ifTrue: [
+ self color: Color red lighter lighter lighter lighter.]
+ ifFalse: [
+ self color: self preferredColor.].
+ ^ mineFlag.
+ !
Item was added:
+ ----- Method: MinesTile>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ "The only real alternative mouse clicks are the yellow button or the shift key. I will treat them as the same thing, and ignore two button presses for now. I am keeping this code around, because it is the only documentation I have of MouseButtonEvent."
+ | mod |
+ " Transcript show: 'anyModifierKeyPressed - '; show: evt anyModifierKeyPressed printString ; cr;
+ show: 'commandKeyPressed - '; show: evt commandKeyPressed printString ; cr;
+ show: 'controlKeyPressed - '; show:evt controlKeyPressed printString ; cr;
+ show: 'shiftPressed - '; show: evt shiftPressed printString ; cr;
+ show: 'buttons - '; show: evt buttons printString ; cr;
+ show: 'handler - '; show: evt handler printString ; cr;
+ show: 'position - '; show: evt position printString ; cr;
+ show: 'type - '; show: evt type printString ; cr;
+ show: 'anyButtonPressed - '; show: evt anyButtonPressed printString ; cr;
+ show: 'blueButtonPressed - '; show: evt blueButtonPressed printString ; cr;
+ show: 'redButtonPressed - '; show: evt redButtonPressed printString ; cr;
+ show: 'yellowButtonPressed - '; show: evt yellowButtonPressed printString ; cr; cr; cr."
+
+
+ mod := (evt yellowButtonPressed) | (evt shiftPressed).
+ switchState ifFalse:[
+ (self doButtonAction: mod) ifTrue:
+ [mod ifFalse: [ self setSwitchState: true. ].].
+ ] ifTrue: [
+ self doButtonAction: mod.].!
Item was added:
+ ----- Method: MinesTile>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+
+ "don't do anything, here"!
Item was added:
+ ----- Method: MinesTile>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+
+ "don't do anything, here"!
Item was added:
+ ----- Method: MinesTile>>nearMines (in category 'accessing') -----
+ nearMines
+
+ ^ nearMines.
+ !
Item was added:
+ ----- Method: MinesTile>>nearMines: (in category 'accessing') -----
+ nearMines: nMines
+
+ nearMines := nMines.
+ !
Item was added:
+ ----- Method: MinesTile>>preferredColor (in category 'initialization') -----
+ preferredColor
+ "PreferredColor := nil <-- to reset cache"
+ PreferredColor ifNil:
+ ["This actually takes a while to compute..."
+ PreferredColor := Color gray lighter lighter lighter].
+ ^ PreferredColor!
Item was added:
+ ----- Method: MinesTile>>switchState (in category 'accessing') -----
+ switchState
+
+ ^ switchState!
Item was added:
+ ----- Method: MinesTile>>switchState: (in category 'accessing') -----
+ switchState: aBoolean
+
+ switchState := aBoolean.
+ disabled ifFalse:
+ [switchState
+ ifTrue:[
+ "flag ifTrue: [self setFlag]." "if this is a flagged tile, unflag it."
+ self borderStyle: (BorderStyle inset width: 1).
+ self color: onColor]
+ ifFalse:[
+ self borderStyle: (BorderStyle raised width: 3).
+ self color: offColor]]!
Item was added:
+ RectangleMorph subclass: #MorphExample
+ instanceVariableNames: 'phase ball star'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Demo'!
+
+ !MorphExample commentStamp: 'kfr 10/26/2003 18:38' prior: 0!
+ This is a example of how to use a morph. It consists of only two
+ methods, initialize and step.
+
+ DoIt:
+ MorphExample new openInWorld.
+
+
+
+ !
Item was added:
+ ----- Method: MorphExample>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ phase := 1.
+ self extent: 200 @ 200.
+ ball := EllipseMorph new extent: 30 @ 30.
+ self
+ addMorph: ((star := StarMorph new extent: 150 @ 150) center: self center)!
Item was added:
+ ----- Method: MorphExample>>step (in category 'stepping') -----
+ step
+ phase := phase\\8 + 1.
+ phase = 1 ifTrue: [^ ball delete].
+ phase < 4 ifTrue:[^self].
+ phase = 4 ifTrue: [self addMorph: ball].
+ ball align: ball center with: (star vertices at: (phase-3*2)).!
Item was added:
+ Object subclass: #PlayingCard
+ instanceVariableNames: 'cardNo suit suitNo cardForm'
+ classVariableNames: 'ASpadesLoc CachedBlank CachedDepth CardSize FaceForms FaceLoc FaceSuitLoc MidSpotLocs NumberForms NumberLoc SuitForms SuitLoc TopSpotLocs'
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !PlayingCard commentStamp: '<historical>' prior: 0!
+ This class assembles card images from their parts. The images are broken down so that the image data is very compact, and the code is written to display properly at all color depths. The method imageData may be removed after initialization to save space, but must be re-built prior to fileOut if you wish to retain the images.
+
+ To use in morphic, one can simply put these forms into ImageMorphs (see example in buildImage). However it should be possible to define a subclass of ImageMorph that simply creates playingCard instances on the fly whenever the image form is needed. This would avoid storing all the images.!
Item was added:
+ ----- Method: PlayingCard class>>imageData (in category 'all') -----
+ imageData ^ 'AgQALwAlAAAAAIDjaN4VEeFDEREREBIiIiIiIiIiIYiBiIGIgYiIiIgSIiIiEBIiIiIREiIiIhgRGBEYERiBiIEiIiIiEBIiIiERESIiIiFEREREREQRGBIiIiIiEBIiIhERERIiIiIRERERERFEQSIiIiISEBIiIhERERIiIiIRERERERERESIiIiEREBIiIhERERIiIiESIiIiISERESIiIhIUEBIiIiERESIiIhISIiIiISEhESIiIhIUEBIiERIREhESIhIRESERESEhISIiIhIUEBIhERERERERIhEREhESESEhISIiIhIUEBIREREREREREhISIhIiISEhISIiIhIUEBIREREREREREhISIhIiISEhISIiIhIUEBIREREREREREhISIhIiISEhISIiIhIUEBIhEREhIRERIhISIREiISEhISIiIhIUEBIiERIKISIREuIfIhEhISEhESIiEhQQEiIiIhESIiIhERIhESIhISEhIhIiEhQQEiIiIRERIiIiEhIiIiIhISISEhEiEhQQEiIiIiIiIiIREhISIhIRISERIRQREhQQEiIiIiIiIiEiEhISEhISESEhIUREEhQQEiIiIiIiIiEhIhISEhIRISIhFIREEhQQEiIiIiIiEREiISEhQSEiFBEUSIREEhQQEiIiIiERERERERQURBQRREQURESBEhQQEiIiERRBiBEhGBFERERERBFIREQSEhQQEiIhREREGIEREYERREREERSIRIEiEhQQEiEUJCQkIYgRIYGBEUQRGBRERBIhEhQQEhEURERERBiBERgYERERgUREgSIREhQQFBESQkJCQkGIERgYgREYgUhEQSEREhQQFBEUREREREEYQRGBGBGBFIhEEiEREhQQFBEUJCQkJCERhBGBiIiIFERIEhFBEhQQFBEUREQREUEUGBEYERQRFEREEhEREhQQEYgRQkEiIhEREYEYGIiIFISBIhF
BEhQQGIiBRBIhEiEUQYEYERQRSIRBIREREhQQEYgRFBIUQSERERgRgYiBRESBIRERERQQERERERIUQSEURBgRgRQRRERBIREiEiEQEUQRERIhEiERERGBgYiBRISBIRIiIREQEREREREiIhERERERERERSIRBIRIRIiEQESISIREREUQSIiFEQRERFESBIRIiEREQBAAvACUAAAAAgONk3hURExERERAYiIiIiIQRQhISESEJIuNPIiIiEBGIiIiIhBFCESEhESIiIiIiIhESIiIiEBIYiIgRhBFCEiESESIiIiIiIRERIiIiEBIhiIgYRBFCEhIhISIiIiIiEREREiIiEBIhiIiEQRRCESIiERIiIiIiEREREiIiEBIiGIiEQRQiEiIiIRIiIiIiEREREiIiEBIiGBGEERQiERIREUEiIiIiIRERIiIiEBIiGBhEEUQhIRIhEUEiIiIREhESERIiEBIhiIRBEUIhIiEiIRQSIiEREREREREiEBIhiIRBFEISIiEiIRQSIhERERERERESEBIYEUQRRCISIiEiIRFBIhERERERERESEBGIFEERQiEiIhESIUFEEhERERERERESEBIRRBEUQiEiIiIiIUQUQSERESEhEREiEBIiERFEIhQSIhESERQRRBIREiEiERIiEBIiIRFCIhFBIiEiERFBFEEiIhESIiIiEBIiERRCIRgREiIhgREUEUQSIRERIiIiEBIhEUQhFISBgREYFIhBRBFBIiIiIiIiEBIRFEISIUhEgYGESIQSFEEUEiIRIiIiEBERQRERERSIRERIiEEREUQUEiFEESIiEBEUiIERESEUiIiIRBISGBQUEhQRRBIiEBGIGIgSISIRFBEUESIRgYFBIUREQSIiEBiIgYGBISERIURBIREYiBESIhEUEhESEBRERBiIEREhIUhBISGBgRGBIiIhIYiBEBREREGIGBEhIURBIRiIFBGBEhESGIESEBREREQRiIgR
ERQREYGBRBGBEYiBEREiEBgYGBREEYGIiBEYiIERhBGBGIgSEiISEBGBgYGBRBEYiIiIgRERhEEYERESIRESEBgYEREREUSBERERERgRhEERRBQRISISEBGBGIiIiBFEgREYEYEYREQUIkERERESEBgYiBERGIgUQRERgYEYREGBQkQUEiISEBGIERgYERiBSBERGBEYRBiBFERBEREiEBQRGBgYGBGIFBERgYEYRBgYgUIkFBIiEBRBGBEREYgYFIEYERgYQYgRERQkQREiEBQkEUREQREYgUGBEREYQYGIFEFERBQSEBQiQUIiRBiBgRERGIEREYERFCIUIkEREBFERBIRJBERgURBREQYgYGIFCEhQkQUEAQALwAlAAAAAIDjaN4VEeE/EREREBIiIiEUFEFEQUFEFBREFBIiIiIiIiIiEBEiIiIRQUQUQUFEFBRBQSIiIhESIiIiEBQSIiIhFBRBEUERFBEUEiIiIRERIiIiEBRBIiIiFERERERERERBEiIiEREREiIiEBREEiIiERERERERERERIiIiEREREiIiEBERESIiGBIiIiIhgYGBIiIiEREREiIiEBiIEiIiGBIiIiIhgYGBIiIiIRERIiIiEBGIEiIiGBERIREhgYGBIiIREhESERIiEBiIEiIiGBESERIRgYGBIiEREREREREiEBGIEiIiGBIiEiIhgYGBIhERERERERESEBiIEiIhGBIiEiIhgYGBIhERERERERESEBGIEiIYGBIiEiIhgYGBIhERERERERESEBiIEiIYGBIhESIhgYGBEiERESEhEREiEAoRGBIi4iMiIiGBgRiBIhESISIREiIQGIgSIYgYISERIiGBEYgRIiIiERIiIiIQERgSIYGIESIiIhGBiBERESIhEREiIiIQGIgSIYiBFBIiIUGBGBESEhIiIiIiIiIQGIgRIhEUFEERFEQYiBEhEkESIiIiIiEQEYEiEUFBFERBFEQREREYE
kRBEiIiIhgQEhIiIRQUFIhBEUESIRIYEkSEIRIiIYgQERERIUFBFERBIREiESGIEkiIQhERGIgQEiESIRQUFIhBIhIhEhiIEohIghERGIgQERgSIUFBFERBEiIRIYgREkiIQhERGIgQEhgSIRQUFIhBESESQYiIEkSEQhERGIgQEYgSIUFBFERBIREkGIEREkREQhERGIgQEhgSFBQRFIhBEhIRiIiIEkSEQhERGIgQEYgREUERFERBQSFBgYEREkiIQhERGIgQGIgRERERSIQYFBQYiIiIEohIghERGIgQGIgRIREhREQRgUGBgREREkiIQRFEGIgQGIgSIhIhSIQYiBiIiIiIEkSEQUSIGIgQGIgSEiIRREQREYgYEREREhERREREGIgQGIgRISEhSIQYiIiIiIiIESIUSIREGIgQGIgSEhIRREQRhBgRGBSBIiFEREQRGIgQGIgRISEkiEGIgUEiIUESIiFIhEESGIgQGIgSEhIUREEYiBIREhIiIhRERBISGIgQGIgRISEUiEGBESFEQSEiIRSIQSEhGIgQBAAvACUAAAAAgONg3hUR4dsREREQEiIiIiIiIhiIgYiBiIiIiIiIgSIiIiIQEiIiIkIiIiGIERgRGIGIiIiIEiIREiEQEiIiJEQiIiIURERESBEYgYiBIiGBIhQQEiIiRERCIiIRERERFERIERgRIhiBIhQQEiIpRERJIiIhEREREREUREQSIhiBIhQQEiKUREREkiIhIiIiESERERESIYgSEREQEiKUREREkiIhIRIiEhIRERESIYEiQkIQEiRERERERCIhESEiEhISEhISIRIiQkIQEkREREREREImIiIiEhISEhISIYEiEhIQEiRERERERCISIiIiEhISEhISIYgSEREQEiKUREREkiEiIiIiEhISEhISIhiBIhQQEiKUREREkiEWIiIiISEhISEhIhiBIhQQEiIpRERJIiIhERISISEhISEhIiGBIh
QQEiIiRERCIiIhIhESIhISEhISEiIREhQQEiIiJEQiIiIiESIiIiEhISEhISIiIhQQEiIiIkIiIiIhIiIiERIhISEhISIiIhQQEiERIiIiIiIhEiIhIiEhISEhISIiIhQQEhISERIiIhEhIiIhIRIhISEhISIiIhQQEhEhISEiISESIiIhEiISEhISEiIiIhQQERISEhISISIiIiIiCRFbIiIUEBEhISIiIRgSIiIRERERiBIiGIEiEREREBISEiIhERGBEREREREhGIEhEYgSIYgSEBIhIhERFEEYERRBERIRIYgREhiBIRiBEBIiEUEYFEERgUFEEQkR4ScRIYIQEhFEREGBEhGBRBQRiIiIiIiIiBEREREQEUREQRgYEUQRFEESEhISEhISIYEREREQFERBGIiBgUQYERIiIiIiIiIiGBRBEiEQFEEYiIERGBEYEiIRERERERIhgYFEESEQFBiIgRERGBIYEhGIiIiIiBIYEUgUQREQEYiBEREhGBEYEYgRERERgSGBiBSBRBEQGIgRESIhEYERGBERREQYEiGBGIFIFEEQGIFEERIiEYERgRFEREQYEhgREYEREREQGBQUQREiEYERgRERERGBIhgRERSBSBQQEYhBRBESERgRgUREREGBIYERGBSBSBQQEUiEFEERIRgRgRERERgSIYEUSBQREREQFEFIhBERERERGBIiIhgRERERERSIQUQQBAAvACUAAAAAgONo3hUR4bsREREQEhiIiIiIFEEiEhIRgSIiIiIiIiIiIiIQEiGIiIEYFEEhISEhiBIiIiIiIkIiIiIQEiGIiIiIFEEiIRIRGBIiIiIiJEQiIiIQEiIYiIEYFEEiEiEhEYEiIiIiRERCIiIQEiIYiIiBFBIRIiIRERgSIiIpRERJIiIQEiIYiBGBRBEiIiIhQRgSIiKUREREkiIQEiIYiIgRQSIREhERQRGBIiKUREREkiIQEiIYgRgUQSEhESERRBG
BIiRERERERCIQEiIYiIEUESIiISIhRBEYEkREREREREIQEiGIEYFEEhIiISIhREEYEiRERERERCIQEiGIiBFBISEiISIhREEYEiKUREREkiIQEhiBgRRBIRIiERIhREEYEiKUREREkiIQEiGIEUQSISIiIiIhREQRgSIpRERJIiIQEiIRFEEiFBIiERIYFEQRgSIiRERCIiIQEiIhRBIiEUEiISIYEUQRgSIiJEQiIiIQEiIUQSIhiBESIiGIEhQRgSIiIkIiIiIQEiFEERESGIgRERGIEhERgSIiIiIiIiIQEhRBEhERIREYiIERIRERgSIiIhESIiIQEUQRIQohERIi4acREhGBIiIRiBEiIhAUQSESERERESIiIhESERgRIiIYEYgSEhAUGBIRESESEREREREhIRGBIiGIiIEiERAREYEhEREhIRESERESERIYEiIRGBIhgRARGBgSEREhISEhISERESGIESIiIRIYgRARgRGBIhESEREhIREREhiBERIiIhGBEhAYEUEYESERERESERESIYGBEhEiIRERIhARFBGBiBEYERERERIhGBGBIRESEiIREhARQRgUEYgRESIiIiEYgRGBIRERIhESEhAUEYERQhGIgRERERiBEUGBIREYEiEhEhARGBFBFCERGIiIiIEYEUGBEhGIESISEhARgRgUEUJBgRERERiIEUIYERiBERISEhAYERgRQSQhGBERGIEYEUIYgYgSEhEhIhASEhGBQUJCGBJBGIiIEUJBiIERERESIhARERGBQSQhGBJBGBEYEUEUGBESEhIRIhASEhIYEUJCGBJBGIiIERRBgRgREREREhAREREYFCQhGBERERERREhBgUGBEhISERASEhIRgUJCGBREREREiIQYESQYERERERAEAC8AJQAAAACA42neFRHjZxERERASIiIiIhQkRCRCRCRCRCQRIiIiIiIiIhASIiIiIiFCRCRCRCRCQkESIiIiQiIi
IhASIiIiIiIUIiRCIiRCJBEiIiIkRCIiIhARIiIiIiIhRERERERERBIiIiJEREIiIhAREiIiIiIhERERERERERIiIilEREkiIhARgSIiIiIhERGBIiIiIhEiIpRERESSIhARgSIiIiIhEYGBIiIiIhEiIpRERESSIhARgSIiIiIhgYGBIREhERgSJEREREREIhARgSIiEiIhgYGBEhESERgSREREREREQhARgSIhEiIhgYGBIiISIhgSJEREREREIhARgSEYEiIhgYGBIiISIhgSIpRERESSIhARERiBIiIhgYGBIiISIhgSIpRERESSIhAUiIERIiIhgYGBIiERIhgSIilEREkiIhARgRESIiIhgYGBIiIiIhgREiJEREIiIhAUgRIiIiEYgYGBIiERISgYgSIkRCIiIhARgSIiIhiBgYGBEiIiIRiBgSIiQiIiIhAUgSIiIhgRgRgUISIiEkGIgSIiIiIiIRARgSIiIhiIGIFERBERREQRERIiIiIiFBAUgSIiIhERERFEREREREESGBESIiIhgRARgSIiEUERIRERREREQRERGBIREiIhhBAUgSIRGBQRESEREREREREhGBEYgRIhgRARgREREYFBEREhERERESERGBIYgUERhBAUgRERERgUERERISEhIRFBGBERgURBgRARgRFBERGBQREREREREUFBGIEhiBFBhBARESEUEREYFBFBQUFBQUFBIYERGIgRgRASISGBQRERgUEUhISEhISBIYgSERiBhBARESEYFBERGBQRQUFBQUFBIRiBEhERgRASIRGBgUEREYFBEUFBQUFBIRGIgREhhBAREUQYERgRERgUEUFBQUFBIRIRiIERgRASESQYGIFBERGBQRSEhISBIRISEYiBhBARgURBgRFIEREYFBFBQUFBIRIRgRERgRARgSJBgYFIQRERgUERQUFBIRIREYFBhBAUgURBgRFISBEhGBQRQUFBIRIYgYEhgRARg
SJBgYFIQRERFIFBFISBERIRGBRBhBAUgURBgRFIESERhEgUEUFBERGIGBQhgRARgSJBgYFBEREUGESBQRQRIRERgURBhBAEAC8AJQAAAACA42neFRHjZxERERASIiIiIiIiIhgYiBiIGIgYiIiBIiIiIhASIkRJIilEQiERgRGBEYERgRgSIiIiIhASJEREkpRERCIYiIiIiIiBiBEiESIiIhASREREQkREREIhREREREiIiBIhiBIiIhASREREREREREIhERERERRERBIhiBESIhASREREREREREIhIiIiIhERERERgSIRIhASREREREREREIhIiIiIhISEhIhgSIYEhASlERERERERJIRERIRERISEhEYgREYEhASKURERERESSEhESERIRISEhEYgRIhIhASKURERERESSEhIiEiIhISEhIYgSIhIhASIpREREREQiEhIiEiIhISEhIhERERIhASIiREREREIiEhIiEiIhISEiEiFERBIhASIiJERERCIhISIhESIiEhISEhEREREhASIiIkREQiIhISIiIiIiEiEhIRQUFBQRASIiIiREIiIiESEhESIiISEhIUREREERASIiIiJCIhEREiEiIiISEhISIRRERBIhASIiIiIiERQRIhISIhISEhIiEiERQSRBASIiIiERERFBESISEhIREiIRISIhEUQRASIiIRFBIhFEEhEiEhIhIREiIiEUERERASIhEiFBIiEUQRIhEhEhiBIhIhQUGBERASERISFBISIRRBEYESEYiBISIUgUERgRARiEEhIUEhIhRBGBgRiIgSIiFIFBERGBAYREESIUEiIhFEEYEYiIgRIiGEFBgRERAUQRERIhQSEiFEQRGIiIgSIhhBQRSIERAUEREUEhRBISEUQRiIiIEiEhQUQREYgRARgRFEQSFEEiIURBiIiBEhIhFEERFEiBAYRIERRBIURBIRQYiIgUEiIRRBERRESBAUSIhBEREhFE
ESEYiIgRIhFEEREUSEGBAUiIFIgRESIREREREREREUQRERFEREiBAYiBQRGBEREiIiRERERERBERERRIQYgRAYiBSIiBgSIiQRERERERESEREURESIgRAYiBQRGBgSIiIiIhREQSIiERFEhBiIERAYiBSIiBgSIiIiERJEQSEhERSERIiBERARiIFIgRERERERIRERQRIREREUGIgRFBARGIiBERERESIhGIiIESIREUQYiIERQRAUEYEREYiIgSIhGBQYEiEhiIiIiBERRBAEAC8AJQAAAACA42neFRHjZxERERASIiIiIiIRISEiERSIiIEiIiIiIiIiIhASIiIiIiESEhISERSBiBIiREkiKURCIhASIiIiIhERIRIiERSIiBIkRESSlEREIhASIiIiIhgSEiEiIRSBgSJERERCREREQhASIiIiIRgRIiIRIRRIgSJEREREREREQhASIiIiIYQSIiIiERFIgSJEREREREREQhASIiIiEYQRESERIRFEiBJEREREREREQhASIiIiGEQREhESEREUSBKUREREREREkhASIiIhGEQSIhIiISERQSIpRERERERJIhASIiIhhEgSIhIiISEREiIpRERERERJIhASIiIhhEgSIhIiISIRESIiRERERESSIhASIiIhhEgSIREiIhIRERIiJEREREQiIhASIiIYRIgSIiIiIhIhEREiIkREREIiIhASIiIYRIERIREiIYEiERESIiRERCIiIhASIiIYRBGBIhIiGIEiIREREiJEQiIiIhASIiIYQYEYEiIhiBESIhERERIkIiIiIhASIiIYEoERgREYgRGBIiERERIiIiIiIhASIiIRghgRGIiBERgSEiIRESIiESESIhASIiEYGEKBEREREYQoERIiEiIhiBiBIhASIhiIgYIYgREYiBKBEREREiIhhEQSIhASIRGBGBhCGIiBJIgRESIiISIiGEiBIhASGIiIiIGIhCFIiBEhEiE
hIRIREYgSEhARERgRGIERGIiBERgRISIiFEGIgRGBEhAYiIiIiBEiEREYERgRIiIRRBiIEiEYEhAREYERGBISERERgYESEhFEERERIiGIEhAYiIiIgRIRESIRgYESIURBiIEhERGBIhARgYERgREhEiEhGBEhIUQYREEhQSESIhAYiIiIgSEhQRIhGBEiFEGESEESESESIhARGBgRgREhhEEiGBISFEGERBESEhIhIhAYiIiIgRIRiEQSERIhRBhEhBEhEhIhIhARgREYESEYGIQRERIhRBhERBIREiERIhAYiIiIESEYEYQRiBERRBhIRBISEiIUEhARgRiBESEYQYhBEYiBFBhEERIREhFEQRAYiIgUERIYQYRBgREYgRERRBEhEURERBAREYFEEhIYEYhBgYiBGIFESBISFEREQRAYiBREESEYGIQYGERIERRIiBESFERBGBAEAC8AJQAAAACA42jeFRHiZxERERASIiIiIhRCREJCRCQkRCQSIiIiIiIiIhARIhESIiFEJEJCRCQkQkEiREkiKURCIhAUEiGBIiIUQiJCIiQiJBEkRESSlEREIhAUEiGIEiIUREREREREQRJERERCREREQhAUEiGIEiIRERERERERERJEREREREREQhARERIYgSIhgYGBgSIiISJEREREREREQhASQkIhgSIhgYGBgSIRISJEREREREREQhASQkIiESIYGBgYEhEhISKUREREREREkhASEhIhgSIYGBgYEiIiJiIpRERERERJIhARERIYgSIYGBgYEiIiIhIpRERERERJIhAUEiGIEiIYGBgYEiIiIiEiRERERESSIhAUEiGIEiIYGBgYEiIRJhEiJEREREQiIhAUEiGBIiIYGBgYEhESISIiIkREREIiIhAUEhESIhEYGBgYEiIiISIiIiRERCIiIhAUEiIiIYiBGBgYEiIhESIiIiJEQiISIhAUEiIiGIGBgYEYEiIiISIiIiIkIhFB
EhAUEiIiGBiBgYGBREIiIREREiIiIhREEhAUEiIiGIEYgYEUREQRGIGIgSIiIiFBIhAUEiIiIYiIGBFEREREQYgRgSIiERFBIhAUEiIiIREREYgRREREQRiIgSIhIiFBIhAUEiIhFCQYiIiIERERiIGIESISIiIREhAUEiERERQhGIiIiIiIiIgRJBESIRISEhAUERIkQREUIRGIiIiIgREkRBERIhEREhAUFEIiJEERFCQRERERFCREERFEEiEiEhARERRCIiRBERQkJCQkJEQREUQiIREREhAYiBEUQiIkQQoRFBER4PtEIiJBESEiEBiBiIEUQiIkQRFBIiFBEUQiIkQRIhEiEBgYiBiBFEIiJEEUEhQRRCIiRBGBISESEBERgYhBERRCIiQRQUEUIiJEEYiBIiIREBIiGIQRiIEUQiJBFBFCIiQRiIiBISEREBEiIUEYiIiBRCIkERQiJEGIiIiBIiIREBIhIRGBEREREUIiQUIiQRERERGBISEREBEiIhiBIiIiIUQiERIkQSIiIiGBIiIREBESEhiBIRERIRRBIiFEESERESGBISEREBESIiGBIYgRESESERIRIREYgSGBIiIREBERISGBIYgRIhEhREEhEiEYgSGBISEREAQALwAlAAAAAIDjad4VEeNnEREREBIiIiIiIiIiGIiIiIiIiIiIiIEiIiIiEBIiIiIhIiIiIYiIiIGBgYGBgRIiIiIiEBIiIiIREiIiIhGBgYFBQUFBQSIiIiIiEBIiIiERESIiIkFBQUREREREEiIiIiIhEBIiIhERERIiIiFEREEREREREiIiIiIREBIiIREREREiIiEREREiIiIiESIiIiGBEBIiERERERESIiEhISEiIiIiEhIiIiGBEBIhERERERERIiEhISERESEREhIiIiGBEBIhERERERERIiEhISESERIRESIiIiGBEBIREREREREREiEhISEiIhIiEhIiIiGBEBIRERERE
REREiEhISEiIhIiEhIiIiGBEBIREREREREREiEhISEiIhIiEhIiIiGBEBIREREhIREREiEhISEiIREiEhIiIiGBEBIhERIhIhERIiEhISEhEiISEhIiIiGBEBIiIiIREiIiIREhISEhIREiESESIiGBEBIiIiERESIiEiEhISEiIiIiEhIhIiGBEBIiIiIiIiIhISEhISEiEiISEhIhIiGBEBIiIiIiIiERIRIhISESEhISEiEYESGBEBIiIiIiIRGBEiISISEiEhESIRGBEhGBEBIiIiIhGBSBEREhEhIhISGBQRgRIUGBEBIiIiERGBEYEYERERESEhGBEYESERGBEBIiIRgYEYEYFBGBgYERERgUGBEhREGBEBIhFEEREYFBgUQRERGBgRgRGBEhQRGBEBIUiBGBEYERgURIiIEREYFBgRIUREGBEBGEQRERgRgRgURIERiEQYERgRIUERGBEBSIQRgYGBgUGBRIiIiEQYEYESFEREGBEBRIEREYERgRGBERERERGBQYESFBEREREBhEEYGBiIGBGBEiISIhGBEYESFBiIgREBiEERGBgRGBGBIhIiEiGBGBEhQYERiIEBSIEYGBiIGBQYEhISEiGBGBEhQYgSGIEBRIERGBgRGBEYEiISIhgUGBERRBERIREBhEEYGBiIgYEYEhIiEhgRGBgRFEREEREBSEERGBgREYEYERERERgRgRERERERIiEBRIEYEYGIgYEYGIiIiIgRgRERERIiEREBEUEREYGBEYEYERERERgRgYgRGBEhIiEBIhIRgRgYgYFIERREERgRgRGIEREiEREAQALwAlAAAAAIDjWd4VEeMnEREREBIiIiIiIRIRISEkGBGIiBIiIiIiIiIiEBIhIiIiERESEhEkGIGIgSIiIiEiIiIiEBIhIiIiESEhEiEkGIiIgSIiIhESIiIiEBIhIiIiERISISIUGBGIEiIiIRERIiIiEBIYEiIiEhEiIhIUGI
GIEiIiEREREiIiEBIYEiIhEhIiIiEUQYiIgSIhERERESIiEBIYEiIhQhERIREUQYEYgSIRERERERIiEBIYEiIhQhESERIURBgYEiEREREREREiEBGIgSIhQhIiEiISRBiBIiEREREREREiEBGBgSIhQhIiEiIhREGBIhERERERERESEBGIgSIUQhIiEiIhJEQRIhERERERERESEBIYEiIUIRIhESIiFEQRIhERERERERESEBIYEiIUIRIiIiIiEkRBIhERESEhERESEBERESISEREhESIhQSREEiEREiEiEREiEBGIgSFCEREiEiIUESREESIiIhESIiIiEBIREiFCERgSIiERgRJEQRIiIRERIiIiEBGIgSFCGBGBERgYGIEkRBEiIiIiIiIiEBGIgSERGIEYGBgRiBESIiESIiIiRCIiEBIREiERGIiBERGIgRERERQRIiJEEUQiEBIUEhESEYGIiIgYERIhFERBgiRBiBRCEBIYEYESEYgYGBiBEiERREIYESJEEUQhEBIYFIgRERiIiIgRIRFERCGBGBEiRCIUEBEYFEgRIRgYGIESERREIhgRGIgSEiGEEBEYFEgRERGIiBEhFERCIYFBEYiBEhEYEBEYFEiBEhGIgRIRREQkQYEREREYEREYEBEYEkSBESERgSEURCJEQYFEQRERIiIYEBEYEUSIERGIEhFEQkRBEYERERESIiIYEBEYEhRIERhEgRREJEEREYgUREEiIiIYEBEYESRIgRhEgURCQREiERgRERIhIhGEEBEYEhFEiBhEgUQkERIiIRGBRBIREREUEBEYESFESIGIFEIRFCIRIhEYEREYEREREBEYEhIURIgRFCERIhEREiERgUGIGBEYEBEYESEhRERERBESIiIiIiIRGBiIGIiBEBEYEhISERERCRETERERiIiBGBARGBEhIURERAlED0REQRERGIEQERgSEg4REhESCxESERiIgREQBAAvACUAAAA
AgONM3hUR4dcREREQEiIRIiFBREFBRBQURBRBIiIiIiIiIiIQEiGIEiIUFEFBRBQUQUQSIiIiISIiIiIQEhgUgSIhQRFBERQRFEEiIiIiERIiIiIQEhgUgSIiFEREREREREEiIiIhEREiIiIQEhgUgSIiEREREREREREiIiIRERESIiIQEiGIEiIiEiIiGBgYGBIiIiERERERIiIQEiIRIiIiEhEiGBgYGBIiIhEREREREiIQEiGIEiIiEhIRIYGBgYEiIRERERERESIQEhgUgSIiYiIiIYGBgYEiIRERERERESIQEiGIEiIhIiIiIYGBgYEiERERERERERIQEiIRIiISIiIiIYGBgYEiERERERERERIQEiGIEiIRIhEmIYGBgYEiERERERERERIQEhgUgSIiEiEWIYGBgYEiERERISERERIQEhgUgSIiEiIiIYGBgYgRIRESISIRESIQEhgUgSIiERIiGIGBgYiIEiIiERIiIiIQEiGIEiIiEiIiGIGIGBgYgSIhEREiIiIQEhEREiIhEiIiQRgYGBiBgSIiIiIiIiIQEhIiESERFiJERBgRgYEYgSIiIiIiIiIQEiESIRERERRERBGIGBiIESIiIiIiIiIQEhIhERIREREJEeDrESIiIiIiIhASEhESEhEREREREREREREhIREiIiIiIhASERIRESGBgYGBgYGBgYEhESERIiIiIhARQREhISEREREREREREREhISEUESIiIhAUEUEhERIUREREREREREEhESFEQREiERARFBESEhIRSESESESESEEhISFBEUQRgRARQRgSEREhREgYSEgYREEhESERRBGIgRAUEYGBISEhFIGEiISBhEEhISFEEYgRERARGBgRIRERgUhEgYRIREEhESERGIiIERARgYGBEhGBERESERIREhEhISERiBERGBAYGBgRERgRgQkhKxERGIiIgRgQEYGBFBGBGIESERIREhERISERiBgREYEQ
GIgRJBgREYEJERMRGIiIiBGBEBgRFEGBGIiBCSITIhiBgREYFBARESQYEYERgQlEE0GIiIiBGEQQERRBgRiIiBEJESMRgYEREYFEEBGEGBERgRgRGBEhIiESESEYiIiIGEREEAQAJwAnAAAAAIDi8MMJIg8iISIiIiIiIiIiIiAJIg8iERIiIiIiIiIiIiAJIg8hEREiIiIiIiIiIiAJIuJ7EREREiIiIiIiIiIgIiIiIiIiIiEREhERIiIiIiIiIiAiIiIiIiIiEREhIRESIiIiIiIiICIiIiIiIiEREhESEREiIiIiIiIgIiIiIiIiEREhEREhERIiIiIiIiAiIiIiIiEREhERERIRESIiIiIiICIiIiIiEREhERIRESEREiIiIiIgIiIiIiEREhERISEREhERIiIiIiAiIiIiEREhERIREhERIRESIiIiICIiIiEREhERIRIRIRESEREiIiIgIiIiEREhERIRISESEREhERIiIiAiIiEREhERIRIREhEhERIRESIiICIiEREhERIREhESERIRESEREiIgIiEREhERIRERISERESEREhERIiAiEREhERESERESERESERERIRESICIREhEREREhESEhESERERESERIgIRESERIRERISERISERESERIRESAhESERESESESESESESESERESERICERIRERIRESEhESEhERIRERIREgERIRESIRESERISERIRESIRESERAREhESERESERESERESERESERIREBESERIRESEREREREREhERIREhEQERIREhESERESERIRERIREhESERAREhERIiERESEhISERESIhERIREBESERERERESERIREhEREREREhEQERIRERERESERERERIRERERESERARESERERESERERERESERERESERECERIhEREiEREhESEREiERESIREgIRERIiIhEREiERIhEREiIiERESAiEREREREREiIREiIRE
RERERESICIhEREREREiIRERIiERERERESIgIiIhERERIiIhEREiIiEREREiIiAJIg8RERESIiIiIiIiIiAJIjcRERESIiIiIiIiIiAiIiIiIiIiIREREREiIiIiIiIiICIiIiIiIiIRERERERIiIiIiIiIgAQALAAsAAAAAgB8LBw4AAAAOHwAAAAduwAAADv/gAAAHdcAAAAoOAAAAAQAJAAoAAAAAgB8KBxwAAAAKPgAAAAddAAAADv+AAAAHawAAAAocAAAAAQAPAA8AAAAAgDIPCwOAAAAHwAAADg/gAAAPB8AAADu4AAB//AAADv/+AAATfXwAADk4AAADgAAAB8AAAAEACwALAAAAAIAiCw8IAAAAHAAAAD4AAAAOfwAAAA8+AAAAHAAAAAgAAAAJAAEACQAKAAAAAIAkCg8IAAAAHAAAAD4AAAAOfwAAABM+AAAAHAAAAAgAAAAAAAAAAQAPAA8AAAAAgDoPEwEAAAADgAAAB8AAAA/gAAAKH/AAAA8/+AAAf/wAAD/4AAAKH/AAABMP4AAAB8AAAAOAAAABAAAAAQALAAsAAAAAgCYLBQALdwAAAPeAAAAO/4AAABd/AAAAPgAAABwAAAAIAAAAAAAAAAEACQAKAAAAAIAkCgt3AAAA94AAAA7/gAAAF38AAAA+AAAAHAAAAAgAAAAAAAAAAQAPAA8AAAAAgDEPDzx4AAB+/AAA/v4AABL//gAACn/8AAAbP/gAAB/wAAAP4AAAB8AAAAOAAAABAAAAAQALAAsAAAAAgCMLBQATCAAAABwAAAA+AAAAfwAAAA7/gAAAB2sAAAAKHAAAAAEACQAKAAAAAIAhChMIAAAAHAAAAD4AAAB/AAAADv+AAAAHawAAAAocAAAAAQAPAA8AAAAAgDUPGwEAAAADgAAAB8AAAA/gAAAf8AAAP/gAAAp//AAADv/+AAAT/X4AAHk8AAADgAAAB8AAAAEADAAMAAAAAIAmDAoCAA
AACgcAAAAKDYAAABMYwAAAH8AAAD/gAAAwYAAACnjwAAABAAoADAAAAACALwwrHwAAAD+AAAAxgAAAAYAAAAOAAAAHAAAADgAAABwAAAA5gAAAMYAAAAo/gAAAAQAKAAwAAAAAgC0MCj+AAAAXMwAAAAYAAAAMAAAAHwAAAB+AAAAKAYAAAA8xgAAAP4AAAB8AAAABAAoADAAAAACAKQwbAwAAAAcAAAAPAAAAHwAAADsAAABzAAAACn/AAAAKAwAAAAoHgAAAAQAKAAwAAAAAgCcMCn8AAAAKYAAAAAt+AAAAfwAAAAoDAAAACmMAAAALfwAAAD4AAAABAAoADAAAAACAKAwbDwAAAB8AAAA4AAAAMAAAAD8AAAA/gAAAEjGAAAALP4AAAB8AAAABAAoADAAAAACAGgwKP4AAAAcxgAAACgMAAAAOBgAAABIMAAAAAQAKAAwAAAAAgCYMCx8AAAA/gAAADjGAAAALHwAAAD+AAAAOMYAAAAs/gAAAHwAAAAEACgAMAAAAAIAoDAsfAAAAP4AAABIxgAAAGz+AAAAfgAAAAYAAAAOAAAAfAAAAHgAAAAEACgAMAAAAAIAYDAtngAAAb8AAACJswAAAC2/AAABngAAAAQAKAAwAAAAAgBkMCg8AAAAaBgAAAApmAAAAC34AAAA8AAAAAQAKAA4AAAAAgCAOCz4AAAB/AAAAImMAAAATfwAAAD4AAAAHAAAAAwAAAAEACgAMAAAAAIAsDAr3gAAAI2YAAABsAAAAeAAAAHAAAAB4AAAAbAAAAGYAAABjAAAACveAAAA='!
Item was added:
+ ----- Method: PlayingCard class>>includeInNewMorphMenu (in category 'all') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: PlayingCard class>>initialize (in category 'class initialization') -----
+ initialize
+ "PlayingCard initialize"
+ "Read the stored forms from mime-encoded data in imageData."
+ | forms f |
+ f := Base64MimeConverter
+ mimeDecodeToBytes: (ReadStream on: self imageData).
+ forms := OrderedCollection new.
+ f next = 2
+ ifFalse: [self error: 'corrupted imageData' translated].
+ [f atEnd]
+ whileFalse: [forms
+ add: (Form new readFrom: f)].
+ "1/2 image of Kc, Qc, Jc, ... d, h, s, and center image of As"
+ FaceForms := forms copyFrom: 1 to: 13.
+ "Images of small club, smaller club (for face cards), large club (for
+ 2-10, A),
+ followed by 3 more each for diamonds, heardt, spaces, all as 1-bit
+ forms. "
+ SuitForms := forms copyFrom: 14 to: 25.
+ "Images of A, 2, 3 ... J, Q, K as 1-bit forms"
+ NumberForms := forms copyFrom: 26 to: 38.
+ CardSize := 71 @ 96.
+ FaceLoc := 12 @ 11.
+ NumberLoc := 2 @ 4.
+ SuitLoc := 3 @ 18.
+ FaceSuitLoc := 2 @ 18.
+ TopSpotLocs := {{}. {28 @ 10}. {28 @ 10}. {15 @ 10. 41 @ 10}. {15 @ 10. 41 @ 10}. {14 @ 10. 42 @ 10}. {14 @ 10. 42 @ 10}. {14 @ 10. 28 @ 26. 42 @ 10}. {14 @ 10. 14 @ 30. 42 @ 10. 42 @ 30}. {14 @ 10. 14 @ 30. 42 @ 10. 42 @ 30. 28 @ 21}}.
+ "A"
+ "2"
+ "3"
+ "4"
+ "5"
+ "6"
+ "7"
+ "8"
+ "9"
+ "10"
+ MidSpotLocs := {{28 @ 40}. {}. {28 @ 40}. {}. {28 @ 40}. {14 @ 40. 42 @ 40}. {14 @ 40. 42 @ 40. 28 @ 26}. {14 @ 40. 42 @ 40}. {28 @ 40}. {}}.
+ "A"
+ "2"
+ "3"
+ "4"
+ "5"
+ "6"
+ "7"
+ "8"
+ "9"
+ "10"
+ ASpadesLoc := 16 @ 27!
Item was added:
+ ----- Method: PlayingCard class>>test (in category 'all') -----
+ test "Display all cards in the deck"
+ "MessageTally spyOn: [20 timesRepeat: [PlayingCard test]]"
+ 1 to: 13 do: [:i | 1 to: 4 do: [:j |
+ (PlayingCard the: i of: (#(clubs diamonds hearts spades) at: j)) cardForm
+ displayAt: (i-1*CardSize x)@(j-1*CardSize y)]]!
Item was added:
+ ----- Method: PlayingCard class>>the:of: (in category 'all') -----
+ the: cardNo of: suitOrNumber
+
+ ^ self new setCardNo: cardNo
+ suitNo: (suitOrNumber isNumber
+ ifTrue: [suitOrNumber]
+ ifFalse: [#(clubs diamonds hearts spades) indexOf: suitOrNumber])
+ cardForm: (Form extent: CardSize depth: Display depth)!
Item was added:
+ ----- Method: PlayingCard>>blankCard (in category 'all') -----
+ blankCard
+
+ CachedDepth = Display depth ifFalse:
+ [CachedDepth := Display depth.
+ CachedBlank := Form extent: CardSize depth: CachedDepth.
+ CachedBlank fillWhite; border: CachedBlank boundingBox width: 1.
+ CachedBlank fill: (0@0 extent: 2@2) fillColor: Color transparent. "Round the top corners"
+ CachedBlank fill: (1@1 extent: 1@1) fillColor: Color black.
+ CachedBlank fill: (CachedBlank width-2@0 extent: 2@2) fillColor: Color transparent.
+ CachedBlank fill: (CachedBlank width-2@1 extent: 1@1) fillColor: Color black].
+ ^ CachedBlank!
Item was added:
+ ----- Method: PlayingCard>>buildImage (in category 'all') -----
+ buildImage "(PlayingCard the: 12 of: #hearts) cardForm display"
+ "World addMorph: (ImageMorph new image: (PlayingCard the: 12 of: #hearts) cardForm)"
+ "PlayingCard test"
+ | blt numForm suitForm spot face ace sloc colorMap fillColor |
+
+ "Set up blt to copy in color for 1-bit forms"
+ blt := BitBlt current toForm: cardForm.
+ fillColor := self color.
+ colorMap := (((Array with: Color white with: fillColor)
+ collect: [:c | cardForm pixelWordFor: c])
+ as: Bitmap).
+
+ blt copy: cardForm boundingBox from: 0@0 in: self blankCard. "Start with a blank card image"
+ numForm := NumberForms at: cardNo. "Put number in topLeft"
+ blt copyForm: numForm to: NumberLoc rule: Form over colorMap: colorMap.
+
+ suitForm := SuitForms at: suitNo*3-2. "Put small suit just below number"
+ sloc := SuitLoc.
+ cardNo > 10 ifTrue:
+ [suitForm := SuitForms at: suitNo*3-1. "Smaller for face cards"
+ sloc := SuitLoc - (1@0)].
+ blt copyForm: suitForm to: sloc rule: Form over colorMap: colorMap.
+
+ cardNo <= 10
+ ifTrue:
+ ["Copy top-half spots to the number cards"
+ spot := SuitForms at: suitNo*3. "Large suit spots"
+ (TopSpotLocs at: cardNo) do:
+ [:loc | blt copyForm: spot to: loc rule: Form over colorMap: colorMap]]
+ ifFalse:
+ ["Copy top half of face cards"
+ face := FaceForms at: suitNo-1*3 + 14-cardNo.
+ blt colorMap: self faceColorMap;
+ copy: (FaceLoc extent: face extent) from: 0@0 in: face].
+
+ "Now copy top half to bottom"
+ self copyTopToBottomHalf.
+
+ cardNo <= 10 ifTrue:
+ ["Copy middle spots to the number cards"
+ (MidSpotLocs at: cardNo) do:
+ [:loc | blt copyForm: spot to: loc rule: Form over colorMap: colorMap]].
+ (cardNo = 1 and: [suitNo = 4]) ifTrue:
+ ["Special treatment for the ace of spades"
+ ace := FaceForms at: 13.
+ blt colorMap: self faceColorMap;
+ copy: (ASpadesLoc extent: ace extent) from: 0@0 in: ace]
+ !
Item was added:
+ ----- Method: PlayingCard>>cardForm (in category 'all') -----
+ cardForm
+
+ ^ cardForm!
Item was added:
+ ----- Method: PlayingCard>>color (in category 'all') -----
+ color
+ CachedDepth = 1 ifTrue: [^ Color black].
+ CachedDepth = 2 ifTrue: [^ Color perform: (#(black gray gray black) at: suitNo)].
+ ^ Color perform: (#(black red red black) at: suitNo)!
Item was added:
+ ----- Method: PlayingCard>>copyTopToBottomHalf (in category 'all') -----
+ copyTopToBottomHalf
+ "The bottom half is a 180-degree rotation of the top half (except for 7)"
+ | topHalf corners |
+ topHalf := 0@0 corner: cardForm width@(cardForm height+1//2).
+ corners := topHalf corners.
+ (WarpBlt current toForm: cardForm)
+ sourceForm: cardForm;
+ combinationRule: 3;
+ copyQuad: ((3 to: 6) collect: [:i | corners atWrap: i])
+ toRect: (CardSize - topHalf extent corner: CardSize).
+ !
Item was added:
+ ----- Method: PlayingCard>>faceColorMap (in category 'all') -----
+ faceColorMap
+ | map |
+ map := Color colorMapIfNeededFrom: 4 to: Display depth.
+ ^ map!
Item was added:
+ ----- Method: PlayingCard>>setCardNo:suitNo:cardForm: (in category 'all') -----
+ setCardNo: c suitNo: s cardForm: f
+ cardNo := c.
+ suitNo := s.
+ cardForm := f.
+ self buildImage!
Item was added:
+ AlignmentMorph subclass: #PlayingCardDeck
+ instanceVariableNames: 'layout stackingPolicy stackingOrder emptyDropPolicy target acceptCardSelector cardDroppedSelector cardDoubleClickSelector cardDraggedSelector seed'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
Item was added:
+ ----- Method: PlayingCardDeck class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: PlayingCardDeck class>>newDeck (in category 'instance creation') -----
+ newDeck
+ ^self new newDeck!
Item was added:
+ ----- Method: PlayingCardDeck class>>newSuit: (in category 'instance creation') -----
+ newSuit: suit
+ ^self new newSuit: suit!
Item was added:
+ ----- Method: PlayingCardDeck class>>suits (in category 'symbols') -----
+ suits
+
+ ^{#Clubs. #Diamonds. #Hearts. #Spades}!
Item was added:
+ ----- Method: PlayingCardDeck class>>values (in category 'symbols') -----
+ values
+
+ ^#(Ace),((2 to: 9) collect: [:i | i printString asSymbol]), #(Jack Queen King)!
Item was added:
+ ----- Method: PlayingCardDeck>>acceptCard:default: (in category 'dropping/grabbing') -----
+ acceptCard: aCard default: aBoolean
+ "if target and acceptCardSelector are both not nil, send to target, if not
+ nil answer
+ else answer aBoolean"
+ "Rewrote this a little (SmallLint calls this 'intention revealing')-th"
+ ^ (target isNil or: [acceptCardSelector isNil])
+ ifTrue: [aBoolean]
+ ifFalse: [(target
+ perform: acceptCardSelector
+ with: aCard
+ with: self)
+ ifNil: [aBoolean]]!
Item was added:
+ ----- Method: PlayingCardDeck>>acceptCardSelector: (in category 'accessing') -----
+ acceptCardSelector: aSymbolOrString
+
+ acceptCardSelector := self nilOrSymbol: aSymbolOrString.!
Item was added:
+ ----- Method: PlayingCardDeck>>acceptDroppingMorph:event: (in category 'layout') -----
+ acceptDroppingMorph: aMorph event: evt
+ target
+ rememberUndoableAction: [target inAutoMove
+ ifFalse: [target removeProperty: #stateBeforeGrab].
+ self addMorph: aMorph.
+ aMorph hasSubmorphs
+ ifTrue: ["Just dropped a sub-deck of cards"
+ aMorph submorphs
+ reverseDo: [:m | self addMorphFront: m]].
+ (target notNil
+ and: [cardDroppedSelector notNil])
+ ifTrue: [target perform: cardDroppedSelector]]
+ named: 'move card' translated!
Item was added:
+ ----- Method: PlayingCardDeck>>addCard: (in category 'accessing') -----
+ addCard: aPlayingCard
+ self addMorph: aPlayingCard!
Item was added:
+ ----- Method: PlayingCardDeck>>cardDoubleClickSelector: (in category 'accessing') -----
+ cardDoubleClickSelector: aSymbolOrString
+
+ cardDoubleClickSelector := self nilOrSymbol: aSymbolOrString.!
Item was added:
+ ----- Method: PlayingCardDeck>>cardDraggedSelector: (in category 'accessing') -----
+ cardDraggedSelector: aSymbolOrString
+
+ cardDraggedSelector := self nilOrSymbol: aSymbolOrString.!
Item was added:
+ ----- Method: PlayingCardDeck>>cardDroppedSelector: (in category 'accessing') -----
+ cardDroppedSelector: aSymbolOrString
+
+ cardDroppedSelector := self nilOrSymbol: aSymbolOrString.!
Item was added:
+ ----- Method: PlayingCardDeck>>cards (in category 'accessing') -----
+ cards
+
+ ^submorphs!
Item was added:
+ ----- Method: PlayingCardDeck>>deal (in category 'shuffling/dealing') -----
+ deal
+ | card |
+ ^ self cards notEmpty
+ ifTrue:
+ [card := self topCard.
+ card delete.
+ card]
+ ifFalse: [nil]!
Item was added:
+ ----- Method: PlayingCardDeck>>deal: (in category 'shuffling/dealing') -----
+ deal: anInteger
+
+ ^(1 to: anInteger) collect: [:i | self deal]!
Item was added:
+ ----- Method: PlayingCardDeck>>doubleClickOnCard: (in category 'events') -----
+ doubleClickOnCard: aCard
+ (target notNil and: [cardDoubleClickSelector notNil])
+ ifTrue:
+ [^target
+ perform: cardDoubleClickSelector
+ with: self
+ with: aCard]!
Item was added:
+ ----- Method: PlayingCardDeck>>emptyDropNotOk: (in category 'dropping/grabbing') -----
+ emptyDropNotOk: aPlayingCard
+
+ ^(self emptyDropOk: aPlayingCard) not!
Item was added:
+ ----- Method: PlayingCardDeck>>emptyDropOk: (in category 'dropping/grabbing') -----
+ emptyDropOk: aPlayingCard
+
+ emptyDropPolicy = #any ifTrue: [^true].
+ emptyDropPolicy = #inOrder ifTrue: [^self inStackingOrder: aPlayingCard].
+ emptyDropPolicy = #anyClub ifTrue: [^aPlayingCard suit = #club].
+ emptyDropPolicy = #anyDiamond ifTrue: [^aPlayingCard suit = #diamond].
+ emptyDropPolicy = #anyHeart ifTrue: [^aPlayingCard suit = #heart].
+ emptyDropPolicy = #anySpade ifTrue: [^aPlayingCard suit = #spade].!
Item was added:
+ ----- Method: PlayingCardDeck>>emptyDropPolicy: (in category 'accessing') -----
+ emptyDropPolicy: aSymbol
+ "#any #inOrder #anyClub #anyDiamond #anyHeart #anySpade"
+
+ emptyDropPolicy := aSymbol!
Item was added:
+ ----- Method: PlayingCardDeck>>hasCards (in category 'accessing') -----
+ hasCards
+
+ ^self hasSubmorphs!
Item was added:
+ ----- Method: PlayingCardDeck>>ifEmpty: (in category 'dropping/grabbing') -----
+ ifEmpty: aBlock
+
+ self hasSubmorphs not ifTrue: [^aBlock value]!
Item was added:
+ ----- Method: PlayingCardDeck>>ifEmpty:ifNotEmpty: (in category 'dropping/grabbing') -----
+ ifEmpty: aBlock1 ifNotEmpty: aBlock2
+
+ self hasSubmorphs not
+ ifTrue: [^aBlock1 value]
+ ifFalse: [^aBlock2 value]!
Item was added:
+ ----- Method: PlayingCardDeck>>inStackingOrder: (in category 'dropping/grabbing') -----
+ inStackingOrder: aPlayingCard
+
+ ^self inStackingOrder: aPlayingCard event: nil!
Item was added:
+ ----- Method: PlayingCardDeck>>inStackingOrder:event: (in category 'dropping/grabbing') -----
+ inStackingOrder: aCard event: evt
+
+ self hasSubmorphs
+ ifTrue: [^ self inStackingOrder: aCard onTopOf: self topCard]
+ ifFalse: [stackingOrder = #ascending ifTrue: [^ aCard cardNumber = 1].
+ stackingOrder = #descending ifTrue: [^ aCard cardNumber = 13]].
+ ^ false.!
Item was added:
+ ----- Method: PlayingCardDeck>>inStackingOrder:onTopOf: (in category 'dropping/grabbing') -----
+ inStackingOrder: aCard onTopOf: cardBelow
+ | diff |
+ (stackingPolicy = #altStraight and: [aCard suitColor = cardBelow suitColor]) ifTrue: [^ false].
+ (stackingPolicy = #straight and: [aCard suit ~= cardBelow suit]) ifTrue: [^ false].
+ diff := aCard cardNumber - cardBelow cardNumber.
+ stackingOrder = #ascending ifTrue: [^ diff = 1].
+ stackingOrder = #descending ifTrue: [^ diff = -1].
+ ^ false.!
Item was added:
+ ----- Method: PlayingCardDeck>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ self cellPositioning: #topLeft.
+ self reverseTableCells: true.
+ self layout: #grid.
+ self hResizing: #shrinkWrap.
+ self vResizing: #shrinkWrap.
+ self borderWidth: 0.
+ self layoutInset: 0.
+ stackingPolicy := #stagger.
+ stackingOrder := #ascending.
+ emptyDropPolicy := #any.
+ self newSeed.
+ ^self!
Item was added:
+ ----- Method: PlayingCardDeck>>insertionIndexFor: (in category 'dropping/grabbing') -----
+ insertionIndexFor: aMorph
+ "Return the index at which the given morph should be inserted into the submorphs of the receiver."
+
+ ^1!
Item was added:
+ ----- Method: PlayingCardDeck>>layout: (in category 'accessing') -----
+ layout: aSymbol
+ " #grid #pile #stagger"
+ layout := aSymbol.
+ layout == #grid
+ ifTrue:[self maxCellSize: SmallInteger maxVal].
+ layout == #pile
+ ifTrue:[self maxCellSize: 0].
+ layout == #stagger
+ ifTrue:[self maxCellSize: self staggerOffset].!
Item was added:
+ ----- Method: PlayingCardDeck>>newDeck (in category 'initialization') -----
+ newDeck
+ | cards |
+ cards := OrderedCollection new: 52.
+ PlayingCardMorph suits
+ do: [:suit | 1 to: 13
+ do: [:cardNo | cards add: (PlayingCardMorph the: cardNo of: suit)]].
+ self addAllMorphs: cards.
+ ^self!
Item was added:
+ ----- Method: PlayingCardDeck>>newSeed (in category 'accessing') -----
+ newSeed
+ seed := (1 to: 32000) atRandom!
Item was added:
+ ----- Method: PlayingCardDeck>>newSuit: (in category 'initialization') -----
+ newSuit: suit
+ | cards |
+ cards := OrderedCollection new: 13.
+ 1 to: 13 do: [:cardNo | cards add: (PlayingCardMorph the: cardNo of: suit)].
+ self addAllMorphs: cards.
+ ^self!
Item was added:
+ ----- Method: PlayingCardDeck>>nilOrSymbol: (in category 'private') -----
+ nilOrSymbol: aSymbolOrString
+
+ (nil = aSymbolOrString or:
+ ['nil' = aSymbolOrString or:
+ [aSymbolOrString isEmpty]])
+ ifTrue: [^nil]
+ ifFalse: [^aSymbolOrString asSymbol]!
Item was added:
+ ----- Method: PlayingCardDeck>>printOn: (in category 'printing') -----
+ printOn: aStream
+ | cards |
+ cards := self cards.
+ aStream nextPutAll: 'aCardDeck('.
+ cards size > 1
+ ifTrue:
+ [cards allButLast do:
+ [:card |
+ aStream
+ print: card;
+ nextPutAll: ', ']].
+ cards notEmpty ifTrue: [aStream print: cards last].
+ aStream nextPut: $)!
Item was added:
+ ----- Method: PlayingCardDeck>>removeAllCards (in category 'accessing') -----
+ removeAllCards
+ self removeAllMorphs!
Item was added:
+ ----- Method: PlayingCardDeck>>repelCard: (in category 'dropping/grabbing') -----
+ repelCard: aCard
+ stackingPolicy = #none ifTrue: [^ self repelCard: aCard default: true].
+ stackingPolicy = #single ifTrue: [^ self ifEmpty: [self repelCard: aCard default: false]
+ ifNotEmpty: [true]].
+ (stackingPolicy = #altStraight or: [stackingPolicy = #straight])
+ ifTrue: [self ifEmpty: [^ self repelCard: aCard default: (self emptyDropNotOk: aCard)]
+ ifNotEmpty: [(self inStackingOrder: aCard onTopOf: self topCard)
+ ifFalse: [^ self repelCard: aCard default: true]]].
+ ^ false!
Item was added:
+ ----- Method: PlayingCardDeck>>repelCard:default: (in category 'dropping/grabbing') -----
+ repelCard: aCard default: aBoolean
+
+ ^(self acceptCard: aCard default: aBoolean not) not!
Item was added:
+ ----- Method: PlayingCardDeck>>repelsMorph:event: (in category 'dropping/grabbing') -----
+ repelsMorph: aMorph event: evt
+
+ (aMorph isKindOf: PlayingCardMorph)
+ ifTrue: [^self repelCard: aMorph]
+ ifFalse: [^true]!
Item was added:
+ ----- Method: PlayingCardDeck>>reverse (in category 'shuffling/dealing') -----
+ reverse
+ self invalidRect: self fullBounds.
+ submorphs := submorphs reversed.
+ self layoutChanged.!
Item was added:
+ ----- Method: PlayingCardDeck>>rootForGrabOf: (in category 'dropping/grabbing') -----
+ rootForGrabOf: aCard
+ self hasSubmorphs ifFalse: [^nil].
+ (target notNil and: [cardDraggedSelector notNil])
+ ifTrue:
+ [^target
+ perform: cardDraggedSelector
+ with: aCard
+ with: self]
+ ifFalse: [^self firstSubmorph]!
Item was added:
+ ----- Method: PlayingCardDeck>>seed (in category 'accessing') -----
+ seed
+
+ ^seed!
Item was added:
+ ----- Method: PlayingCardDeck>>seed: (in category 'accessing') -----
+ seed: anInteger
+
+ seed := anInteger!
Item was added:
+ ----- Method: PlayingCardDeck>>shuffle (in category 'shuffling/dealing') -----
+ shuffle
+ self invalidRect: self fullBounds.
+ submorphs := submorphs shuffledBy: (Random new seed: seed).
+ self layoutChanged.!
Item was added:
+ ----- Method: PlayingCardDeck>>stackingOrder: (in category 'accessing') -----
+ stackingOrder: aSymbol
+ "#ascending #descending"
+
+ stackingOrder := aSymbol!
Item was added:
+ ----- Method: PlayingCardDeck>>stackingPolicy (in category 'accessing') -----
+ stackingPolicy
+
+ ^ stackingPolicy!
Item was added:
+ ----- Method: PlayingCardDeck>>stackingPolicy: (in category 'accessing') -----
+ stackingPolicy: aSymbol
+ "#straight #altStraight #single #none"
+
+ stackingPolicy := aSymbol!
Item was added:
+ ----- Method: PlayingCardDeck>>staggerOffset (in category 'layout') -----
+ staggerOffset
+ ^18 px!
Item was added:
+ ----- Method: PlayingCardDeck>>subDeckStartingAt: (in category 'accessing') -----
+ subDeckStartingAt: aCard
+ | i subDeck |
+
+ i := submorphs indexOf: aCard ifAbsent: [^ aCard].
+ i = 1 ifTrue: [^aCard].
+ subDeck := PlayingCardDeck new.
+ (submorphs copyFrom: 1 to: i-1) do:
+ [:m | m class = aCard class ifTrue: [subDeck addMorphBack: m]].
+ ^subDeck.
+ !
Item was added:
+ ----- Method: PlayingCardDeck>>target: (in category 'accessing') -----
+ target: anObject
+
+ target := anObject!
Item was added:
+ ----- Method: PlayingCardDeck>>topCard (in category 'accessing') -----
+ topCard
+
+ ^self firstSubmorph!
Item was added:
+ ImageMorph subclass: #PlayingCardMorph
+ instanceVariableNames: 'cardNumber suitNumber'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !PlayingCardMorph commentStamp: '<historical>' prior: 0!
+ This class displays images from the PlayingCard class as morphs. It attempts to be space-efficient by only producing its images on demand.!
Item was added:
+ ----- Method: PlayingCardMorph class>>cardSize (in category 'access') -----
+ cardSize
+ " a real hack, but I don't want to muck with Dan's class "
+ ^71 px @ 96 px!
Item was added:
+ ----- Method: PlayingCardMorph class>>height (in category 'access') -----
+ height
+ ^self cardSize y!
Item was added:
+ ----- Method: PlayingCardMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: PlayingCardMorph class>>suits (in category 'access') -----
+ suits
+ ^ #(clubs diamonds hearts spades)!
Item was added:
+ ----- Method: PlayingCardMorph class>>test (in category 'testing') -----
+ test "Display all cards in the deck"
+ "MessageTally spyOn: [20 timesRepeat: [PlayingCardMorph test]]"
+ | table row |
+ table := AlignmentMorph newColumn.
+ self suits do: [:suit |
+ row := AlignmentMorph newRow.
+ table addMorph: row.
+ 1 to: 13 do: [:cn |
+ row addMorph:
+ (PlayingCardMorph the: cn of: suit)]].
+ table openInWorld.!
Item was added:
+ ----- Method: PlayingCardMorph class>>the:of: (in category 'initialize-release') -----
+ the: cardNumber of: suit
+
+ | image |
+ image := (PlayingCard the: cardNumber of: suit) cardForm.
+ image := image scaledToSize: image extent * RealEstateAgent scaleFactor.
+ ^ self new
+ image: image;
+ cardNumber: cardNumber suitNumber: (self suits indexOf: suit)!
Item was added:
+ ----- Method: PlayingCardMorph class>>width (in category 'access') -----
+ width
+ ^self cardSize x!
Item was added:
+ ----- Method: PlayingCardMorph>>aboutToBeGrabbedBy: (in category 'dropping/grabbing') -----
+ aboutToBeGrabbedBy: aHand
+ "I'm about to be grabbed by the hand. If other cards are above me in a deck,
+ then move them from the deck to being submorphs of me"
+ | i |
+ super aboutToBeGrabbedBy: aHand.
+ self removeProperty: #undoGrabCommand. "So it won't interfere with overall move"
+ self board captureStateBeforeGrab.
+ i := owner submorphs indexOf: self ifAbsent: [^ self].
+ i = 1 ifTrue: [^ self].
+ (owner submorphs copyFrom: 1 to: i-1) do:
+ [:m | m class = self class ifTrue: [self addMorphBack: m]].
+ !
Item was added:
+ ----- Method: PlayingCardMorph>>board (in category 'access') -----
+ board
+
+ ^ owner owner owner!
Item was added:
+ ----- Method: PlayingCardMorph>>cardDeck (in category 'access') -----
+ cardDeck
+
+ ^self owner!
Item was added:
+ ----- Method: PlayingCardMorph>>cardNumber (in category 'access') -----
+ cardNumber
+ ^cardNumber!
Item was added:
+ ----- Method: PlayingCardMorph>>cardNumber:suitNumber: (in category 'access') -----
+ cardNumber: c suitNumber: s
+ cardNumber := c.
+ suitNumber := s.!
Item was added:
+ ----- Method: PlayingCardMorph>>click: (in category 'event handling') -----
+ click: evt
+
+ "since we really want to know about double-clicks before making our move, ignore this and wait until #firstClickTimedOut: arrives"!
Item was added:
+ ----- Method: PlayingCardMorph>>doubleClick: (in category 'event handling') -----
+ doubleClick: evt
+
+ ^self cardDeck doubleClickOnCard: self!
Item was added:
+ ----- Method: PlayingCardMorph>>firstClickTimedOut: (in category 'event handling') -----
+ firstClickTimedOut: evt
+ | root popUp |
+ root := owner rootForGrabOf: self.
+ root isNil
+ ifTrue:
+ ["Display hidden card in front"
+
+ popUp := self copy.
+ self board owner owner addMorphFront: popUp.
+ self world displayWorld.
+ (Delay forMilliseconds: 750) wait.
+ popUp delete]
+ ifFalse: [evt hand grabMorph: root]!
Item was added:
+ ----- Method: PlayingCardMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ ^ true!
Item was added:
+ ----- Method: PlayingCardMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: newOwner event: evt
+
+ (newOwner isKindOf: PlayingCardDeck)
+ ifFalse: ["Can't drop a card anywhere but on a deck"
+ self rejectDropMorphEvent: evt].
+ ^super justDroppedInto: newOwner event: evt!
Item was added:
+ ----- Method: PlayingCardMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ "Do nothing upon mouse-down except inform the hand to watch for a double-click; wait until an ensuing click:, doubleClick:, or drag: message gets dispatched"
+
+ evt hand waitForClicksOrDrag: self event: evt selectors: { #click:. #doubleClick:. #firstClickTimedOut:. nil} threshold: 5!
Item was added:
+ ----- Method: PlayingCardMorph>>printOn: (in category 'printing') -----
+ printOn: aStream
+
+ aStream
+ print: cardNumber;
+ nextPutAll: ' of ';
+ print: (self class suits at: suitNumber).!
Item was added:
+ ----- Method: PlayingCardMorph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
+ slideBackToFormerSituation: evt
+
+ super slideBackToFormerSituation: evt.
+ self board removeProperty: #stateBeforeGrab.
+ self hasSubmorphs ifTrue:
+ ["Just cancelled a drop of multiple cards -- have to unload submorphs"
+ self submorphs reverseDo: [:m | owner addMorphFront: m]].
+ !
Item was added:
+ ----- Method: PlayingCardMorph>>suit (in category 'access') -----
+ suit
+ ^self class suits at: suitNumber!
Item was added:
+ ----- Method: PlayingCardMorph>>suitColor (in category 'access') -----
+ suitColor
+ ^#(black red red black) at: suitNumber!
Item was added:
+ ----- Method: PlayingCardMorph>>suitNumber (in category 'access') -----
+ suitNumber
+
+ ^suitNumber!
Item was added:
+ AlignmentMorph subclass: #SameGame
+ instanceVariableNames: 'board scoreDisplay selectionDisplay helpText'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !SameGame commentStamp: '<historical>' prior: 0!
+ See SameGame>>helpString for an explanation of how to play!
Item was added:
+ ----- Method: SameGame class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Same' translatedNoop
+ categories: {'Games' translatedNoop}
+ documentation: 'A board game implementedby Tim Olson, based on a game originally written for UNIX by Eiji Fukumoto.' translatedNoop!
Item was added:
+ ----- Method: SameGame>>board (in category 'access') -----
+ board
+
+ board ifNil:
+ [board := SameGameBoard new
+ target: self;
+ actionSelector: #selection].
+ ^ board!
Item was added:
+ ----- Method: SameGame>>board: (in category 'access') -----
+ board: aSameGameBoard
+
+ board := aSameGameBoard!
Item was added:
+ ----- Method: SameGame>>buildButton:target:label:selector: (in category 'initialization') -----
+ buildButton: aButton target: aTarget label: aLabel selector: aSelector
+ "wrap a button or switch in an alignmentMorph to allow a row of buttons to fill space"
+
+ | a |
+ aButton
+ target: aTarget;
+ label: aLabel;
+ actionSelector: aSelector;
+ borderStyle: (BorderStyle raised width: 2 px);
+ color: color.
+ a := AlignmentMorph newColumn
+ wrapCentering: #center; cellPositioning: #topCenter;
+ hResizing: #spaceFill;
+ vResizing: #shrinkWrap;
+ color: color.
+ a addMorph: aButton.
+ ^ a!
Item was added:
+ ----- Method: SameGame>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color lightGray!
Item was added:
+ ----- Method: SameGame>>help: (in category 'actions') -----
+ help: helpState
+
+ helpState
+ ifTrue: [helpText := self helpText.
+ "Text layout is broken, so add text and apply #spaceFill to make line breaks work"
+ self addMorphBack: helpText.
+ helpText textMorph hResizing: #spaceFill]
+ ifFalse: [helpText delete]!
Item was added:
+ ----- Method: SameGame>>helpString (in category 'access') -----
+ helpString
+ ^ 'The object of SameGame is to maximize your score by removing tiles from the board. Tiles are selected and removed by clicking on a tile that has at least one adjacent tile of the same color (where adjacent is defined as up, down, left, or right).
+
+ The first click selects a group of adjacent tiles, a second click in that group will remove it from the board, sliding tiles down and right to fill the space of the removed group. If you wish to select a different group, simply click on it instead.
+
+ The score increases by "(selection - 2) squared", so you want to maximize the selection size as much as possible. However, making small strategic selections may allow you to increase the size of a later selection.
+
+ If you are having a hard time finding a group, the "Hint" button will find one and select it for you (although it is likely not the best group to select!!).
+
+ When there are no more groups available, the score display will flash with your final score. Your final score is reduced by 1 for each tile remaining on the board. If you manage to remove all tiles, your final score is increased by a bonus of 5 times the number of tiles on a full board.
+
+ Come on, you can beat that last score!! Click "New game" ;-)
+
+ SameGame was originally written by Eiji Fukumoto for UNIX and X; this version is based upon the same game concept, but was rewritten from scratch.' translated!
Item was added:
+ ----- Method: SameGame>>helpText (in category 'access') -----
+ helpText
+
+ helpText ifNil:
+ [helpText := PluggableTextMorph new
+ width: board width;
+ editString: self helpString].
+ ^ helpText!
Item was added:
+ ----- Method: SameGame>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ self listDirection: #topToBottom;
+ wrapCentering: #center;
+ cellPositioning: #topCenter;
+ vResizing: #shrinkWrap;
+ hResizing: #shrinkWrap;
+ layoutInset: 3 px;
+ addMorph: self makeControls;
+ addMorph: self board.
+ helpText := nil.
+ self newGame!
Item was added:
+ ----- Method: SameGame>>makeControls (in category 'initialization') -----
+ makeControls
+
+ | row |
+ row := AlignmentMorph newRow
+ color: color;
+ borderWidth: 0;
+ layoutInset: 3 px.
+ row hResizing: #spaceFill; vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; extent: 5 px @ 5 px.
+ row addMorph:
+ (self
+ buildButton: SimpleSwitchMorph new
+ target: self
+ label: 'Help' translated
+ selector: #help:).
+ row addMorph:
+ (self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'Quit' translated
+ selector: #delete).
+ row addMorph:
+ (self
+ buildButton: SimpleButtonMorph new
+ target: self board
+ label: 'Hint' translated
+ selector: #hint).
+ row addMorph:
+ (self
+ buildButton: SimpleButtonMorph new
+ target: self
+ label: 'New game' translated
+ selector: #newGame).
+ selectionDisplay := LedMorph new
+ digits: 2;
+ extent: (10 px * 2 @ 15 px).
+ row addMorph: (self wrapPanel: selectionDisplay label: 'Selection:' translated).
+ scoreDisplay := LedMorph new
+ digits: 4;
+ extent: (10 px * 4 @ 15 px).
+ row addMorph: (self wrapPanel: scoreDisplay label: 'Score:' translated).
+ ^ row!
Item was added:
+ ----- Method: SameGame>>newGame (in category 'actions') -----
+ newGame
+
+ scoreDisplay value: 0; flash: false.
+ selectionDisplay value: 0.
+ self board resetBoard.!
Item was added:
+ ----- Method: SameGame>>scoreDisplay (in category 'access') -----
+ scoreDisplay
+
+ ^ scoreDisplay!
Item was added:
+ ----- Method: SameGame>>selection (in category 'actions') -----
+ selection
+ "a selection was made on the board; get its count and update the displays"
+
+ | count score |
+ count := self board selectionCount.
+ count = 0
+ ifTrue:
+ [score := scoreDisplay value + (selectionDisplay value - 2) squared.
+ board findSelection ifNil:
+ [count := board tilesRemaining.
+ score := count = 0
+ ifTrue: [score + (5 * board rows * board columns)]
+ ifFalse: [score - count max:0].
+ scoreDisplay flash: true].
+ scoreDisplay value: score].
+ selectionDisplay value: count!
Item was added:
+ ----- Method: SameGame>>wrapPanel:label: (in category 'initialization') -----
+ wrapPanel: anLedPanel label: aLabel
+ "wrap an LED panel in an alignmentMorph with a label to its left"
+
+ | a |
+ a := AlignmentMorph newRow
+ wrapCentering: #center; cellPositioning: #leftCenter;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ borderWidth: 0;
+ layoutInset: 3;
+ color: color lighter.
+ a addMorph: anLedPanel.
+ a addMorph: (StringMorph contents: aLabel).
+ ^ a
+
+ !
Item was added:
+ AlignmentMorph subclass: #SameGameBoard
+ instanceVariableNames: 'protoTile rows columns palette selection selectionColor flashColor flash target actionSelector arguments'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !SameGameBoard commentStamp: '<historical>' prior: 0!
+ I am an MxN array of SameGameTiles, and implement most of the logic to play the SameGame, including adjacent tile selection and removal.!
Item was added:
+ ----- Method: SameGameBoard class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: SameGameBoard>>acceptDroppingMorph:event: (in category 'layout') -----
+ acceptDroppingMorph: aMorph event: evt
+ "Allow the user to set the protoTile just by dropping it on this morph."
+
+ self protoTile: aMorph.
+ self removeAllMorphs.
+ !
Item was added:
+ ----- Method: SameGameBoard>>actionSelector (in category 'accessing') -----
+ actionSelector
+
+ ^ actionSelector!
Item was added:
+ ----- Method: SameGameBoard>>actionSelector: (in category 'accessing') -----
+ actionSelector: aSymbolOrString
+
+ (nil = aSymbolOrString or:
+ ['nil' = aSymbolOrString or:
+ [aSymbolOrString isEmpty]])
+ ifTrue: [^ actionSelector := nil].
+
+ actionSelector := aSymbolOrString asSymbol.
+ !
Item was added:
+ ----- Method: SameGameBoard>>adjustTiles (in category 'private') -----
+ adjustTiles
+ "add or remove new protoTile submorphs to fill out my new bounds"
+
+ | newSubmorphs requiredSubmorphs count r c |
+ columns := self width // protoTile width.
+ rows := self height // protoTile height.
+ requiredSubmorphs := rows * columns.
+ newSubmorphs := OrderedCollection new.
+ r := 0.
+ c := 0.
+ self submorphCount > requiredSubmorphs
+ ifTrue: "resized smaller -- delete rows or columns"
+ [count := 0.
+ submorphs do:
+ [:m |
+ count < requiredSubmorphs
+ ifTrue:
+ [m position: self position + (protoTile extent * (c @ r)).
+ m arguments: (Array with: c @ r).
+ newSubmorphs add: m]
+ ifFalse: [m privateOwner: nil].
+ count := count + 1.
+ c := c + 1.
+ c >= columns ifTrue: [c := 0. r := r + 1]]]
+ ifFalse: "resized larger -- add rows or columns"
+ [submorphs do:
+ [:m |
+ m position: self position + (self protoTile extent * (c @ r)).
+ m arguments: (Array with: c @ r).
+ newSubmorphs add: m.
+ c := c + 1.
+ c >= columns ifTrue: [c := 0. r := r + 1]].
+ 1 to: (requiredSubmorphs - self submorphCount) do:
+ [:m |
+ newSubmorphs add:
+ (protoTile copy
+ position: self position + (self protoTile extent * (c @ r));
+ actionSelector: #tileClickedAt:newSelection:;
+ arguments: (Array with: c @ r);
+ target: self;
+ privateOwner: self).
+ c := c + 1.
+ c >= columns ifTrue: [c := 0. r := r + 1]]].
+ submorphs := newSubmorphs asArray.
+ !
Item was added:
+ ----- Method: SameGameBoard>>capturedState (in category 'undo') -----
+ capturedState
+ "Note the state stored in the second element is an array of associations
+ from submorph index to a shallowCopy of the morph, but only for those
+ morphs that change. Therefore the capturedState record *first* delivers
+ all the morphs, and *then* computes the difference and stores this back.
+ In the end, both undo and redo records follow this format."
+
+ | prior state oldMorphs priorChanges newChanges |
+ (prior := self valueOfProperty: #priorState) isNil
+ ifTrue:
+ [state := {
+ self shallowCopy. "selection, etc."
+ self submorphs collect: [:m | m shallowCopy]. "state of all tiles"
+ owner scoreDisplay flash. "score display"
+ owner scoreDisplay value}.
+ self setProperty: #priorState toValue: state.
+ ^state].
+ oldMorphs := prior second.
+ priorChanges := OrderedCollection new.
+ newChanges := OrderedCollection new.
+ 1 to: oldMorphs size
+ do:
+ [:i |
+ (oldMorphs at: i) color = (submorphs at: i) color
+ ifFalse:
+ [priorChanges addLast: i -> (oldMorphs at: i).
+ newChanges addLast: i -> (submorphs at: i) shallowCopy]].
+ self removeProperty: #priorState.
+ prior at: 2 put: priorChanges asArray. "Store back into undo state.2"
+ ^{
+ self shallowCopy. "selection, etc."
+ newChanges asArray. "state of tiles that changed"
+ owner scoreDisplay flash. "score display"
+ owner scoreDisplay value}!
Item was added:
+ ----- Method: SameGameBoard>>collapseColumn:fromRow: (in category 'actions') -----
+ collapseColumn: col fromRow: row
+
+ | targetTile sourceTile |
+ (targetTile := self tileAt: col@row) disabled ifTrue:
+ [row - 1 to: 0 by: -1 do:
+ [:r |
+ (sourceTile := self tileAt: col@r) disabled ifFalse:
+ [targetTile color: sourceTile color.
+ targetTile disabled: false.
+ sourceTile disabled: true.
+ ^ true]]].
+ ^ false
+ !
Item was added:
+ ----- Method: SameGameBoard>>collapseColumns: (in category 'actions') -----
+ collapseColumns: columnsToCollapse
+
+ | columnsToRemove |
+ columnsToRemove := OrderedCollection new.
+ columnsToCollapse do:
+ [:c |
+ rows - 1 to: 0 by: -1 do: [:r | self collapseColumn: c fromRow: r].
+ (self tileAt: c@(rows-1)) disabled ifTrue: [columnsToRemove add: c]].
+ self world displayWorld.
+ columnsToRemove reverseDo: [:c | self removeColumn: c].
+ !
Item was added:
+ ----- Method: SameGameBoard>>columns (in category 'accessing') -----
+ columns
+
+ ^ columns!
Item was added:
+ ----- Method: SameGameBoard>>columns: (in category 'accessing') -----
+ columns: newColumns
+
+ self extent: self protoTile extent * (newColumns @ rows)!
Item was added:
+ ----- Method: SameGameBoard>>columns:rows: (in category 'accessing') -----
+ columns: newColumns rows: newRows
+
+ self extent: self protoTile extent * (newColumns @ newRows)!
Item was added:
+ ----- Method: SameGameBoard>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 2 px!
Item was added:
+ ----- Method: SameGameBoard>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color gray!
Item was added:
+ ----- Method: SameGameBoard>>deselectSelection (in category 'actions') -----
+ deselectSelection
+
+ selection ifNotNil:
+ [selection do: [:loc | (self tileAt: loc) setSwitchState: false; color: selectionColor].
+ selection := nil.
+ flash := false]!
Item was added:
+ ----- Method: SameGameBoard>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "constrain the extent to be a multiple of the protoTile size during resizing"
+ super extent: (aPoint truncateTo: protoTile extent).
+ self adjustTiles.!
Item was added:
+ ----- Method: SameGameBoard>>findSelection (in category 'actions') -----
+ findSelection
+ "find a possible selection and return it, or nil if no selection"
+
+ | tile k testTile |
+ 0 to: rows-1 do:
+ [:r |
+ 0 to: columns-1 do:
+ [:c |
+ tile := self tileAt: c@r.
+ tile disabled ifFalse:
+ [k := tile color.
+ c+1 < columns ifTrue:
+ [testTile := self tileAt: (c+1)@r.
+ (testTile disabled not and: [testTile color = k]) ifTrue: [^ tile]].
+ r+1 < rows ifTrue:
+ [testTile := self tileAt: c@(r+1).
+ (testTile disabled not and: [testTile color = k]) ifTrue: [^ tile]]]]].
+ ^ nil
+ !
Item was added:
+ ----- Method: SameGameBoard>>hint (in category 'actions') -----
+ hint
+ "find a possible selection and select it"
+
+ | tile |
+ self deselectSelection.
+ tile := self findSelection.
+ tile ifNotNil: [tile mouseDown: MouseButtonEvent new]!
Item was added:
+ ----- Method: SameGameBoard>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ target := nil.
+ actionSelector := #selection.
+ arguments := #().
+ self layoutPolicy: nil.
+ self hResizing: #rigid.
+ self vResizing: #rigid.
+ rows := self preferredRows.
+ columns := self preferredColumns.
+
+ palette := (Color wheel: self preferredTileTypes + 1) asOrderedCollection.
+ flashColor := palette removeLast.
+ flash := false.
+ self extent: self protoTile extent * (columns @ rows).
+ self resetBoard!
Item was added:
+ ----- Method: SameGameBoard>>preferredColumns (in category 'preferences') -----
+ preferredColumns
+
+ ^ 20!
Item was added:
+ ----- Method: SameGameBoard>>preferredRows (in category 'preferences') -----
+ preferredRows
+
+ ^ 10!
Item was added:
+ ----- Method: SameGameBoard>>preferredTileTypes (in category 'preferences') -----
+ preferredTileTypes
+
+ ^ 5!
Item was added:
+ ----- Method: SameGameBoard>>protoTile (in category 'accessing') -----
+ protoTile
+
+ protoTile ifNil: [protoTile := SameGameTile new].
+ ^ protoTile!
Item was added:
+ ----- Method: SameGameBoard>>protoTile: (in category 'accessing') -----
+ protoTile: aTile
+
+ protoTile := aTile!
Item was added:
+ ----- Method: SameGameBoard>>removeColumn: (in category 'actions') -----
+ removeColumn: column
+
+ | sourceTile |
+ column+1 to: columns-1 do:
+ [:c |
+ 0 to: rows-1 do:
+ [:r |
+ sourceTile := self tileAt: c@r.
+ (self tileAt: c-1@r)
+ color: sourceTile color;
+ disabled: sourceTile disabled]].
+ 0 to: rows-1 do:
+ [:r | (self tileAt: columns-1@r) disabled: true]!
Item was added:
+ ----- Method: SameGameBoard>>removeSelection (in category 'actions') -----
+ removeSelection
+ selection
+ ifNil: [^ self].
+ self
+ rememberUndoableAction: [selection
+ do: [:loc | (self tileAt: loc) setSwitchState: false; disabled: true].
+ self collapseColumns: (selection
+ collect: [:loc | loc x] as: Set) sorted.
+ selection := nil.
+ flash := false.
+ (target notNil
+ and: [actionSelector notNil])
+ ifTrue: [target perform: actionSelector withArguments: arguments]]
+ named: 'remove selection' translated!
Item was added:
+ ----- Method: SameGameBoard>>resetBoard (in category 'initialization') -----
+ resetBoard
+ Collection initialize. "randomize"
+ selection := nil.
+ self purgeAllCommands.
+ self submorphsDo:
+ [:m |
+ m disabled: false.
+ m setSwitchState: false.
+ m color: palette atRandom].
+
+ !
Item was added:
+ ----- Method: SameGameBoard>>rows (in category 'accessing') -----
+ rows
+
+ ^ rows!
Item was added:
+ ----- Method: SameGameBoard>>rows: (in category 'accessing') -----
+ rows: newRows
+
+ self extent: self protoTile extent * (columns @ newRows)!
Item was added:
+ ----- Method: SameGameBoard>>selectTilesAdjacentTo: (in category 'actions') -----
+ selectTilesAdjacentTo: location
+
+ | al at |
+ {-1@0. 0@ -1. 1@0. 0@1} do:
+ [:offsetPoint |
+ al := location + offsetPoint.
+ ((al x between: 0 and: columns - 1) and: [al y between: 0 and: rows - 1]) ifTrue:
+ [at := self tileAt: al.
+ (at color = selectionColor and: [at switchState not and: [at disabled not]]) ifTrue:
+ [selection add: al.
+ at setSwitchState: true.
+ self selectTilesAdjacentTo: al]]]
+ !
Item was added:
+ ----- Method: SameGameBoard>>selectionCount (in category 'accessing') -----
+ selectionCount
+
+ ^ selection isNil
+ ifTrue: [0]
+ ifFalse: [selection size]!
Item was added:
+ ----- Method: SameGameBoard>>step (in category 'stepping') -----
+ step
+
+ | newColor |
+ selection ifNotNil:
+ [newColor := flash
+ ifTrue: [selectionColor]
+ ifFalse: [flashColor].
+ selection do: [:loc | (self tileAt: loc) color: newColor].
+ flash := flash not]
+ !
Item was added:
+ ----- Method: SameGameBoard>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^ 500!
Item was added:
+ ----- Method: SameGameBoard>>target (in category 'accessing') -----
+ target
+
+ ^ target!
Item was added:
+ ----- Method: SameGameBoard>>target: (in category 'accessing') -----
+ target: anObject
+
+ target := anObject!
Item was added:
+ ----- Method: SameGameBoard>>tileAt: (in category 'accessing') -----
+ tileAt: aPoint
+
+ ^ submorphs at: (aPoint x + (aPoint y * columns) + 1)!
Item was added:
+ ----- Method: SameGameBoard>>tileClickedAt:newSelection: (in category 'actions') -----
+ tileClickedAt: location newSelection: isNewSelection
+ | tile |
+ isNewSelection
+ ifTrue:
+ [self deselectSelection.
+ tile := self tileAt: location.
+ selectionColor := tile color.
+ selection := OrderedCollection with: location.
+ self selectTilesAdjacentTo: location.
+ selection size = 1
+ ifTrue: [self deselectSelection]
+ ifFalse:
+ [(target notNil and: [actionSelector notNil])
+ ifTrue: [target perform: actionSelector withArguments: arguments]]]
+ ifFalse: [self removeSelection]!
Item was added:
+ ----- Method: SameGameBoard>>tilesRemaining (in category 'private') -----
+ tilesRemaining
+
+ ^ (submorphs reject: [:m | m disabled]) size
+ !
Item was added:
+ ----- Method: SameGameBoard>>undoFromCapturedState: (in category 'undo') -----
+ undoFromCapturedState: st
+
+ self copyFrom: st first.
+ st second do: [:assn | (submorphs at: assn key) copyFrom: assn value].
+ selection ifNotNil:
+ [selection do: [:loc | (self tileAt: loc) setSwitchState: false; color: selectionColor].
+ selection := nil].
+ owner scoreDisplay flash: st third. "score display"
+ owner scoreDisplay value: st fourth.
+ self changed.!
Item was added:
+ SimpleSwitchMorph subclass: #SameGameTile
+ instanceVariableNames: 'switchState disabled oldSwitchState'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !SameGameTile commentStamp: '<historical>' prior: 0!
+ I am a single tile for the SameGame. I act much like a switch.!
Item was added:
+ ----- Method: SameGameTile class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: SameGameTile>>color: (in category 'accessing') -----
+ color: aColor
+ super color: aColor.
+ self borderColor: aColor.
+ onColor := aColor.
+ offColor := aColor.
+ self changed!
Item was added:
+ ----- Method: SameGameTile>>disabled (in category 'accessing') -----
+ disabled
+
+ ^ disabled!
Item was added:
+ ----- Method: SameGameTile>>disabled: (in category 'accessing') -----
+ disabled: aBoolean
+
+ disabled := aBoolean.
+ disabled
+ ifTrue:
+ [self color: owner color.
+ self borderColor: owner color]
+ ifFalse:
+ [self setSwitchState: self switchState]!
Item was added:
+ ----- Method: SameGameTile>>doButtonAction (in category 'button') -----
+ doButtonAction
+ "Perform the action of this button. The last argument of the message sent to the target is the new state of this switch."
+
+ (target notNil and: [actionSelector notNil])
+ ifTrue:
+ [target perform: actionSelector
+ withArguments: (arguments copyWith: switchState)]!
Item was added:
+ ----- Method: SameGameTile>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+ self label: ''.
+ self borderWidth: 2 px.
+ bounds := 0 @ 0 corner: 16 px @ 16 px.
+ offColor := Color gray.
+ onColor := Color gray.
+ switchState := false.
+ oldSwitchState := false.
+ disabled := false.
+ self useSquareCorners.!
Item was added:
+ ----- Method: SameGameTile>>insetColor (in category 'accessing') -----
+ insetColor
+ "Use my own color for insets"
+ ^color!
Item was added:
+ ----- Method: SameGameTile>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+
+ disabled ifFalse:
+ [oldSwitchState := switchState.
+ self setSwitchState: (oldSwitchState = false).
+ self doButtonAction].
+ !
Item was added:
+ ----- Method: SameGameTile>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+
+ "don't do anything, here"!
Item was added:
+ ----- Method: SameGameTile>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+
+ "don't do anything, here"!
Item was added:
+ ----- Method: SameGameTile>>setSwitchState: (in category 'accessing') -----
+ setSwitchState: aBoolean
+
+ switchState := aBoolean.
+ disabled ifFalse:
+ [switchState
+ ifTrue:
+ [self borderInset.
+ self color: onColor]
+ ifFalse:
+ [self borderRaised.
+ self color: offColor]]!
Item was added:
+ ----- Method: SameGameTile>>switchState (in category 'accessing') -----
+ switchState
+
+ ^ switchState!
Item was added:
+ AlignmentMorph subclass: #SpectrumAnalyzerMorph
+ instanceVariableNames: 'soundInput statusLight levelMeter graphMorph sonogramMorph fft displayType'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-SoundInterface'!
+
+ !SpectrumAnalyzerMorph commentStamp: '<historical>' prior: 0!
+ I am a tool for analyzing sound data from a microphone, CD, or other input source in real time. I have several display modes:
+
+ signal snapshots of the raw signal data as it arrives
+ spectrum frequency spectrum of the signal data as it arrives
+ sonogram scrolling plot of the frequency spectrum over time,
+ where the vertical axis is frequency, the horizontal
+ axis is time, and amount of energy at a given
+ frequency is shown as a grayscale value with
+ larger values being darker
+
+ To use this tool, be sure that you have selected the proper sound source using you host OS facilities. Set the desired sampling rate and FFT size (try 22050 samples/sec and an FFT size of 512) then click on the 'start' button. Use the slider to adjust the level so that the yellow level indicator peaks somewhere between the middle and the right edge at the maximum signal level.
+
+ Note that if the level meter peaks hit the right edge, you will get 'clipping', which creates a bunch of spurious high frequency noise in the frequency spectrum. If the display is set to 'signal' mode, you can actually see the tops and bottoms of the waveform being cut off when clipping occurs.
+
+ Many machines may not be able to perform spectrum analysis in real time, especially at higher sampling rates and larger FFT sizes. In both 'signal' and 'spectrum' modes, this tool will skip data to try to keep up with real time. However, in 'sonogram' mode it always processes all the data, even if it falls behind. This allows you to get a complete sonogram without dropouts even on a slower machine. However, as the sonogram display falls behind there will be a larger and larger time lag between when a sound is input and when it appears on the display.
+
+ The smaller the FFT size, the less frequency resolution you get. The lower the sampling rate, the less total frequency range you get. For an FFT size of N and a sampling rate of R, each of the N/2 'bins' of the frequency spectrum has a frequency resolution of R / N. For example, at a sampleing rate of 22050 samples/second, the total frequency range is 0 to 11025 Hz and an FFT of size 256 would divide this range into 128 bins (the output of an FFT of size N has N/2 bins), each of which covers a frequency band about 86 Hz wide.
+
+ To increase time resolution, increase the sampling rate and decrease the FFT size.
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self
+ partName: 'Spectrum Analyzer' translatedNoop
+ categories: {'Multimedia' translatedNoop}
+ documentation: 'A device for analyzing sound input' translatedNoop
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>addButtonRow (in category 'private') -----
+ addButtonRow
+
+ | r |
+ r := AlignmentMorph newRow vResizing: #shrinkWrap.
+ r addMorphBack: (self buttonName: 'Menu' translated action: #invokeMenu).
+ r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
+ r addMorphBack: (self buttonName: 'Start' translated action: #start).
+ r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
+ r addMorphBack: (self buttonName: 'Stop' translated action: #stop).
+ r addMorphBack: (Morph new extent: 12@1; color: Color transparent).
+ self addMorphBack: r.
+ ^ r fullBounds.
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>addLevelSliderIn: (in category 'private') -----
+ addLevelSliderIn: aPoint
+
+ | levelSlider r |
+ (levelSlider := SimpleSliderMorph new)
+ color: color;
+ sliderColor: Color gray;
+ extent: (aPoint x * 0.75) asInteger @ (aPoint y * 0.6) asInteger;
+ minimumExtent: levelSlider extent;
+ target: soundInput;
+ actionSelector: #recordLevel:;
+ orientation: #horizontal;
+ adjustToValue: soundInput recordLevel.
+ r := AlignmentMorph newRow
+ color: color;
+ layoutInset: 0;
+ wrapCentering: #center; cellPositioning: #leftCenter;
+ hResizing: #shrinkWrap;
+ vResizing: #rigid;
+ height: aPoint y + 2 px.
+ r addMorphBack: (StringMorph contents: '0 ' font: Preferences standardButtonFont).
+ r addMorphBack: levelSlider.
+ r addMorphBack: (StringMorph contents: ' 10' font: Preferences standardButtonFont).
+ self addMorphBack: r.!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>buttonName:action: (in category 'private') -----
+ buttonName: aString action: aSymbol
+
+ ^ SimpleButtonMorph new
+ target: self;
+ label: aString font: Preferences standardButtonFont;
+ actionSelector: aSymbol
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 2 px!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>delete (in category 'submorphs - add/remove') -----
+ delete
+ "Turn off recording when this morph is deleted."
+
+ super delete.
+ soundInput stopRecording.
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>fftSize: (in category 'accessing') -----
+ fftSize: aSize
+
+ | on |
+ on := soundInput isRecording.
+ self stop.
+ fft := FFT new: aSize.
+ self resetDisplay.
+ on ifTrue: [self start].!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ | full |
+ super initialize.
+ ""
+ self listDirection: #topToBottom.
+ soundInput := SoundInputStream new samplingRate: 22050.
+ fft := FFT new: 512.
+ displayType := 'sonogram'.
+ self hResizing: #shrinkWrap.
+ self vResizing: #shrinkWrap.
+ full := self addButtonRow.
+ submorphs last addMorphBack: (self makeStatusLightIn: full extent).
+
+ self addLevelSliderIn: full extent.
+ self addMorphBack: (self makeLevelMeterIn: full extent).
+ self addMorphBack: (Morph new extent: 10 px @ 10 px;
+ color: Color transparent).
+ "spacer"
+ self resetDisplay!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>invokeMenu (in category 'menu and buttons') -----
+ invokeMenu
+ "Invoke the settings menu."
+
+ | aMenu |
+ aMenu := CustomMenu new.
+ aMenu addList: {
+ {'set sampling rate' translated. #setSamplingRate}.
+ {'set FFT size' translated. #setFFTSize}.
+ {'set display type' translated. #setDisplayType}}.
+ aMenu invokeOn: self defaultSelection: nil.
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>makeLevelMeterIn: (in category 'private') -----
+ makeLevelMeterIn: aPoint
+
+ | outerBox h |
+ h := (aPoint y * 0.6) asInteger.
+ outerBox := Morph new extent: aPoint x asInteger @ h; color: Color gray.
+ levelMeter := Morph new extent: 1 px @ h; color: Color yellow.
+ levelMeter position: outerBox topLeft + (1 px @ 1 px).
+ outerBox addMorph: levelMeter.
+ ^ outerBox!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>makeStatusLightIn: (in category 'private') -----
+ makeStatusLightIn: aPoint
+
+ | s p |
+ p := (aPoint x min: aPoint y) asPoint.
+ statusLight := RectangleMorph new extent: p.
+ statusLight color: Color gray.
+ s := StringMorph contents: '' font: Preferences standardButtonFont.
+ statusLight addMorph: s.
+ ^ statusLight!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>processBuffer: (in category 'private') -----
+ processBuffer: buf
+ "Analyze one buffer of data."
+
+ | data |
+ data := displayType = 'signal'
+ ifTrue: [buf]
+ ifFalse: [fft transformDataFrom: buf startingAt: 1].
+ graphMorph ifNotNil:
+ [graphMorph
+ data: data;
+ changed].
+ sonogramMorph ifNotNil:
+ [data := data collect: [:v | v sqrt]. "square root compresses dynamic range"
+ data /= 400.0.
+ sonogramMorph plotColumn: (data copyFrom: 1 to: data size // 1)]!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>removeAllDisplays (in category 'private') -----
+ removeAllDisplays
+ "Remove all currently showing displays."
+
+ sonogramMorph ifNotNil: [sonogramMorph delete].
+ graphMorph ifNotNil: [graphMorph delete].
+ sonogramMorph := graphMorph := nil.
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>resetDisplay (in category 'menu and buttons') -----
+ resetDisplay
+ "Recreate my display after changing some parameter such as FFT size."
+
+ displayType = 'signal' ifTrue: [self showSignal].
+ displayType = 'spectrum' ifTrue: [self showSpectrum].
+ displayType = 'sonogram' ifTrue: [self showSonogram].
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>setDisplayType (in category 'menu and buttons') -----
+ setDisplayType
+ "Set the display type."
+
+ | aMenu choice on |
+ aMenu := CustomMenu new title: ('display type (currently {1})' translated format:{displayType}).
+ aMenu addList: {
+ {'signal' translated. 'signal'}.
+ {'spectrum' translated. 'spectrum'}.
+ {'sonogram' translated. 'sonogram'}}.
+ choice := aMenu startUp.
+ choice ifNil: [^ self].
+
+ on := soundInput isRecording.
+ self stop.
+ displayType := choice.
+ self resetDisplay.
+ on ifTrue: [self start].
+
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>setFFTSize (in category 'menu and buttons') -----
+ setFFTSize
+ "Set the size of the FFT used for frequency analysis."
+
+ | aMenu sz |
+ aMenu := CustomMenu new title: ('FFT size (currently {1})' translated format:{fft n}).
+ ((7 to: 10) collect: [:n | 2 raisedTo: n]) do:[:r | aMenu add: r printString action: r].
+ sz := aMenu startUp.
+ sz ifNil: [^ self].
+ self fftSize: sz.!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>setSamplingRate (in category 'menu and buttons') -----
+ setSamplingRate
+ "Set the sampling rate to be used for incoming sound data."
+
+ | aMenu rate on |
+ aMenu := CustomMenu new title:
+ ('Sampling rate (currently {1})' translated format:{soundInput samplingRate}).
+ #(11025 22050 44100) do:[:r | aMenu add: r printString action: r].
+ rate := aMenu startUp.
+ rate ifNil: [^ self].
+ on := soundInput isRecording.
+ self stop.
+ soundInput samplingRate: rate.
+ self resetDisplay.
+ on ifTrue: [self start].
+
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>showSignal (in category 'private') -----
+ showSignal
+ "Display the actual signal waveform."
+
+ displayType := 'signal'.
+ self removeAllDisplays.
+ graphMorph := GraphMorph new.
+ graphMorph extent: (400 px + (graphMorph borderWidth * 2)) @ 128 px.
+ graphMorph data: (Array new: 100 withAll: 0).
+ graphMorph color: (Color r: 0.8 g: 1.0 b: 1.0).
+ self addMorphBack: graphMorph.
+ self extent: 10 px @ 10 px. "shrink to minimum size"!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>showSonogram (in category 'private') -----
+ showSonogram
+ "Display a sonogram showing the frequency spectrum versus time."
+
+ | zeros h w |
+ displayType := 'sonogram'.
+ self removeAllDisplays.
+ h := fft n // 2.
+ h := h min: 512 px max: 64 px.
+ w := 400 px.
+ sonogramMorph :=
+ Sonogram new
+ extent: w@h
+ minVal: 0.0
+ maxVal: 1.0
+ scrollDelta: w.
+ zeros := Array new: sonogramMorph height withAll: 0.
+ sonogramMorph width timesRepeat: [sonogramMorph plotColumn: zeros].
+ self addMorphBack: sonogramMorph.
+ self extent: 10 px @ 10 px. "shrink to minimum size"!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>showSpectrum (in category 'private') -----
+ showSpectrum
+ "Display the frequency spectrum."
+
+ displayType := 'spectrum'.
+ self removeAllDisplays.
+ graphMorph := GraphMorph new.
+ graphMorph extent: ((fft n // 2) + (graphMorph borderWidth * 2)) @ 128 px.
+ graphMorph data: (Array new: fft n // 2 withAll: 0).
+ self addMorphBack: graphMorph.
+ self extent: 10 px @ 10 px. "shrink to minimum size"!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>start (in category 'stepping') -----
+ start
+ "Start displaying sound data."
+
+ displayType = 'signal'
+ ifTrue: [soundInput bufferSize: graphMorph width - (2 * graphMorph borderWidth)]
+ ifFalse: [soundInput bufferSize: fft n].
+ soundInput startRecording.
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>step (in category 'stepping') -----
+ step
+ "Update the record light, level meter, and display."
+
+ | w |
+ "update the record light and level meter"
+ statusLight color:
+ (soundInput isRecording ifTrue: [Color yellow] ifFalse: [Color gray]).
+ statusLight firstSubmorph in: [:stringMorph |
+ stringMorph contents:
+ (soundInput isRecording ifTrue: ['On' translated] ifFalse: ['Off' translated]).
+ stringMorph position: statusLight center - (stringMorph extent // 2)].
+
+ w := ((121 px * soundInput meterLevel) // 100) max: 1.
+ levelMeter width: w.
+
+ "update the display if any data is available"
+ self updateDisplay.!
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^ 0
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>stop (in category 'stepping') -----
+ stop
+ "Stop displaying sound data."
+
+ soundInput stopRecording.
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>stopStepping (in category 'stepping') -----
+ stopStepping
+ "Turn off recording."
+
+ super stopStepping.
+ soundInput stopRecording.
+ !
Item was added:
+ ----- Method: SpectrumAnalyzerMorph>>updateDisplay (in category 'private') -----
+ updateDisplay
+ "Update the display if any data is available."
+
+ | buf bufCount |
+ soundInput bufferCount = 0 ifTrue: [^ self].
+
+ graphMorph ifNotNil: [
+ [soundInput bufferCount > 0] whileTrue: [
+ "skip to the most recent buffer"
+ buf := soundInput nextBufferOrNil].
+ ^ self processBuffer: buf].
+
+ sonogramMorph ifNotNil: [
+ "at small buffer sizes we have to update the sonogram in
+ batches or we may get behind; shoot for 8 updates/second"
+ bufCount := (soundInput samplingRate / (8 * soundInput bufferSize)) truncated max: 1.
+ [bufCount > 0 and: [soundInput bufferCount > 0]] whileTrue: [
+ self processBuffer: (soundInput nextBufferOrNil)]].
+ !
Item was added:
+ AlignmentMorph subclass: #Tetris
+ instanceVariableNames: 'board scoreDisplay pauseSwitch'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !Tetris commentStamp: '<historical>' prior: 0!
+ This is a port of JTetris.java 1.0.0.
+
+ How to start:
+ choose new morph.../Games/Tetris
+
+ How to play:
+ 1) using buttons
+ 2) using keyboard:
+ drop - spacebar
+ move to left - left arrow
+ move to right - right arrow
+ rotate clockwise - up arrow
+ rotate anticlockwise - down arrow
+ NOTE: mouse must be over Tetris!
Item was added:
+ ----- Method: Tetris class>>colors (in category 'constants') -----
+ colors
+
+ ^{
+ Color r: 0.5 g: 0 b: 0.
+ Color r: 0 g: 0.5 b: 0.
+ Color r: 0 g: 0 b: 0.5.
+ Color r: 0.5 g: 0.5 b: 0.
+ Color r: 0.5 g: 0 b: 0.5.
+ Color r: 0 g: 0.5 b: 0.5
+ }
+ !
Item was added:
+ ----- Method: Tetris class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Tetris' translatedNoop
+ categories: {'Games' translatedNoop}
+ documentation: 'Tetris, yes Tetris' translatedNoop!
Item was added:
+ ----- Method: Tetris>>buildButtonTarget:label:selector:help: (in category 'initialization') -----
+ buildButtonTarget: aTarget label: aLabel selector: aSelector help: aString
+
+ ^self rowForButtons
+ addMorph: (
+ SimpleButtonMorph new
+ target: aTarget;
+ label: aLabel;
+ actionSelector: aSelector;
+ borderStyle: (BorderStyle raised width: 2 px);
+ color: color
+ )!
Item was added:
+ ----- Method: Tetris>>buildSwitchTarget:label:selector:help: (in category 'initialization') -----
+ buildSwitchTarget: aTarget label: aLabel selector: aSelector help: aString
+
+ ^self rowForButtons
+ addMorph: (
+ SimpleSwitchMorph new
+ target: aTarget;
+ label: aLabel;
+ actionSelector: aSelector;
+ borderStyle: (BorderStyle raised width: 2 px);
+ color: color
+ )!
Item was added:
+ ----- Method: Tetris>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color lightGray!
Item was added:
+ ----- Method: Tetris>>handlesKeyboard: (in category 'event handling') -----
+ handlesKeyboard: evt
+ ^true!
Item was added:
+ ----- Method: Tetris>>handlesMouseOver: (in category 'event handling') -----
+ handlesMouseOver: evt
+ ^true
+ !
Item was added:
+ ----- Method: Tetris>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ board := TetrisBoard new game: self.
+ board addDependent: self.
+ self listDirection: #topToBottom;
+ wrapCentering: #center;
+ vResizing: #shrinkWrap;
+ hResizing: #shrinkWrap;
+ layoutInset: 3 px;
+ addMorphBack: self makeGameControls;
+ addMorphBack: self makeMovementControls;
+ addMorphBack: self showScoreDisplay;
+ addMorphBack: board.
+ board newGame.
+
+ self updateGameOver.!
Item was added:
+ ----- Method: Tetris>>isGameOver (in category 'testing') -----
+ isGameOver
+
+ ^ board isGameOver!
Item was added:
+ ----- Method: Tetris>>keyStroke: (in category 'event handling') -----
+ keyStroke: evt
+
+ | charValue |
+ charValue := evt keyCharacter asciiValue.
+ charValue = 28 ifTrue: [board moveLeft].
+ charValue = 29 ifTrue: [board moveRight].
+ charValue = 30 ifTrue: [board rotateClockWise].
+ charValue = 31 ifTrue: [board rotateAntiClockWise].
+ charValue = 32 ifTrue: [board dropAllTheWay].
+ !
Item was added:
+ ----- Method: Tetris>>makeGameControls (in category 'initialization') -----
+ makeGameControls
+ ^ self rowForButtons
+ addMorph: (self
+ buildButtonTarget: self
+ label: 'Quit' translated
+ selector: #delete
+ help: 'quit' translated);
+
+ addMorph: (pauseSwitch := (self
+ buildSwitchTarget: self
+ label: 'Pause' translated
+ selector: #pause
+ help: 'pause' translated) firstSubmorph) owner;
+
+ addMorph: (self
+ buildButtonTarget: self
+ label: 'New game' translated
+ selector: #newGame
+ help: 'new game' translated)!
Item was added:
+ ----- Method: Tetris>>makeMovementControls (in category 'initialization') -----
+ makeMovementControls
+ ^ self rowForButtons
+ addMorph: (self
+ buildButtonTarget: board
+ label: '->'
+ selector: #moveRight
+ help: 'move to the right' translated);
+
+ addMorph: (self
+ buildButtonTarget: board
+ label: ' ) '
+ selector: #rotateClockWise
+ help: 'rotate clockwise' translated);
+
+ addMorph: (self
+ buildButtonTarget: board
+ label: ' | '
+ selector: #dropAllTheWay
+ help: 'drop' translated);
+
+ addMorph: (self
+ buildButtonTarget: board
+ label: ' ( '
+ selector: #rotateAntiClockWise
+ help: 'rotate anticlockwise' translated);
+
+ addMorph: (self
+ buildButtonTarget: board
+ label: '<-'
+ selector: #moveLeft
+ help: 'move to the left' translated)!
Item was added:
+ ----- Method: Tetris>>mouseEnter: (in category 'event handling') -----
+ mouseEnter: evt
+ evt hand newKeyboardFocus: self!
Item was added:
+ ----- Method: Tetris>>newGame (in category 'actions') -----
+ newGame
+
+ board newGame.!
Item was added:
+ ----- Method: Tetris>>pause (in category 'actions') -----
+ pause
+
+ board pause.
+ pauseSwitch setSwitchState: self paused.!
Item was added:
+ ----- Method: Tetris>>paused (in category 'testing') -----
+ paused
+
+ ^ board paused!
Item was added:
+ ----- Method: Tetris>>rowForButtons (in category 'initialization') -----
+ rowForButtons
+
+ ^AlignmentMorph newRow
+ color: color;
+ borderWidth: 0;
+ layoutInset: 3 px;
+ vResizing: #shrinkWrap;
+ wrapCentering: #center
+ !
Item was added:
+ ----- Method: Tetris>>score: (in category 'events') -----
+ score: anInteger
+
+ scoreDisplay value: anInteger!
Item was added:
+ ----- Method: Tetris>>showScoreDisplay (in category 'initialization') -----
+ showScoreDisplay
+ ^ self rowForButtons hResizing: #shrinkWrap;
+
+ addMorph: (self wrapPanel: ((scoreDisplay := LedMorph new) digits: 5;
+ extent: 10 px * 4 @ 15 px) label: 'Score:' translated)!
Item was added:
+ ----- Method: Tetris>>update: (in category 'updating') -----
+ update: what
+
+ what = #paused ifTrue:
+ [pauseSwitch setSwitchState: self paused].
+ what = #isGameOver ifTrue:
+ [self updateGameOver].
+
+ ^ super update: what!
Item was added:
+ ----- Method: Tetris>>updateGameOver (in category 'events') -----
+ updateGameOver
+
+ scoreDisplay color: (self isGameOver ifTrue: [Color red] ifFalse: [Color green]).!
Item was added:
+ ----- Method: Tetris>>wrapPanel:label: (in category 'initialization') -----
+ wrapPanel: anLedPanel label: aLabel
+ "wrap an LED panel in an alignmentMorph with a label to its left"
+
+ ^self rowForButtons
+ color: color lighter;
+ addMorph: anLedPanel;
+ addMorph: (StringMorph contents: aLabel)
+ !
Item was added:
+ Morph subclass: #TetrisBlock
+ instanceVariableNames: 'angle shapeInfo board baseCellNumber'
+ classVariableNames: 'ShapeChoices'
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
Item was added:
+ ----- Method: TetrisBlock class>>flipShapes: (in category 'support') -----
+ flipShapes: anArray
+
+ ^OrderedCollection new
+ add: anArray;
+ add: (anArray collect: [ :each | each y negated @ each x]);
+ add: (anArray collect: [ :each | each x negated @ each y negated]);
+ add: (anArray collect: [ :each | each y @ each x negated]);
+ yourself
+
+ !
Item was added:
+ ----- Method: TetrisBlock class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: TetrisBlock class>>shapeChoices (in category 'constants') -----
+ shapeChoices
+
+ ^ ShapeChoices ifNil: [
+ ShapeChoices := {
+ { { 0 @ 0 . 1 @ 0 . 0 @ 1 . 1 @ 1 } }. "square - one is sufficient here"
+ self flipShapes: { 0 @ 0 . -1 @ 0 . 1 @ 0 . 0 @ -1 }. "T"
+ {
+ { 0 @ 0 . -1 @ 0 . 1 @ 0 . 2 @ 0 }.
+ { 0 @ 0 . 0 @ -1 . 0 @ 1 . 0 @ 2 } "long - two are sufficient here"
+ }.
+ self flipShapes: { 0 @ 0 . 0 @ -1 . 0 @ 1 . 1 @ 1 }. "L"
+ self flipShapes: { 0 @ 0 . 0 @ -1 . 0 @ 1 . -1 @ 1 }. "inverted L"
+ self flipShapes: { 0 @ 0 . -1 @ 0 . 0 @ -1 . 1 @ -1 }. "S"
+ self flipShapes: { 0 @ 0 . 1 @ 0 . 0 @ -1 . -1 @ -1 } "Z"
+ }.
+ ]
+ !
Item was added:
+ ----- Method: TetrisBlock>>board: (in category 'as yet unclassified') -----
+ board: theBoard
+
+ board := theBoard.
+ 4 timesRepeat: [
+ self addMorph: (
+ RectangleMorph new
+ color: color;
+ extent: board cellSize;
+ borderRaised
+ )
+ ].
+ self positionCellMorphs.!
Item was added:
+ ----- Method: TetrisBlock>>defaultBounds (in category 'initialization') -----
+ defaultBounds
+ "answer the default bounds for the receiver"
+ ^ (2 px @ 2 px) negated extent: 1 px @ 1 px!
Item was added:
+ ----- Method: TetrisBlock>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Tetris colors atRandom!
Item was added:
+ ----- Method: TetrisBlock>>dropByOne (in category 'as yet unclassified') -----
+ dropByOne
+
+ ^self moveDeltaX: 0 deltaY: 1 deltaAngle: 0!
Item was added:
+ ----- Method: TetrisBlock>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+
+ "keep this puppy out of sight"
+ shapeInfo := self class shapeChoices atRandom.
+ baseCellNumber := 4 atRandom + 2 @ 1.
+ angle := 4 atRandom!
Item was added:
+ ----- Method: TetrisBlock>>moveDeltaX:deltaY:deltaAngle: (in category 'as yet unclassified') -----
+ moveDeltaX: deltaX deltaY: deltaY deltaAngle: deltaAngle
+
+ | delta |
+
+ delta := deltaX @ deltaY.
+ (shapeInfo atWrap: angle + deltaAngle) do: [ :offsetThisCell |
+ (board emptyAt: baseCellNumber + offsetThisCell + delta) ifFalse: [^ false]
+ ].
+ baseCellNumber := baseCellNumber + delta.
+ angle := angle + deltaAngle - 1 \\ 4 + 1.
+ self positionCellMorphs.
+ ^ true !
Item was added:
+ ----- Method: TetrisBlock>>positionCellMorphs (in category 'as yet unclassified') -----
+ positionCellMorphs
+
+ (shapeInfo atWrap: angle) withIndexDo: [ :each :index |
+ (submorphs at: index)
+ position: (board originForCell: baseCellNumber + each)
+ ].
+ fullBounds := nil.
+ self changed.
+
+ !
Item was added:
+ PasteUpMorph subclass: #TetrisBoard
+ instanceVariableNames: 'paused gameOver delay score currentBlock game'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
Item was added:
+ ----- Method: TetrisBoard class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^false!
Item was added:
+ ----- Method: TetrisBoard>>basicGameOver: (in category 'accessing') -----
+ basicGameOver: aBoolean
+
+ gameOver := aBoolean.
+ self changed: #isGameOver.!
Item was added:
+ ----- Method: TetrisBoard>>basicPaused: (in category 'accessing') -----
+ basicPaused: aBoolean
+
+ paused := aBoolean.
+ self changed: #paused.!
Item was added:
+ ----- Method: TetrisBoard>>cellSize (in category 'accessing') -----
+ cellSize
+
+ ^12 px @ 12 px!
Item was added:
+ ----- Method: TetrisBoard>>checkForFullRows (in category 'other') -----
+ checkForFullRows
+
+ | targetY morphsInRow bonus |
+ self numRows to: 2 by: -1 do: [ :row |
+ targetY := (self originForCell: 1@row) y.
+ [
+ morphsInRow := self submorphsSatisfying: [ :each | each top = targetY].
+ morphsInRow size = self numColumns
+ ] whileTrue: [
+ bonus := (morphsInRow collect: [:each | each color]) asSet size = 1
+ ifTrue: [1000]
+ ifFalse: [100].
+ self score: score + bonus.
+ submorphs copy do: [ :each |
+ each top = targetY ifTrue: [
+ each delete
+ ].
+ each top < targetY ifTrue: [
+ each position: each position + (0@self cellSize y)
+ ].
+ ].
+ ].
+ ].
+
+ !
Item was added:
+ ----- Method: TetrisBoard>>defaultBounds (in category 'initialization') -----
+ defaultBounds
+ "answer the default bounds for the receiver"
+ ^ 0 @ 0 extent: self numColumns @ self numRows * self cellSize + (1 px @ 1 px)!
Item was added:
+ ----- Method: TetrisBoard>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color
+ lightBlue!
Item was added:
+ ----- Method: TetrisBoard>>dropAllTheWay (in category 'button actions') -----
+ dropAllTheWay
+
+ self running ifFalse: [^ self].
+ [currentBlock dropByOne] whileTrue: [
+ self score: score + 1
+ ].
+ !
Item was added:
+ ----- Method: TetrisBoard>>emptyAt: (in category 'data') -----
+ emptyAt: aPoint
+
+ | cellOrigin |
+ (aPoint x between: 1 and: self numColumns) ifFalse: [^ false].
+ (aPoint y < 1) ifTrue: [^ true]. "handle early phases"
+ (aPoint y <= self numRows) ifFalse: [^ false].
+ cellOrigin := self originForCell: aPoint.
+ ^(self submorphsSatisfying: [ :each | each topLeft = cellOrigin]) isEmpty
+
+ !
Item was added:
+ ----- Method: TetrisBoard>>game: (in category 'accessing') -----
+ game: aTetris
+
+ game := aTetris!
Item was added:
+ ----- Method: TetrisBoard>>isGameOver (in category 'testing') -----
+ isGameOver
+
+ ^ gameOver!
Item was added:
+ ----- Method: TetrisBoard>>moveLeft (in category 'button actions') -----
+ moveLeft
+
+ self running ifFalse: [^ self].
+ currentBlock moveDeltaX: -1 deltaY: 0 deltaAngle: 0.
+ !
Item was added:
+ ----- Method: TetrisBoard>>moveRight (in category 'button actions') -----
+ moveRight
+
+ self running ifFalse: [^ self].
+ currentBlock moveDeltaX: 1 deltaY: 0 deltaAngle: 0.
+ !
Item was added:
+ ----- Method: TetrisBoard>>newGame (in category 'button actions') -----
+ newGame
+
+ self removeAllMorphs.
+ self basicGameOver: false.
+ self basicPaused: false.
+ delay := 500.
+ currentBlock := nil.
+ self score: 0.
+ !
Item was added:
+ ----- Method: TetrisBoard>>numColumns (in category 'data') -----
+ numColumns
+
+ ^10
+ !
Item was added:
+ ----- Method: TetrisBoard>>numRows (in category 'data') -----
+ numRows
+
+ ^27
+ !
Item was added:
+ ----- Method: TetrisBoard>>originForCell: (in category 'accessing') -----
+ originForCell: aPoint
+
+ ^aPoint - (1@1) * self cellSize + self position
+
+ !
Item was added:
+ ----- Method: TetrisBoard>>pause (in category 'button actions') -----
+ pause
+
+ gameOver ifTrue: [^ self].
+ self basicPaused: self paused not.!
Item was added:
+ ----- Method: TetrisBoard>>paused (in category 'testing') -----
+ paused
+
+ ^ paused!
Item was added:
+ ----- Method: TetrisBoard>>rotateAntiClockWise (in category 'button actions') -----
+ rotateAntiClockWise
+
+ self running ifFalse: [^ self].
+ currentBlock moveDeltaX: 0 deltaY: 0 deltaAngle: -1.
+ !
Item was added:
+ ----- Method: TetrisBoard>>rotateClockWise (in category 'button actions') -----
+ rotateClockWise
+
+ self running ifFalse: [^ self].
+ currentBlock moveDeltaX: 0 deltaY: 0 deltaAngle: 1.
+ !
Item was added:
+ ----- Method: TetrisBoard>>running (in category 'button actions') -----
+ running
+
+ ^currentBlock notNil and: [paused not]!
Item was added:
+ ----- Method: TetrisBoard>>score: (in category 'accessing') -----
+ score: aNumber
+
+ score := aNumber.
+ game score: score.!
Item was added:
+ ----- Method: TetrisBoard>>step (in category 'stepping') -----
+ step
+
+ (self ownerThatIsA: HandMorph) ifNotNil: [^self].
+ paused ifTrue: [^ self].
+ currentBlock ifNil: [
+ currentBlock := TetrisBlock new.
+ self addMorphFront: currentBlock.
+ currentBlock board: self.
+ ] ifNotNil: [
+ currentBlock dropByOne ifFalse: [self storePieceOnBoard]
+ ].
+ !
Item was added:
+ ----- Method: TetrisBoard>>stepTime (in category 'testing') -----
+ stepTime
+ ^ delay!
Item was added:
+ ----- Method: TetrisBoard>>storePieceOnBoard (in category 'other') -----
+ storePieceOnBoard
+
+ currentBlock submorphs do: [ :each |
+ self addMorph: each.
+ ((each top - self top) // self cellSize y) < 3 ifTrue: [
+ self basicPaused: true.
+ self basicGameOver: true.
+ ].
+ ].
+ currentBlock delete.
+ currentBlock := nil.
+ self checkForFullRows.
+ self score: score + 10.
+ delay := delay - 2 max: 80.
+
+ !
Item was added:
+ EllipseMorph subclass: #WatchMorph
+ instanceVariableNames: 'fontName cColor handsColor romanNumerals antialias'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Demo'!
+
+ !WatchMorph commentStamp: '<historical>' prior: 0!
+ This class is a representation of a watch.
+ The labels' font is changeble. Labels' font size increase or decrease when resizing me.
+
+ WatchMorph new openInWorld
+ (WatchMorph fontName: 'ComicPlain' bgColor: Color transparent centerColor: Color transparent) openInWorld " transparent "
+ (WatchMorph fontName: 'ComicBold' bgColor: Color white centerColor: Color black) openInWorld
+
+ Structure:
+ fontName String -- the labels' font name
+ cColor Color -- center color
+ handsColor Color
+ romanNumerals Boolean
+ antialias Boolean!
Item was added:
+ ----- Method: WatchMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ "Answer a description for use in parts bins."
+
+ ^ self partName: 'Clock' translatedNoop
+ categories: #('Just for Fun')
+ documentation: 'An analog clock face' translatedNoop!
Item was added:
+ ----- Method: WatchMorph class>>example (in category 'examples') -----
+ example
+ "WatchMorph example openInWorld"
+
+ ^ (WatchMorph
+ fontName: #BitstreamVeraSerif
+ bgColor: Color lightGray
+ centerColor: Color red paler)
+ handsColor: Color grape;
+ toggleRoman;
+ yourself!
Item was added:
+ ----- Method: WatchMorph class>>fontName:bgColor:centerColor: (in category 'instance creation') -----
+ fontName: aString bgColor: aColor centerColor: otherColor
+ ^ self new
+ fontName: aString;
+ color: aColor;
+ centerColor: otherColor!
Item was added:
+ ----- Method: WatchMorph>>addCustomMenuItems:hand: (in category 'menus') -----
+ addCustomMenuItems: aMenu hand: aHandMorph
+ "Add morph-specific items to the given menu which was invoked by the given hand."
+
+ super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addLine.
+ aMenu addUpdating: #romanNumeralString action: #toggleRoman.
+ aMenu addUpdating: #antiAliasString action: #toggleAntialias.
+ aMenu addLine.
+ aMenu add: 'change font...' translated action: #changeFont.
+ aMenu balloonTextForLastItem: 'Allows you to change the font used to display the numbers.' translated.
+ aMenu add: 'change hands color...' translated action: #changeHandsColor.
+ aMenu balloonTextForLastItem: 'Allows you to specify a new color for the hands of the watch. Note that actual *watch* color can be changed simply by using the halo''s recoloring handle.' translated.
+ aMenu add: 'change center color...' translated action: #changeCenterColor.
+ aMenu balloonTextForLastItem: 'Allows you to specify a new color to be used during PM hours for the center portion of the watch; during AM hours, a lighter shade of the same color will be used.' translated.!
Item was added:
+ ----- Method: WatchMorph>>antiAliasString (in category 'menus') -----
+ antiAliasString
+ ^ (antialias
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'anti-aliasing' translated!
Item was added:
+ ----- Method: WatchMorph>>antialias: (in category 'accessing') -----
+ antialias: aBoolean
+ antialias := aBoolean!
Item was added:
+ ----- Method: WatchMorph>>centerColor: (in category 'accessing') -----
+ centerColor: aColor
+ "Set the center color as indicated; map nil into transparent"
+
+ cColor := aColor ifNil: [Color transparent]!
Item was added:
+ ----- Method: WatchMorph>>changeCenterColor (in category 'menus') -----
+ changeCenterColor
+ "Let the user change the color of the center of the watch"
+
+ ColorPickerMorph new
+ choseModalityFromPreference;
+ sourceHand: self activeHand;
+ target: self;
+ selector: #centerColor:;
+ originalColor: self color;
+ putUpFor: self near: self fullBounds!
Item was added:
+ ----- Method: WatchMorph>>changeFont (in category 'menus') -----
+ changeFont
+
+ self fontName: ((SelectionMenu labelList: StrikeFont familyNames
+ selections: StrikeFont familyNames) startUp
+ ifNil: [^ self])!
Item was added:
+ ----- Method: WatchMorph>>changeHandsColor (in category 'menus') -----
+ changeHandsColor
+ "Let the user change the color of the hands of the watch."
+
+ ColorPickerMorph new
+ choseModalityFromPreference;
+ sourceHand: self activeHand;
+ target: self;
+ selector: #handsColor:;
+ originalColor: self color;
+ putUpFor: self near: self fullBounds!
Item was added:
+ ----- Method: WatchMorph>>createLabels (in category 'updating') -----
+ createLabels
+
+ | numeral font h r |
+ self removeAllMorphs.
+ font := StrikeFont familyName: fontName size: (h := self height min: self width)//8.
+ r := 1.0 - (1.4 * font height / h).
+ 1 to: 12 do:
+ [:hour |
+ numeral := romanNumerals
+ ifTrue: [#('I' 'II' 'III' 'IV' 'V' 'VI' 'VII' ' VIII' 'IX' 'X' 'XI' 'XII') at: hour]
+ ifFalse: [hour asString].
+ self addMorphBack: ((StringMorph contents: numeral font: font emphasis: 1)
+ center: (self radius: r hourAngle: hour)) lock].
+ !
Item was added:
+ ----- Method: WatchMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color green!
Item was added:
+ ----- Method: WatchMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ "Draw the watch on the given canvas"
+
+ | pHour pMin pSec time centerColor |
+ time := Time now.
+ pHour := self radius: 0.6 hourAngle: time hours + (time minutes/60.0).
+ pMin := self radius: 0.72 hourAngle: (time minutes / 5.0).
+ pSec := self radius: 0.8 hourAngle: (time seconds / 5.0).
+ centerColor := cColor
+ ifNil:
+ [Color transparent]
+ ifNotNil:
+ [time hours < 12
+ ifTrue: [cColor muchLighter]
+ ifFalse: [cColor]].
+
+ antialias ifTrue:
+ [aCanvas asBalloonCanvas
+ aaLevel: 4;
+ drawOval: (self bounds insetBy: self borderWidth // 2 + 1) color: self fillStyle
+ borderWidth: self borderWidth borderColor: self borderColor;
+ drawOval: (self bounds insetBy: self extent*0.35) color: centerColor
+ borderWidth: 0 borderColor: Color black;
+ drawPolygon: {self center. pHour}
+ color: Color transparent borderWidth: 3 borderColor: handsColor;
+ drawPolygon: {self center. pMin}
+ color: Color transparent borderWidth: 2 borderColor: handsColor;
+ drawPolygon: {self center. pSec}
+ color: Color transparent borderWidth: 1 borderColor: handsColor]
+ ifFalse:
+ [super drawOn: aCanvas.
+ aCanvas
+ fillOval: (self bounds insetBy: self extent*0.35) color: centerColor;
+ line: self center to: pHour width: 3 color: handsColor;
+ line: self center to: pMin width: 2 color: handsColor;
+ line: self center to: pSec width: 1 color: handsColor]
+ !
Item was added:
+ ----- Method: WatchMorph>>extent: (in category 'geometry') -----
+ extent: newExtent
+
+ super extent: newExtent.
+ self createLabels!
Item was added:
+ ----- Method: WatchMorph>>fontName: (in category 'accessing') -----
+ fontName: aString
+
+ fontName := aString.
+ self createLabels!
Item was added:
+ ----- Method: WatchMorph>>handsColor: (in category 'accessing') -----
+ handsColor: aColor
+
+ handsColor := aColor!
Item was added:
+ ----- Method: WatchMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+
+ self handsColor: Color red.
+ self centerColor: Color gray.
+ romanNumerals := false.
+ antialias := false.
+ fontName := 'NewYork'.
+ self extent: 130 px @ 130 px.
+ self start!
Item was added:
+ ----- Method: WatchMorph>>radius:hourAngle: (in category 'private') -----
+ radius: unitRadius hourAngle: hourAngle
+ "unitRadius goes from 0.0 at the center to 1.0 on the circumference.
+ hourAngle runs from 0.0 clockwise around to 12.0 with wrapping."
+
+ ^ self center + (self extent * (Point r: 0.5 * unitRadius
+ degrees: hourAngle * 30.0 - 90.0)).!
Item was added:
+ ----- Method: WatchMorph>>romanNumeralString (in category 'menus') -----
+ romanNumeralString
+ "Answer a string governing the roman-numerals checkbox"
+ ^ (romanNumerals
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'roman numerals' translated!
Item was added:
+ ----- Method: WatchMorph>>step (in category 'stepping') -----
+ step
+
+ self changed.!
Item was added:
+ ----- Method: WatchMorph>>toggleAntialias (in category 'menus') -----
+ toggleAntialias
+ antialias := antialias not!
Item was added:
+ ----- Method: WatchMorph>>toggleRoman (in category 'menus') -----
+ toggleRoman
+
+ romanNumerals := romanNumerals not.
+ self createLabels!
Item was added:
+ BorderedMorph subclass: #WordGameLetterMorph
+ instanceVariableNames: 'letter originalLetter idString linkedLetters predecessor successor indexInQuote lineMorph letterMorph style'
+ classVariableNames: 'IDFont IDHeight LetterFont LetterHeight'
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !WordGameLetterMorph commentStamp: '<historical>' prior: 0!
+ WordGameLetterMorph implements letter boxes for type-in and display of letter in word games. Several variant displays are supported, depending on the setting of style, and blanks can be displayed as black boxes or empty letter boxes.
+
+ Default support for type-in is distributed between this class and WordGamePaneMorph
+
+ letter the Character stored in this morph.
+ Can be either blank or nil as well as a letter.
+ indexInQuote a retained copy of the index of this character
+ Facilitates responses to, eg, clicking or typing in this box.
+ If indexInQuote==nil, then this is displayed as a black box
+ predecessor another LetterMorph or nil
+ Used for linked typing and, eg, word selection
+ successor another LetterMorph or nil
+ Used for linked typing and, eg, word selection
+ style a Symbol, one of #(plain boxed underlined)
+ Boxed and underlined display further depends on whether
+ the id strings are nil or not.
+ Each format has an associated default size
+
+ The following two variables are also submorphs, as are the id strings if present.
+ letterMorph a StringMorph for displaying the letter
+ Used when changing the letter to be displayed
+ lineMorph a PolygonMorph used to display the underline
+ and also to place the id string in underlined format!
Item was added:
+ ----- Method: WordGameLetterMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^ false!
Item was added:
+ ----- Method: WordGameLetterMorph class>>initialize (in category 'class initialization') -----
+ initialize "WordGameLetterMorph initialize"
+
+ IDFont := StrikeFont familyName: 'ComicPlain' size: 13.
+ IDHeight := IDFont height.
+ LetterFont := StrikeFont familyName: 'ComicBold' size: 19.
+ LetterHeight := LetterFont height.
+
+ !
Item was added:
+ ----- Method: WordGameLetterMorph>>boxed (in category 'style inits') -----
+ boxed
+
+ style := #boxed!
Item was added:
+ ----- Method: WordGameLetterMorph>>handlesKeyboard: (in category 'event handling') -----
+ handlesKeyboard: evt
+ ^ true!
Item was added:
+ ----- Method: WordGameLetterMorph>>id2: (in category 'initialization') -----
+ id2: idString
+ "Add further clue id for acrostic puzzles."
+
+ | idMorph |
+ idString ifNotNil:
+ [idMorph := StringMorph contents: idString font: IDFont.
+ idMorph align: idMorph bounds topRight with: self bounds topRight + (-1 px @ -1 px).
+ self addMorph: idMorph].
+
+ !
Item was added:
+ ----- Method: WordGameLetterMorph>>indexInQuote (in category 'accessing') -----
+ indexInQuote
+
+ ^ indexInQuote!
Item was added:
+ ----- Method: WordGameLetterMorph>>indexInQuote:id1: (in category 'initialization') -----
+ indexInQuote: qi id1: aString
+ "Initialize me with the given index and an optional aString"
+ | idMorph y |
+ style = #boxed
+ ifTrue: [aString isNil
+ ifTrue: [self extent: 18 px @ 16 px;
+ borderWidth: 1 px]
+ ifFalse: [self extent: 26 px @ 24 px;
+ borderWidth: 1 px]]
+ ifFalse: [aString isNil
+ ifTrue: [self extent: 18 px @ 16 px;
+ borderWidth: 0]
+ ifFalse: [self extent: 18 px @ 26 px;
+ borderWidth: 0]].
+ qi
+ ifNil: [^ self color: Color gray].
+ "blank"
+ self color: self normalColor.
+ indexInQuote := qi.
+ style == #underlined
+ ifTrue: [y := self bottom - 2 px.
+ aString
+ ifNotNil: [y := y - IDFont ascent + 2 px].
+ lineMorph := PolygonMorph
+ vertices: {self left + 2 px @ y. self right - 3 px @ y}
+ color: Color gray
+ borderWidth: 1 px
+ borderColor: Color gray.
+ self addMorph: lineMorph.
+ aString
+ ifNil: [^ self].
+ idMorph := StringMorph contents: aString font: IDFont.
+ idMorph align: idMorph bounds bottomCenter with: self bounds bottomCenter + (0 @ (IDFont descent - 1 px)).
+ self addMorphBack: idMorph]
+ ifFalse: [aString
+ ifNil: [^ self].
+ idMorph := StringMorph contents: aString font: IDFont.
+ idMorph align: idMorph bounds topLeft with: self bounds topLeft + (2 px @ -1 px).
+ self addMorph: idMorph
+ "
+ World addMorph: (WordGameLetterMorph new boxed
+ indexInQuote: 123 id1: '123';
+ id2: 'H'; setLetter: $W).
+ World addMorph: (WordGameLetterMorph new underlined
+ indexInQuote: 123 id1: '123';
+ setLetter: $W).
+ World addMorph: (WordGameLetterMorph new underlined
+ indexInQuote: 123 id1: nil;
+ setLetter: $W).
+ "]!
Item was added:
+ ----- Method: WordGameLetterMorph>>isBlank (in category 'accessing') -----
+ isBlank
+ ^indexInQuote isNil!
Item was added:
+ ----- Method: WordGameLetterMorph>>keyboardFocusChange: (in category 'event handling') -----
+ keyboardFocusChange: boolean
+
+ | panel |
+ boolean ifFalse:
+ [panel := self nearestOwnerThat: [:m | m respondsTo: #checkForLostFocus].
+ panel ifNotNil: [panel checkForLostFocus]]!
Item was added:
+ ----- Method: WordGameLetterMorph>>letter (in category 'accessing') -----
+ letter
+
+ ^ letter!
Item was added:
+ ----- Method: WordGameLetterMorph>>morphsInWordDo: (in category 'linking') -----
+ morphsInWordDo: aBlock
+ aBlock value: self.
+ (successor isNil or: [successor isBlank]) ifTrue: [^self].
+ successor morphsInWordDo: aBlock!
Item was added:
+ ----- Method: WordGameLetterMorph>>nextTypeableLetter (in category 'linking') -----
+ nextTypeableLetter
+
+ successor ifNil: [^ self].
+ successor isBlank ifTrue: [^ successor nextTypeableLetter].
+ ^ successor!
Item was added:
+ ----- Method: WordGameLetterMorph>>normalColor (in category 'initialization') -----
+ normalColor
+
+ ^ Color r: 1.0 g: 0.8 b: 0.2
+ !
Item was added:
+ ----- Method: WordGameLetterMorph>>plain (in category 'style inits') -----
+ plain
+
+ style := #plain!
Item was added:
+ ----- Method: WordGameLetterMorph>>predecessor (in category 'accessing') -----
+ predecessor
+
+ ^ predecessor!
Item was added:
+ ----- Method: WordGameLetterMorph>>predecessor: (in category 'accessing') -----
+ predecessor: pred
+
+ predecessor := pred
+ !
Item was added:
+ ----- Method: WordGameLetterMorph>>previousTypeableLetter (in category 'linking') -----
+ previousTypeableLetter
+
+ predecessor ifNil: [^ self].
+ predecessor isBlank ifTrue: [^ predecessor previousTypeableLetter].
+ ^ predecessor!
Item was added:
+ ----- Method: WordGameLetterMorph>>setLetter: (in category 'initialization') -----
+ setLetter: aLetter
+
+ ^ self setLetter: aLetter color: Color black
+ !
Item was added:
+ ----- Method: WordGameLetterMorph>>setLetter:color: (in category 'initialization') -----
+ setLetter: aLetter color: aColor
+ letterMorph ifNotNil: [letterMorph delete].
+ letter := aLetter.
+ letter ifNil: [^letterMorph := nil].
+ letterMorph := StringMorph contents: aLetter asString font: LetterFont.
+ letterMorph color: aColor.
+ style == #boxed
+ ifTrue:
+ [letterMorph align: letterMorph bounds bottomCenter
+ with: self bounds bottomCenter + (0 @ (LetterFont descent - 2 px))]
+ ifFalse:
+ [lineMorph isNil
+ ifTrue:
+ [letterMorph align: letterMorph bounds bottomCenter
+ with: self bounds bottomCenter + (0 @ (LetterFont descent - 4 px))]
+ ifFalse:
+ [letterMorph align: letterMorph bounds bottomCenter
+ with: self center x @ (lineMorph top + LetterFont descent)]].
+ self addMorphBack: letterMorph!
Item was added:
+ ----- Method: WordGameLetterMorph>>startOfWord (in category 'linking') -----
+ startOfWord
+ (predecessor isNil or: [predecessor isBlank]) ifTrue: [^self].
+ ^predecessor startOfWord!
Item was added:
+ ----- Method: WordGameLetterMorph>>successor (in category 'accessing') -----
+ successor
+
+ ^ successor!
Item was added:
+ ----- Method: WordGameLetterMorph>>successor: (in category 'accessing') -----
+ successor: succ
+
+ successor := succ
+ !
Item was added:
+ ----- Method: WordGameLetterMorph>>underlined (in category 'style inits') -----
+ underlined
+
+ style := #underlined!
Item was added:
+ ----- Method: WordGameLetterMorph>>unhighlight (in category 'typing') -----
+ unhighlight
+
+ (self isBlank or: [self color = self normalColor])
+ ifFalse: [self color: self normalColor]!
Item was added:
+ BorderedMorph subclass: #WordGamePanelMorph
+ instanceVariableNames: 'letterMorphs haveTypedHere'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'MorphicExtras-Games'!
+
+ !WordGamePanelMorph commentStamp: '<historical>' prior: 0!
+ WordGamePanelMorph provides some default support for clicking and typing in a panel with letterMorphs.
+
+ letterMorphs a collection of LetterMorphs
+ Useful in referring specifically to active letterMorphs
+ when submorphs may contain other morphs
+
+ haveTypedHere a Boolean used to determine how backspace should be handled!
Item was added:
+ ----- Method: WordGamePanelMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+
+ ^ false!
Item was added:
+ ----- Method: WordGamePanelMorph>>addCustomMenuItems:hand: (in category 'menus') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ "Include our modest command set in the ctrl-menu"
+
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu addLine.
+ self addMenuItemsTo: aCustomMenu hand: aHandMorph!
Item was added:
+ ----- Method: WordGamePanelMorph>>addMenuItemsTo:hand: (in category 'menu') -----
+ addMenuItemsTo: aCustomMenu hand: aHandMorph
+ "override with actual menu items"!
Item was added:
+ ----- Method: WordGamePanelMorph>>checkForLostFocus (in category 'events') -----
+ checkForLostFocus
+ "Determine if the user has clicked outside this panel"
+
+ self activeHand ifNil: [^ self].
+ (self containsPoint: self activeHand position) ifFalse: [self lostFocus]!
Item was added:
+ ----- Method: WordGamePanelMorph>>clearTyping (in category 'defaults') -----
+ clearTyping
+ "Clear out all letters entered as a solution."
+
+ letterMorphs do: [:m | (m letter notNil and: [m letter isLetter])
+ ifTrue: [m setLetter: Character space]].
+ self unhighlight.
+ !
Item was added:
+ ----- Method: WordGamePanelMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: event
+ "Absorb mouseDown so stray clicks will not pick up the panel"
+
+ ^ true!
Item was added:
+ ----- Method: WordGamePanelMorph>>highlight: (in category 'defaults') -----
+ highlight: morph
+
+ self unhighlight.
+ morph color: Color green!
Item was added:
+ ----- Method: WordGamePanelMorph>>isClean (in category 'defaults') -----
+ isClean
+ "Return true only if all cells are blank."
+
+ letterMorphs do:
+ [:m | (m letter notNil and: [m letter ~= $ ]) ifTrue: [^ false]].
+ ^ true
+ !
Item was added:
+ ----- Method: WordGamePanelMorph>>keyCharacter:atIndex:nextFocus: (in category 'defaults') -----
+ keyCharacter: keyCharacter atIndex: indexOfAffectedMorph nextFocus: nextFocus
+
+ "Override with actual response"
+ !
Item was added:
+ ----- Method: WordGamePanelMorph>>keyStrokeEvent:letterMorph: (in category 'events') -----
+ keyStrokeEvent: evt letterMorph: morph
+ "Handle typing. Calls keyCharacter:atIndex:nextFocus: for further behavior."
+
+ | affectedMorph keyCharacter nextFocus |
+ evt keyCharacter = Character backspace
+ ifTrue:
+ ["<delete> zaps the current selection if there has been no typing,
+ but it zaps the previous selection if there has been prior typing."
+
+ affectedMorph := haveTypedHere
+ ifTrue: [morph previousTypeableLetter]
+ ifFalse: [morph].
+ keyCharacter := Character space.
+ nextFocus := morph previousTypeableLetter]
+ ifFalse:
+ [affectedMorph := morph.
+ keyCharacter := evt keyCharacter asUppercase.
+ (keyCharacter isLetter or: [keyCharacter = Character space])
+ ifFalse: [^self].
+ haveTypedHere := true.
+ nextFocus := morph nextTypeableLetter.
+ nextFocus == morph
+ ifTrue:
+ ["If hit end of a word, change backspace mode"
+
+ haveTypedHere := false]].
+ evt hand newKeyboardFocus: nextFocus.
+ self unhighlight.
+ nextFocus color: Color green.
+ self
+ keyCharacter: keyCharacter
+ atIndex: affectedMorph indexInQuote
+ nextFocus: nextFocus!
Item was added:
+ ----- Method: WordGamePanelMorph>>letterMorphs (in category 'access') -----
+ letterMorphs
+
+ ^ letterMorphs!
Item was added:
+ ----- Method: WordGamePanelMorph>>lostFocus (in category 'defaults') -----
+ lostFocus
+
+ self unhighlight!
Item was added:
+ ----- Method: WordGamePanelMorph>>mouseDownEvent:letterMorph: (in category 'events') -----
+ mouseDownEvent: evt letterMorph: morph
+
+ haveTypedHere := false.
+ evt hand newKeyboardFocus: morph.
+ self highlight: morph!
Item was added:
+ ----- Method: WordGamePanelMorph>>unhighlight (in category 'defaults') -----
+ unhighlight
+
+ letterMorphs do: [:m | m ifNotNil: [m unhighlight]]
+ !
1
0