06-24-2025, 06:18 PM
A far from complete map maker. It reads an image and extracts unique tiles. I've been testing it with maps from https://github.com/Josef-Friedrich/turri...collection
Code: (Select All)
' Map Maker
'
' Version 0.4
'
' Scan an image file of a game map to extract unique tiles.
'
' Written by Dave Mayes (ukdave74)
' Requirements
' Complete - Load image file to scan
' Complete - Scan Image and find unique tiles
' Complete - Map tiles to array
' complete - Tile Viewer
' - Adjust Grid size
' - Save PNG with Meta, Tiles and Map
' - GUI
'
' Nice features
' - Map editor
' - Pixel fonts
'int memcmp(const void *str1, const void *str2, size_t n)
Declare CustomType Library
Function memcmp% (ByVal s1%&, ByVal s2%&, ByVal n As _Offset)
End Declare
' Type data for global varibles
Type tProps
SHandle As Long ' Screen Handle
IHandle As Long ' Image handle
IWidth As Integer ' Image width
IHeight As Integer ' Image height
TWidth As Integer ' Tile width
THeight As Integer ' Tile height
MapCol As Integer ' Map columns
MapRow As Integer ' Map rows
Status As Integer ' Status flag
TTile As Integer ' Total Tiles
UTile As Integer ' Unique Tiles
ScanX As Integer ' Scan Row
ScanY As Integer ' Scan Column
End Type
' Type data for tiles array
Type tTile
ImgHan As Long
Count As Integer
Solid As Integer
End Type
' Type data for map array
Type tGrid
TileID As Integer
End Type
Dim Shared Props As tProps
Dim Shared Tiles(500 ) As tTile
Init
Do Until Props.Status < 0
KB = _KeyHit
If KB = 27 Then Props.Status = -1
Select Case Props.Status
Case 0
GetImage
If Props.Status = 1 Then ReDim Shared Grid(Props.MapCol - 1, Props.MapRow - 1) As tGrid
Case 1
FindUnique
Props.Status = 2
Case 2
DrawMap
Props.Status = 3
Case 3
DrawTiles
Props.Status = 4
End Select
Loop
End
' Image compare function from QB64PR forum
Function CompareImages (handle1 As Long, handle2 As Long)
Static ImgCmp(1) As _MEM
ImgCmp(0 ) = _MemImage(handle1)
ImgCmp(1) = _MemImage(handle2)
If ImgCmp(0 ).SIZE <> ImgCmp(1).SIZE Then Exit Function 'not identical
If ImgCmp(0 ).ELEMENTSIZE <> ImgCmp(1).ELEMENTSIZE Then Exit Function 'not identical
If memcmp(ImgCmp(0 ).OFFSET, ImgCmp(1).OFFSET, ImgCmp(0 ).SIZE) = 0 Then x = -1 Else x = 0
CompareImages = x
End Function
' Initialize defaults
Sub Init ()
Props.SHandle = _NewImage(_DesktopWidth - 128, _DesktopHeight - 256, 32)
Screen Props.SHandle
_Title "Map Maker"
_Delay 1
_ScreenMove _Middle
Props.TWidth = 32
Props.THeight = 32
End Sub
' Select image file
Sub GetImage ()
FileName$ = _OpenFileDialog$("Select Image to scan", "", "*.png|*.jpg|*.bmp", "Image Files", 0 )
If FileName$ > "" Then
Props.IHandle = _LoadImage(FileName$)
If Props.IHandle < 0 Then
_PutImage (0, 100 ), Props.IHandle
Props.Status = 1
ImageStats
DrawGrid
Else
Props.Status = -1
End If
End If
End Sub
' Overlay Grid
Sub DrawGrid ()
DefInt X, Y
_Dest Props.SHandle
For X = 0 To Props.IWidth Step Props.TWidth
Line (X, 100 )-(X, 100 + Props.IHeight), _RGBA(200, 200, 200, 128)
Next X
For y = 0 To Props.IHeight Step Props.THeight
Line (0, 100 + y)-(Props.IWidth, 100 + y), _RGBA(200, 200, 200, 128)
Next y
_Display
' delay 1
End Sub
'Display Status Data
Sub ImageStats ()
Props.IWidth = _Width(Props.IHandle)
Props.IHeight = _Height(Props.IHandle)
Props.MapCol = Props.IWidth / Props.TWidth
Props.MapRow = Props.IHeight / Props.THeight
Props.TTile = Props.MapCol * Props.MapRow
Locate 1, 1
Print "Image Dimentions :"; Str$(Props.IWidth); " *"; Str$(Props.IHeight)
Print "Tile Dimentions :"; Str$(Props.TWidth); " *"; Str$(Props.THeight)
Print "Columns and Rows :"; Str$(Props.MapCol); " *"; Str$(Props.MapRow)
Print "Total Tiles :"; Str$(Props.TTile)
Print "Unique Tiles :"; Str$(Props.UTile)
End Sub
' Find unique Tiles
Sub FindUnique ()
DefInt C, T
Props.UTile = 1
Grid(0, 0 ).TileID = 1
C = 1
Tiles(1).ImgHan = _NewImage(Props.TWidth, Props.THeight, 32)
Tiles(2).ImgHan = _NewImage(Props.TWidth, Props.THeight, 32)
For Props.ScanY = 0 To Props.MapRow - 1
TR = Props.ScanY * Props.THeight
For Props.ScanX = 0 To Props.MapCol - 1
TC = Props.ScanX * Props.THeight
_PutImage (0, 0 ), Props.IHandle, Tiles(C).ImgHan, (TC, TR)-Step(Props.TWidth - 1, Props.THeight - 1)
Line (TC, TR + 100 )-Step(Props.TWidth - 1, Props.THeight - 1), _RGBA(0, 0, 0, 255), BF
If C > 1 Then
C = Compare(C)
Else
C = 2
End If
Next Props.ScanX
ImageStats
_Display
Next Props.ScanY
Props.ScanX = Props.ScanX - 1
Props.ScanY = Props.ScanY - 1
If Props.UTile < Compare(C) Then Props.UTile = C
_Title "Scan Complete" + Str$(C)
ImageStats
_Display
' delay 1
Props.Status = 2
End Sub
Function Compare (N)
DefInt I, T
TileNo = 0
For I = 1 To N - 1
If CompareImages(Tiles(N).ImgHan, Tiles(I).ImgHan) Then
TileNo = I
Grid(Props.ScanX, Props.ScanY).TileID = TileNo
End If
Next I
If TileNo = 0 Then
Grid(Props.ScanX, Props.ScanY).TileID = N
Props.UTile = Props.UTile + 1
N = N + 1
Tiles(N).ImgHan = _NewImage(Props.TWidth, Props.THeight, 32)
End If
Compare = N
End Function
Sub DrawMap
_Dest Props.SHandle
Cls
For TY = 0 To Props.MapRow - 1
For TX = 0 To Props.MapCol - 1
_PutImage (TX * Props.TWidth, TY * Props.THeight), Tiles(Grid(TX, TY).TileID).ImgHan
Next TX
Next TY
ImageStats
_Display
' delay 1
End Sub
Sub DrawTiles ()
_Title "Draw Tiles"
Cls
Dim J As Integer, T As Single, X As Integer, Y As Integer
T = Sqr(Props.UTile)
If T > Int(T) Then T = Int(T) + 1
T = T * 2
For J = 1 To Props.UTile
Y = J \ T
X = J Mod T
_PutImage (X * Props.TWidth, Y * Props.THeight), Tiles(J).ImgHan
Next J
_Display
' delay 1
End Sub