[ANN] LambdaMessageSend on SqueakMap

Stéphane Rollandin lecteur at zogotounga.net
Sun May 14 19:52:50 UTC 2006


Alexandre Bergel wrote:
> Hello,
> 
> I like this. But where can I try it ? Squeaksource and squeakmap do not 
> know about it. I would like to see more about it.

it's on SqueakMap: the name is LambdaMessageSend:
http://map.squeak.org/package/6bc04644-035c-4d47-a513-f7cde7b01bad

anyway, attached to this post is the latest version, not even on 
SqueakMap yet :)

file it into a 3.8 image

>>
>> you can do things like:
>>
>> | x y f g j |
>>
>> x _ Lambda x.
>> y _ Lambda y.
> 
> Why do you use the term lambda to create a variable ?
> 

That's syntactic sugar. The full expression would be
x _ LambdaSlot id: 'x'

and in the newest version of the package which I am currently working on 
(the one attached to this post), it would be
x _ AtomicLambdaMessageSend receiver: (LambdaSlot id: 'x')

whatever, the idea is that x is not a variable name, it's an instance of 
the lambda function identity which evaluates to its (single) argument. 
AtomicLambdaMessageSend instances are the leaves of the recursive 
evaluation mechanism.


>> f _ ((x*x) + (y*y)) sqrt.
> 
> Why is there no term named lambda here ?

x and y are themselves the lambda functions used to build f

so f is a LambdaMessageSend whose receiver is ((x*x) + (y*y)), a 
LambdaMessageSend, and selector is #sqrt.

now ((x*x) + (y*y)) is itself a LambdaMessageSend whose receiver is 
(x*x), selector #+ and argument (y+y) which is also a LambdaMessageSend. 
the tree has two branchs.

(x*x) is a LambdaMessageSend in which both receiver and argument are x, 
an AtomicLambdaMessageSend . this is the end of one branch, with two 
identical (in the == sense) leaves.

same thing for (y*y)

> 
>> self assert: f printString = '(((<x> * <x>) + (<y> * <y>)) sqrt)'.
>> self assert: {3 . 4} ~~> f = 5.
>> g := ('y' -> 0) ~>> f.
> 
> I like this mechanism of curryfication.

yes, you can also do
g := (Lambda . 0) ~~> f.

BTW I made all arrow operators work in both directions, so you can also do
g := f <~~ (Lambda . 0)
or
g := f <<~ ('y' -> 0)

the operators are:
@> and <@ 	substitute the (single) argument
@@> and <@@ 	substitute the array of arguments
~> and <~	substitute and reduce (one single arguments)
~~> and <~~	substitute and reduce (arguments array)
~>> and <<~	substitute one named slot
~~>> and <<~~	substitute several named slots


> 
>> self assert: g printString = '(((<x> * <x>) + 0) sqrt)' .
>> self assert: 3 ~> g = 3.
>>
> 
>> j := ('y' -> (Lambda z1 + Lambda z2)) ~>> f.
> 
> I did not get this one... Could you explain a bit ?

in j, the y in f is replaced by (z1 + z2). so j is now a function of 
three arguments:

(((<x> * <x>) + ((<z1> + <z2>) * (<z1> + <z2>))) sqrt)

thus we have:

>> self assert: {3 . 2 . 2} ~~> j = 5.
>>
>>
>> see the test cases in FunctionalTalkTest for comprehensive documentation.
> 
> Where are they ?
> 

see attached file :)


> It seems to me that, what is tricky with lambda calculus are the 
> evaluation strategies...
> 

could you please elaborate ?


in my package, the evaluation is as described above the plain 
MessageSend mechanism, only made fully recursive (even the selector can 
be a lambda function). I was very surprised as how easy it was to made 
the thing work, which made me think that Smalltalk could almost be 
considered a functional language if you consider LambdaMessageSend as 
its basic object.

it took me a couple of days to code the package and at the end of it I 
just wondered: why did not people do this or something of the like 
before ?


cheers,

Stef
-------------- next part --------------
'From Squeak3.8 of ''5 May 2005'' [latest update: #6665] on 13 May 2006 at 9:08:01 pm'!
MessageSend subclass: #LambdaMessageSend
	instanceVariableNames: 'compiledForm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FunctionalTalk'!
!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 
!


!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]]! !

!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]! !


!LambdaMessageSend methodsFor: 'composition' stamp: 'spfa 5/11/2006 15:18'!
adaptToNumber: rcvr andSend: sel

	^  (rcvr lambda: sel) substitute: {self}! !

!LambdaMessageSend methodsFor: 'composition' stamp: 'spfa 5/11/2006 19:23'!
composeWith: aMessageSend

	^ aMessageSend substitute: {self}! !

!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! !


!LambdaMessageSend methodsFor: 'printing' stamp: 'spfa 5/13/2006 20:55'!
constructor

	^ String streamContents: [:stream | self writeConstructorOn: stream]! !

!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: $)! !

!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: $)
! !

!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: $)! !

!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)'! !


!LambdaMessageSend methodsFor: 'accessing' stamp: 'spfa 5/11/2006 21:25'!
lambdaArity

	^ self slots asIdentitySet size! !

!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}]]! !

!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]]]]
! !


!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: 'reducting' stamp: 'spfa 5/10/2006 23:14'!
copyKeepSlots: slots

	^ self shallowCopy postCopyKeepSlots: slots
! !

!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: 'reducting' stamp: 'spfa 5/11/2006 22:19'!
reduceWithAllNonLambda: args

	self hasCompiledForm ifFalse: [self compileAsBlock].
	^ compiledForm valueWithArguments: args
! !

!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/13/2006 00:06'!
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]

! !

!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])
! !

!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/12/2006 10:43'!
reduceWithSlot: anAssociation

	^ self reduceWithAll: 
		(self rootSlots collect: [:lambda | 
				lambda reduceWithSlot: anAssociation])


! !

!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/9/2006 14:18'!
reduceWith: arg

	^ self reduceWithAll: {arg}


! !

!LambdaMessageSend methodsFor: 'reducting' stamp: 'spfa 5/11/2006 22:22'!
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: LambdaSlot new).
			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
! !


!LambdaMessageSend methodsFor: 'evaluating' stamp: 'spfa 5/10/2006 15:36'!
argument: anObject

	super arguments: {anObject}! !

!LambdaMessageSend methodsFor: 'evaluating' stamp: 'spfa 5/9/2006 11:46'!
lambdaValue

	^ self value! !

!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: 'short API' stamp: 'spfa 5/11/2006 19:23'!
o: aMessageSend

	^ self composeWith: aMessageSend

	! !

!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

! !


!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: $]])
			
! !


!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: '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
		! !

!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/12/2006 14:28'!
deepCopy

	self eraseCompiledForm.
	^super deepCopy

! !

!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]
! !

!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/12/2006 14:26'!
hasCompiledForm

	^ compiledForm notNil and: [compiledForm isBlock]
! !

!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/13/2006 18:13'!
initialize

	super initialize.
	self bePure

	

! !

!LambdaMessageSend methodsFor: 'compilation' stamp: 'spfa 5/12/2006 23:51'!
isPure

	^ compiledForm == #not

! !

!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: '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: 'compilation' stamp: 'spfa 5/12/2006 14:28'!
storeDataOn: aDataStream

	self eraseCompiledForm.
	super storeDataOn: aDataStream.
	self compileAsBlock

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

LambdaMessageSend class
	instanceVariableNames: ''!

!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! !


More information about the Squeak-dev mailing list