Excel display driver class for Tetris

Question

This is the first of (hopefully) several posts as I reimplement an ancient (and unfortunately long lost) Excel VBA Tetris clone. The main workhorse class in the game engine is the display driver, which uses a rectangular area of a Worksheet to emulate a monitor. The display is sprite based, so the class holds a Dictionary loaded with IDrawables, which are basically bitmaps. The interface is as follows:

'IDrawable.cls
Option Explicit
Public Property Get Top() As Long
End Property
Public Property Let Top(inValue As Long)
End Property
Public Property Get Left() As Long
End Property
Public Property Let Left(inValue As Long)
End Property
Public Property Get Width() As Long
End Property
Public Property Get Height() As Long
End Property
Public Property Let Bitmap(colors() As Long)
End Property
Public Property Get Bitmap() As Long()
End Property
Public Function GetPixel(pixelRow As Long, pixelColumn As Long) As Long
End Function

---

Properties

AnchorCell - This is a one cell Range that determines where the display rectangle will be placed. It will raise an error if more than one cell is passed.

Top and Left are the row and column number of the AnchorCell in the parent Worksheet's coordinates. These are read-only and are derived from the AnchorCell.

Width and Height set the dimensions of the display.

DotPitch is the size of each "pixel", and the rows and columns in the display range are set to this width and height (in pixels). Currently I have it limited to CGA resolution (mainly for convenience when I test it), but the limits can be set by altering the appropriate constants.

BackColor sets the background color for the display. Any pixel in an IDrawable that matches the BackColor will be "transparent".

---

Methods

AddDrawable, RemoveDrawable and ClearDrawables are the main methods for interacting with the display. Any item added to the container will be rendered.

Refresh forces the display to repaint itself. If changes were made to any of the properties that alter how it is rendered on the Worksheet, it will apply those changes. As a side note, this should eventually include Z-ordering, but I'm still up in the air as to the implementation details (and Tetris doesn't need the functionality - maybe for some other game...). There's also room for improvement in the resize - I currently have the conversion between character width and pixels fixed, but it should really calculate it based on the display settings.

Create is simply a factory method. I'm open to ideas as to how to make the "default constructor" private. :-P

---

The Code

Note, VB_PredeclaredId is set to True. For convenience, the raw file is available on pastebin.

^{Yes, yes, I know - I'll get it up on github eventually.}

'CellDisplayDriver.cls
Option Explicit
Public Enum DriverErrors
 NullRangeError = vbObjectError + 1
 ArgumentError = vbObjectError + 2
 InvalidStateError = vbObjectError + 3
End Enum
Private Const MIN_WIDTH As Long = 10
Private Const MAX_WIDTH As Long = 160
Private Const MIN_HEIGHT As Long = 10
Private Const MAX_HEIGHT As Long = 100
Private Const MIN_PITCH As Long = 1
Private Const MAX_PITCH As Long = 10
Private Type DriverProperties
 AnchorCell As Range
 Top As Long
 Left As Long
 Width As Long
 Height As Long
 DotPitch As Long
 BackColor As Long
 DisplayArea As Range
 Drawables As Scripting.Dictionary
 PendingResize As Boolean
End Type
Private this As DriverProperties
Private Sub Class_Initialize()
 With this
 Set .Drawables = New Scripting.Dictionary
 .PendingResize = True
 .Width = MIN_WIDTH
 .Height = MIN_HEIGHT
 .DotPitch = MAX_PITCH
 End With
End Sub
Public Property Get AnchorCell() As Range
 Set AnchorCell = this.AnchorCell
End Property
Public Property Set AnchorCell(inValue As Range)
 If inValue Is Nothing Then
 Err.Raise DriverErrors.NullRangeError, "CellDisplayDriver.AnchorCell", "AnchorCell cannot be set to Nothing."
 End If
 With inValue
 If .Rows.Count > 1 Or .Columns.Count > 1 Then
 RaiseInvalidArgument "AnchorCell", "AnchorCell must be a Range containing a single cell."
 End If
 End With
 If Not this.AnchorCell Is Nothing Then
 this.PendingResize = inValue.Address <> this.AnchorCell.Address
 End If
 Set this.AnchorCell = inValue
 With this.AnchorCell
 this.Top = .Rows(1).Row
 this.Left = .Columns(1).Column
 End With
 With this.AnchorCell.Parent
 Set this.DisplayArea = .Range(.Cells(this.Top, this.Left), _
 .Cells(this.Top + this.Height - 1, this.Left + this.Width - 1))
 End With
End Property
Public Property Get Top() As Long
 Top = this.Top
End Property
Public Property Get Left() As Long
 Left = this.Left
End Property
Public Property Get Width() As Long
 Width = this.Width
End Property
Public Property Let Width(inValue As Long)
 If inValue < MIN_WIDTH Or inValue > MAX_WIDTH Then
 RaiseInvalidArgument "Width", "Width must be between " & MIN_WIDTH & " and " & MAX_WIDTH & "."
 End If
 this.PendingResize = inValue <> this.Width
 this.Width = inValue
End Property
Public Property Get Height() As Long
 Height = this.Height
End Property
Public Property Let Height(inValue As Long)
 If inValue < MIN_HEIGHT Or inValue > MAX_HEIGHT Then
 RaiseInvalidArgument "Height", "Height must be between " & MIN_HEIGHT & " and " & MAX_HEIGHT & "."
 End If
 this.PendingResize = inValue <> this.Height
 this.Height = inValue
End Property
Public Property Get DotPitch() As Long
 DotPitch = this.DotPitch
End Property
Public Property Let DotPitch(inValue As Long)
 If inValue < MIN_PITCH Or inValue > MAX_PITCH Then
 RaiseInvalidArgument "Create", "Dot pitch must be between " & MIN_PITCH & " and " & MAX_PITCH & "."
 End If
 this.PendingResize = inValue <> this.DotPitch
 this.DotPitch = inValue
End Property
Public Property Get BackColor() As Long
 BackColor = this.BackColor
End Property
Public Property Let BackColor(rgbValue As Long)
 this.BackColor = rgbValue
End Property
Public Sub AddDrawable(addition As IDrawable)
 With this.Drawables
 If Not .Exists(addition) Then .Add addition, vbNull
 End With
End Sub
Public Sub RemoveDrawable(deletion As IDrawable)
 With this.Drawables
 If .Exists(deletion) Then .Remove deletion
 End With
End Sub
Public Sub ClearDrawables()
 this.Drawables.RemoveAll
End Sub
Public Sub Refresh()
 If this.DisplayArea Is Nothing Then
 Err.Raise DriverErrors.InvalidStateError, "CellDisplayDriver.Refresh", "AnchorCell must be set prior to Refresh."
 End If
 Application.ScreenUpdating = False
 If this.PendingResize Then Resize
 With this.DisplayArea
 .Interior.Color = this.BackColor
 Dim drawable As Variant
 For Each drawable In this.Drawables.Keys
 Dim r As Long
 Dim c As Long
 Dim rowTarget As Long
 Dim colTarget As Long
 For r = 1 To drawable.Height
 rowTarget = r + drawable.Top
 If rowTarget >= 1 And rowTarget < this.Height Then
 For c = 1 To drawable.Width
 colTarget = c + drawable.Left
 If colTarget >= 1 And colTarget < this.Width Then
 .Cells(rowTarget, colTarget).Interior.Color = drawable.GetPixel(r, c)
 End If
 Next
 End If
 Next
 Next
 End With
 Application.ScreenUpdating = True
 DoEvents
End Sub
Public Function Create(displayWidth As Long, displayHeight As Long, pitch As Long, anchor As Range) As CellDisplayDriver
 Dim display As New CellDisplayDriver
 With display
 .Width = displayWidth
 .Height = displayHeight
 .DotPitch = pitch
 Set .AnchorCell = anchor
 End With
 Set Create = display
End Function
Private Sub Resize()
 With this.DisplayArea
 Dim rng As Range
 For Each rng In .Cells.Rows
 rng.RowHeight = this.DotPitch
 Next
 For Each rng In .Cells.Columns
 rng.ColumnWidth = this.DotPitch * 0.085
 Next
 .Interior.Color = this.BackColor
 End With
 this.PendingResize = False
End Sub
Private Sub RaiseInvalidArgument(proc As String, description As String)
 Err.Raise DriverErrors.ArgumentError, "CellDisplayDriver." & proc, description
End Sub

---

Test code

This isn't nearly as much fun without some test code, so I knocked together a super basic IDrawable...

'Sprite.cls
Option Explicit
Implements IDrawable
Private Type SpriteMembers
 Top As Long
 Left As Long
 Bitmap() As Long
End Type
Private this As SpriteMembers
Public Property Get Top() As Long
 Top = this.Top
End Property
Public Property Let Top(inValue As Long)
 this.Top = inValue
End Property
Public Property Get Left() As Long
 Left = this.Left
End Property
Public Property Let Left(inValue As Long)
 this.Left = inValue
End Property
Public Property Get Width() As Long
 Width = UBound(this.Bitmap, 2) + 1
End Property
Public Property Get Height() As Long
 Height = UBound(this.Bitmap, 1) + 1
End Property
Public Property Let Bitmap(colors() As Long)
 this.Bitmap = colors
End Property
Public Property Get Bitmap() As Long()
 Bitmap = this.Bitmap
End Property
Public Function GetPixel(pixelRow As Long, pixelColumn As Long) As Long
 GetPixel = this.Bitmap(pixelRow - 1, pixelColumn - 1)
End Function
Public Property Get IDrawable_Top() As Long
 IDrawable_Top = Top
End Property
Public Property Let IDrawable_Top(inValue As Long)
 Top = inValue
End Property
Public Property Get IDrawable_Left() As Long
 IDrawable_Left = Left
End Property
Public Property Let IDrawable_Left(inValue As Long)
 Left = inValue
End Property
Public Property Get IDrawable_Width() As Long
 IDrawable_Width = Width
End Property
Public Property Get IDrawable_Height() As Long
 IDrawable_Height = Height
End Property
Public Property Let IDrawable_BitMap(colors() As Long)
 Bitmap = colors
End Property
Public Property Get IDrawable_BitMap() As Long()
 IDrawable_BitMap = Bitmap
End Property
Public Function IDrawable_GetPixel(pixelRow As Long, pixelColumn As Long) As Long
 IDrawable_GetPixel = GetPixel(pixelRow, pixelColumn)
End Function

...and a test Sub that bounces a red square around:

Sub Test()
 Dim sheet As Worksheet
 Set sheet = ActiveWorkbook.Worksheets.Add
 sheet.Name = "Demo"
 Dim screen As CellDisplayDriver
 Set screen = CellDisplayDriver.Create(160, 100, 2, ActiveSheet.Cells(2, 2))
 Dim foo As Sprite
 Set foo = New Sprite
 Dim colors() As Long
 ReDim colors(9, 9)
 Dim r As Long
 Dim c As Long
 For r = 0 To 9
 For c = 0 To 9
 colors(r, c) = RGB(255, 0, 0)
 Next
 Next
 With foo
 .Top = 45
 .Left = 0
 .Bitmap = colors
 End With
 Dim down As Boolean
 Dim right As Boolean
 Dim frames As Long
 screen.AddDrawable foo
 Dim ending As Single
 ending = Timer + 30
 With foo
 Do
 If .Left = 0 Then right = True
 If .Left = 150 Then right = False
 If .Top = 0 Then down = True
 If .Top = 90 Then down = False
 If right Then
 .Left = .Left + 1
 Else
 .Left = .Left - 1
 End If
 If down Then
 .Top = .Top + 1
 Else
 .Top = .Top - 1
 End If
 screen.Refresh
 frames = frames + 1
 Loop While Timer < ending
 End With
 Application.DisplayAlerts = False
 sheet.Delete
 Application.DisplayAlerts = True
 Debug.Print "~" & Format$(frames / 30, "#.00") & " frames per second."
End Sub

---

Edit:

Sample "output" by popular request:

ScreenToGif sample

• Comintern: BTW, my VM with 2 i7 cores and 4 GB allocated averages about 30fps. I'm curious what other people's results are like.

Answer 1

First let me say that this is pure awesome, (削除) and I only have superficial improvements to suggest. (削除ここまで) nevermind, this grew bigger than I originally thought.... again.

There is no reason for any of the parameters (well, except the array one) you're passing any of the IDrawable interface members to be passed ByRef - and they're all passed by reference, implicitly.

Public Property Let Top(inValue As Long)
End Property
Public Property Let Left(inValue As Long)
End Property
Public Function GetPixel(pixelRow As Long, pixelColumn As Long) As Long
End Function

Could be:

Public Property Let Top(ByVal inValue As Long)
End Property
Public Property Let Left(ByVal inValue As Long)
End Property
Public Function GetPixel(ByVal pixelRow As Long, ByVal pixelColumn As Long) As Long
End Function

While we're at it, might as well make the colors() array explicitly passed ByRef:

Public Property Let Bitmap(ByRef colors() As Long)
End Property

In the Sprite class (I know, it's test/demo code), there's not really a need to expose any public members - in fact the only reason you do need them is because you've declared foo As Sprite:

Dim foo As Sprite
Set foo = New Sprite

But this would work just as well:

Dim foo As IDrawable
Set foo = New Sprite

Actually, I think the IDrawable interface should not expose Property Let members to mutate Top and Left values (but leave them on the concrete implementations... or don't - and give it a PredeclaredId and a Create function instead). It could expose some Move procedure instead of mutators:

Public Sub Move(ByVal x As Long, ByVal y As Long)
End Sub

That would change this client code:

If right Then
 .Left = .Left + 1
Else
 .Left = .Left - 1
End If
If down Then
 .Top = .Top + 1
Else
 .Top = .Top - 1
End If

Into that one-liner:

.Move IIf(right, 1, -1), IIf(down, 1, -1)

---

The Refresh method feels a bit cluttered, because it's responsible for drawing every pixel of every drawable object. You could have some DrawableObject with a PredeclaredId, and a "static" method where you could draw one single IDrawable object:

Public Sub Draw(ByRef drawable As IDrawable, ByRef screen As Range)
 Dim r As Long
 Dim c As Long
 Dim rowTarget As Long
 Dim colTarget As Long
 For r = 1 To drawable.Height
 rowTarget = r + drawable.Top
 If rowTarget >= 1 And rowTarget < this.Height Then
 For c = 1 To drawable.Width
 colTarget = c + drawable.Left
 If colTarget >= 1 And colTarget < this.Width Then
 screen.Cells(rowTarget, colTarget).Interior.Color = drawable.GetPixel(r, c)
 End If
 Next
 End If
 Next
End Sub

Then this:

With this.DisplayArea
 .Interior.Color = this.BackColor
 Dim drawable As Variant
 For Each drawable In this.Drawables.Keys
 Dim r As Long
 Dim c As Long
 Dim rowTarget As Long
 Dim colTarget As Long
 For r = 1 To drawable.Height
 rowTarget = r + drawable.Top
 If rowTarget >= 1 And rowTarget < this.Height Then
 For c = 1 To drawable.Width
 colTarget = c + drawable.Left
 If colTarget >= 1 And colTarget < this.Width Then
 .Cells(rowTarget, colTarget).Interior.Color = drawable.GetPixel(r, c)
 End If
 Next
 End If
 Next
 Next
End With

Becomes this:

With this.DisplayArea
 .Interior.Color = this.BackColor
 Dim drawable As Variant 'shame this can't be IDrawable.. right?
 For Each drawable In this.Drawables.Keys
 DrawableObject.Draw drawable, .Range 'might need to cast to IDrawable
 Next
End With

• Comintern: I like the DrawableObject idea - Refresh is bound to become even more cluttered if I ever implement Z-ordering, because it would need to sort them. I also like the idea of making Left and Top read-only in IDrawable - in c# I'd add an IMoveable interface that inherits from IDrawable, but even if IMovable_IDrawable_Top were possible in VBA, it would be a ugly sight to see... :sigh:
• Mathieu Guindon: My first idea was to add a Draw method to IDrawable, but then all implementations would have repeated themselves, so extracting a whole type made more sense.

Answer 2

Have you considered using Conditional Formats as your rendering cathode ray?

I've just thrown this together, so it's by no means complete or optimized, but by assigning sprite arrays of values to specific ranges, I avoid the need for any calls to the interior of a Range. This approach might also solve your Z-Order dilemma, as you can just write over the top, or you could even to blends!

It's fast. So fast I can't tell if it's even rendering on every frame, but I do see lots of movement. It runs about twice as fast if I omit the removal of the prior sprite location.

Theoretically, it's 1500 frames/sec with sprite erase on each frame, or 4000 frames/sec if I omit the sprite erase on each frame.

Set up the screen Apply 3 different conditional formats for values 1, 2 and 3

Sub InitScreen()
 Dim screen As Range
 Set screen = Range(Cells(1, 1), Cells(ScreenHeight, ScreenWidth))
 screen.EntireColumn.ColumnWidth = 0.15
 screen.EntireRow.RowHeight = 2
 screen.FormatConditions.Delete
 With screen.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=1")
 .SetFirstPriority
 .Interior.Color = RGB(192, 32, 32)
 End With
 With screen.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=2")
 .SetFirstPriority
 .Interior.Color = RGB(32, 192, 32)
 End With
 With screen.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=3")
 .SetFirstPriority
 .Interior.Color = RGB(32, 32, 192)
 End With
End Sub

Render the Frames Define a sprite of random numbers between 1 and 3, and a sprite the same size of all zeros.

Sub RenderFrames()
 Const FrameCount As Long = 1500
 Const SpriteHeight As Long = 3
 Const SpriteWidth As Long = 3
 Dim screen As Range
 Dim i As Long, j As Long, x As Long
 Dim sprite(1 To 3, 1 To 3)
 Dim spriteLocation As Range
 Dim start As Double
 Set screen = Range(Cells(1, 1), Cells(ScreenHeight, ScreenWidth))
 'Set up an sprite
 Dim eraserSprite(1 To 3, 1 To 3) As Long
 'Set up a random sprite
 For i = 1 To SpriteHeight
 For j = 1 To SpriteWidth
 sprite(i, j) = 1 + (Rnd * 17 Mod 3)
 Next j
 Next i
 start = Timer
 For x = 1 To FrameCount
 If Not spriteLocation Is Nothing Then
 spriteLocation.Value2 = eraserSprite
 End If
 Set spriteLocation = screen.Range(Cells(1 + x Mod 150, 1), Cells(4 + x Mod 150, 3))
 spriteLocation.Value2 = sprite
 Next x
 Debug.Print Timer - start, FrameCount / (Timer - start)
End Sub

• Comintern: Interesting. It would require a palette of possible colors to set the conditional formatting to though (if done without palette switching). Is there a limit to the number of conditional formats a cell can hold?
• ThunderFrame: I'm unsure of the maximum number of conditional formats, but if you're striving for the classic beauty of Tetris Duotone, you could perhaps use a conditional format that applies colors on a scale, based on the values, and set the color scale to gamma. ;-P