Implements filtering history by tags

hpi-swa · Feb 12, 2025 · 0fdab2e · 0fdab2e
1 parent f4bbe56
commit 0fdab2e
Show file tree

Hide file tree

Showing 33 changed files with 768 additions and 170 deletions.
diff --git a/packages/Sandblocks-Babylonian/ImageMorph.extension.st b/packages/Sandblocks-Babylonian/ImageMorph.extension.st
@@ -8,3 +8,13 @@ ImageMorph >> applyResize: aPoint [
 	form := form applyResize: aPoint.
 	^ form asMorph
 ]
+
+{ #category : #'*Sandblocks-Babylonian' }
+ImageMorph >> layoutedTaggedCopy [
+
+	^ super layoutedTaggedCopy
+		image: self image;
+		yourself
+
+
+]
diff --git a/packages/Sandblocks-Babylonian/Morph.extension.st b/packages/Sandblocks-Babylonian/Morph.extension.st
@@ -6,18 +6,53 @@ Morph >> applyResize: aPoint [
 	^ self extent: aPoint
 ]
 
+{ #category : #'*Sandblocks-Babylonian' }
+Morph >> childrenFormCollection [
+
+	^ (self isTextMorph or: [self isStringMorph])
+		ifTrue: [{}]
+		ifFalse: [{ImageMorph new newForm: self imageForm}]
+]
+
 { #category : #'*Sandblocks-Babylonian' }
 Morph class >> exampleObject [
 
 	^ self new
 ]
 
+{ #category : #'*Sandblocks-Babylonian' }
+Morph >> hasBeenTagged [
+
+	^ self tag isNilTag not
+]
+
+{ #category : #'*Sandblocks-Babylonian' }
+Morph >> layoutedTaggedCopy [
+
+	^ self class new
+		extent: self extent;
+		color: self color;
+		layoutProperties: self layoutProperties;
+		layoutPolicy: self layoutPolicy;
+		borderStyle: self borderStyle;
+		tag: self tag;
+		yourself 
+
+
+]
+
 { #category : #'*Sandblocks-Babylonian' }
 Morph >> listensToPermutations [ 
 
 	^ false
 ]
 
+{ #category : #'*Sandblocks-Babylonian' }
+Morph >> satisfiesTag: anotherSBTag [
+
+	^ self tag satisfiesTag: anotherSBTag
+]
+
 { #category : #'*Sandblocks-Babylonian' }
 Morph >> sbWatchValueMorphFor: aSBWatchValue sized: aSBMorphResizer [
 
@@ -26,6 +61,65 @@ Morph >> sbWatchValueMorphFor: aSBWatchValue sized: aSBMorphResizer [
 		yourself
 ]
 
+{ #category : #'*Sandblocks-Babylonian' }
+Morph >> snapshot [
+
+	^ self snapshotSatisfying: {} 
+]
+
+{ #category : #'*Sandblocks-Babylonian' }
+Morph >> snapshotSatisfying: aCollectionOfTags [
+
+	| emptyCopy |
+	"normal morph, doesn't even know tags!"
+	(self hasBeenTagged not and: [ self topLevelTaggedChildren isEmpty ])
+		ifTrue: [^ ImageMorph new newForm: self imageForm ]. 
+
+	"there are some tags in this layout that we want to preserve"
+	emptyCopy := self layoutedTaggedCopy.
+
+	"Not satisfying tag, filter out" 
+	(self hasBeenTagged and: [aCollectionOfTags anySatisfy: [:aTag | (self satisfiesTag: aTag) not ]])
+		ifTrue: [ ^ nil ]. 
+
+	"When this is the last tag in the hierarchy, we can stop right here."
+	(self hasBeenTagged and: [self topLevelTaggedChildren isEmpty]) 
+		ifTrue: [ ^ (ImageMorph new newForm: self imageForm) tag: self tag].
+
+	"Process and add tagged children."
+	^ emptyCopy addAllMorphsBack: ((self submorphs 
+											collect: [:aChild | aChild snapshotSatisfying: aCollectionOfTags])
+											reject: #isNil)
+
+]
+
+{ #category : #'*Sandblocks-Babylonian' }
+Morph >> tag [
+
+	^ self valueOfProperty: #SBTag ifAbsentPut: [ SBNilTag new ]
+]
+
+{ #category : #'*Sandblocks-Babylonian' }
+Morph >> tag: aSBTag [
+
+	self setProperty: #SBTag toValue: aSBTag 
+]
+
+{ #category : #'*Sandblocks-Babylonian' }
+Morph >> topLevelTaggedChildren [
+
+	| childrenToCheck foundTaggedChildren |
+	childrenToCheck := self submorphs asOrderedCollection.
+	foundTaggedChildren := OrderedCollection new.
+	[childrenToCheck isEmpty] whileFalse: [ | child |
+		child := childrenToCheck removeFirst. 
+		child hasBeenTagged
+			ifTrue: [foundTaggedChildren add: child]
+			ifFalse: [childrenToCheck addAll: child submorphs]].
+	^ foundTaggedChildren 
+
+]
+
 { #category : #'*Sandblocks-Babylonian' }
 Morph >> topLevelVariants [
 

diff --git a/packages/Sandblocks-Babylonian/SBCluster.class.st b/packages/Sandblocks-Babylonian/SBCluster.class.st
@@ -169,7 +169,7 @@ SBCluster >> wrapInCell: aMorph [
 { #category : #helper }
 SBCluster >> wrapInCell: aMorph flexVertically: aVBoolean flexHorizontally: aHBoolean [
 
-	| cell targetExtent|
+	| cell targetExtent |
 	cell := self newCellMorph.
 
 	aVBoolean ifTrue: [cell vResizing: #shrinkWrap].
@@ -188,7 +188,8 @@ SBCluster >> wrapInCell: aMorph flexVertically: aVBoolean flexHorizontally: aHBo
 	self flag: #todo. "Another way besides turning into an image to keep interactions.-jb"
 	cell addMorph: (ImageMorph new 
 		newForm: (aMorph imageForm scaledIntoFormOfSize: targetExtent);
-		when: #clicked send: #triggerEvent: to: aMorph with: #clicked).
+		when: #clicked send: #triggerEvent: to: aMorph with: #clicked;
+		tag: aMorph tag)..
 	cell on: #click send: #value to: [cell submorphs first triggerEvent: #clicked].
 	^ cell
 ]
diff --git a/packages/Sandblocks-Babylonian/SBCorrelationCluster.class.st b/packages/Sandblocks-Babylonian/SBCorrelationCluster.class.st
@@ -55,10 +55,16 @@ SBCorrelationCluster >> buildDisplayMatrix [
 		rows: 2
 		columns: self correlatingUniverses size + 1.
 
-	matrix atRow: 1 put: ({TextMorph new contents: self basePermutation asVariantString}, 
+	matrix atRow: 1 put: ({TextMorph new
+								tag: (SBTag newFromPermutation: self basePermutation); 
+								contents: self basePermutation asVariantString;
+								yourself}, 
 	(self extractedTopHeadingsFrom: self correlatingUniverses)).
 
-	matrix at: 2 at: 1 put: (SBPermutationLabel newDisplaying: self basePermutation).
+	matrix at: 2 at: 1 put: ((SBPermutationLabel 
+								newDisplaying: self basePermutation)
+								tag: (SBTag newFromPermutation: self basePermutation);
+								yourself).
 
 	self extractRow withIndexDo: [:aCellMorph :column | matrix at: 2 at: column+1 put: aCellMorph].
 
@@ -105,19 +111,24 @@ SBCorrelationCluster >> displayedWatch: anSBExampleWatch [
 SBCorrelationCluster >> extractRow [
 
 	^ self correlatingUniverses 
-		collect: [:aUniverse | | display | 
-		display := ((aUniverse watches detect: [:aWatch | aWatch originalIdentifier = self displayedWatch identifier]) 
-					exampleToDisplay at: self displayedExample) value display.
-		self compressedMorphsForDisplay: display]
+		collect: [:aUniverse | | display watchMorph |
+		watchMorph :=  aUniverse watches detect: [:aWatch | aWatch originalIdentifier = self displayedWatch identifier].
+		display := (watchMorph exampleToDisplay at: self displayedExample) value display.
+		(self compressedMorphsForDisplay: display)
+			tag: (SBTag new
+				addFromExample: self displayedExample;
+				addFromWatch: self displayedWatch;
+				addFromPermutation: aUniverse activePermutation )]
 ]
 
 { #category : #building }
 SBCorrelationCluster >> extractedTopHeadingsFrom: aCollectionOfCorrelatingUniverses [
 
-	^ aCollectionOfCorrelatingUniverses collect: [:aCorrelatingUniverse |  
-		SBPartialPermutationLabel 
-			newDisplaying: (aCorrelatingUniverse activePermutation copyRemovingVariants: self basePermutation referencedVariants)
-			referingTo: aCorrelatingUniverse]
+	^ aCollectionOfCorrelatingUniverses collect: [:aCorrelatingUniverse | | partialPermutation |
+		partialPermutation :=  (aCorrelatingUniverse activePermutation copyRemovingVariants: self basePermutation referencedVariants).
+		(SBPartialPermutationLabel 
+			newDisplaying: partialPermutation
+			referingTo: aCorrelatingUniverse)]
 ]
 
 { #category : #visualisation }
@@ -131,6 +142,7 @@ SBCorrelationCluster >> newTopRowFrom: aCollectionOfPermutationLabels [
 		hResizing: #spaceFill;
 		addAllMorphsBack: (aCollectionOfPermutationLabels collect: [:aLabel | 
 			self newContainerMorph 
+				tag: (SBTag newFromPermutation: aLabel universe activePermutation);
 				addAllMorphsBack: {
 					(self 
 						wrapInCell: aLabel 

diff --git a/packages/Sandblocks-Babylonian/SBCorrelationView.class.st b/packages/Sandblocks-Babylonian/SBCorrelationView.class.st
@@ -28,14 +28,21 @@ SBCorrelationView >> buildAllPossibleResults [
 { #category : #building }
 SBCorrelationView >> buildForExample: anExample watching: aWatch [
 
-	gridContainer addMorphBack: (self containerRow cellPositioning: #center;
-		addAllMorphsBack: {
-			self containerRow listDirection: #topToBottom;
-				addAllMorphsBack: { 
-					SBOwnTextMorph new contents: (
-						'{1}, {2}' format: {anExample label.
-											 (aWatch cleanedExpression sourceString)}).
-					self buildGridsFor: anExample watching: aWatch} flatten})
+	gridContainer addMorphBack: (
+		self containerRow 
+			cellPositioning: #center;
+			tag: (SBTag new 
+					addFromExample: anExample;
+					addFromWatch: aWatch);
+			addAllMorphsBack: {
+				self containerRow 
+					listDirection: #topToBottom;
+					cellPositioning: #bottomRight;
+					addAllMorphsBack: { 
+						SBOwnTextMorph new contents: (
+							'{1}, {2}' format: {anExample label.
+												 (aWatch cleanedExpression sourceString)}).
+						self buildGridsFor: anExample watching: aWatch} flatten})
 ]
 
 { #category : #building }

diff --git a/packages/Sandblocks-Babylonian/SBCustomView.class.st b/packages/Sandblocks-Babylonian/SBCustomView.class.st
@@ -38,7 +38,7 @@ SBCustomView >> initialize [
 	self buildButtonRow.
 
 	self block addMorphBack: viewOptions.
-	self block addMorphBack: self selectedView
+	self block addMorphBack: self selectedView block
 
 ]
 

diff --git a/packages/Sandblocks-Babylonian/SBExample.class.st b/packages/Sandblocks-Babylonian/SBExample.class.st
@@ -126,6 +126,19 @@ SBExample >> assertionBlock [
 	^ self submorphCount > 7 ifTrue: [self submorphs ninth] ifFalse: [nil]
 ]
 
+{ #category : #actions }
+SBExample >> backtrack [
+	<action>
+
+	SBExploriants uniqueInstance isInEditor 
+		ifTrue: [
+			self sandblockEditor openMorphInView: 
+				(SBExploriants uniqueInstance historyView backtrackForExample: self)] 
+
+
+
+]
+
 { #category : #'event handling' }
 SBExample >> click: anEvent [