[ANN] LambdaMessageSend on SqueakMapStéphane Rollandin lecteur at zogotounga.netSun May 14 20:01:33 UTC 2006
stupid me :)
please ignore the attached file from my previous post. here is the good
one !
cheers,
Stef
-------------- next part --------------
SystemOrganization addCategory: #FunctionalTalk!
SystemOrganization addCategory: #'FunctionalTalk-Tests'!
TestCase subclass: #FunctionalTalkTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'FunctionalTalk-Tests'!
Object subclass: #Lambda
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'FunctionalTalk'!
MessageSend subclass: #LambdaMessageSend
instanceVariableNames: 'compiledForm'
classVariableNames: ''
poolDictionaries: ''
category: 'FunctionalTalk'!
LambdaMessageSend subclass: #AtomicLambdaMessageSend
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'FunctionalTalk'!
Object subclass: #LambdaSlot
instanceVariableNames: 'id'
classVariableNames: ''
poolDictionaries: ''
category: 'FunctionalTalk'!
FunctionalTalkTest class
instanceVariableNames: ''!
Lambda class
instanceVariableNames: ''!
LambdaMessageSend class
instanceVariableNames: ''!
AtomicLambdaMessageSend class
instanceVariableNames: ''!
LambdaSlot class
instanceVariableNames: ''!
!AtomicLambdaMessageSend commentStamp: 'spfa 5/14/2006 13:22' prior: 0!
Wrapper for a LambdaSlot, e.g. function identity!
]style[(48)f1!
!FunctionalTalkTest commentStamp: 'spfa 5/10/2006 16:26' prior: 0!
Unit tests for the package FunctionalTalk.
See the tests classified "documentation" for an overview of the package.!
!Lambda commentStamp: 'spfa 5/14/2006 14:32' prior: 0!
This class simply provides syntactic sugar for lambda expressions.
| f |
"1) compact syntax for AtomicLambdaMessageSend creation"
f _ Lambda x + (Lambda y * 5) sqrt. "printIt"
"2) compact syntax for 'section' (Haskell vocabulary)"
f <~~ {Lambda . 1} "printIt"!
!LambdaMessageSend commentStamp: 'spfa 5/11/2006 18:13' prior: 0!
a MessageSend suitable for functional programming:
its receiver, selector and arguments can themselves be LambdaMessageSends.
see the 'documentation' test cases in FunctionalTalkTest for a comprehensive overview of this topic
!
!LambdaSlot commentStamp: 'spfa 5/10/2006 16:23' prior: 0!
A slot in a lambda construct.
see LambdaMessageSend for details!
!LambdaMessageSend methodsFor: 'easy arithmetic' stamp: 'spfa 5/14/2006 11:09'!
adaptToNumber: rcvr andSend: sel
"allows things like (1 + Lambda x)"
^ (rcvr lambda: sel) substitute: {self}! !
!LambdaMessageSend methodsFor: 'evaluating' stamp: 'spfa 5/10/2006 15:36'!
argument: anObject
super arguments: {anObject}! !
!LambdaMessageSend methodsFor: 'conversion' stamp: 'spfa 5/11/2006 22:03'!
asBlock
| slots |
^ Compiler evaluate: (String streamContents: [:str |
str nextPut: $[.
(slots _ self rootSlots) do: [:arg |
str nextPut: $:.
arg printAsCodeOn: str.
str space].
slots size isZero ifFalse: [str nextPut: $|; space].
self printAsCodeOn: str.
str nextPut: $]])
! !
!LambdaSlot methodsFor: 'printing' stamp: 'spfa 5/10/2006 13:52'!
asVariableName
^ String streamContents: [:str | self printAsCodeOn: str]
! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/13/2006 18:16'!
beFast
"allow internal compilation"
compiledForm _ nil.
self compileAsBlock.! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/13/2006 00:09'!
bePure
"do not allow internal compilation"
compiledForm _ #not
! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/11/2006 08:41'!
collectArgumentsForAll: anArray from: aStream
^ anArray collect: [:each | self collectArgumentsFor: each from: aStream ]! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/11/2006 15:35'!
collectArgumentsFor: anObject from: aStream
^ anObject isLambda
ifFalse: [anObject]
ifTrue: [anObject reduceWithAll: (aStream next: anObject slots size)]! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/12/2006 14:25'!
compileAsBlock
compiledForm == #not ifTrue: [^ self].
compiledForm _ self asBlock.
! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/11/2006 15:40'!
compileAs: aSelector in: aClass classified: heading
aClass class compile:
(String streamContents: [:code |
self rootSlots with: aSelector keywords do: [:arg :word |
code nextPutAll: word.
code space.
arg printAsCodeOn: code.
code space].
code cr; cr; tab; nextPutAll: '^ '.
self printAsCodeOn: code.])
classified: heading.
! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/13/2006 18:26'!
compiled
self isPure ifTrue: [^ self asBlock].
compiledForm ifNil: [self compileAsBlock].
^ compiledForm
! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/11/2006 09:23'!
compiledForm
^ compiledForm ! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/11/2006 15:40'!
compileIn: aClass classified: heading
self compileAs: (String streamContents: [:sel |
self rootSlots do: [:slot |
slot printAsCodeOn: sel.
sel nextPut: $:]])
in: aClass classified: heading
! !
!AtomicLambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/14/2006 13:49'!
composeWith: aMessageSend
^ aMessageSend substitute: {receiver}! !
!LambdaMessageSend methodsFor: 'composition' stamp: 'spfa 5/11/2006 19:23'!
composeWith: aMessageSend
^ aMessageSend substitute: {self}! !
!LambdaMessageSend methodsFor: 'printing' stamp: 'spfa 5/13/2006 20:55'!
constructor
^ String streamContents: [:stream | self writeConstructorOn: stream]! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/10/2006 23:14'!
copyKeepSlots: slots
^ self shallowCopy postCopyKeepSlots: slots
! !
!LambdaSlot methodsFor: 'reduction' stamp: 'spfa 5/10/2006 23:15'!
copyKeepSlots: slots
(slots identityIncludes: self)
ifFalse: [^ self copy]! !
!LambdaSlot methodsFor: 'printing' stamp: 'spfa 5/13/2006 20:57'!
declareOn: stream
"specific usage. see #declareOn: "
self printAsCodeOn: stream .
stream nextPutAll: ' _ Lambda '.
self printAsCodeOn: stream .
stream nextPut: $.; space
! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/12/2006 14:28'!
deepCopy
self eraseCompiledForm.
^super deepCopy
! !
!AtomicLambdaMessageSend methodsFor: 'printing' stamp: 'spfa 5/14/2006 13:45'!
doesNotUnderstand: aMessage
^ LambdaMessageSend
receiver: receiver
selector: aMessage selector
arguments: aMessage arguments! !
!Lambda class methodsFor: 'as yet unclassified' stamp: 'spfa 5/14/2006 12:43'!
doesNotUnderstand: aMessage
aMessage selector numArgs isZero
ifTrue: [^ AtomicLambdaMessageSend receiver:
(LambdaSlot new id: aMessage selector)].
^ super doesNotUnderstand: aMessage
! !
!LambdaMessageSend methodsFor: 'composition' stamp: 'spfa 5/13/2006 20:23'!
doesNotUnderstand: aMessage
^ self class
receiver: (self copyKeepSlots: self rootSlots)
selector: aMessage selector
arguments: aMessage arguments! !
!LambdaSlot class methodsFor: 'API' stamp: 'spfa 5/9/2006 22:39'!
doesNotUnderstand: aMessage
^ self selector: aMessage selector arguments: aMessage arguments! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/11/2006 19:49'!
ensureSlotsArityFromIds
self slots do: [:s1 |
self slots do: [:s2 |
((s1 == s2) not and: [s1 id = s2 id])
ifTrue: [s1 becomeForward: s2]]].! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/11/2006 19:50'!
ensureUnambigousSlotIds
self slots do: [:s1 |
self slots do: [:s2 |
((s1 == s2) not and: [s1 id = s2 id])
ifTrue: [s1 getNewId]]].! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/12/2006 14:27'!
eraseCompiledForm
compiledForm isBlock ifTrue: [compiledForm _ nil]
! !
!LambdaSlot methodsFor: 'accessing' stamp: 'spfa 5/10/2006 22:26'!
getNewId
self id: (id isNumber ifTrue: [id +1]
ifFalse: [id isString ifTrue: [id, 'z'] ifFalse: [1]])
! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/12/2006 14:26'!
hasCompiledForm
^ compiledForm notNil and: [compiledForm isBlock]
! !
!LambdaSlot methodsFor: 'accessing' stamp: 'spfa 5/9/2006 22:34'!
id
^ id ! !
!LambdaSlot methodsFor: 'accessing' stamp: 'spfa 5/9/2006 14:43'!
id: anObject
id _ anObject! !
!LambdaSlot class methodsFor: 'instance creation' stamp: 'spfa 5/9/2006 14:45'!
id: anObject
^ self new id: anObject! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/13/2006 18:13'!
initialize
super initialize.
self bePure
! !
!AtomicLambdaMessageSend methodsFor: 'testing' stamp: 'spfa 5/14/2006 13:54'!
isAtomicLambda
^ true! !
!LambdaMessageSend methodsFor: 'testing' stamp: 'spfa 5/14/2006 13:55'!
isAtomicLambda
^ false! !
!LambdaSlot methodsFor: 'testing' stamp: 'spfa 5/14/2006 13:58'!
isAtomicLambda
^ true! !
!AtomicLambdaMessageSend methodsFor: 'testing' stamp: 'spfa 5/14/2006 13:56'!
isLambda
^ true! !
!LambdaMessageSend methodsFor: 'testing' stamp: 'spfa 5/9/2006 23:46'!
isLambda
^ receiver isLambda
or: [selector isLambda]
or: [arguments isLambda]
or: [arguments anySatisfy: [:arg | arg isLambda]]! !
!LambdaSlot methodsFor: 'testing' stamp: 'spfa 5/14/2006 14:14'!
isLambda
^ true
! !
!Object methodsFor: '*FunctionalTalk' stamp: 'spfa 5/9/2006 10:23'!
isLambda
^ false! !
!LambdaSlot methodsFor: 'testing' stamp: 'spfa 5/11/2006 14:02'!
isLambdaSlot
^ true
! !
!Object methodsFor: '*FunctionalTalk' stamp: 'spfa 5/11/2006 14:03'!
isLambdaSlot
^ false! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/12/2006 23:51'!
isPure
^ compiledForm == #not
! !
!LambdaMessageSend methodsFor: 'easy arithmetic' stamp: 'spfa 5/13/2006 22:01'!
isZero
"allows things like (1/(Lambda x + 1))"
^ false
! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/9/2006 20:52'!
lambda
^ LambdaMessageSend
receiver: self
selector: nil
arguments: #()
! !
!AtomicLambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/14/2006 14:05'!
lambdaArity
^ 1! !
!LambdaMessageSend methodsFor: 'accessing' stamp: 'spfa 5/11/2006 21:25'!
lambdaArity
^ self slots asIdentitySet size! !
!Object methodsFor: '*FunctionalTalk' stamp: 'spfa 5/9/2006 13:13'!
lambdaArity
^ 0 ! !
!LambdaSlot class methodsFor: 'API' stamp: 'spfa 5/10/2006 10:00'!
lambdaMessage
^ (self id: 'receiver') lambdaMessage! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/10/2006 09:59'!
lambdaMessage
^ LambdaMessageSend
receiver: self
selector: (LambdaSlot id: 'selector')
arguments: (LambdaSlot id: 'arguments')
! !
!LambdaMessageSend methodsFor: 'evaluating' stamp: 'spfa 5/9/2006 11:46'!
lambdaValue
^ self value! !
!Object methodsFor: '*FunctionalTalk' stamp: 'spfa 5/9/2006 11:46'!
lambdaValue
^ self ! !
!LambdaSlot class methodsFor: 'API' stamp: 'spfa 5/10/2006 09:53'!
lambda: anObjectOrArray
^ (self id: 'receiver') lambda: anObjectOrArray! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/10/2006 09:53'!
lambda: aSymbolOrArray
aSymbolOrArray isSymbol
ifTrue:
[
^ LambdaMessageSend
receiver: self
selector: aSymbolOrArray
arguments: ((1 to: aSymbolOrArray numArgs)
collect: [:n | LambdaSlot id: n])
]
ifFalse: "Array, then"
[
^ LambdaMessageSend
receiver: self
selector: (LambdaSlot id: 'selector')
arguments: aSymbolOrArray
]
! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/9/2006 14:48'!
lambda: aSymbol slotIds: anArray
^ LambdaMessageSend
receiver: self
selector: aSymbol
arguments: (anArray collect: [:n | LambdaSlot id: n])
! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/9/2006 16:01'!
lambda: aSymbol slotId: anObject
aSymbol numArgs ~= 1 ifTrue: [^ self error: 'more than one slot defined'].
^ LambdaMessageSend
receiver: self
selector: aSymbol
arguments: {LambdaSlot id: anObject}
! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/9/2006 21:01'!
lambda: aSymbol with: anObject
^ LambdaMessageSend
receiver: self
selector: aSymbol
arguments: {anObject}
! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/9/2006 21:03'!
lambda: aSymbol with: anObject with: bObject
^ LambdaMessageSend
receiver: self
selector: aSymbol
arguments: {anObject . bObject}
! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/9/2006 21:03'!
lambda: aSymbol with: anObject with: bObject with: cObject
^ LambdaMessageSend
receiver: self
selector: aSymbol
arguments: {anObject . bObject . cObject}
! !
!LambdaMessageSend methodsFor: 'short API' stamp: 'spfa 5/11/2006 19:23'!
o: aMessageSend
^ self composeWith: aMessageSend
! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/12/2006 14:28'!
postCopy
self eraseCompiledForm.
receiver isLambda ifTrue: [receiver _ receiver copy].
selector isLambda ifTrue: [selector _ selector copy].
arguments _ arguments isLambda ifTrue: [arguments copy]
ifFalse: [arguments collect:
[:arg | arg isLambda ifTrue: [arg copy] ifFalse: [arg]]].
self ensureSlotsArityFromIds
! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/12/2006 14:28'!
postCopyKeepSlots: slots
self eraseCompiledForm.
receiver isLambda
ifTrue: [receiver _ receiver copyKeepSlots: slots].
selector isLambda
ifTrue: [selector _ selector copyKeepSlots: slots].
arguments _ arguments isLambda
ifTrue: [arguments copyKeepSlots: slots]
ifFalse: [arguments collect:
[:arg | arg isLambda
ifTrue: [arg copyKeepSlots: slots]
ifFalse: [arg]]].
self ensureSlotsArityFromIds! !
!LambdaMessageSend methodsFor: 'printing' stamp: 'spfa 5/10/2006 13:54'!
printAsCodeOn: stream
stream nextPut: $(.
receiver printAsCodeOn: stream.
selector ifNotNil: [
stream space.
(arguments isLambda not and: [arguments isEmpty]) ifTrue: [
selector isLambda ifTrue:[
stream nextPutAll: 'perform: '.
selector printAsCodeOn: stream]
ifFalse: [stream nextPutAll: selector]]
ifFalse: [
(selector isLambda or: [arguments isLambda]) ifTrue:[
stream nextPutAll: 'perform:'; space.
selector printAsCodeOn: stream.
stream space; nextPutAll: 'withArguments:'; space.
arguments isLambda
ifTrue:[arguments printAsCodeOn: stream]
ifFalse: [
stream nextPut: ${.
arguments do: [:arg |
arg printAsCodeOn: stream.
stream nextPutAll: ' . '].
stream skip: -3; nextPut: $}]]
ifFalse: [
arguments with: selector keywords do: [:arg :word |
stream nextPutAll: word.
stream space.
arg printAsCodeOn: stream.
stream space].
stream skip: -1]]].
stream nextPut: $)! !
!LambdaSlot methodsFor: 'printing' stamp: 'spfa 5/10/2006 13:52'!
printAsCodeOn: stream
| varname |
varname _ id asString.
(varname allSatisfy: [:char | char isAlphaNumeric])
ifFalse: [varname _ varname asIdentifier: false]
ifTrue: [varname startsWithDigit ifTrue: [stream nextPutAll: 'arg']].
stream nextPutAll: varname
! !
!Object methodsFor: '*FunctionalTalk' stamp: 'spfa 5/11/2006 23:31'!
printAsCodeOn: aStream
self storeOn: aStream! !
!AtomicLambdaMessageSend methodsFor: 'printing' stamp: 'spfa 5/14/2006 12:44'!
printOn: aStream
^ receiver printOn: aStream! !
!LambdaMessageSend methodsFor: 'printing' stamp: 'spfa 5/10/2006 10:15'!
printOn: stream
stream nextPut: $(.
receiver printOn: stream.
selector ifNotNil: [
stream space.
(arguments isLambda not and: [arguments isEmpty]) ifTrue: [
selector isLambda ifTrue:[
stream nextPutAll: 'perform: '.
selector printOn: stream]
ifFalse: [stream nextPutAll: selector]]
ifFalse: [
(selector isLambda or: [arguments isLambda]) ifTrue:[
stream nextPutAll: 'perform:'; space.
selector printOn: stream.
stream space; nextPutAll: 'withArguments:'; space.
arguments printOn: stream.]
ifFalse: [
arguments with: selector keywords do: [:arg :word |
stream nextPutAll: word.
stream space.
arg printOn: stream.
stream space].
stream skip: -1]]].
stream nextPut: $)
! !
!LambdaSlot methodsFor: 'printing' stamp: 'spfa 5/10/2006 16:21'!
printOn: stream
stream nextPut: $<.
stream nextPutAll: id asString.
stream nextPut: $>.
! !
!AtomicLambdaMessageSend class methodsFor: 'as yet unclassified' stamp: 'spfa 5/14/2006 12:42'!
receiver: aLambdaSlot
^ self receiver: aLambdaSlot selector: #yourself arguments: #()! !
!LambdaMessageSend class methodsFor: 'as yet unclassified' stamp: 'spfa 5/11/2006 19:50'!
receiver: anObject selector: aSymbol arguments: anArray
^ (super receiver: anObject selector: aSymbol arguments: anArray)
ensureUnambigousSlotIds compileAsBlock! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/11/2006 22:19'!
reduceWithAllNonLambda: args
self hasCompiledForm ifFalse: [self compileAsBlock].
^ compiledForm valueWithArguments: args
! !
!AtomicLambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/14/2006 13:47'!
reduceWithAll: args
| arg |
arg _ args first.
arg == Lambda ifTrue: [^ self].
arg isLambdaSlot ifTrue: [^ self class receiver: arg].
^ arg ! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/14/2006 13:41'!
reduceWithAll: args
| val |
self isPure ifFalse:
[
self hasCompiledForm ifFalse: [self compileAsBlock].
((args size = self lambdaArity)
and: [args noneSatisfy: [:arg | arg isLambda or: [arg == Lambda]]])
ifTrue: [^ compiledForm valueWithArguments: args]
].
val _ self substitute: args.
val isLambda ifTrue: [^ val compileAsBlock] ifFalse: [^ val value]
! !
!LambdaSlot methodsFor: 'reduction' stamp: 'spfa 5/14/2006 14:18'!
reduceWithAll: args
| x |
args size ~= 1 ifTrue: [self error: 'Bad number of arguments'].
((x _ args first) == Lambda
or: [x isLambdaSlot and: [x id isNil]]) ifTrue: [^ self].
^ x
! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/11/2006 10:17'!
reduceWithNonLambda: arg
^ self reduceWithAllNonLambda: {arg}
! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/12/2006 10:43'!
reduceWithSlots: anArrayOfAssociations
^ self reduceWithAll:
(self rootSlots collect: [:lambda |
lambda reduceWithSlots: anArrayOfAssociations])
! !
!LambdaSlot methodsFor: 'reduction' stamp: 'spfa 5/12/2006 10:43'!
reduceWithSlots: anArrayOfAssociation
^ (anArrayOfAssociation
detect: [:assoc | (id = assoc key)] ifNone: [^ self]) value
! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/12/2006 10:43'!
reduceWithSlot: anAssociation
^ self reduceWithAll:
(self rootSlots collect: [:lambda |
lambda reduceWithSlot: anAssociation])
! !
!LambdaSlot methodsFor: 'reduction' stamp: 'spfa 5/12/2006 10:42'!
reduceWithSlot: anAssociation
(id = anAssociation key) ifTrue: [^ anAssociation value]
! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/9/2006 14:18'!
reduceWith: arg
^ self reduceWithAll: {arg}
! !
!LambdaMessageSend methodsFor: 'accessing' stamp: 'spfa 5/11/2006 15:39'!
rootSlots
^ self slots inject: #() into: [:uslots :s |
(uslots identityIncludes: s) ifTrue: [uslots] ifFalse: [uslots, {s}]]! !
!LambdaSlot class methodsFor: 'API' stamp: 'spfa 5/9/2006 14:39'!
selector: aSymbol
^ self selector: aSymbol arguments: #()! !
!LambdaSlot class methodsFor: 'API' stamp: 'spfa 5/10/2006 09:53'!
selector: aSymbol arguments: anArray
^ self selector: aSymbol arguments: anArray slotId: 'receiver'! !
!LambdaSlot class methodsFor: 'API' stamp: 'spfa 5/9/2006 22:39'!
selector: aSymbol arguments: anArray slotId: anObject
^ LambdaMessageSend receiver: (LambdaSlot id: anObject) selector: aSymbol arguments: anArray! !
!LambdaSlot class methodsFor: 'API' stamp: 'spfa 5/9/2006 14:39'!
selector: aSymbol argument: anObject
^ self selector: aSymbol arguments: {anObject}! !
!LambdaSlot class methodsFor: 'API' stamp: 'spfa 5/9/2006 22:40'!
selector: aSymbol argument: anObject slotId: bObject
^ self selector: aSymbol arguments: {anObject} slotId: bObject! !
!LambdaSlot class methodsFor: 'API' stamp: 'spfa 5/9/2006 22:41'!
selector: aSymbol slotId: bObject
^ self selector: aSymbol arguments: #() slotId: bObject! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/11/2006 15:40'!
slotIds
^ self rootSlots collect: [:slot | slot id].! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/11/2006 15:40'!
slotIds: anArray
self rootSlots with: anArray do: [:slot :id | slot id: id].! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/11/2006 22:21'!
slotId: anObject newId: bObject
(self rootSlots detect: [:slot | slot id = anObject] ifNone: [^ self])
id: bObject! !
!LambdaMessageSend methodsFor: 'accessing' stamp: 'spfa 5/11/2006 15:34'!
slots
^ Array streamContents: [:str |
receiver isLambda ifTrue: [str nextPutAll: receiver slots].
selector isLambda ifTrue: [str nextPutAll: selector slots].
arguments isLambda ifTrue: [str nextPutAll: arguments slots]
ifFalse: [arguments do: [:a |
a isLambda ifTrue: [str nextPutAll: a slots]]]]
! !
!LambdaSlot methodsFor: 'accessing' stamp: 'spfa 5/11/2006 15:35'!
slots
^ {self}! !
!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/12/2006 14:28'!
storeDataOn: aDataStream
self eraseCompiledForm.
super storeDataOn: aDataStream.
self compileAsBlock
! !
!AtomicLambdaMessageSend methodsFor: 'printing' stamp: 'spfa 5/14/2006 12:44'!
storeOn: aStream
^ receiver storeOn: aStream! !
!LambdaMessageSend methodsFor: 'printing' stamp: 'spfa 5/13/2006 20:59'!
storeOn: stream
"specific usage - should be renamed I guess"
stream nextPut: $(.
receiver storeOn: stream.
selector ifNotNil: [
stream space.
(arguments isLambda not and: [arguments isEmpty]) ifTrue: [
selector isLambda ifTrue:[
stream nextPutAll: 'perform: '.
selector storeOn: stream]
ifFalse: [stream nextPutAll: selector]]
ifFalse: [
(selector isLambda or: [arguments isLambda]) ifTrue:[
stream nextPutAll: 'perform:'; space.
selector storeOn: stream.
stream space; nextPutAll: 'withArguments:'; space.
arguments isLambda
ifTrue:[arguments storeOn: stream]
ifFalse: [
stream nextPut: ${.
arguments do: [:arg |
arg storeOn: stream.
stream nextPutAll: ' . '].
stream skip: -3; nextPut: $}]]
ifFalse: [
arguments with: selector keywords do: [:arg :word |
stream nextPutAll: word.
stream space.
arg storeOn: stream.
stream space].
stream skip: -1]]].
stream nextPut: $)! !
!LambdaSlot methodsFor: 'printing' stamp: 'spfa 5/13/2006 20:46'!
storeOn: stream
"specific usage. see #declareOn: "
self printAsCodeOn: stream
! !
!Rectangle methodsFor: '*FunctionalTalk-unrelated-fix' stamp: 'spfa 5/12/2006 14:16'!
storeOn: aStream
aStream nextPut: $(.
self printOn: aStream.
aStream nextPut: $)! !
!AtomicLambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/14/2006 13:46'!
substitute: args
^ self reduceWithAll: args! !
!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/14/2006 13:52'!
substitute: args
| argsSlots fullArgs mySlots stream |
mySlots _ self slots.
args size = mySlots size
ifTrue: [
"this is NOT a public API ; used internally by #collectArgumentsFor:from:"
fullArgs _ args]
ifFalse: [
| size argsStream z |
args size > (size _ mySlots asIdentitySet size) "self lambdaArity"
ifTrue: [self error: 'Too many arguments'].
argsStream _ ReadStream on:
(args forceTo: size paddingWith: Lambda).
z _ 'zzzzdoing'.
fullArgs _ Array new: mySlots size withAll: z.
mySlots doWithIndex: [:s :i |
| a |
(fullArgs at: i) == z ifTrue: [
fullArgs at: i put: (a _ argsStream next).
mySlots doWithIndex: [:ss :j |
(ss == s and: [j > i])
ifTrue: [fullArgs at: j put: a]]]]].
stream _ ReadStream on: fullArgs.
argsSlots _ Array streamContents: [:str |
(fullArgs select: [:arg | arg isLambda])
do: [:arg | str nextPutAll: arg slots]].
^ ((self copyKeepSlots: argsSlots)
receiver: (self collectArgumentsFor: receiver from: stream);
selector: (self collectArgumentsFor: selector from: stream);
arguments: (arguments isLambda
ifTrue: [arguments reduceWithAll: stream upToEnd]
ifFalse: [self collectArgumentsForAll: arguments from: stream]))
ensureUnambigousSlotIds; compileAsBlock
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/13/2006 22:17'!
testArithmetic
self assert: (2 + Lambda x) isLambda.
self assert: (1/(Lambda x + 1)) isLambda.
self assert: (1/Lambda x) isLambda! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 18:38'!
testArity1
| f g f2 ff sumf |
f _ 56 lambda: #+ .
g _ f sqrt.
f2 _ f * 2.
ff _ f * f.
sumf _ ff + f2 + g.
self assert: (sumf <~ 8) = 4232.
self assert: (f <~ 4) = 60.
self assert: (g <~ 8) = 8.
self assert: (f2 <~ 4) = 120.
self assert: (ff <~ 4) = 3600.
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 18:35'!
testArity2
| f t |
f _ 56 lambda: #+.
t _ (f sqrt) lambda: #+.
self assert: t lambdaArity = 2.
self assert: (t <~~ {8 . 2}) = 10.
self assert: (t+f) lambdaArity = 2.
self assert: ((t + f) <~~ {8 . 2}) = 74.
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 18:50'!
testArity3
| f g t h |
f _ 56 lambda: #+.
g _ 10 lambda: #-.
t _ f + g.
self assert: t lambdaArity = 2.
self assert: (t <~~ {8 . 8}) = 66.
h _ Point lambda: #x:y:.
t _ h r.
self assert: (t <~ 0 <~ 1) = 1.
self assert: ((f + t) <~ 4 <~ 10 <~ 0) = 70
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 18:37'!
testArityPreservation
| f t g |
f _ LambdaSlot selector: #+ arguments: {56}.
t _ (f sqrt) + 2.
g _ ((f sqrt) + 2) * f.
self assert: ((t <~ 8) closeTo: 10).
self assert: ((g <~ 8) closeTo: 640).
self assert: ((t <~ -56) closeTo: 2).
self assert: ((g <~ -55) closeTo: 3).
! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/11/2006 18:54'!
testBasics
"defining a message send from an arbitrary object:"
self assert: 5 lambda isMessageSend.
self assert: 5 lambda value = 5.
"defining a message send from an object and message:"
self assert: (4 lambda + 1) isMessageSend.
self assert: (4 lambda + 1) value = 5.
"defining a lambda expression from an object and selector only"
self assert: (4 lambda: #+) isLambda.
"this can not be reduced: it is not a plain message send"
self assert: (4 lambda: #+) value isLambda.
"an argument can be provided:"
self assert: ((4 lambda: #+) argument: 5) isMessageSend.
"this can now be reduced:"
self assert: ((4 lambda: #+) argument: 5) value = 9 .
"note that the argument can itself be a lambda expression:"
self assert: ((4 lambda: #+) argument: (2 lambda: #+)) isLambda.
"giving an argument and getting the corresponding value is called reduction. this can be done in one step"
self assert: ((4 lambda: #+) reduceWith: 5) = 9 .
"shorter API :"
self assert: ((4 lambda: #+) <~ 5) = 9 .
"giving an argument without evaluating is called substitution"
self assert: ((4 lambda: #+) substitute: {5}) printString = '(4 + 5)' .
"there is also a shorter API :"
self assert: ((4 lambda: #+) <@ 5) printString = '(4 + 5)' .! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/11/2006 19:04'!
testBasics2
| f g r |
f _ 4 lambda: #+.
"a lambda expression can be expanded by sending it any messages"
g _ (f + 10) * 2.
self assert: g isLambda.
self assert: (g <~ 1) = 30.
"it can be composed with another lambda expression"
self assert: (f ~> g) isLambda.
self assert: ((f ~> g) <~ 1) = 38.
"actually ~> is just <~ the other way round"
self assert: (g <~ f <~ 1) = 38.
self assert: (1 ~> f ~> g) = 38.
self assert: (f ~> g <~ 1) = 38.
"to see what (f ~> g) really is, print it"
self assert: (f ~> g) printString = '(((4 + (4 + <1>)) + 10) * 2)'.
self assert: f printString = '(4 + <1>)'.
self assert: g printString = '(((4 + <1>) + 10) * 2)'.
self assert: (g ~> f) printString = '(4 + (((4 + <1>) + 10) * 2))'.
"<1>, <2>, .. are the default labels (id) for lambda slots
it is possible to define arbitrary ids"
f _ 4 lambda: #+ slotId: 'étonnant, non ?'.
self assert: f printString = '(4 + <étonnant, non ?>)'.
f _ 4 lambda: #+ slotId: Smalltalk.
self assert: f printString = '(4 + <a SystemDictionary(lots of globals)>)'.
"this is especially useful for expressions with several arguments"
r _ Rectangle lambda: #left:right:top:bottom:
slotIds: #('left' 'right' 'top' 'bottom').
self assert: r printString =
'(Rectangle left: <left> right: <right> top: <top> bottom: <bottom>)'.
"we can reduce the number of arguments by providing values for specific slots, using slot ids"
r _ r reduceWithSlots: {'left' -> 50 . 'right' -> 60}.
self assert:
r <~~ {0 . 100} = (Rectangle left: 50 right: 60 top: 0 bottom: 100).
self assert:
r printString = '(Rectangle left: 50 right: 60 top: <top> bottom: <bottom>)' .
"we can substitute a lambda expression in a slot"
r _ r reduceWithSlot: ('bottom' -> (100 lambda: #- slotId: 'bottom offset')).
self assert:
r slotIds = #('top' 'bottom offset').
self assert:
r <~~ {0 . 0} = (Rectangle left: 50 right: 60 top: 0 bottom: 100).
self assert: r printString =
'(Rectangle left: 50 right: 60 top: <top> bottom: (100 - <bottom offset>))' .
"<<~ and <<~~ are shortcuts for reduceWithSlot: and reduceWithSlots:
you can also use the backward versions ~>> and ~~>>"
r _ Rectangle lambda: #left:right:top:bottom:
slotIds: #('left' 'right' 'top' 'bottom').
r _ r <<~ ('right' -> 60).
r _ {'left' -> 50 . 'bottom' -> (100 lambda: #-)} ~~>> r.
self assert:
{0 . 0} ~~> r = (Rectangle left: 50 right: 60 top: 0 bottom: 100).
! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/10/2006 16:38'!
testBasics3
| f g h k j m |
"lambda abstraction can be based on the receiver of an expression"
f _ LambdaSlot + 5.
self assert: (f <~ 1) = 6.
self assert: f printString = '(<receiver> + 5)'.
"we can also abstract both receiver and arguments at the same time"
g _ (LambdaSlot lambda: #+) .
self assert: (g <~~ {2 . 3}) = 5.
self assert: g printString = '(<receiver> + <1>)'.
"this is equivalent to"
g _ LambdaMessageSend
receiver: (LambdaSlot id: 'receiver')
selector: #+
arguments: {LambdaSlot id: 'argument'}.
self assert: (g <~~ {2 . 3}) = 5.
"the selector can be abstracted too..."
h _ 5 lambda: {5}.
self assert: (h <~ #+) = 10.
self assert: (h <~ #*) = 25.
self assert: h printString = '(5 perform: <selector> withArguments: #(5))'.
"abstracting both receiver and selector"
j _ (LambdaSlot lambda: {5}) .
self assert: (j <~~ {2 . #+}) = 7.
self assert: (j <~~ {1 . #-}) = -4.
self assert: j printString =
'(<receiver> perform: <selector> withArguments: #(5))'.
"abstracting both selector and arguments"
m _ 5 lambdaMessage.
self assert: (m <~~ {#+ . {3}}) = 8.
self assert: (m <~~ {#raisedTo: . {2}}) = 25.
self assert: (m <~~ {#adaptToFraction:andSend: . {1/2 . #+}}) = (11/2).
self assert: m printString =
'(5 perform: <selector> withArguments: <arguments>)'.
"here is the full monty"
k _ LambdaSlot lambdaMessage.
self assert: (k <~~ {2 . #+ . {3}}) = 5.
self assert: (k <~~ {'hello' . #padded:to:with: . {#right . 10 . $!!}}) = 'hello!!!!!!!!!!'.
self assert: k printString =
'(<receiver> perform: <selector> withArguments: <arguments>)'.
"this is equivalent to"
k _ LambdaMessageSend
receiver: (LambdaSlot id: 'receiver')
selector: (LambdaSlot id: 'selector')
arguments: (LambdaSlot id: 'arguments').
self assert: (k <~~ {2 . #+ . {3}}) = 5.
! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/11/2006 19:08'!
testBasics4
| x f g h z p |
"slots are shared by default when combining functions"
x _ Lambda x.
f _ x * (1+x).
self assert: f lambdaArity = 1. "this means the two x above will take the same one argument"
self assert: f slots printString= '#(<x> <x>)'.
self assert: f rootSlots printString= '#(<x>)'.
self assert: 10 ~> f = 110.
"slots are not shared when copying"
g _ x * (1+ x copy).
self assert: g lambdaArity = 2. "theres is now TWO arguments"
self assert: g slots printString = '#(<xz> <x>)'.
self assert: g rootSlots printString= '#(<xz> <x>)'.
self assert: {10 . 2} ~~> g = 30.
"slots built independently stay independent"
h _ Lambda y * (1+ Lambda y).
self assert: h lambdaArity = 2. "the two Lambda y define different slots"
self assert: h slots printString= '#(<yz> <y>)'.
self assert: h rootSlots printString= '#(<yz> <y>)'.
self assert: {10 . 2} ~~> h = 30.
"note that it is always possible to redefine the slots and change the arity"
z _ Lambda z.
p _ {z . z} ~~> h.
self assert: p lambdaArity = 1.
self assert: p slots printString = '#(<z> <z>)'.
self assert: p rootSlots printString = '#(<z>)'.
self assert: 10 ~> p = 110.
! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/13/2006 19:56'!
testBenchmarks
| bk x y f tblock fassert t |
x _ Lambda x.
y _ Lambda y.
f _ ((x*x) + (y*y)) sqrt.
f beFast. "we allow internal compilation"
bk _ [:a :b | ((a*a) + (b*b)) sqrt].
"tblock is the duration taken by bk to evaluate 100000 times:"
tblock _ [100000 timesRepeat: [bk value: 3 value: 4]] durationToRun.
"fassert is a lambda function which compare a duration t with tblock
it succeeds if t is very roughly the same as tblock "
t _ Lambda t.
fassert _ self lambda: #assert: with: ((t * 1.4) > tblock) & ((t * 0.7) < tblock).
"
NOTE:
in the following we replace all the usual 'self assert: ...' with invocation of our specialized fassert. this will provide an example of functional programming along with our benchmarks :)
now let's proceed:
"
"the default way to reduce a lambda expression is VERY slow:
here it is about 5000 times slower than its equivalent block
(although this does not make much sense as both do not perform the same operation at all)"
fassert <~ [20 timesRepeat: [f <~~ {3 . Lambda}]] durationToRun.
"now if we are not actually substituting but simply evaluating the lambda expression, it gets better.
here we perform exactly the same operation as the block: it is roughly 50 times slower"
fassert <~ [2000 timesRepeat: [f <~~ {3 . 4}]] durationToRun.
"if the function is to be evaluated with plain, non-lambda arguments, as in our example, then it is much better to use //> instead of ~~> because some expensive checks gets disabled.
we are now only 2 times slower than the block"
fassert <~ [50000 timesRepeat: [f <// {3 . 4}]] durationToRun.
"even faster is the direct invocation of the compiled form of the function (which is a block itself): we eventually catch up with the block"
fassert <~ [100000 timesRepeat: [f compiled value: 3 value: 4]] durationToRun. ! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/11/2006 15:25'!
testBeware
"lambda expressions expand by receiving message.
they do not expand when sent to other objects"
self assert: ('abc' lambda, 'def') value = 'abcdef'.
self should: [('abc', 'def' lambda) value] raise: Error.
self assert: ('abc' lambda, 'def' lambda) value = 'abcdef'.
"as an exception, arithmetic operations do allow more freedom"
self assert: (77 + 5 lambda) isMessageSend.
self assert: (77 + 5 lambda) value = 82.
! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/11/2006 19:10'!
testBeware2
| f g h |
"slots ids are changed silently if a name clash happen
this allows further compilation of the function as a method or a block, where different arguments with the same name would not be accepted"
f _ 5 lambda: #+ slotId: 'x'.
g _ 1 lambda: #- slotId: 'x'.
h _ f + g.
self assert: h lambdaArity = 2.
self assert: (h <~~ {5 . 1}) = 10.
self assert: h slotIds = {'xz' . 'x'}. "a 'z' was appended"
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 11:02'!
testCompilation
| cat |
cat _ '--test leftover (remove it all)--'.
((Rectangle lambda: #left:right:top:bottom:)
<<~~ {3 -> 500 . 4 -> 600})
slotIds: {'gauche' . 'droite' };
compileAs: #gauche:droite: in: Rectangle classified: cat.
self assert: (Rectangle gauche: 45 droite: 177) = (45 at 500 corner: 177 at 600).
Rectangle class removeCategory: cat! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 11:03'!
testCompilation2
| cat |
cat _ '--test leftover (remove it all)--'.
((Rectangle lambda: #left:right:top:bottom:)
<<~~ {3 -> 500 . 4 -> 600})
slotIds: {'gauche' . 'droite' };
compileIn: Rectangle classified: cat.
self assert: (Rectangle gauche: 45 droite: 177) = (45 at 500 corner: 177 at 600).
Rectangle class removeCategory: cat! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/10/2006 15:06'!
testCompilation3
| g cat |
cat _ '--compiled example (remove it if you want)--'.
g _ LambdaMessageSend
receiver: (LambdaSlot id: 'receiver')
selector: (LambdaSlot id: 'selector')
arguments: {LambdaSlot id: 'argument'}.
g compileIn: LambdaSlot classified: cat.
self assert: (LambdaSlot receiver: 10 selector: #/ argument: 2) = 5.
LambdaSlot class removeCategory: cat! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/10/2006 15:06'!
testCompilation4
| cat |
cat _ '--compiled example (remove it if you want)--'.
LambdaSlot lambdaMessage compileIn: LambdaSlot classified: cat.
self assert: (LambdaSlot receiver: 10 selector: #/ arguments: {2}) = 5.
LambdaSlot class removeCategory: cat! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/13/2006 18:17'!
testCompiledForm
| f g morph |
f _ ((Lambda x raisedTo: 2) + (Lambda y raisedTo: 2)) sqrt.
f beFast.
self assert: f hasCompiledForm.
self assert: f copy hasCompiledForm not.
g _ f copy <<~ ('y' -> 0).
self assert: g hasCompiledForm.
self assert: (g <~ 2) = 2.
self assert: (f <// {3 . 4}) = 5.
"watch out --- there is a problem with compiled forms: ---"
morph _ Morph new.
f _ morph lambda: #position:.
f beFast.
self assert: f hasCompiledForm.
"trouble is:"
self deny: (f <~ (0 at 0)) == (f <~ (0 at 0)) .
f <~ (55 at 12). "we actually touch a temporary copy of morph"
self deny: morph position = (55 at 12).
"fix:"
f bePure. "do not use internal compilation - this is the default BTW"
self deny: f hasCompiledForm.
f <~ (55 at 12).
self assert: morph position = (55 at 12).
"deeper fix:
pure functional programming does not use mutable variables and does not expect side-effects from the evaluation of a function.
so the example above is just an example of bad practice :)"
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 17:03'!
testComposition
| f g gf ggf gggf fgggf |
f _ 56 lambda: #+ .
g _ 10 lambda: #* .
gf _ f ~> g.
ggf _ gf ~> g.
gggf _ f ~> g ~> g ~> g.
fgggf _ f <~ g <~ ggf.
self assert: ((4 ~> gf ) = 600).
self assert: ((4 ~> ggf ) = 6000).
self assert: ((4 ~> gggf ) = 60000).
self assert: ((4 ~> fgggf ) = 60056)! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 17:05'!
testComposition2
| p mp |
p _ Point lambda: #x:y: .
p _ p <~~ {1 lambda: #+ slotIds: {1} . 2 lambda: #* slotIds: {2}}.
self assert: p printString = '(Point x: (1 + <1>) y: (2 * <2>))'.
self assert: (p <~~ {5 . 15}) = (6 @ 30).
mp _ p <~~ {5 . (Point lambda: #x:y:) r}.
self assert: mp printString = '(Point x: 6 y: (2 * ((Point x: <1> y: <2>) r)))'.
self assert: (mp <~~ {0 . 1}) = (6 @ 2)
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/10/2006 16:16'!
testComposition3
| f t y |
f _ LambdaSlot selector: #+ arguments: {56}.
t _ f <~~ {3 lambda: #-}.
y _ t <~~ {LambdaSlot selector: #+ arguments: {10}}.
self assert: t printString = '((3 - <1>) + 56)'.
self assert: (t <~ 2) = 57.
self assert: y printString = '((3 - (<receiver> + 10)) + 56)'.
self assert: (y <~ 2) = 47.
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/13/2006 21:27'!
testConstructor
| x f g |
x _ Lambda x.
f _ 2+x.
g _ x * x.
self assert: (Compiler evaluate: (f + g) constructor) = (f + g)
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/12/2006 09:49'!
testConversionAsMessageSend
| f fx fy g h |
fx _ Lambda x.
fy _ Lambda y.
f _ ((fx*fx) + (fy*fy)) sqrt.
g _ f as: MessageSend.
self assert: g value = f.
self assert: g value <~~ {3. 4} = 5.
h _ (f <~~ {3 . Lambda}) as: MessageSend.
self assert: h value = (f <<~ ('x' -> 3)).
self assert: h value <~ 4 = 5! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/12/2006 13:53'!
testCopy
| f g |
f _ ((Lambda x raisedTo: 2) + (Lambda y raisedTo: 2)) sqrt.
g _ f copy.
self deny: (f slots identityIncludes: g slots first).
self deny: (f slots identityIncludes: g slots second).
f _ BlobMorph new lambda yourself yourself yourself.
self assert: f value == f value.
g _ f copy.
self assert: g value == f value.
g _ f veryDeepCopy.
self deny: g value == f value.
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/14/2006 14:25'!
testEquality
| f x y x2 xy g o oo s |
x _ Lambda x.
y _ Lambda y.
self assert: x = LambdaSlot new.
"lambda slots are functionaly lambda atoms. All atoms are equivalent"
self assert: x = y.
f _ ((x*x) + (y*y)) sqrt.
x2 _ x*x.
xy _ x*y.
self deny: (x2+x2) sqrt = f.
self deny: (xy+xy copy) sqrt = f.
self assert: (x2+x2 copy) sqrt = f.
self assert: (x2+(y*y)) sqrt = f.
g _ {f . xy} ~~> (Point lambda: #x:y:).
self assert: {3 . 4} ~~> g = (5 at 12).
o _ (LambdaSlot lambda: #x:y:) <~~ {Lambda . (x2 + Lambda y2) sqrt . x*y}.
s _ Lambda s.
oo _ ('y2' -> (s * s)) ~>> (Point ~> o).
self assert: (('s' ->y) ~>> oo) = g.
self deny: (('s' ->Lambda z) ~>> oo) = g. ! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/13/2006 14:33'!
testExample
| x y f g j |
x _ Lambda x.
y _ Lambda y.
f _ ((x*x) + (y*y)) sqrt.
self assert: f printString = '(((<x> * <x>) + (<y> * <y>)) sqrt)'.
self assert: {3 . 4} ~~> f = 5.
g := ('y' -> 0) ~>> f.
self assert: g printString = '(((<x> * <x>) + 0) sqrt)' .
self assert: 3 ~> g = 3.
j := ('y' -> (Lambda z1 + Lambda z2)) ~>> f.
self assert: j printString = '(((<x> * <x>) + ((<z1> + <z2>) * (<z1> + <z2>))) sqrt)' .
self assert: {3 . 2 . 2} ~~> j = 5.
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/14/2006 14:26'!
testLambda
"Lambda acts as a shortcut for the creation of an AtomicLambdaMessageSend which a function wrapper for a LambdaSlot"
| f |
self assert: Lambda x <~ 4 = 4.
self assert: {4} ~~> Lambda z = 4.
self assert: Lambda x <@ 4 = 4.
self assert: (Lambda x <@ Lambda y) printString = '<y>'.
self assert: ({Lambda} ~~> Lambda z) printString = '<z>'.
self assert: ({Lambda x} ~~> Lambda z) printString = '<x>'.
self assert: ('x' -> 45) ~>> Lambda x = 45.
self assert: Lambda x <<~ ('x' -> 45) = 45.
f _ Lambda x * Lambda y.
self assert: (f o: Lambda x) = f.
self assert: (Lambda x o: f) = f.! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/13/2006 18:25'!
testLambdaVsBlock
| b f fx fy c g |
"let's compare two ways to define a function of two variables"
"1) with a block"
b _ [:x :y | ((x*x) + (y*y)) sqrt].
"2) with a lambda expression"
fx _ Lambda x. "shortcut for LambdaSlot id: 'x'"
fy _ Lambda y.
f _ ((fx*fx) + (fy*fy)) sqrt.
"they allow the same calculation"
self assert: (b value: 3 value: 4) = (f <~~ {3 . 4}).
"reducing the number of arguments"
c _ [:x | b value: x value: 0].
g _ f <<~ ('y' -> 0).
self assert: (c value: 4) = (g <~ 4).
"lambda function printing is completely transparent"
self assert: c printString =
'[] in FunctionalTalkTest>>testLambdaVsBlock {[:x | b value: x value: 0]}'.
self assert: g printString = '(((<x> * <x>) + 0) sqrt)'.
"you can not add blocks"
self should: [b+c] raise: Error.
self assert: (f copy+g) isLambda.
self assert: (f <~~ {3 . 4}) + (g <~ 4) = ((f copy+g) <~~ {3 . 4 . 4}).
"a lambda function can be converted into a block"
self assert: f compiled isBlock.
self assert: (f compiled value: 3 value: 4) = 5.
! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/12/2006 09:07'!
testLambdaVsBlock2
"as far as local variables are concerned, lambda expressions are analogous to a block with #fixTemps sent"
| b c f fx fy a |
a _ 10.
b _ [:x :y | a + ((x*x) + (y*y)) sqrt].
c _ [:x :y | a + ((x*x) + (y*y)) sqrt] fixTemps.
fx _ Lambda x.
fy _ Lambda y.
f _ a + ((fx*fx) + (fy*fy)) sqrt.
self assert: (b value: 3 value: 4) = (f <~~ {3 . 4}).
self assert: (c value: 3 value: 4) = (f <~~ {3 . 4}).
a _ 0.
self deny: (b value: 3 value: 4) = (f <~~ {3 . 4}).
self assert: (c value: 3 value: 4) = (f <~~ {3 . 4}).! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/13/2006 18:28'!
testLambdaVsBlock3
| b f |
"lambda expressions capture objects, not only code"
b _ [BlobMorph new].
f _ BlobMorph new lambda.
self assert: f value == f value.
self deny: b value == b value.
"tricky consequence: the compiled form, which is a block, may not have the same semantic as the lambda expression"
f beFast.
self deny: f value == f compiled value.
self deny: f compiled value == f compiled value.
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 18:47'!
testObfuscated
| p mp |
p _ Point lambda: #x:y: .
p _ p <~~ {1 lambda: #+ slotIds: {1} . 2 lambda: #* slotIds: {2}}.
self assert: p printString = '(Point x: (1 + <1>) y: (2 * <2>))'.
self assert: {5 . 15} ~~> p = (6 @ 30).
mp _ p <~~ {5 . (Point lambda: #x:y: slotIds: {'x2' . 'y2'}) r}.
self assert: mp printString = '(Point x: 6 y: (2 * ((Point x: <x2> y: <y2>) r)))'.
self assert: {0 . 1} ~~> mp = (6 @ 2)
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/10/2006 16:13'!
testPrinting1
| f g |
f _ LambdaSlot selector: #+ arguments: {56}.
g _ ((f sqrt) + 2) * f.
self assert: g printString = '((((<receiver> + 56) sqrt) + 2) * (<receiver> + 56))'
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/10/2006 16:13'!
testPrinting2
| f g f2 ff |
f _ 56 lambda: #+ .
g _ f sqrt.
f2 _ f * 2.
ff _ f * f.
self assert: f printString = '(56 + <1>)'.
self assert: g printString = '((56 + <1>) sqrt)'.
self assert: f2 printString = '((56 + <1>) * 2)'.
self assert: ff printString = '((56 + <1>) * (56 + <1>))'.
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/10/2006 16:14'!
testPrinting3
| p sp |
p _ Point lambda: #x:y: .
sp _ p <~~ {0 . LambdaSlot id: 1}.
self assert: p printString = '(Point x: <1> y: <2>)'.
self assert: sp printString = '(Point x: 0 y: <1>)'.
p <~~ {1 . 2}.
self assert: p printString = '(Point x: <1> y: <2>)'.
sp <~ 10.
self assert: sp printString = '(Point x: 0 y: <1>)'.
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 15:37'!
testRenameSlots
| f |
f _ Behavior lambda: #read:go:buy:cook:inviteForDinner:.
f slotIds: #('recipe' 'shop' 'food' 'dish' 'girlfriend').
self assert: f slots printString =
'#(<recipe> <shop> <food> <dish> <girlfriend>)'.
self assert: (f <<~ ('girlfriend' -> #bob)) slots printString =
'#(<recipe> <shop> <food> <dish>)'.! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 18:41'!
testSection
| p sp a sa ssa sssa |
p _ Point lambda: #x:y:.
sp _ p <~~ {5 . Lambda}.
self assert: (sp <~ 3) = (5 at 3).
a _ Array lambda: #with:with:with:with:with:with:.
sa _ a <~~ {Lambda . Lambda. Lambda . #hello . Lambda . Lambda}.
ssa _ sa <~~ {Lambda . #two . Lambda . #five . Lambda}.
sssa _ ssa <~~ {#a . #b . Lambda}.
self assert: (sa lambdaArity = 5).
self assert: (sa <~~ {1 . 2 . 3 . 4 . 5}) = {1 . 2 . 3 . #hello . 4 . 5}.
self assert: (ssa lambdaArity = 3).
self assert: (ssa <~~ {1 . 2 . 3}) = {1 . #two . 2 . #hello . #five . 3}.
self assert: (sssa lambdaArity = 1).
self assert: (sssa <~ 1) = {#a . #two . #b . #hello . #five . 1}.
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/13/2006 18:20'!
testSerialization
| f rs g |
f _ Lambda x + Time lambda: #primSecondsClock.
f beFast.
rs _ SmartRefStream streamedRepresentationOf: f.
g _ SmartRefStream objectFromStreamedRepresentation: rs.
self assert: f hasCompiledForm.
self deny: g hasCompiledForm.
self assert: f = g.
f _ BlobMorph new lambda: #openInWorld.
f beFast.
rs _ SmartRefStream streamedRepresentationOf: f.
g _ SmartRefStream objectFromStreamedRepresentation: rs.
self assert: f hasCompiledForm.
self deny: g hasCompiledForm.
self deny: f = g.! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/13/2006 21:25'!
testSerialization2
| x f g rs a |
x _ Lambda x.
f _ 2+x.
g _ x * x.
rs _ SmartRefStream streamedRepresentationOf: {f . g}.
a _ SmartRefStream objectFromStreamedRepresentation: rs.
self assert: (a first + a second) lambdaArity = 1.
self assert: (3 ~> (a first + a second)) = 14
! !
!FunctionalTalkTest methodsFor: 'documentation' stamp: 'spfa 5/13/2006 18:21'!
testShortAPI
| f |
"all arrow notations work in both direction, although parenthesis are needed in a chain from left to right when pointing to a non-lambda object"
f _ Lambda x - Lambda y.
self assert: (f <~~ {3 . 4}) = -1.
self assert: ({3 . 4} ~~> f) = -1.
self assert: (f <~ 3) printString = '(3 - <y>)'.
self assert: (3 ~> f) printString = '(3 - <y>)'.
self assert: (f <~ 3 <~ 4) = -1.
self assert: (4 ~> (3 ~> f)) = -1.
self should: [4 ~> 3 ~> f] raise: Error.
self assert: (f <~~ {Lambda . 4}) printString = '(<x> - 4)'.
self assert: ({Lambda . 4} ~~> f) printString = '(<x> - 4)'.
self assert: (f <~~ {Lambda . 4} <~ 3) = -1.
self assert: (3~> ({Lambda . 4} ~~> f)) = -1.
self assert: (f <<~ ('y' -> 4)) printString = '(<x> - 4)'.
self assert: (('y' -> 4) ~>> f) printString = '(<x> - 4)'.
self assert: (f <<~~ {'y' -> 4 . 'x' -> 3}) = -1.
self assert: ({'y' -> 4 . 'x' -> 3} ~~>> f) = -1.
self assert: (f <@@ {3 . 4}) printString = '(3 - 4)'.
self assert: ({3 . 4} @@> f) printString = '(3 - 4)'.
self assert: (f <@ 3) printString = '(3 - <y>)'.
self assert: (3 @> f) printString = '(3 - <y>)'.
self assert: (f <@ 3 <@ 4) printString = '(3 - 4)'.
self assert: (4 @> (3 @> f)) printString = '(3 - 4)'.
self should: [4 @> 3 @> f] raise: Error.
f beFast.
self assert: (f <// {3 . 4}) = -1.
self assert: ({3 . 4} //> f) = -1.
self should: [f </ 3] raise: Error.! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/14/2006 13:50'!
testSlotVariableName
self assert: (LambdaSlot id: 1) asVariableName = 'arg1'.
self assert: (LambdaSlot id: Float pi) asVariableName = 'a3141592653589793'.
self assert: (LambdaSlot id: 'le schtroumpf qui fait schtroumpf') asVariableName = 'leschtroumpfquifaitschtroumpf'.
self assert: ((LambdaSlot id: BlobMorph new) asVariableName beginsWith: 'aBlobMorph').! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/9/2006 15:53'!
testSubstituteSlot
| p sp a sa ssa sssa |
p _ Point lambda: #x:y: slotIds: {'x' . 'y'}.
sp _ p <<~ ('x' -> 5).
self assert: (sp <~ 3) = (5 at 3).
a _ Array lambda: #with:with:with:with:with:with:.
sa _ a <<~ (4 -> #hello).
ssa _ sa <<~~ {2 -> #two . 5 -> #five}.
sssa _ ssa <<~~ {1 -> #a . 3 -> #b}.
self assert: (sa lambdaArity = 5).
self assert: (sa <~~ {1 . 2 . 3 . 4 . 5}) = {1 . 2 . 3 . #hello . 4 . 5}.
self assert: (ssa lambdaArity = 3).
self assert: (ssa <~~ {1 . 2 . 3}) = {1 . #two . 2 . #hello . #five . 3}.
self assert: (sssa lambdaArity = 1).
self assert: (sssa <~ 1) = {#a . #two . #b . #hello . #five . 1}.
! !
!FunctionalTalkTest methodsFor: 'tests' stamp: 'spfa 5/11/2006 18:44'!
testSubstituteSlot2
| f sf ssf sssf |
f _ Behavior lambda: #read:go:buy:cook:inviteForDinner:
slotIds: #('recipe' 'shop' 'food' 'dish' 'girlfriend').
sf _ ('recipe' -> (Preferences lambda: #cookbook: slotId: 'book')) ~>> f.
ssf _ {
'shop' -> (Utilities lambda: #store:inCity: slotIds: {'store' . 'city'}).
'girlfriend' -> (Preferences lambda: #girlNamed: slotId: 'lovedOne')
}~~>> sf.
sssf _ {
'dish' -> 'couscous' .
'food' -> (Utilities lambda: #allYouNeedForAGoodCouscous)
}~~>> ssf.
self assert:
sf slots printString = '#(<book> <shop> <food> <dish> <girlfriend>)'.
self assert:
ssf slots printString = '#(<book> <store> <city> <food> <dish> <lovedOne>)' .
self assert:
sssf slots printString = '#(<book> <store> <city> <lovedOne>)' .
self assert:
sssf printString = '(Behavior read: (Preferences cookbook: <book>) go: (Utilities store: <store> inCity: <city>) buy: (Utilities allYouNeedForAGoodCouscous) cook: ''couscous'' inviteForDinner: (Preferences girlNamed: <lovedOne>))'! !
!LambdaMessageSend methodsFor: 'evaluating' stamp: 'spfa 5/9/2006 23:56'!
value
arguments isLambda ifTrue: [^ self].
^ self valueWithArguments: arguments
! !
!LambdaMessageSend methodsFor: 'evaluating' stamp: 'spfa 5/9/2006 22:56'!
valueWithArguments: anArray
selector ifNil: [^ receiver lambdaValue].
(receiver isLambda
or: [selector isLambda]
or: [anArray anySatisfy: [:arg | arg isLambda]])
ifTrue: [^ self].
^ receiver lambdaValue
perform: selector lambdaValue
withArguments: (anArray collect: [:each | each lambdaValue])! !
!LambdaMessageSend methodsFor: 'printing' stamp: 'spfa 5/13/2006 21:03'!
writeConstructorOn: stream
stream nextPutAll: '([| '.
self rootSlots do: [:s | s storeOn: stream. stream space].
stream nextPutAll: '| '.
self rootSlots do: [:s | s declareOn: stream].
self storeOn: stream.
stream nextPutAll: '] value)'! !
!SequenceableCollection methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/11/2006 13:28'!
//> aLambdaMessageSend
^ aLambdaMessageSend reduceWithAllNonLambda: self! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/11/2006 13:28'!
/> aLambdaMessageSend
^ aLambdaMessageSend reduceWithNonLambda: self! !
!LambdaMessageSend methodsFor: 'short API' stamp: 'spfa 5/11/2006 10:18'!
</ arg
^ self reduceWithNonLambda: arg
! !
!LambdaMessageSend methodsFor: 'short API' stamp: 'spfa 5/11/2006 10:18'!
<// arg
^ self reduceWithAllNonLambda: arg
! !
!LambdaMessageSend methodsFor: 'short API' stamp: 'spfa 5/10/2006 15:33'!
<<~ anAssociation
^ self reduceWithSlot: anAssociation
! !
!LambdaMessageSend methodsFor: 'short API' stamp: 'spfa 5/10/2006 15:33'!
<<~~ anAssociation
^ self reduceWithSlots: anAssociation
! !
!LambdaMessageSend methodsFor: 'short API' stamp: 'spfa 5/10/2006 15:32'!
<@ anObject
^ self substitute: {anObject}
! !
!LambdaMessageSend methodsFor: 'short API' stamp: 'spfa 5/10/2006 15:32'!
<@@ anArray
^ self substitute: anArray
! !
!LambdaMessageSend methodsFor: 'short API' stamp: 'spfa 5/9/2006 14:19'!
<~ arg
^ self reduceWith: arg
! !
!LambdaMessageSend methodsFor: 'short API' stamp: 'spfa 5/9/2006 14:18'!
<~~ args
^ self reduceWithAll: args
! !
!AtomicLambdaMessageSend methodsFor: 'testing' stamp: 'spfa 5/14/2006 13:54'!
= anObject
^ anObject isLambda and: [anObject isAtomicLambda]! !
!LambdaMessageSend methodsFor: 'testing' stamp: 'spfa 5/12/2006 09:57'!
= anObject
^ anObject species == self species
and: [receiver = anObject receiver
and: [selector = anObject selector
and: [arguments = anObject arguments]]]
and: [anObject lambdaArity = self lambdaArity]! !
!LambdaSlot methodsFor: 'testing' stamp: 'spfa 5/14/2006 14:04'!
= anObject
^ anObject isLambdaSlot! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/11/2006 13:26'!
@> aLambdaMessageSend
^ aLambdaMessageSend substitute: {self}! !
!SequenceableCollection methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/11/2006 13:26'!
@@> aLambdaMessageSend
^ aLambdaMessageSend substitute: self! !
!Object methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/11/2006 13:20'!
~> aLambdaMessageSend
^ aLambdaMessageSend reduceWith: self! !
!Association methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/11/2006 13:31'!
~>> aLambdaMessageSend
^ aLambdaMessageSend reduceWithSlot: self! !
!SequenceableCollection methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/11/2006 13:26'!
~~> aLambdaMessageSend
^ aLambdaMessageSend reduceWithAll: self! !
!SequenceableCollection methodsFor: '*FunctionalTalk-API' stamp: 'spfa 5/11/2006 13:30'!
~~>> aLambdaMessageSend
^ aLambdaMessageSend reduceWithSlots: self! !
More information about the Squeak-dev mailing list |