axxord/src/Axxord.st

Smalltalk createPackage: 'Axxord'!
Object subclass: #Axes
	instanceVariableNames: ''
	package: 'Axxord'!

!Axes class methodsFor: 'delegated'!

on: anObject at: aCollection consume: aBlock
	| value |
	value := anObject atAxes: aCollection ifAbsent: [ ^ anObject ].
	^ aBlock value: value
!

on: anObject at: aCollection ifAbsent: aBlock
	^ aCollection inject: anObject into: [ :soFar :segment |
		segment asAxisIn: soFar ifAbsent: [ ^ aBlock value ]]
!

on: anObject at: aCollection ifAbsent: aBlock put: value
	| penultimate |
	penultimate := anObject atAxes: aCollection allButLast ifAbsent: aBlock.
	^ aCollection last asAxisIn: penultimate ifAbsent: aBlock put: value
!

on: anObject at: aCollection transform: aBlock
	| value newValue |
	value := anObject atAxes: aCollection ifAbsent: [ ^ anObject ].
	newValue := aBlock value: value.
	value == newValue ifFalse: [ anObject atAxes: aCollection ifAbsent: [ ^ anObject ] put: newValue ].
	anObject axxord ifNotNil: [:axon | axon changed: aCollection]
! !

!Axes class methodsFor: 'factory'!

newInterestThru: anAspect doing: aBlock
	^ PluggableInterest new
		accept: [ :aspect | aspect size <= anAspect size
			ifTrue: [ aspect = (anAspect copyFrom: 1 to: aspect size) ]
			ifFalse: [ anAspect = (aspect copyFrom: 1 to: anAspect size) ] ]
		enact: aBlock
!

newInterestUpTo: anAspect doing: aBlock
	^ PluggableInterest new
		accept: [ :changedAspect | changedAspect size <= anAspect size and:
			[changedAspect = (anAspect copyFrom: 1 to: changedAspect size)] ]
		enact: aBlock
! !

!Axes class methodsFor: 'parsing'!

parse: message
	| result stack anArray |
	anArray := message tokenize: ' '.
	result := #().
	stack := { result }.
	anArray do: [ :each |
		| asNum inner close |
		close := 0.
		inner := each.
		[ inner notEmpty and: [ inner first = '(' ]] whileTrue: [ inner := inner allButFirst. stack add: (stack last add: #()) ].
		[ inner notEmpty and: [ inner last = ')' ]] whileTrue: [ inner := inner allButLast. close := close + 1 ].
		(inner notEmpty and: [ inner first = '~' ]) ifTrue: [ inner := { inner allButFirst } ].
		asNum := inner isString ifTrue: [ (inner ifEmpty: [ 'NaN' ]) asNumber ] ifFalse: [ inner ].
		asNum = asNum ifTrue: [ stack last add: asNum ] ifFalse: [
			inner ifNotEmpty: [ stack last add: inner ] ].
		close timesRepeat: [ stack removeLast ] ].
	^ result
! !

Object subclass: #Axolator
	instanceVariableNames: 'root'
	package: 'Axxord'!

!Axolator methodsFor: 'accessing'!

root

^root
!

root: anObject

root := anObject
! !

!Axolator methodsFor: 'action'!

model: anEavModel modify: aBlock

| newValue |
newValue := aBlock value: (anEavModel on: self).
anEavModel on: self put: newValue deepCopy
!

model: anEavModel read: aBlock

aBlock value: (anEavModel on: self) deepCopy
! !

!Axolator class methodsFor: 'instance creation'!

on: anObject
^self new root: anObject
! !

Object subclass: #Axon
	instanceVariableNames: 'factory'
	package: 'Axxord'!
!Axon commentStamp!
I represent a pub-sub based on a key (called 'aspect').
I manage aspect-block subscriptions (called 'interests') as well as run blocks of dirtied interests.
The interest objects are responsible of decision if the change of an aspect is relevant for them.
Interest object must be subclasses of `AxonInterest`.

My subclasses must provide implementation for:

 - add:
 - do:
 - clean!

!Axon methodsFor: 'accessing'!

addInterest: anInterest
	self
		add: (anInterest flag; yourself);
		dirty: true
! !

!Axon methodsFor: 'change-update'!

changed: anAspect
	| needsToRun |
	needsToRun := false.
	self do: [ :each |
		(each accepts: anAspect) ifTrue: [
			each flag.
			needsToRun := true ]].
	self dirty: needsToRun
!

changedAll
	| needsToRun |
	needsToRun := false.
	self do: [ :each |
		each flag.
		needsToRun := true ].
	self dirty: needsToRun
! !

!Axon methodsFor: 'primitive ops'!

add: anInterest
	self subclassResponsibility
!

clean
	self subclassResponsibility
!

do: aBlock
	self subclassResponsibility
! !

!Axon methodsFor: 'private'!

dirty: aBoolean
	aBoolean ifTrue: [[ self run ] fork]
!

run
	[
		| needsClean |
	    needsClean := false.
		self do: [ :each |
			each isFlagged ifTrue: [ each run ].
	        each isClosed ifTrue: [ needsClean := true ]
		].
    	needsClean ifTrue: [ self clean ]
	] on: Error do: [ self dirty: true ]
! !

Axon subclass: #SimpleAxon
	instanceVariableNames: 'queue'
	package: 'Axxord'!

!SimpleAxon methodsFor: 'initialization'!

initialize
    super initialize.
	queue := OrderedCollection new
! !

!SimpleAxon methodsFor: 'primitive ops'!

add: aSubscription
	queue add: aSubscription.
!

clean
	queue := queue reject: [ :each | each isClosed ]
!

do: aBlock
	queue do: aBlock
! !

Object subclass: #AxonInterest
	instanceVariableNames: 'flagged'
	package: 'Axxord'!

!AxonInterest methodsFor: 'accessing'!

flag
	flagged := true
! !

!AxonInterest methodsFor: 'action'!

close
	self subclassResponsibility
!

enact
	self subclassResponsibility
!

run
	[ flagged := false. self enact ]
    on: AxonOff do: [ self close ]
! !

!AxonInterest methodsFor: 'initialization'!

initialize
	super initialize.
    flagged := false.
! !

!AxonInterest methodsFor: 'testing'!

accepts: anAspect
    "Should return true if change for anAspect is relevant for this AxonInterest"
    self subclassResponsibility
!

isClosed
	self subclassResponsibility
!

isFlagged
	^flagged
! !

AxonInterest subclass: #PluggableInterest
	instanceVariableNames: 'acceptBlock enactBlock'
	package: 'Axxord'!

!PluggableInterest methodsFor: 'accessing'!

accept: aBlock enact: anotherBlock
	acceptBlock := aBlock.
    enactBlock := anotherBlock
! !

!PluggableInterest methodsFor: 'action'!

close
	acceptBlock := nil.
	enactBlock := nil
!

enact
	enactBlock value
! !

!PluggableInterest methodsFor: 'initialization'!

initialize
	super initialize.
    self close
! !

!PluggableInterest methodsFor: 'testing'!

accepts: anAspect
    ^ acceptBlock value: anAspect
!

isClosed
	^ acceptBlock isNil
! !

Error subclass: #AxonOff
	instanceVariableNames: ''
	package: 'Axxord'!
!AxonOff commentStamp!
Signal me from the subscription block to unsubscribe it.!

!Array methodsFor: '*Axxord'!

asAxisIn: anObject ifAbsent: aBlock
	| receiver selector result |
	selector := self first.
	receiver := anObject yourself. "JSObjectProxy hack"
	
	[ result := receiver perform: selector ]
	on: MessageNotUnderstood do: [ :mnu |
		((mnu message selector = selector
			and: [ mnu receiver == receiver ])
			and: [ mnu message arguments isEmpty ])
			ifFalse: [ mnu resignal ].
		^ aBlock value ].
	^ result
!

asAxisIn: anObject ifAbsent: aBlock put: anotherObject
	| receiver selector arguments result |
	selector := self first asMutator.
	receiver := anObject yourself. "JSObjectProxy hack"
	arguments := { anotherObject }.
	
	[ result := receiver perform: selector withArguments: arguments ]
	on: MessageNotUnderstood do: [ :mnu |
		((mnu message selector = selector
			and: [ mnu receiver == receiver ])
			and: [ mnu message arguments = arguments ])
			ifFalse: [ mnu resignal ].
		^ aBlock value ].
	^ result
! !

!JSObjectProxy methodsFor: '*Axxord'!

asAxisIn: anObject ifAbsent: aBlock
	^ aBlock value
!

asAxisIn: anObject ifAbsent: aBlock put: anotherObject
	^ aBlock value
!

atAxes: aCollection ifAbsent: aBlock
	^ Axes on: self at: aCollection ifAbsent: aBlock
!

atAxes: aCollection ifAbsent: aBlock put: value
	^ Axes on: self at: aCollection ifAbsent: aBlock put: value
!

axes: aCollection consume: aBlock
	^ Axes on: self at: aCollection consume: aBlock
!

axes: aCollection transform: aBlock
	^ Axes on: self at: aCollection transform: aBlock
!

axxord
<inlineJS: 'return $self["@jsObject"].$axxord$'>
!

axxord: anAxon
<inlineJS: '$self["@jsObject"].$axxord$ = anAxon'>
! !

!Number methodsFor: '*Axxord'!

asAxisIn: anObject ifAbsent: aBlock
	(anObject respondsTo: #at:ifAbsent:)
		ifTrue: [ ^ anObject at: self ifAbsent: aBlock ]
		ifFalse: aBlock
!

asAxisIn: anObject ifAbsent: aBlock put: anotherObject
	(anObject respondsTo: #at:put:)
		ifTrue: [ ^ anObject at: self put: anotherObject ]
		ifFalse: aBlock
! !

!Object methodsFor: '*Axxord'!

asAxisIn: anObject ifAbsent: aBlock
	^ aBlock value
!

asAxisIn: anObject ifAbsent: aBlock put: anotherObject
	^ aBlock value
!

atAxes: aCollection ifAbsent: aBlock
	^ Axes on: self at: aCollection ifAbsent: aBlock
!

atAxes: aCollection ifAbsent: aBlock put: value
	^ Axes on: self at: aCollection ifAbsent: aBlock put: value
!

axes: aCollection consume: aBlock
	^ Axes on: self at: aCollection consume: aBlock
!

axes: aCollection transform: aBlock
	^ Axes on: self at: aCollection transform: aBlock
!

axxord
<inlineJS: 'return self.$axxord$'>
!

axxord: anAxon
<inlineJS: 'self.$axxord$ = anAxon'>
! !

!String methodsFor: '*Axxord'!

asAxisIn: anObject ifAbsent: aBlock
	(anObject respondsTo: #at:ifAbsent:)
		ifTrue: [ ^ anObject at: self ifAbsent: aBlock ]
		ifFalse: aBlock
!

asAxisIn: anObject ifAbsent: aBlock put: anotherObject
	(anObject respondsTo: #at:put:)
		ifTrue: [ ^ anObject at: self put: anotherObject ]
		ifFalse: aBlock
! !