Merge pull request #315 from tomooda/main

add validatorium for SVO tasks
ReMobidyc · Mar 11, 2024 · 2328128 · 2328128
2 parents 94d22b4 + 7b6822e
commit 2328128
Show file tree

Hide file tree

Showing 14 changed files with 295 additions and 125 deletions.
diff --git a/src/ReMobidyc-Interpreter/RMDActionContext.class.st b/src/ReMobidyc-Interpreter/RMDActionContext.class.st
@@ -59,6 +59,12 @@ RMDActionContext >> createPatchAttributeDict: anInteger [
 		  assoc value: anInteger + assoc value ]
 ]
 
+{ #category : #testing }
+RMDActionContext >> hasObject [
+
+	^ object notNil
+]
+
 { #category : #accessing }
 RMDActionContext >> location [
 
@@ -114,6 +120,31 @@ RMDActionContext >> objectDefinition [
 	^ objectDefinition
 ]
 
+{ #category : #printing }
+RMDActionContext >> printOn: aStream [
+
+	subjectDefinition
+		ifNotNil: [ aStream nextPutAll: subjectDefinition name ]
+		ifNil: [ aStream nextPut: $- ].
+	aStream nextPut: $(.
+	subject
+		ifNotNil: [ subject printOn: aStream ]
+		ifNil: [ aStream nextPut: $- ].
+	aStream
+		nextPut: $);
+		space.
+	action
+		ifNotNil: [ aStream nextPutAll: action identifier ]
+		ifNil: [ aStream nextPut: $- ].
+	aStream space.
+	objectDefinition ifNotNil: [
+		aStream nextPutAll: objectDefinition identifier ].
+	object ifNotNil: [
+		aStream nextPut: $(.
+		object printOn: aStream.
+		aStream nextPut: $) ]
+]
+
 { #category : #accessing }
 RMDActionContext >> space [
 	^ space

diff --git a/src/ReMobidyc-Interpreter/RMDTaskDefinitionNode.extension.st b/src/ReMobidyc-Interpreter/RMDTaskDefinitionNode.extension.st
@@ -8,7 +8,7 @@ RMDTaskDefinitionNode >> evalIn: aRMDInterpreter [
 		self hasObject
 			ifTrue: [
 				nearest
-					ifTrue: [ self evalWithNearestObjectsIn: aRMDInterpreter ]
+					ifTrue: [ self evalWithNearestObjectIn: aRMDInterpreter ]
 					ifFalse: [ self evalWithAllObjectsIn: aRMDInterpreter ] ]
 			ifFalse: [ self evalWithoutObjectIn: aRMDInterpreter ] ]
 			on: RMDSemanticError
@@ -65,7 +65,7 @@ RMDTaskDefinitionNode >> evalWithAllObjectsIn: aRMDInterpreter [
 ]
 
 { #category : #'*ReMobidyc-Interpreter' }
-RMDTaskDefinitionNode >> evalWithNearestObjectsIn: aRMDInterpreter [
+RMDTaskDefinitionNode >> evalWithNearestObjectIn: aRMDInterpreter [
 
 	| specializedAction taskHash subjectAgent objectAgent interactionSpace |
 	specializedAction := self actionWith: aRMDInterpreter simulationModel.
@@ -143,35 +143,85 @@ RMDTaskDefinitionNode >> typecheckIn: aRMDInterpreter [
 ]
 
 { #category : #'*ReMobidyc-Interpreter' }
-RMDTaskDefinitionNode >> validateWithSubject: anInteger in: aRMDInterpreter [
+RMDTaskDefinitionNode >> validate: anInteger in: aRMDInterpreter do: aBlock [
 
-	| traceableAction taskHash subjectAgent |
-	traceableAction := (self actionWith: aRMDInterpreter simulationModel)
-		                   beTraceable.
+	self hasObject
+		ifTrue: [
+			nearest
+				ifTrue: [
+					self
+						validate: anInteger
+						withNearestObjectIn: aRMDInterpreter
+						do: aBlock ]
+				ifFalse: [  ] ]
+		ifFalse: [
+			self
+				validateWithoutObject: anInteger
+				in: aRMDInterpreter
+				do: aBlock ]
+]
+
+{ #category : #'*ReMobidyc-Interpreter' }
+RMDTaskDefinitionNode >> validate: anInteger withAllObjectsIn: aRMDInterpreter do: aBlock [
+
+	| specializedAction taskHash subjectAgent objectAgent interactionSpace subjectAnimat subjectX subjectY |
+	specializedAction := self actionWith: aRMDInterpreter simulationModel.
 	taskHash := aRMDInterpreter taskHashFor: self.
 	subjectAgent := aRMDInterpreter simulationModel
 		                agentDefinitionAt: subjectIdentifier
 		                ifAbsent: [
 		                ^ RMDUndefinedAnimatError signal: subjectIdentifier ].
-	aRMDInterpreter simulationModel typechecker
-		typecheck: traceableAction
-		subject: subjectAgent
-		object: nil.
+	objectAgent := aRMDInterpreter simulationModel
+		               animatDefinitionAt: objectIdentifier
+		               ifAbsent: [
+		               ^ RMDUndefinedAnimatError signal: objectIdentifier ].
+	interactionSpace := RMDInteractionSpace
+		                    width: aRMDInterpreter simulationModel north
+		                    height: aRMDInterpreter simulationModel east
+		                    range: range numeric.
+	aRMDInterpreter individualsOf: objectAgent do: [ :objectAnimat |
+		aRMDInterpreter
+			withObserverContextWithSubject: objectAnimat
+			definition: objectAgent
+			do: [
+				| x y |
+				x := aRMDInterpreter my: 'x'.
+				y := aRMDInterpreter my: 'y'.
+				interactionSpace add: objectAnimat x: x y: y ] ].
+	subjectAnimat := anInteger.
 	aRMDInterpreter
-		withActionContextWith: traceableAction
-		subject: anInteger
+		withObserverContextWithSubject: subjectAnimat
 		definition: subjectAgent
-		taskHash: taskHash
-		do: [ traceableAction evalIn: aRMDInterpreter ].
-	^ traceableAction
+		do: [
+			subjectX := aRMDInterpreter my: 'x'.
+			subjectY := aRMDInterpreter my: 'y' ].
+	interactionSpace
+		animatsAroundX: subjectX
+		y: subjectY
+		do: [ :objectAnimat |
+			| traceableAction |
+			traceableAction := specializedAction beTraceable.
+			aRMDInterpreter simulationModel typechecker
+				typecheck: traceableAction
+				subject: subjectAgent
+				object: objectAgent.
+			aRMDInterpreter
+				withActionContextWith: specializedAction
+				subject: subjectAnimat
+				definition: subjectAgent
+				object: objectAnimat
+				definition: objectAgent
+				taskHash: taskHash
+				do: [ :interpreter :context |
+					traceableAction evalIn: interpreter.
+					aBlock value: context ] ]
 ]
 
 { #category : #'*ReMobidyc-Interpreter' }
-RMDTaskDefinitionNode >> validateWithSubject: anInteger object: anotherInteger in: aRMDInterpreter [
+RMDTaskDefinitionNode >> validate: anInteger withNearestObjectIn: aRMDInterpreter do: aBlock [
 
-	| traceableAction taskHash subjectAgent objectAgent |
-	traceableAction := (self actionWith: aRMDInterpreter simulationModel)
-		                   beTraceable.
+	| specializedAction taskHash subjectAgent objectAgent interactionSpace subjectAnimat subjectX subjectY |
+	specializedAction := self actionWith: aRMDInterpreter simulationModel.
 	taskHash := aRMDInterpreter taskHashFor: self.
 	subjectAgent := aRMDInterpreter simulationModel
 		                agentDefinitionAt: subjectIdentifier
@@ -181,17 +231,69 @@ RMDTaskDefinitionNode >> validateWithSubject: anInteger object: anotherInteger i
 		               animatDefinitionAt: objectIdentifier
 		               ifAbsent: [
 		               ^ RMDUndefinedAnimatError signal: objectIdentifier ].
+	interactionSpace := RMDInteractionSpace
+		                    width: aRMDInterpreter simulationModel north
+		                    height: aRMDInterpreter simulationModel east
+		                    range: range numeric.
+	aRMDInterpreter individualsOf: objectAgent do: [ :objectAnimat |
+		aRMDInterpreter
+			withObserverContextWithSubject: objectAnimat
+			definition: objectAgent
+			do: [
+				| x y |
+				x := aRMDInterpreter my: 'x'.
+				y := aRMDInterpreter my: 'y'.
+				interactionSpace add: objectAnimat x: x y: y ] ].
+	subjectAnimat := anInteger.
+	aRMDInterpreter
+		withObserverContextWithSubject: subjectAnimat
+		definition: subjectAgent
+		do: [
+			subjectX := aRMDInterpreter my: 'x'.
+			subjectY := aRMDInterpreter my: 'y' ].
+	interactionSpace
+		nearestAnimatAroundX: subjectX
+		y: subjectY
+		do: [ :objectAnimat |
+			| traceableAction |
+			traceableAction := specializedAction beTraceable.
+			aRMDInterpreter simulationModel typechecker
+				typecheck: traceableAction
+				subject: subjectAgent
+				object: objectAgent.
+			aRMDInterpreter
+				withActionContextWith: traceableAction
+				subject: subjectAnimat
+				definition: subjectAgent
+				object: objectAnimat
+				definition: objectAgent
+				taskHash: taskHash
+				do: [ :interpreter :context |
+					traceableAction evalIn: interpreter.
+					aBlock value: context ] ]
+]
+
+{ #category : #'*ReMobidyc-Interpreter' }
+RMDTaskDefinitionNode >> validateWithoutObject: anInteger in: aRMDInterpreter do: aBlock [
+
+	| traceableAction taskHash subjectAgent |
+	traceableAction := (self actionWith: aRMDInterpreter simulationModel)
+		                   beTraceable.
+	taskHash := aRMDInterpreter taskHashFor: self.
+	subjectAgent := aRMDInterpreter simulationModel
+		                agentDefinitionAt: subjectIdentifier
+		                ifAbsent: [
+		                ^ RMDUndefinedAnimatError signal: subjectIdentifier ].
 	aRMDInterpreter simulationModel typechecker
 		typecheck: traceableAction
 		subject: subjectAgent
-		object: objectAgent.
+		object: nil.
 	aRMDInterpreter
 		withActionContextWith: traceableAction
 		subject: anInteger
 		definition: subjectAgent
-		object: anotherInteger
-		definition: objectAgent
 		taskHash: taskHash
-		do: [ traceableAction evalIn: aRMDInterpreter ].
-	^ traceableAction
+		do: [ :interpreter :context |
+			traceableAction evalIn: interpreter.
+			aBlock value: context ]
 ]
diff --git a/src/ReMobidyc-Spec2/RMDAttributeByTimeTabular.class.st b/src/ReMobidyc-Spec2/RMDAttributeByTimeTabular.class.st
@@ -44,7 +44,7 @@ RMDAttributeByTimeTabular class >> defaultLayout [
 		  yourself
 ]
 
-{ #category : #private }
+{ #category : #updating }
 RMDAttributeByTimeTabular >> agentChanged [
 
 	self updateTable
@@ -159,7 +159,13 @@ RMDAttributeByTimeTabular >> openChartMenu [
 	menu openWithSpecAtPointer
 ]
 
-{ #category : #private }
+{ #category : #accessing }
+RMDAttributeByTimeTabular >> selectedAgent [
+
+	^ agentDropList selectedItem
+]
+
+{ #category : #accessing }
 RMDAttributeByTimeTabular >> selectedIndividual [
 
 	^ table selectedItem ifNotNil: [ :row |

diff --git a/src/ReMobidyc-Spec2/RMDAttributeByTimeValidatorium.class.st b/src/ReMobidyc-Spec2/RMDAttributeByTimeValidatorium.class.st
@@ -3,7 +3,7 @@ Class {
 	#superclass : #RMDAttributeByTimeTabular,
 	#instVars : [
 		'taskList',
-		'traceableAction'
+		'traceableActionContext'
 	],
 	#category : #'ReMobidyc-Spec2-Tabulars'
 }
@@ -30,11 +30,13 @@ RMDAttributeByTimeValidatorium class >> defaultLayout [
 						    yourself);
 				   yourself)
 		  expand: false;
-		  add: #table;
-		  add: (SpPanedLayout newHorizontal
-				   positionOfSlider: 0.3;
-				   add: #taskList;
-				   add: #traceableAction);
+		  add: (SpPanedLayout newVertical
+				   positionOfSlider: 0.7;
+				   add: #table;
+				   add: (SpPanedLayout newHorizontal
+						    positionOfSlider: 0.3;
+						    add: #taskList;
+						    add: #traceableActionContext));
 		  add: (SpBoxLayout newHorizontal
 				   add: #openTabularButton width: self buttonHeight;
 				   add: #openObservatoryButton width: self buttonHeight;
@@ -55,11 +57,11 @@ RMDAttributeByTimeValidatorium >> initializePresenters [
 	taskList := self newTable
 		            addColumn:
 			            (SpStringTableColumn
-				             title: 'verb'
-				             evaluated: #verbIdentifier);
+				             title: 'task'
+				             evaluated: #printString);
 		            whenSelectedItemChangedDo: [ self updateTraceableAction ];
 		            yourself.
-	traceableAction := self instantiate: RMDTraceableActionPresenter
+	traceableActionContext := self instantiate: RMDTraceableActionContextPresenter
 ]
 
 { #category : #updating }
@@ -68,24 +70,23 @@ RMDAttributeByTimeValidatorium >> updateTaskList [
 	| selection |
 	selection := taskList selectedItem.
 	self selectedInterpreter ifNotNil: [ :interpreter |
-		agentDropList selectedItem ifNotNil: [ :agent |
-			taskList items:
-				(interpreter simulationModel taskDefinitions select: [ :task |
-					 task enabled and: [
-						 task subjectIdentifier = agent name and: [
-							 task objectIdentifier isNil ] ] ]).
-			selection ifNotNil: [ taskList selectItem: selection ].
-			^ self ] ].
+		self selectedAgent ifNotNil: [ :agent |
+			self selectedIndividual ifNotNil: [ :subject |
+				taskList items: (Array streamContents: [ :stream |
+						 interpreter simulationModel taskDefinitions do: [ :task |
+							 (task enabled and: [ task subjectIdentifier = agent name ])
+								 ifTrue: [
+									 task
+										 validate: subject
+										 in: self selectedInterpreter
+										 do: [ :context | stream nextPut: context ] ] ] ]).
+				selection ifNotNil: [ taskList selectItem: selection ].
+				^ self ] ] ].
 	taskList items: Array new
 ]
 
 { #category : #updating }
 RMDAttributeByTimeValidatorium >> updateTraceableAction [
 
-	taskList selectedItem ifNotNil: [ :task |
-		self selectedIndividual ifNotNil: [ :subject |
-			traceableAction action:
-				(task validateWithSubject: subject in: self selectedInterpreter).
-			^ self ] ].
-	traceableAction action: nil
+	traceableActionContext context: taskList selectedItem
 ]
diff --git a/src/ReMobidyc-Spec2/RMDExperimentarium.class.st b/src/ReMobidyc-Spec2/RMDExperimentarium.class.st
@@ -406,19 +406,19 @@ RMDExperimentarium >> saveRunAs [
 				self setMetaInterpreter: (RMDMetaInterpreter onModelPath: ref) ] ] ]
 ]
 
-{ #category : #private }
+{ #category : #accessing }
 RMDExperimentarium >> selectedIndividual [
 
 	^ nil
 ]
 
-{ #category : #private }
+{ #category : #accessing }
 RMDExperimentarium >> selectedRunId [
 
 	^ nil
 ]
 
-{ #category : #private }
+{ #category : #accessing }
 RMDExperimentarium >> selectedTime [
 
 	| time |

diff --git a/src/ReMobidyc-Spec2/RMDIndividualHistoryTabular.class.st b/src/ReMobidyc-Spec2/RMDIndividualHistoryTabular.class.st
@@ -227,6 +227,16 @@ RMDIndividualHistoryTabular >> selectTime: anInteger [
 			 ifNone: [ nil ])
 ]
 
+{ #category : #accessing }
+RMDIndividualHistoryTabular >> selectedAgent [
+
+	^ stageDropList selectedItem ifNotNil: [ :assoc |
+		  self selectedInterpreter ifNotNil: [ :interpreter |
+			  interpreter simulationModel
+				  animatDefinitionAt: assoc value first
+				  ifAbsent: [ nil ] ] ]
+]
+
 { #category : #private }
 RMDIndividualHistoryTabular >> selectedIndividual [