Added bitmap cache with background processes

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/boxForOop..st

@@ -4,6 +4,7 @@ boxForOop: o
 	box := RSBox new.
 	box model: o.
 	box paint: (colorProvider colorForOop: o).
+	box popup.
 	self enableInspectOnClickForBox: box.
 	scaling value: box.
 	self contextMenuForBox: box.

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/buildMemorySpaceIn..st

@@ -1,15 +1,15 @@
 building
 buildMemorySpaceIn: aCanvas
 	| controller |
-	aCanvas addAll: (scopedOop collect: [ :anOop | self boxForOop: anOop ]).
-
-	RSGridLayout new
-		gapSize: 1;
-		on: aCanvas nodes.
+	aCanvas add: bitmap.
+	self queueNewBitmap.
 	controller := RSCanvasController new.
 	controller configuration
-		maxScale: 100000;
+		maxScale: 5;
 		minScale: 0.00001.
-	aCanvas addInteraction: controller.
-	self contextMenuForCanvas: aCanvas.
+	aCanvas 
+		addInteraction: controller;
+		when: RSExtentChangedEvent send: #queueNewBitmap to: self;
+		when: RSMouseClick send: #mouseClick: to: self.
+
 	aCanvas signalUpdate.

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/contextMenuForCanvas..st

@@ -2,8 +2,7 @@ updating
 contextMenuForCanvas: canvas
 	| menuActivable |
 	menuActivable := RSMenuActivable new.
-	menuActivable menuDo: [ :menu :element | 
-
+	menuActivable menuDo: [ :menu :element |
 		menu 
 			add: 'No scaling'
 			target: self

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/createBitmap.st

@@ -0,0 +1,30 @@
+building
+createBitmap
+	| newCanvas mainCanvas rectangle |
+	mainCanvas := bitmap canvas.
+	bitmap form: self newLoadingForm.
+	mainCanvas signalUpdate.
+	newCanvas := RSCanvas new.
+	nodes := self createNodes.
+	newCanvas addAll: nodes.
+
+	mainCanvas
+		removeKey: #firstScale;
+		propertyAt: #rtree put: (RSPolyphemusRTree withAll: nodes).
+
+	rectangle := newCanvas encompassingRectangle.
+	mainCanvas controllerInteraction configuration maxScale: (rectangle extent * 0.01) max.
+	newCanvas camera
+		zoomToFit: mainCanvas extent
+		rectangle: rectangle.
+	newCanvas extent: rectangle extent * newCanvas camera scale.
+
+	bitmap form: newCanvas asForm.
+	self contextMenuForCanvas: newCanvas.
+	mainCanvas propertyAt: #originalCamera put: newCanvas camera.
+	mainCanvas
+		when: RSScaleChangedEvent send: #queueUpdateView: to: self;
+		when: RSPositionChangedEvent send: #queueUpdateView: to: self;
+		removeKey: #encompassingRectangle;
+		zoomToFit;
+		signalUpdate.

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/createNodes.st

@@ -0,0 +1,8 @@
+building
+createNodes
+	| shapes |
+	shapes := scopedOop collect: [ :anOop | self boxForOop: anOop ] as: RSGroup.
+	RSGridLayout new
+		gapSize: 1;
+		on: shapes.
+	^ shapes

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/enqueueOperation..st

@@ -0,0 +1,7 @@
+building
+enqueueOperation: aBlock
+	| mainCanvas process |
+	mainCanvas := bitmap canvas.
+	mainCanvas propertyAt: #viewProcess ifPresent: [ :p | p terminate ].
+	process := aBlock forkAt: Processor userBackgroundPriority.
+	mainCanvas propertyAt: #viewProcess put: process.

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/initializePresenters.st

@@ -1,5 +1,5 @@
 initialization
 initializePresenters
-
-	memorySpace := self instantiate: SpRoassalPresenter.
-	memorySpace script: [ :canvas | self buildMemorySpaceIn: canvas ].
+	memorySpace := self newRoassal.
+	bitmap := self newEmptyBitmap.
+	memorySpace script: [ :canvas | self buildMemorySpaceIn: canvas ]

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/mouseClick..st

@@ -0,0 +1,14 @@
+events
+mouseClick: evt
+	| mainCanvas rtree point shapes camera |
+	mainCanvas := evt canvas.
+	rtree := mainCanvas propertyAt: #rtree ifAbsent: [ ^ self ].
+	camera := mainCanvas propertyAt: #originalCamera.
+	point := evt position.
+	point := (camera fromPixelToSpace: evt position)+((camera canvas extent/2)/camera scale).
+
+	shapes := rtree nodesWithPoint: point.
+	mainCanvas removeInteractionIfPresent: RSMenuActivable.
+	(shapes
+		ifEmpty: [ camera canvas ]
+		ifNotEmpty: [ shapes first ]) announce: evt.

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/newEmptyBitmap.st

@@ -0,0 +1,8 @@
+initialization
+newEmptyBitmap
+	"this method is going to create a new empty bitmap with a loading logo "
+	| shape |
+	shape := RSBitmap new.
+
+	shape form: self newLoadingForm.
+	^ shape

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/newLoadingForm.st

@@ -0,0 +1,10 @@
+initialization
+newLoadingForm
+	| canvas |
+	canvas := RSCanvas new.
+	canvas extent: 300 asPoint.
+	canvas add: (RSLabel new
+		text: 'Loading data...';
+		color: 'black';
+		yourself).
+	^ canvas asForm

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/queueNewBitmap.st

@@ -0,0 +1,3 @@
+building
+queueNewBitmap
+	self enqueueOperation: [ self createBitmap ].

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/queueUpdateView..st

@@ -0,0 +1,14 @@
+building
+queueUpdateView: evt
+	| mainCanvas scale firstScale |
+	mainCanvas := bitmap canvas.
+	scale := evt camera scale.
+	#queueUpdateView: traceCr.
+	mainCanvas identityHash traceCr.
+	firstScale := mainCanvas propertyAt: #firstScale ifAbsentPut: [ scale ].
+	mainCanvas propertyAt: #viewport ifPresent: [ :view | 
+		view remove.
+		mainCanvas removeKey: #viewport.
+		mainCanvas signalUpdate ].
+	scale > firstScale ifFalse: [ ^ self ].
+	self enqueueOperation: [ self updateViewPort: evt ].

Polyphemus-Memory.package/AbstractMemoryPresenter.class/instance/updateViewPort..st

@@ -0,0 +1,28 @@
+building
+updateViewPort: evt
+	| viewport newCanvas mainCanvas ext camera scale rtree |
+	mainCanvas := bitmap canvas.
+	viewport := mainCanvas
+		propertyAt: #viewport
+		ifAbsentPut: [ RSBitmap new ].
+	camera := mainCanvas propertyAt: #originalCamera.
+	camera ifNil: [ ^ self ].
+	rtree := mainCanvas propertyAt: #rtree.
+	newCanvas := RSCanvas new.
+
+	ext := mainCanvas extent.
+	scale := mainCanvas camera scale * camera scale.
+
+	newCanvas camera
+		scale: scale;
+		position: (mainCanvas camera position * (1 /camera scale))+camera position.
+	newCanvas extent: mainCanvas extent.
+	newCanvas addAll: (rtree nodesIntersetcsRectangle: newCanvas visibleRectangle).
+
+	viewport form: newCanvas asForm.
+	viewport 
+		isFixed: true;
+		position: ext / 2.
+	mainCanvas add: viewport.
+	viewport pushBack.
+	mainCanvas signalUpdate.

Polyphemus-Memory.package/AbstractMemoryPresenter.class/properties.json

@@ -13,7 +13,9 @@
 		"queryInput",
 		"updateOutput",
 		"updateBlock",
-		"reifiedMemory"
+		"reifiedMemory",
+		"bitmap",
+		"nodes"
 	],
 	"name" : "AbstractMemoryPresenter",
 	"type" : "normal"

Polyphemus-Memory.package/MemoryInspector.class/instance/initializeWindow..st

@@ -0,0 +1,5 @@
+initialization
+initializeWindow: aWindowPresenter
+	aWindowPresenter
+		title: self title;
+		initialExtent: 900@ 700

Polyphemus-Memory.package/RSPolyphemusRTree.class/README.md

@@ -0,0 +1 @@
+This RTree is prepared for PolyphemusRTree to have a balanced tree

Polyphemus-Memory.package/RSPolyphemusRTree.class/class/withAll..st

@@ -0,0 +1,5 @@
+instance creation
+withAll: aCollection
+	^ self new
+		addAll: aCollection;
+		yourself

Polyphemus-Memory.package/RSPolyphemusRTree.class/instance/addAll..st

@@ -0,0 +1,5 @@
+adding
+addAll: aCollection
+	aCollection ifEmpty: [ ^ self ].
+	root := RSRNode new.
+	root rectangleAddAll: aCollection axis: true.

Polyphemus-Memory.package/RSPolyphemusRTree.class/properties.json

@@ -0,0 +1,11 @@
+{
+	"commentStamp" : "akevalion 5/12/2022 10:09",
+	"super" : "RSRenderTree",
+	"category" : "Polyphemus-Memory-Presenters",
+	"classinstvars" : [ ],
+	"pools" : [ ],
+	"classvars" : [ ],
+	"instvars" : [ ],
+	"name" : "RSPolyphemusRTree",
+	"type" : "normal"
+}

Polyphemus-Memory.package/RSRNode.extension/instance/listsFor.axis.center..st

@@ -0,0 +1,17 @@
+*Polyphemus-Memory
+listsFor: aCollection axis: aBoolean center: point
+	| listA listB |
+	listA := RSGroup new.
+	listB := RSGroup new.
+	aCollection do: [ :shape |
+		aBoolean ifTrue: [ 
+			(shape position x < point x 
+				ifTrue: [ listA ]
+				ifFalse: [ listB ]) add: shape
+		]ifFalse: [ 
+			(shape position y < point y
+				ifTrue: [ listA ]
+				ifFalse: [ listB ]) add: shape
+		]
+	].
+	^ { listA. listB }

Polyphemus-Memory.package/RSRNode.extension/instance/rectangleAddAll.axis..st

@@ -0,0 +1,19 @@
+*Polyphemus-Memory
+rectangleAddAll: aCollection axis: aBoolean
+	aCollection ifEmpty: [ ^ self error: 'should not' ].
+	aCollection size = 1 ifTrue: [ 
+		contents := aCollection first.
+		rectangle := contents encompassingRectangle.
+	] ifFalse: [ | center lists |
+		rectangle := aCollection encompassingRectangle.
+		center := rectangle floatCenter.
+		lists := self listsFor: aCollection axis: aBoolean center: center.
+		(lists anySatisfy: [ :list | list isEmpty ])
+			ifTrue: [ lists := self listsFor: aCollection axis: aBoolean not center: center ].
+		(lists anySatisfy: [:list | list isEmpty ])
+			ifTrue: [ self error: 'listFor: error' ].
+		left := self class new.
+		left rectangleAddAll: lists first axis: aBoolean not.
+		right := self class new.
+		right rectangleAddAll: lists second axis: aBoolean not. 
+	]

Polyphemus-Memory.package/RSRNode.extension/properties.json

@@ -0,0 +1,3 @@
+{
+	"name" : "RSRNode"
+}

Polyphemus-Object.package/OOP64BitIndexableObject.class/instance/printOn..st

@@ -1,5 +1,4 @@
 printing
 printOn: aStream
-	memory rememberedSetObj = address ifTrue: [ ^ aStream << 'Remembered Set' ].
 	memory freeListsObj = address ifTrue:[ ^ aStream << 'Free Lists' ].
 	address printOn: aStream

Polyphemus-Object.package/OOPRememberedSetObject.class/class/canHandle.memory..st

@@ -0,0 +1,3 @@
+instance creation
+canHandle: anAddress memory: aMemory
+	^ aMemory rememberedSetObj = anAddress

Polyphemus-Object.package/OOPRememberedSetObject.class/instance/containedInspectionItems.st

@@ -0,0 +1,12 @@
+printing
+containedInspectionItems
+	| counter res |
+	counter := 0.
+	res := OrderedCollection new: self numSlots + 1.
+	res add: (#numIndexedElements -> self numSlots).
+	self allElements collect: [ :anElement | | object |
+		counter := counter + 1.
+		object :=  (memory objectAt: anElement) ifNil: [ anElement ].
+		('element', counter printString) -> object.
+		] into: res.
+	^ res

Polyphemus-Object.package/OOPRememberedSetObject.class/instance/printOn..st

@@ -0,0 +1,3 @@
+printing
+printOn: aStream
+	aStream << 'Rememebered Set'

Polyphemus-Object.package/OOPRememberedSetObject.class/properties.json

@@ -0,0 +1,11 @@
+{
+	"commentStamp" : "",
+	"super" : "OOP64BitIndexableObject",
+	"category" : "Polyphemus-Object-oop",
+	"classinstvars" : [ ],
+	"pools" : [ ],
+	"classvars" : [ ],
+	"instvars" : [ ],
+	"name" : "OOPRememberedSetObject",
+	"type" : "normal"
+}

Polyphemus-Tests.package/VMObjectCreationTest.class/instance/testCreatinRememberedSetObject.st

@@ -0,0 +1,5 @@
+tests
+testCreatinRememberedSetObject
+	| oopObject |
+	oopObject :=  self reifyOop: memory rememberedSetObj.
+	self assert: oopObject class equals: OOPRememberedSetObject