|
@@ -3,6 +3,50 @@ 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
|
|
@@ -75,13 +119,15 @@ My subclasses must provide implementation for:
|
|
|
- do:
|
|
|
- clean!
|
|
|
|
|
|
-!Axon methodsFor: 'action'!
|
|
|
+!Axon methodsFor: 'accessing'!
|
|
|
|
|
|
addInterest: anInterest
|
|
|
self
|
|
|
add: (anInterest flag; yourself);
|
|
|
dirty: true
|
|
|
-!
|
|
|
+! !
|
|
|
+
|
|
|
+!Axon methodsFor: 'change-update'!
|
|
|
|
|
|
changed: anAspect
|
|
|
| needsToRun |
|
|
@@ -100,8 +146,24 @@ changedAll
|
|
|
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]
|
|
|
!
|
|
@@ -112,95 +174,66 @@ run
|
|
|
needsClean := false.
|
|
|
self do: [ :each |
|
|
|
each isFlagged ifTrue: [ each run ].
|
|
|
- each isEnabled ifFalse: [ needsClean := true ]
|
|
|
+ each isClosed ifTrue: [ needsClean := true ]
|
|
|
].
|
|
|
needsClean ifTrue: [ self clean ]
|
|
|
] on: Error do: [ self dirty: true ]
|
|
|
! !
|
|
|
|
|
|
-!Axon methodsFor: 'injecting'!
|
|
|
-
|
|
|
-registerIn: anObject
|
|
|
-<inlineJS: 'anObject.$axon$=self'>
|
|
|
-! !
|
|
|
-
|
|
|
-Axon subclass: #DumbAxon
|
|
|
- instanceVariableNames: ''
|
|
|
+Axon subclass: #SimpleAxon
|
|
|
+ instanceVariableNames: 'queue'
|
|
|
package: 'Axxord'!
|
|
|
-!DumbAxon commentStamp!
|
|
|
-I am an axon that does nothing.!
|
|
|
-
|
|
|
-!DumbAxon methodsFor: 'as yet unclassified'!
|
|
|
-
|
|
|
-add: anInterest
|
|
|
- "pass"
|
|
|
-!
|
|
|
|
|
|
-clean
|
|
|
- "pass"
|
|
|
-!
|
|
|
+!SimpleAxon methodsFor: 'initialization'!
|
|
|
|
|
|
-do: aBlock
|
|
|
- "pass"
|
|
|
+initialize
|
|
|
+ super initialize.
|
|
|
+ queue := OrderedCollection new
|
|
|
! !
|
|
|
|
|
|
-Axon subclass: #SimpleAxon
|
|
|
- instanceVariableNames: 'queue'
|
|
|
- package: 'Axxord'!
|
|
|
-
|
|
|
-!SimpleAxon methodsFor: 'accessing'!
|
|
|
+!SimpleAxon methodsFor: 'primitive ops'!
|
|
|
|
|
|
add: aSubscription
|
|
|
queue add: aSubscription.
|
|
|
-! !
|
|
|
-
|
|
|
-!SimpleAxon methodsFor: 'bookkeeping'!
|
|
|
+!
|
|
|
|
|
|
clean
|
|
|
- queue := queue select: [ :each | each isEnabled ]
|
|
|
-! !
|
|
|
-
|
|
|
-!SimpleAxon methodsFor: 'enumeration'!
|
|
|
+ queue := queue reject: [ :each | each isClosed ]
|
|
|
+!
|
|
|
|
|
|
do: aBlock
|
|
|
queue do: aBlock
|
|
|
! !
|
|
|
|
|
|
-!SimpleAxon methodsFor: 'initialization'!
|
|
|
-
|
|
|
-initialize
|
|
|
- super initialize.
|
|
|
- queue := OrderedCollection new
|
|
|
-! !
|
|
|
-
|
|
|
Object subclass: #AxonInterest
|
|
|
- instanceVariableNames: 'aspect actionBlock flagged'
|
|
|
+ instanceVariableNames: 'flagged'
|
|
|
package: 'Axxord'!
|
|
|
|
|
|
!AxonInterest methodsFor: 'accessing'!
|
|
|
|
|
|
-aspect: anAspect block: aBlock
|
|
|
- aspect := anAspect.
|
|
|
- actionBlock := aBlock
|
|
|
-!
|
|
|
-
|
|
|
flag
|
|
|
flagged := true
|
|
|
! !
|
|
|
|
|
|
!AxonInterest methodsFor: 'action'!
|
|
|
|
|
|
+close
|
|
|
+ self subclassResponsibility
|
|
|
+!
|
|
|
+
|
|
|
+enact
|
|
|
+ self subclassResponsibility
|
|
|
+!
|
|
|
+
|
|
|
run
|
|
|
- [ flagged := false. actionBlock value ]
|
|
|
- on: AxonOff do: [ actionBlock := nil ]
|
|
|
+ [ flagged := false. self enact ]
|
|
|
+ on: AxonOff do: [ self close ]
|
|
|
! !
|
|
|
|
|
|
!AxonInterest methodsFor: 'initialization'!
|
|
|
|
|
|
initialize
|
|
|
super initialize.
|
|
|
- aspect := nil.
|
|
|
- actionBlock := nil.
|
|
|
flagged := false.
|
|
|
! !
|
|
|
|
|
@@ -211,44 +244,51 @@ accepts: anAspect
|
|
|
self subclassResponsibility
|
|
|
!
|
|
|
|
|
|
-isEnabled
|
|
|
- ^actionBlock notNil
|
|
|
+isClosed
|
|
|
+ self subclassResponsibility
|
|
|
!
|
|
|
|
|
|
isFlagged
|
|
|
^flagged
|
|
|
! !
|
|
|
|
|
|
-AxonInterest subclass: #InterestedInEqual
|
|
|
- instanceVariableNames: ''
|
|
|
+AxonInterest subclass: #PluggableInterest
|
|
|
+ instanceVariableNames: 'acceptBlock enactBlock'
|
|
|
package: 'Axxord'!
|
|
|
|
|
|
-!InterestedInEqual methodsFor: 'testing'!
|
|
|
+!PluggableInterest methodsFor: 'accessing'!
|
|
|
|
|
|
-accepts: anAspect
|
|
|
- ^ anAspect = aspect
|
|
|
+accept: aBlock enact: anotherBlock
|
|
|
+ acceptBlock := aBlock.
|
|
|
+ enactBlock := anotherBlock
|
|
|
! !
|
|
|
|
|
|
-AxonInterest subclass: #InterestedThruAxes
|
|
|
- instanceVariableNames: ''
|
|
|
- package: 'Axxord'!
|
|
|
+!PluggableInterest methodsFor: 'action'!
|
|
|
|
|
|
-!InterestedThruAxes methodsFor: 'testing'!
|
|
|
+close
|
|
|
+ acceptBlock := nil.
|
|
|
+ enactBlock := nil
|
|
|
+!
|
|
|
|
|
|
-accepts: anAspect
|
|
|
- ^anAspect size <= aspect size
|
|
|
- ifTrue: [anAspect = (aspect copyFrom: 1 to: anAspect size)]
|
|
|
- ifFalse: [aspect = (anAspect copyFrom: 1 to: aspect size)]
|
|
|
+enact
|
|
|
+ enactBlock value
|
|
|
! !
|
|
|
|
|
|
-AxonInterest subclass: #InterestedUpToAxes
|
|
|
- instanceVariableNames: ''
|
|
|
- package: 'Axxord'!
|
|
|
+!PluggableInterest methodsFor: 'initialization'!
|
|
|
|
|
|
-!InterestedUpToAxes methodsFor: 'testing'!
|
|
|
+initialize
|
|
|
+ super initialize.
|
|
|
+ self close
|
|
|
+! !
|
|
|
+
|
|
|
+!PluggableInterest methodsFor: 'testing'!
|
|
|
|
|
|
accepts: anAspect
|
|
|
- ^anAspect size <= aspect size and: [anAspect = (aspect copyFrom: 1 to: anAspect size)]
|
|
|
+ ^ acceptBlock value: anAspect
|
|
|
+!
|
|
|
+
|
|
|
+isClosed
|
|
|
+ ^ acceptBlock isNil
|
|
|
! !
|
|
|
|
|
|
Error subclass: #AxonOff
|
|
@@ -290,6 +330,40 @@ asAxisIn: anObject ifAbsent: aBlock put: anotherObject
|
|
|
^ 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
|
|
@@ -315,32 +389,27 @@ asAxisIn: anObject ifAbsent: aBlock put: anotherObject
|
|
|
!
|
|
|
|
|
|
atAxes: aCollection ifAbsent: aBlock
|
|
|
- ^ aCollection inject: self into: [ :soFar :segment |
|
|
|
- segment asAxisIn: soFar ifAbsent: [ ^ aBlock value ]]
|
|
|
+ ^ Axes on: self at: aCollection ifAbsent: aBlock
|
|
|
!
|
|
|
|
|
|
atAxes: aCollection ifAbsent: aBlock put: value
|
|
|
- | penultimate |
|
|
|
- penultimate := self atAxes: aCollection allButLast ifAbsent: aBlock.
|
|
|
- ^ aCollection last asAxisIn: penultimate ifAbsent: aBlock put: value
|
|
|
+ ^ Axes on: self at: aCollection ifAbsent: aBlock put: value
|
|
|
!
|
|
|
|
|
|
axes: aCollection consume: aBlock
|
|
|
- | value |
|
|
|
- value := self atAxes: aCollection ifAbsent: [ ^self ].
|
|
|
- ^ aBlock value: value
|
|
|
+ ^ Axes on: self at: aCollection consume: aBlock
|
|
|
!
|
|
|
|
|
|
axes: aCollection transform: aBlock
|
|
|
- | value newValue |
|
|
|
- value := self atAxes: aCollection ifAbsent: [ ^self ].
|
|
|
- newValue := aBlock value: value.
|
|
|
- value == newValue ifFalse: [ self atAxes: aCollection ifAbsent: [ ^self ] put: newValue ].
|
|
|
- self registeredAxon ifNotNil: [:axon | axon changed: aCollection]
|
|
|
+ ^ Axes on: self at: aCollection transform: aBlock
|
|
|
+!
|
|
|
+
|
|
|
+axxord
|
|
|
+<inlineJS: 'return self.$axxord$'>
|
|
|
!
|
|
|
|
|
|
-registeredAxon
|
|
|
-<inlineJS: 'return self.$axon$'>
|
|
|
+axxord: anAxon
|
|
|
+<inlineJS: 'self.$axxord$ = anAxon'>
|
|
|
! !
|
|
|
|
|
|
!String methodsFor: '*Axxord'!
|