+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Works in Progress (https://staging.qb64phoenix.com/forumdisplay.php?fid=9)
+---- Thread: Ascii-tile editor (/showthread.php?tid=906)
Ascii-tile editor - James D Jarvis - 09-21-2022
This a modification of my earlier minimal text animator. I promise there will be a demo program that shows how to make use of the files produced with ascii graphics for video-game style tiles/sprites (not that it would be all that hard to write your own).
When you run the program you'll see a frame, that's where the tiles will be drawn. The default size is 8 by 8.
Click on the arrows to resize the tiles in the tileset; you'll get asked if you want to continue and then the program will gladly ignore all data you are clipping off if you reduce the size of the tiles in the tile set. Press "h" or "?" for help.
Currently set up for 256 tiles as the maximum but you can of course edit that.
There's some little bits from the previous program hanging about I haven't cleaned out yet btu it's functional.
Code: (Select All)
'ASCII tile maker
'by James D. Jarvis Sept 21,2022 v 0.1c
'
' a very minimal program to create a set of ascii tiles menat for use as sprites and backgrounds
'S - Save file
'L - load file
' can save files unencoded (encodingg 0), or tile channel endcoded (encoding 1)
' currently hardcoded to use encoding 1
'use mouse to draw
'? or H for help to see other commands
'
'nothing fancy here at all, just a minimal program that functions
'$dynamic
Screen _NewImage(80, 25, 0)
_Title "ASCII TileMaker"
Type gcelltype
t As String * 1
fgk As _Byte
bgk As _Byte
End Type
Dim Shared maxtx, maxty, maxtiles, pen$, fg_klr, bg_klr, pen_klr
Dim Shared tileX, tileY, smallerxx, smallerxy, smalleryy, smalleryx, largeryy, largeryx, largerxx, largerxy
Dim Shared showonion, tilerate, lasttile, tileno, tileshow, encoding, hightile
tileX = 8
tileY = 8
smalleryx = tileX + 3
smalleryy = 2
largeryx = tileX + 3
largeryy = tileY + 3
smallerxx = 1
smallerxy = tileY + 4
largerxx = tileX + 2
largerxy = tileY + 4
tilerate = 20
tileshow = -1
encoding = 1
maxtx = _Width
maxty = _Height
maxtiles = 256
pen$ = "*"
showonion = 0
hightile = 1
Print "ASCII TileMaker"
_ControlChr Off
Dim Shared gcell(maxtiles, maxtx, maxty) As gcelltype
For f = 1 To maxtiles
For y = 1 To _Height
For x = 1 To _Width
gcell(f, x, y).t = " "
gcell(f, x, y).fgk = 15
gcell(f, x, y).bgk = 0
Next x
Next y
Next f
tileno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
oflag = 0
Color fg_klr, bg_klr
'main program loop
drawtile tileno
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
_PrintString (1, 1), Str$(mx): _PrintString (12, 1), Str$(my)
If mx > 1 And my > 2 And my < tileY + 3 And mx < tileX + 3 Then
gcell(tileno, mx - 1, my - 2).t = pen$
gcell(tileno, mx - 1, my - 2).fgk = pen_klr
gcell(tileno, mx - 1, my - 2).bgk = bg_klr
Color pen_klr, gcell(tileno, mx - 1, my - 2).bgk
_PrintString (mx, my), gcell(tileno, mx - 1, my - 2).t
End If
tsize = 0
If mx = smalleryx And my = smalleryy Then
aak$ = ynbox$("Resize ALL Tiles?", mx, my)
If aak$ = "Y" Or aak$ = "y" Then
tileY = tileY - 1
If tileY < 2 Then tileY = 2
tsize = 1
End If
End If
If mx = largeryx And my = largeryy Then
aak$ = ynbox$("Resize ALL Tiles?", mx, my)
If aak$ = "Y" Or aak$ = "y" Then
tileY = tileY + 1
If tileY > 20 Then tileY = 20
tsize = 1
End If
End If
If mx = smallerxx And my = smallerxy Then
aak$ = ynbox$("Resize ALL Tiles?", mx, my)
If aak$ = "Y" Or aak$ = "y" Then
tileX = tileX - 1
If tileX < 2 Then tileX = 2
tsize = 1
End If
End If
If mx = largerxx And my = largerxy Then
aak$ = ynbox$("Resize ALL Tiles?", mx, my)
If aak$ = "Y" Or aak$ = "y" Then
tileX = tileX + 1
If tileX > 40 Then tileX = 40
tsize = 1
End If
End If
If aak$ = "N" Or aak$ = "n" Then drawtile tileno
If tsize = 1 Then
smalleryx = tileX + 3
smalleryy = 2
largeryx = tileX + 3
largeryy = tileY + 3
smallerxx = 1
smallerxy = tileY + 4
largerxx = tileX + 2
largerxy = tileY + 4
drawtile tileno
End If
Color 15, 0
End If
Loop
Select Case kk$
Case "n", "N"
Cls
tileno = tileno + 1
hightile = hightile + 1
If hightile > maxtiles Then hightile = maxtiles
' If showonion = 1 And tileno > 1 Then drawonion (tileno - 1)
drawtile tileno
Case "p", "P" 'play the animation
playanimation 1, lasttile
Case ",", "<" 'cycle down through drawn tiles
tileno = tileno - 1
If tileno < 1 Then tileno = hightile
drawtile tileno
Case ".", ">" 'cycle up through drawn tiles
tileno = tileno + 1
If tileno > hightile Then tileno = 1
Cls
drawtile tileno
Case "f", "F"
pen_klr = select_pencolor
Cls
drawtile tileno
Case "b", "B"
bg_klr = select_backgroundcolor
Cls
drawtile tileno
Case "S"
savefile
Cls
drawtile tileno
Case "L"
loadfile
Cls
playanimation 1, lasttile
tileno = 1
Case "h", "H", "?"
helpme
Cls
drawtile tileno
Case "r", "R"
tilerate = newrate
Cls
drawtile tileno
Case "c", "C"
pen$ = Chr$(newchar)
Cls
drawtile tileno
Case "v", "V" 'eyedropper that copies cell from previous tile in the same position.
If tileno > 1 Then eyedropper _MouseX, _MouseY
Case "z", "Z" 'zap a cell .... well erase it
zapcell _MouseX, _MouseY
Case "D" 'duplicate
duplicatetile tileno
tileno = tileno + 1
lasttile = tileno
Cls
drawtile tileno
Case "X"
newanimation
drawtile tileno
Case "1" 'show tilecount
tileshow = tileshow * -1
drawtile tileno
Case "T", "t"
inserttext _MouseX, _MouseY, pen_klr, bg_klr
End Select
kk$ = InKey$
If kk$ = "f" Then _PrintString (1, 1), Str$(tileno)
Loop Until kk$ = Chr$(27)
Sub drawtile (f As Integer)
Cls
For y = 1 To tileY
For x = 1 To tileX
If gcell(f, x, y).t <> " " Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x + 1, y + 2), gcell(f, x, y).t
End If
Next
Next
Color 15, 0
If tileshow = 1 Then
_PrintString (_Width - 4, 1), Str$(tileno)
End If
tbar$ = String$(tileX + 2, Asc("+"))
_PrintString (1, 2), tbar$ + Chr$(30)
For y = 1 To tileY
_PrintString (1, y + 2), "+"
_PrintString (2 + tileX, y + 2), "+"
Next
_PrintString (1, 3 + tileY), tbar$ + Chr$(31)
tbar$ = Chr$(17) + String$(tileX, " ") + Chr$(16)
_PrintString (1, 4 + tileY), tbar$
End Sub
Sub drawonion (f As Integer)
'i don't work and it makes no sense that I'm here in this program
'noted for delete
For y = 1 To _Height
For x = 1 To _Width
Color 24, 0
_PrintString (x, y), gcell(f, x, y).t
Next
Next
Color 15, 0
End Sub
Sub eyedropper (cx, cy)
gcell(tileno, cx, cy).t = gcell(tileno - 1, cx, cy).t
gcell(tileno, cx, cy).fgk = gcell(tileno - 1, cx, cy).fgk
gcell(tileno, cx, cy).bgk = gcell(tileno - 1, cx, cy).bgk
Color gcell(tileno, cx, cy).fgk, gcell(tileno, cx, cy).bgk
_PrintString (cx, cy), gcell(tileno, cx, cy).t
End Sub
Sub duplicatetile (fr)
For cy = 1 To _Height
For cx = 1 To _Width
gcell(fr + 1, cx, cy).t = gcell(fr, cx, cy).t
gcell(fr + 1, cx, cy).fgk = gcell(fr, cx, cy).fgk
gcell(fr + 1, cx, cy).bgk = gcell(fr, cx, cy).bgk
Next cx
Next cy
End Sub
Sub inserttext (cx, cy, fk, bk)
Cls
Print "Enter Text You Wish to Insert"
Input txt$
Cls
For tp = 1 To Len(txt$)
If (cx - 1 + tp) <= _Width Then
gcell(tileno, cx - 1 + tp, cy).t = Mid$(txt$, tp, 1)
gcell(tileno, cx - 1 + tp, cy).fgk = fk
gcell(tileno, cx - 1 + tp, cy).bgk = bk
End If
Next
drawtile tileno
End Sub
Sub newanimation
Cls
Print "Erase Animation and Start New One?"
Print " Y or N "
nflag = 0
Do
k$ = Input$(1)
Select Case k$
Case "Y", "y"
ask$ = "Y"
nflag = 1
Case "N", "n"
ask$ = "N"
nflag = 1
End Select
Loop Until nflag = 1
If ask$ = "Y" Then
ReDim gcell(maxtiles, maxtx, maxty) As gcelltype
For f = 1 To maxtiles
For y = 1 To _Height
For x = 1 To _Width
gcell(f, x, y).t = " "
gcell(f, x, y).fgk = 15
gcell(f, x, y).bgk = 0
Next x
Next y
Next f
tileno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
oflag = 0
Color fg_klr, bg_klr
End If
End Sub
Sub zapcell (cx, cy)
gcell(tileno, cx, cy).t = " "
gcell(tileno, cx, cy).fgk = 0
gcell(tileno, cx, cy).bgk = 0
Color gcell(tileno, cx, cy).fgk, gcell(tileno, cx, cy).bgk
_PrintString (cx, cy), gcell(tileno, cx, cy).t
End Sub
Sub playanimation (ff, lf)
For f = ff To lf
Cls
_Limit tilerate
For y = 1 To _Height
For x = 1 To _Width
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Next
Next
_Display
Next f
_AutoDisplay
Color 15, 0
End Sub
Function select_pencolor
Cls
Color 15, 0
Print "SELECT PEN COLOR"
Print
Print " 0.",: Color 0, 0: Print Chr$(219),: Color 15, 0: Print "16.",: Color 16, 0: Print Chr$(219): Color 15, 0
Print " 1.",: Color 1, 0: Print Chr$(219),: Color 15, 0: Print "17.",: Color 17, 0: Print Chr$(219): Color 15, 0
Print " 2.",: Color 2, 0: Print Chr$(219),: Color 15, 0: Print "18.",: Color 18, 0: Print Chr$(219): Color 15, 0
Print " 3.",: Color 3, 0: Print Chr$(219),: Color 15, 0: Print "19.",: Color 19, 0: Print Chr$(219): Color 15, 0
Print " 4.",: Color 4, 0: Print Chr$(219),: Color 15, 0: Print "20.",: Color 20, 0: Print Chr$(219): Color 15, 0
Print " 5.",: Color 5, 0: Print Chr$(219),: Color 15, 0: Print "21.",: Color 21, 0: Print Chr$(219): Color 15, 0
Print " 6.",: Color 6, 0: Print Chr$(219),: Color 15, 0: Print "22.",: Color 22, 0: Print Chr$(219): Color 15, 0
Print " 7.",: Color 7, 0: Print Chr$(219),: Color 15, 0: Print "23.",: Color 23, 0: Print Chr$(219): Color 15, 0
Print " 8.",: Color 8, 0: Print Chr$(219),: Color 15, 0: Print "24.",: Color 24, 0: Print Chr$(219): Color 15, 0
Print " 9.",: Color 9, 0: Print Chr$(219),: Color 15, 0: Print "25.",: Color 25, 0: Print Chr$(219): Color 15, 0
Print "10.",: Color 10, 0: Print Chr$(219),: Color 15, 0: Print "26.",: Color 26, 0: Print Chr$(219): Color 15, 0
Print "11.",: Color 11, 0: Print Chr$(219),: Color 15, 0: Print "27.",: Color 27, 0: Print Chr$(219): Color 15, 0
Print "12.",: Color 12, 0: Print Chr$(219),: Color 15, 0: Print "28.",: Color 28, 0: Print Chr$(219): Color 15, 0
Print "13.",: Color 13, 0: Print Chr$(219),: Color 15, 0: Print "29.",: Color 29, 0: Print Chr$(219): Color 15, 0
Print "14.",: Color 14, 0: Print Chr$(219),: Color 15, 0: Print "30.",: Color 30, 0: Print Chr$(219): Color 15, 0
Print "15.",: Color 15, 0: Print Chr$(219),: Color 15, 0: Print "31.",: Color 31, 0: Print Chr$(219): Color 15, 0
Do
Locate 20, 3: Input "enter color from 0 to 31 ", kk$
Loop Until Val(kk$) > -1 Or Val(kk$) < 32
select_pencolor = Val(kk$)
End Function
Function newrate
Cls
Print "Change tile Rate ?"
Print
Print "Current tile rate is "; tilerate
Print
Do
Locate 20, 3: Input "enter rate from 1 to 60 ", kk$
Loop Until Val(kk$) > 0 Or Val(kk$) < 61
newrate = Val(kk$)
End Function
Function ynbox$ (msg$, mx, my)
tx = mx: ty = my
lr = Len(msg$) + 4
If tx + lr > _Width Then tx = _Width - (lr + 5)
If ty + 4 > _Height Then ty = _Height + 5
_PrintString (tx, ty), String$(lr, Asc("*"))
_PrintString (tx, ty + 1), "* " + msg$ + " *"
_PrintString (tx, ty + 2), "*" + String$(lr - 2, Asc(".")) + "*"
_PrintString (tx + lr / 2 - 4, ty + 2), " Y or N "
_PrintString (tx, ty + 3), String$(lr, Asc("*"))
Do
ak$ = Input$(1)
Loop Until UCase$(ak$) = "Y" Or UCase$(ak$) = "N"
ynbox$ = ak$
End Function
Function select_backgroundcolor
Cls
Color 15, 0
Print "SELECT Background COLOR"
Print
Print " 0.",: Color 0, 0: Print Chr$(219),: Color 15, 0
Print " 1.",: Color 1, 0: Print Chr$(219): Color 15, 0
Print " 2.",: Color 2, 0: Print Chr$(219),: Color 15, 0
Print " 3.",: Color 3, 0: Print Chr$(219): Color 15, 0
Print " 4.",: Color 4, 0: Print Chr$(219),: Color 15, 0
Print " 5.",: Color 5, 0: Print Chr$(219): Color 15, 0
Print " 6.",: Color 6, 0: Print Chr$(219),: Color 15, 0
Print " 7.",: Color 7, 0: Print Chr$(219): Color 15, 0
Print " 8.",: Color 8, 0: Print Chr$(219),: Color 15, 0
Print " 9.",: Color 9, 0: Print Chr$(219): Color 15, 0
Print "10.",: Color 10, 0: Print Chr$(219),: Color 15, 0
Print "11.",: Color 11, 0: Print Chr$(219): Color 15, 0
Print "12.",: Color 12, 0: Print Chr$(219),: Color 15, 0
Print "13.",: Color 13, 0: Print Chr$(219): Color 15, 0
Print "14.",: Color 14, 0: Print Chr$(219),: Color 15, 0
Print "15.",: Color 15, 0: Print Chr$(219): Color 15, 0
Do
Locate 20, 1: Input "enter color from 0 to 31", kk$
Loop Until Val(kk$) > -1 Or Val(kk$) < 32
select_backgroundcolor = Val(kk$)
End Function
Sub helpme
Cls
Print "HELP"
Print
Print "S - Save file "
Print "L - load file "
Print "use mosue to draw, click on arrows to resize the tileset (be careful)"
Print "N,n - create a new tile (limited to 200 as coded but you can edit that if you wish"
Print "P,p - play tiles as animation"
Print "C,c - change pen foreground color , you'll have to enter color number afterward"
Print "B,b - change pen background color, you'll have to enter color number afterward"
Print "R,r - change tile rate for animation playback.....not all that important relly"
Print "V,v - eyedropper, copies cell from previous tile"
Print "Z,z - zap the cell, erase it by setting it to a space with a foreground and background of zero"
Print "T,t - insert text string, will be prompeted for text to insert"
Print "D - Duplicate tile, be careful this will replace the next tile"
Print "X - Delete tiles, prompted to verify delete"
Print "1 - show current tile in top right corner, will not be recodeed"
Print "esc - to quit program.... be careful this just dumps you out and you'll lose any work currently"
Print
Print "Press any key to continue"
any$ = Input$(1)
End Sub
Function newchar
Dim mc(0 To 256, 2)
Cls
x = 0
y = 3
newc = -1
Print "Click on the Character you wish to use."
For c = 0 To 255
x = x + 2
If x > 60 Then
x = 2
y = y + 2
End If
_PrintString (x, y), Chr$(c)
mc(c, 1) = x
mc(c, 2) = y
Next c
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
c = 0
Do
If mc(c, 1) = mx And mc(c, 2) = my Then newc = c
c = c + 1
If c = 256 Then newc = -2
Loop Until newc <> -1
If newc = -2 Then newc = -1
End If
Color 15, 0
Loop
Loop Until newc <> -1
newchar = newc
End Function
Sub savefile
Locate 1, 1
Print "Enter file name "
Locate 2, 1
Input filename$
Open filename$ For Output As #1
Write #1, tilerate, tileX, tileY, hightile, encoding
'encoding = 0
If encoding = 0 Then
For f = 1 To hightile
For y = 1 To tileY
For x = 1 To tileX
Write #1, gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk,
Print gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk,
Next x
Next y
Next f
End If
If encoding = 1 Then
For f = 1 To hightile
ttile$ = ""
ftile$ = ""
btile$ = ""
For y = 1 To tileY
For x = 1 To tileX
ttile$ = ttile$ + gcell(f, x, y).t
ftile$ = ftile$ + Chr$(gcell(f, x, y).fgk)
btile$ = btile$ + Chr$(gcell(f, x, y).bgk)
Next x
Next y
Write #1, ttile$
Write #1, ftile$
Write #1, btile$
Next f
End If
Close #1
Locate 3, 1
Print filename$; " saved"
Print "press any key to continue"
any$ = Input$(1)
End Sub
Sub loadfile
Locate 1, 1
Print "Enter file name "
Locate 2, 1
Input filename$
Open filename$ For Input As #1
Input #1, tilerate, tileX, tileY, hightile, encoding
'encoding = 1
If encoding = 0 Then 'no encoding just read each cell
For f = 1 To hightile
For y = 1 To tileY
For x = 1 To tileX
Input #1, gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Print gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Next x
Next y
Next f
End If
If encoding = 1 Then 'discrete run length encoding
'each tile breaks the data down into a channel for the the charcter, a channel for foreground and a channel for background
' encoding is limited to line by line
For f = 1 To hightile
Input #1, ttile$
Input #1, ftile$
Input #1, btile$
For y = 1 To tileY
For x = 1 To tileX
gcell(f, x, y).t = Mid$(ttile$, (y - 1) * tileY + x, 1)
gcell(f, x, y).fgk = Asc(Mid$(ftile$, (y - 1) * tileY + x, 1))
gcell(f, x, y).bgk = Asc(Mid$(btile$, (y - 1) * tileY + x, 1))
Next x
Next y
Next f
End If
Close #1
Locate 3, 1
Print filename$; " loaded"
Print "press any key to continue"
any$ = Input$(1)
End Sub