+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Works in Progress (https://qb64phoenix.com/forum/forumdisplay.php?fid=9)
+---- Thread: Minimal Text Animator (/showthread.php?tid=893)
Minimal Text Animator - James D Jarvis - 09-15-2022
Minimal Text Animator is exactly what this is. This is a very simple program to create and playback animations in 80x25 text mode.
It's simply structured with a main input loop, functions and subroutines are called from that loop. I want beginners to be able to look at this and modify it for their own needs. Currently there isn't much in the way of comments and there's a couple other commands I want to add but it certainly is a Minimal Text Animator right now.
Currently the user can Save and Load files, change the pen foreground and background color, change the character being drawn, and change the framerate. It's currently limited to 200 frames but that can easily be modified (just keep memory use and file size in mind).
Code: (Select All)
'Minimal Text Animator
'by James D. Jarvis Sept 15,2022 v 0.1
'
' a very minimal program to create and playback simple text screen animations
'S - Save file
'L - load file
'use mosue to draw
'N,n - create a new frame (limited to 200 as coded but you can edit that if you wish
'P,p - play animation
'F,f - change pen foreground color , you'll have to enter color number afterward
'B,b - change pen background color, you'll have to enter color number afterward
'esc - to quit program.... be careful this just dumps you out and you'll lose any work currently
'
'nothing fancy here at all, just a minimal program that functions
Screen _NewImage(80, 25, 0)
_Title "Minimal Text Animator"
Type gcelltype
t As String * 1
fgk As _Byte
bgk As _Byte
End Type
Dim Shared maxtx, maxty, maxframes, pen$, fg_klr, bg_klr, pen_klr
Dim Shared showonion, framerate, lastframe
framerate = 20
maxtx = _Width
maxty = _Height
maxframes = 200
pen$ = "*"
showonion = 0
Print "Minimal Text Animator"
_ControlChr Off
Dim Shared gcell(maxframes, maxtx, maxty) As gcelltype
For f = 1 To maxframes
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
frameno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
Color fg_klr, bg_klr
'main program loop
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
gcell(frameno, mx, my).t = pen$
gcell(frameno, mx, my).fgk = pen_klr
gcell(frameno, mx, my).bgk = bg_klr
Color pen_klr, gcell(frameno, mx, my).bgk
_PrintString (mx, my), gcell(frameno, mx, my).t
End If
Color 15, 0
Loop
Select Case kk$
Case "n", "N"
Cls
frameno = frameno + 1
If frameno > maxframes Then frameno = 1
If showonion = 1 And frameno > 1 Then drawonion (frameno - 1)
drawframe frameno
lastframe = frameno
Case "o", "O"
If showonion = 0 Then
Cls
showonion = 1
drawonion (frameno - 1)
drawframe frameno
Else
showonion = 0
End If
Case "p", "P" 'play the animation
playanimation 1, lastframe
Case ",", "<" 'cycle down through drawn frames
frameno = frameno - 1
If frameno < 1 Then frameno = lastframe
drawframe frameno
Case ".", ">" 'cycle up through drawn frames
frameno = frameno + 1
If frameno > lastframe Then frameno = 1
Cls
drawframe frameno
Case "f", "F"
pen_klr = select_pencolor
Cls
drawframe frameno
Case "b", "B"
bg_klr = select_backgroundcolor
Cls
drawframe frameno
Case "S"
savefile
Cls
drawframe frameno
Case "L"
loadfile
Cls
playanimation 1, lastframe
frameno = 1
Case "h", "H", "?"
helpme
Cls
drawframe frameno
Case "r", "R"
framerate = newrate
Cls
drawframe frameno
Case "c", "C"
pen$ = Chr$(newchar)
Cls
drawframe frameno
End Select
kk$ = InKey$
If kk$ = "f" Then _PrintString (1, 1), Str$(frameno)
Loop Until kk$ = Chr$(27)
Sub drawframe (f As Integer)
For y = 1 To _Height
For x = 1 To _Width
If onion = 0 Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Else
If gcell(f, x, y).t <> " " Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
End If
End If
Next
Next
Color 15, 0
End Sub
Sub drawonion (f As Integer)
For y = 1 To _Height
For x = 1 To _Width
Color 8, 0
_PrintString (x, y), gcell(f, x, y).t
Next
Next
Color 15, 0
End Sub
Sub playanimation (ff, lf)
For f = ff To lf
Cls
_Limit framerate
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 Frame Rate ?"
Print
Print "Current frame rate is "; framerate
Print
Do
Locate 20, 3: Input "enter color from 1 to 60 ", kk$
Loop Until Val(kk$) > 0 Or Val(kk$) < 61
newrate = Val(kk$)
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"
Print "N,n - create a new frame (limited to 200 as coded but you can edit that if you wish"
Print "P,p - play 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 framerate for animation"
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, framerate, maxtx, maxty, lastframe
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
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
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, framerate, maxtx, maxty, lastframe
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
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
Close #1
Locate 3, 1
Print filename$; " loaded"
Print "press any key to continue"
any$ = Input$(1)
End SubRE: Minimal Text Animator - James D Jarvis - 09-15-2022
I couldn't stop myself and added an eyedropper "v" to copy a cell from the previous frame and an eraser "z" that zaps a cell right after I finished dinner.
Code: (Select All)
'Minimal Text Animator
'by James D. Jarvis Sept 15,2022 v 0.2d
'
' a very minimal program to create and playback simple text screen animations
'S - Save file
'L - load file
'use mosue to draw
'? for help to see other commands
'
'nothing fancy here at all, just a minimal program that functions
Screen _NewImage(80, 25, 0)
_Title "Minimal Text Animator"
Type gcelltype
t As String * 1
fgk As _Byte
bgk As _Byte
End Type
Dim Shared maxtx, maxty, maxframes, pen$, fg_klr, bg_klr, pen_klr
Dim Shared showonion, framerate, lastframe, frameno
framerate = 20
maxtx = _Width
maxty = _Height
maxframes = 200
pen$ = "*"
showonion = 0
Print "Minimal Text Animator"
_ControlChr Off
Dim Shared gcell(maxframes, maxtx, maxty) As gcelltype
For f = 1 To maxframes
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
frameno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
oflag = 0
Color fg_klr, bg_klr
'main program loop
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
gcell(frameno, mx, my).t = pen$
gcell(frameno, mx, my).fgk = pen_klr
gcell(frameno, mx, my).bgk = bg_klr
Color pen_klr, gcell(frameno, mx, my).bgk
_PrintString (mx, my), gcell(frameno, mx, my).t
End If
Color 15, 0
Loop
Select Case kk$
Case "n", "N"
Cls
frameno = frameno + 1
If frameno > maxframes Then frameno = 1
If showonion = 1 And frameno > 1 Then drawonion (frameno - 1)
drawframe frameno
lastframe = frameno
Case "o", "O"
If showonion = 0 And oflag = 0 Then
Cls
showonion = 1
drawonion (frameno - 1)
drawframe frameno
oflag = 1
Else
showonion = 0
oflag = 0
drawframe frameno
End If
Case "p", "P" 'play the animation
playanimation 1, lastframe
Case ",", "<" 'cycle down through drawn frames
frameno = frameno - 1
If frameno < 1 Then frameno = lastframe
drawframe frameno
Case ".", ">" 'cycle up through drawn frames
frameno = frameno + 1
If frameno > lastframe Then frameno = 1
Cls
drawframe frameno
Case "f", "F"
pen_klr = select_pencolor
Cls
drawframe frameno
Case "b", "B"
bg_klr = select_backgroundcolor
Cls
drawframe frameno
Case "S"
savefile
Cls
drawframe frameno
Case "L"
loadfile
Cls
playanimation 1, lastframe
frameno = 1
Case "h", "H", "?"
helpme
Cls
drawframe frameno
Case "r", "R"
framerate = newrate
Cls
drawframe frameno
Case "c", "C"
pen$ = Chr$(newchar)
Cls
drawframe frameno
Case "v", "V" 'eyedropper that copies cell from previous frame in the same position.
If frameno > 1 Then eyedropper _MouseX, _MouseY
Case "z", "Z" 'zap a cell .... well erase it
zapcell _MouseX, _MouseY
End Select
kk$ = InKey$
If kk$ = "f" Then _PrintString (1, 1), Str$(frameno)
Loop Until kk$ = Chr$(27)
Sub drawframe (f As Integer)
For y = 1 To _Height
For x = 1 To _Width
If onion = 0 Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Else
If gcell(f, x, y).t <> " " Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
End If
End If
Next
Next
Color 15, 0
End Sub
Sub drawonion (f As Integer)
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(frameno, cx, cy).t = gcell(frameno - 1, cx, cy).t
gcell(frameno, cx, cy).fgk = gcell(frameno - 1, cx, cy).fgk
gcell(frameno, cx, cy).bgk = gcell(frameno - 1, cx, cy).bgk
Color gcell(frameno, cx, cy).fgk, gcell(frameno, cx, cy).bgk
_PrintString (cx, cy), gcell(frameno, cx, cy).t
End Sub
Sub zapcell (cx, cy)
gcell(frameno, cx, cy).t = " "
gcell(frameno, cx, cy).fgk = 0
gcell(frameno, cx, cy).bgk = 0
Color gcell(frameno, cx, cy).fgk, gcell(frameno, cx, cy).bgk
_PrintString (cx, cy), gcell(frameno, cx, cy).t
End Sub
Sub playanimation (ff, lf)
For f = ff To lf
Cls
_Limit framerate
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 Frame Rate ?"
Print
Print "Current frame rate is "; framerate
Print
Do
Locate 20, 3: Input "enter color from 1 to 60 ", kk$
Loop Until Val(kk$) > 0 Or Val(kk$) < 61
newrate = Val(kk$)
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"
Print "N,n - create a new frame (limited to 200 as coded but you can edit that if you wish"
Print "P,p - play 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 framerate for animation"
Print "V,v - eyedropper, copies cell from previous frame"
Print "Z,z - zap the cell, erase it by settinhg it ot a space with a foreground and background of zero"
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, framerate, maxtx, maxty, lastframe
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
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
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, framerate, maxtx, maxty, lastframe
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
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
Close #1
Locate 3, 1
Print filename$; " loaded"
Print "press any key to continue"
any$ = Input$(1)
End SubRE: Minimal Text Animator - James D Jarvis - 09-16-2022
Added additional commands. Can now Duplicate a whole frame into the next frame, erase an animation and start a new one (without having to restart the program), show the frame number, and insert a text string.
I'm, working on encoding options but that's not posted yet, might get one posted tomorrow.
Code: (Select All)
'Minimal Text Animator
'by James D. Jarvis Sept 15,2022 v 0.2f
'
' a very minimal program to create and playback simple text screen animations
'S - Save file
'L - load file
'use mosue 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 "Minimal Text Animator"
Type gcelltype
t As String * 1
fgk As _Byte
bgk As _Byte
End Type
Dim Shared maxtx, maxty, maxframes, pen$, fg_klr, bg_klr, pen_klr
Dim Shared showonion, framerate, lastframe, frameno, frameshow
framerate = 20
frameshow = -1
maxtx = _Width
maxty = _Height
maxframes = 200
pen$ = "*"
showonion = 0
Print "Minimal Text Animator"
_ControlChr Off
Dim Shared gcell(maxframes, maxtx, maxty) As gcelltype
For f = 1 To maxframes
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
frameno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
oflag = 0
Color fg_klr, bg_klr
'main program loop
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
gcell(frameno, mx, my).t = pen$
gcell(frameno, mx, my).fgk = pen_klr
gcell(frameno, mx, my).bgk = bg_klr
Color pen_klr, gcell(frameno, mx, my).bgk
_PrintString (mx, my), gcell(frameno, mx, my).t
End If
Color 15, 0
Loop
Select Case kk$
Case "n", "N"
Cls
frameno = frameno + 1
If frameno > maxframes Then frameno = 1
If showonion = 1 And frameno > 1 Then drawonion (frameno - 1)
drawframe frameno
lastframe = frameno
Case "o", "O"
If showonion = 0 And oflag = 0 Then
Cls
showonion = 1
drawonion (frameno - 1)
drawframe frameno
oflag = 1
Else
showonion = 0
oflag = 0
drawframe frameno
End If
Case "p", "P" 'play the animation
playanimation 1, lastframe
Case ",", "<" 'cycle down through drawn frames
frameno = frameno - 1
If frameno < 1 Then frameno = lastframe
drawframe frameno
Case ".", ">" 'cycle up through drawn frames
frameno = frameno + 1
If frameno > lastframe Then frameno = 1
Cls
drawframe frameno
Case "f", "F"
pen_klr = select_pencolor
Cls
drawframe frameno
Case "b", "B"
bg_klr = select_backgroundcolor
Cls
drawframe frameno
Case "S"
savefile
Cls
drawframe frameno
Case "L"
loadfile
Cls
playanimation 1, lastframe
frameno = 1
Case "h", "H", "?"
helpme
Cls
drawframe frameno
Case "r", "R"
framerate = newrate
Cls
drawframe frameno
Case "c", "C"
pen$ = Chr$(newchar)
Cls
drawframe frameno
Case "v", "V" 'eyedropper that copies cell from previous frame in the same position.
If frameno > 1 Then eyedropper _MouseX, _MouseY
Case "z", "Z" 'zap a cell .... well erase it
zapcell _MouseX, _MouseY
Case "D" 'duplicate
duplicateframe frameno
frameno = frameno + 1
lastframe = frameno
Cls
drawframe frameno
Case "X"
newanimation
drawframe frameno
Case "1" 'show framecount
frameshow = frameshow * -1
drawframe frameno
Case "T", "t"
inserttext _MouseX, _MouseY, pen_klr, bg_klr
End Select
kk$ = InKey$
If kk$ = "f" Then _PrintString (1, 1), Str$(frameno)
Loop Until kk$ = Chr$(27)
Sub drawframe (f As Integer)
For y = 1 To _Height
For x = 1 To _Width
If onion = 0 Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Else
If gcell(f, x, y).t <> " " Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
End If
End If
Next
Next
Color 15, 0
If frameshow = 1 Then
_PrintString (_Width - 4, 1), Str$(frameno)
End If
End Sub
Sub drawonion (f As Integer)
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(frameno, cx, cy).t = gcell(frameno - 1, cx, cy).t
gcell(frameno, cx, cy).fgk = gcell(frameno - 1, cx, cy).fgk
gcell(frameno, cx, cy).bgk = gcell(frameno - 1, cx, cy).bgk
Color gcell(frameno, cx, cy).fgk, gcell(frameno, cx, cy).bgk
_PrintString (cx, cy), gcell(frameno, cx, cy).t
End Sub
Sub duplicateframe (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(frameno, cx - 1 + tp, cy).t = Mid$(txt$, tp, 1)
gcell(frameno, cx - 1 + tp, cy).fgk = fk
gcell(frameno, cx - 1 + tp, cy).bgk = bk
End If
Next
drawframe frameno
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(maxframes, maxtx, maxty) As gcelltype
For f = 1 To maxframes
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
frameno = 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(frameno, cx, cy).t = " "
gcell(frameno, cx, cy).fgk = 0
gcell(frameno, cx, cy).bgk = 0
Color gcell(frameno, cx, cy).fgk, gcell(frameno, cx, cy).bgk
_PrintString (cx, cy), gcell(frameno, cx, cy).t
End Sub
Sub playanimation (ff, lf)
For f = ff To lf
Cls
_Limit framerate
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 Frame Rate ?"
Print
Print "Current frame rate is "; framerate
Print
Do
Locate 20, 3: Input "enter color from 1 to 60 ", kk$
Loop Until Val(kk$) > 0 Or Val(kk$) < 61
newrate = Val(kk$)
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 mouse to draw"
Print "N,n - create a new frame (limited to 200 as coded but you can edit that if you wish"
Print "P,p - play 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 framerate for animation"
Print "V,v - eyedropper, copies cell from previous frame"
Print "Z,z - zap the cell, erase it by settinhg it ot 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 frame, be careful this will replace the next frame"
Print "X - Delete animation, prompted to verify delete"
Print "1 - show current frame in top right corner, will not be recodeed in animation"
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, framerate, maxtx, maxty, lastframe
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
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
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, framerate, maxtx, maxty, lastframe
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
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
Close #1
Locate 3, 1
Print filename$; " loaded"
Print "press any key to continue"
any$ = Input$(1)
End SubRE: Minimal Text Animator - James D Jarvis - 09-16-2022
now with "encoding". 6K a frame. I sure have to compress that. Got two schemes in mind.
Code: (Select All)
'Minimal Text Animator
'by James D. Jarvis Sept 15,2022 v 0.3a
'
' a very minimal program to create and playback simple text screen animations
'S - Save file
'L - load file
' can save files unencoded (encodingg 0), or frame channel endcoded (encoding 1)
' encoding 1 is 6K per frame.
'encoding 2 does not work yet , left the awful code in place so other people can witness the joy and slendor of the awful
'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 "Minimal Text Animator"
Type gcelltype
t As String * 1
fgk As _Byte
bgk As _Byte
End Type
Dim Shared maxtx, maxty, maxframes, pen$, fg_klr, bg_klr, pen_klr
Dim Shared showonion, framerate, lastframe, frameno, frameshow, encoding
framerate = 20
frameshow = -1
encoding = 1
maxtx = _Width
maxty = _Height
maxframes = 200
pen$ = "*"
showonion = 0
Print "Minimal Text Animator"
_ControlChr Off
Dim Shared gcell(maxframes, maxtx, maxty) As gcelltype
For f = 1 To maxframes
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
frameno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
oflag = 0
Color fg_klr, bg_klr
'main program loop
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
gcell(frameno, mx, my).t = pen$
gcell(frameno, mx, my).fgk = pen_klr
gcell(frameno, mx, my).bgk = bg_klr
Color pen_klr, gcell(frameno, mx, my).bgk
_PrintString (mx, my), gcell(frameno, mx, my).t
End If
Color 15, 0
Loop
Select Case kk$
Case "n", "N"
Cls
frameno = frameno + 1
If frameno > maxframes Then frameno = 1
If showonion = 1 And frameno > 1 Then drawonion (frameno - 1)
drawframe frameno
lastframe = frameno
Case "o", "O"
If showonion = 0 And oflag = 0 Then
Cls
showonion = 1
drawonion (frameno - 1)
drawframe frameno
oflag = 1
Else
showonion = 0
oflag = 0
drawframe frameno
End If
Case "p", "P" 'play the animation
playanimation 1, lastframe
Case ",", "<" 'cycle down through drawn frames
frameno = frameno - 1
If frameno < 1 Then frameno = lastframe
drawframe frameno
Case ".", ">" 'cycle up through drawn frames
frameno = frameno + 1
If frameno > lastframe Then frameno = 1
Cls
drawframe frameno
Case "f", "F"
pen_klr = select_pencolor
Cls
drawframe frameno
Case "b", "B"
bg_klr = select_backgroundcolor
Cls
drawframe frameno
Case "S"
savefile
Cls
drawframe frameno
Case "L"
loadfile
Cls
playanimation 1, lastframe
frameno = 1
Case "h", "H", "?"
helpme
Cls
drawframe frameno
Case "r", "R"
framerate = newrate
Cls
drawframe frameno
Case "c", "C"
pen$ = Chr$(newchar)
Cls
drawframe frameno
Case "v", "V" 'eyedropper that copies cell from previous frame in the same position.
If frameno > 1 Then eyedropper _MouseX, _MouseY
Case "z", "Z" 'zap a cell .... well erase it
zapcell _MouseX, _MouseY
Case "D" 'duplicate
duplicateframe frameno
frameno = frameno + 1
lastframe = frameno
Cls
drawframe frameno
Case "X"
newanimation
drawframe frameno
Case "1" 'show framecount
frameshow = frameshow * -1
drawframe frameno
Case "T", "t"
inserttext _MouseX, _MouseY, pen_klr, bg_klr
End Select
kk$ = InKey$
If kk$ = "f" Then _PrintString (1, 1), Str$(frameno)
Loop Until kk$ = Chr$(27)
Sub drawframe (f As Integer)
For y = 1 To _Height
For x = 1 To _Width
If onion = 0 Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Else
If gcell(f, x, y).t <> " " Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
End If
End If
Next
Next
Color 15, 0
If frameshow = 1 Then
_PrintString (_Width - 4, 1), Str$(frameno)
End If
End Sub
Sub drawonion (f As Integer)
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(frameno, cx, cy).t = gcell(frameno - 1, cx, cy).t
gcell(frameno, cx, cy).fgk = gcell(frameno - 1, cx, cy).fgk
gcell(frameno, cx, cy).bgk = gcell(frameno - 1, cx, cy).bgk
Color gcell(frameno, cx, cy).fgk, gcell(frameno, cx, cy).bgk
_PrintString (cx, cy), gcell(frameno, cx, cy).t
End Sub
Sub duplicateframe (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(frameno, cx - 1 + tp, cy).t = Mid$(txt$, tp, 1)
gcell(frameno, cx - 1 + tp, cy).fgk = fk
gcell(frameno, cx - 1 + tp, cy).bgk = bk
End If
Next
drawframe frameno
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(maxframes, maxtx, maxty) As gcelltype
For f = 1 To maxframes
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
frameno = 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(frameno, cx, cy).t = " "
gcell(frameno, cx, cy).fgk = 0
gcell(frameno, cx, cy).bgk = 0
Color gcell(frameno, cx, cy).fgk, gcell(frameno, cx, cy).bgk
_PrintString (cx, cy), gcell(frameno, cx, cy).t
End Sub
Sub playanimation (ff, lf)
For f = ff To lf
Cls
_Limit framerate
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 Frame Rate ?"
Print
Print "Current frame rate is "; framerate
Print
Do
Locate 20, 3: Input "enter color from 1 to 60 ", kk$
Loop Until Val(kk$) > 0 Or Val(kk$) < 61
newrate = Val(kk$)
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"
Print "N,n - create a new frame (limited to 200 as coded but you can edit that if you wish"
Print "P,p - play 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 framerate for animation"
Print "V,v - eyedropper, copies cell from previous frame"
Print "Z,z - zap the cell, erase it by settinhg it ot 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 frame, be careful this will replace the next frame"
Print "X - Delete animation, prompted to verify delete"
Print "1 - show current frame in top right corner, will not be recodeed in animation"
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, framerate, maxtx, maxty, lastframe, encoding
'encoding = 0
If encoding = 0 Then
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
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 'discrete run length encoding
'each frame 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 lastframe
tframe$ = ""
fframe$ = ""
bframe$ = ""
For y = 1 To maxty
For x = 1 To maxtx
tframe$ = tframe$ + gcell(f, x, y).t
fframe$ = fframe$ + Chr$(gcell(f, x, y).fgk)
bframe$ = bframe$ + Chr$(gcell(f, x, y).bgk)
Next x
Next y
Write #1, tframe$
Write #1, fframe$
Write #1, bframe$
Next f
End If
If encoding = 2 Then 'discrete run length encoding
'each frame 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 lastframe
tframe$ = ""
tf2$ = ""
fframe$ = ""
ff2$ = ""
bframe$ = ""
bf2$ = ""
For y = 1 To maxty
For x = 1 To maxtx
tframe$ = tframe$ + gcell(f, x, y).t
fframe$ = fframe$ + Chr$(gcell(f, x, y).fgk)
bframe$ = bframe$ + Chr$(gcell(f, x, y).bgk)
Next x
Next y
'Write #1, tframe$
' Write #1, fframe$
'Write #1, bframe$
lc$ = ""
rl = 0
rt = 0
For c = 1 To Len(tframe$)
cc$ = Mid$(tframe$, c, 1)
rl = rl + 1
rt = rt + 1
If cc$ <> lc$ Or rt = 80 Or c = Len(tframe$) Then
tf2$ = tf2$ + cc$ + Chr$(rl)
rl = 0
lc$ = cc$
If rt = 80 Then rt = 0
End If
Next c
lc$ = ""
rl = 0
rt = 0
For c = 1 To Len(fframe$)
cc$ = Mid$(fframe$, c, 1)
rl = rl + 1
rt = rt + 1
If cc$ <> lc$ Or rt = 80 Or c = Len(fframe$) Then
ff2$ = ff2$ + cc$ + Chr$(rl)
rl = 0
lc$ = cc$
If rt = 80 Then rt = 0
End If
Next c
lc$ = ""
rl = 0
rt = 0
For c = 1 To Len(bframe$)
cc$ = Mid$(bframe$, c, 1)
rl = rl + 1
rt = rt + 1
If cc$ <> lc$ Or rt = 80 Or c = Len(bframe$) Then
bf2$ = bf2$ + cc$ + Chr$(rl)
rl = 0
rt = 80
lc$ = cc$
If rt = 80 Then rt = 0
End If
Next c
Write #1, tf2$
Write #1, ff2$
Write #1, bf2$
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, framerate, maxtx, maxty, lastframe, encoding
'encoding = 1
If encoding = 0 Then 'no encoding just read each cell
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
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 frame 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 lastframe
Input #1, tframe$
Input #1, fframe$
Input #1, bframe$
For y = 1 To maxty
For x = 1 To maxtx
gcell(f, x, y).t = Mid$(tframe$, (y - 1) * 80 + x, 1)
gcell(f, x, y).fgk = Asc(Mid$(fframe$, (y - 1) * 80 + x, 1))
gcell(f, x, y).bgk = Asc(Mid$(bframe$, (y - 1) * 80 + x, 1))
Next x
Next y
Next f
End If
If encoding = 2 Then 'discrete run length encoding
'each frame breaks the data down into a channel for the the charcter, a channel for foreground and a channel for background
For f = 1 To lastframe
tf2$ = ""
ff2$ = ""
bf2$ = ""
Input #1, tf2$
Input #1, ff2$
Input #1, bf2$
Print tf2$
Print ff2$
Print bf2$
tx = 0
ty = 1
For c = 1 To Len(tf2$)
ca$ = Mid$(tf2$, c, 1)
c = c + 1
cb$ = Mid$(tf2$, c, 1)
For n = 1 To Val(cb$)
tx = tx + 1
If tx = 81 Then
tx = 1
ty = ty + 1
End If
gcell(f, tx, ty).t = ca$
Next n
Next c
tx = 0
ty = 1
For c = 1 To Len(ff2$)
ca$ = Mid$(ff2$, c, 1)
c = c + 1
cb$ = Mid$(ff2$, c, 1)
For n = 1 To Val(cb$)
tx = tx + 1
If tx = 81 Then
tx = 1
ty = ty + 1
End If
gcell(f, tx, ty).fgk = Val(ca$)
Next n
Next c
tx = 0
ty = 1
For c = 1 To Len(bf2$)
ca$ = Mid$(bf2$, c, 1)
c = c + 1
cb$ = Mid$(bf2$, c, 1)
For n = 1 To Val(cb$)
tx = tx + 1
If tx = 81 Then
tx = 1
ty = ty + 1
End If
gcell(f, tx, ty).fgk = Val(ca$)
Next n
Next c
Next f
End If
Close #1
Locate 3, 1
Print filename$; " loaded"
Print "press any key to continue"
any$ = Input$(1)
End SubRE: Minimal Text Animator - Pete - 09-16-2022
Have a look at the "R" option. I pressed it to change the frame rate, and got this...
Change Frame Rate?
Current rate = 1
enter color from 1 - 60 _
------------------------------------
So it ignores allowing a rate input and gives a color input, instead.
I wanted to slow the rate down significantly. Frames worked great. Animation was just too fast, which is a good thing. Beats the old QB days of too slow.
Pete
RE: Minimal Text Animator - James D Jarvis - 09-16-2022
Oooops. Thanks for spotting that.
bug fixed (at least in this version). Showonion isn't working yet either. I'm not sure I have the color space to make it work well anyway but we'll see.
Code: (Select All)
'Minimal Text Animator
'by James D. Jarvis Sept 15,2022 v 0.3b
'
' a very minimal program to create and playback simple text screen animations
'S - Save file
'L - load file
' can save files unencoded (encodingg 0), or frame channel endcoded (encoding 1)
' encoding 1 is 6K per frame.
'encoding 2 does not work yet , left the awful code in place so other people can witness the joy and splendor of the awful
'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 "Minimal Text Animator"
Type gcelltype
t As String * 1
fgk As _Byte
bgk As _Byte
End Type
Dim Shared maxtx, maxty, maxframes, pen$, fg_klr, bg_klr, pen_klr
Dim Shared showonion, framerate, lastframe, frameno, frameshow, encoding
framerate = 20
frameshow = -1
encoding = 1
maxtx = _Width
maxty = _Height
maxframes = 200
pen$ = "*"
showonion = 0
Print "Minimal Text Animator"
_ControlChr Off
Dim Shared gcell(maxframes, maxtx, maxty) As gcelltype
For f = 1 To maxframes
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
frameno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
oflag = 0
Color fg_klr, bg_klr
'main program loop
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
gcell(frameno, mx, my).t = pen$
gcell(frameno, mx, my).fgk = pen_klr
gcell(frameno, mx, my).bgk = bg_klr
Color pen_klr, gcell(frameno, mx, my).bgk
_PrintString (mx, my), gcell(frameno, mx, my).t
End If
Color 15, 0
Loop
Select Case kk$
Case "n", "N"
Cls
frameno = frameno + 1
If frameno > maxframes Then frameno = 1
If showonion = 1 And frameno > 1 Then drawonion (frameno - 1)
drawframe frameno
lastframe = frameno
Case "o", "O"
If showonion = 0 And oflag = 0 Then
Cls
showonion = 1
drawonion (frameno - 1)
drawframe frameno
oflag = 1
Else
showonion = 0
oflag = 0
drawframe frameno
End If
Case "p", "P" 'play the animation
playanimation 1, lastframe
Case ",", "<" 'cycle down through drawn frames
frameno = frameno - 1
If frameno < 1 Then frameno = lastframe
drawframe frameno
Case ".", ">" 'cycle up through drawn frames
frameno = frameno + 1
If frameno > lastframe Then frameno = 1
Cls
drawframe frameno
Case "f", "F"
pen_klr = select_pencolor
Cls
drawframe frameno
Case "b", "B"
bg_klr = select_backgroundcolor
Cls
drawframe frameno
Case "S"
savefile
Cls
drawframe frameno
Case "L"
loadfile
Cls
playanimation 1, lastframe
frameno = 1
Case "h", "H", "?"
helpme
Cls
drawframe frameno
Case "r", "R"
framerate = newrate
Cls
drawframe frameno
Case "c", "C"
pen$ = Chr$(newchar)
Cls
drawframe frameno
Case "v", "V" 'eyedropper that copies cell from previous frame in the same position.
If frameno > 1 Then eyedropper _MouseX, _MouseY
Case "z", "Z" 'zap a cell .... well erase it
zapcell _MouseX, _MouseY
Case "D" 'duplicate
duplicateframe frameno
frameno = frameno + 1
lastframe = frameno
Cls
drawframe frameno
Case "X"
newanimation
drawframe frameno
Case "1" 'show framecount
frameshow = frameshow * -1
drawframe frameno
Case "T", "t"
inserttext _MouseX, _MouseY, pen_klr, bg_klr
End Select
kk$ = InKey$
If kk$ = "f" Then _PrintString (1, 1), Str$(frameno)
Loop Until kk$ = Chr$(27)
Sub drawframe (f As Integer)
For y = 1 To _Height
For x = 1 To _Width
If onion = 0 Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Else
If gcell(f, x, y).t <> " " Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
End If
End If
Next
Next
Color 15, 0
If frameshow = 1 Then
_PrintString (_Width - 4, 1), Str$(frameno)
End If
End Sub
Sub drawonion (f As Integer)
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(frameno, cx, cy).t = gcell(frameno - 1, cx, cy).t
gcell(frameno, cx, cy).fgk = gcell(frameno - 1, cx, cy).fgk
gcell(frameno, cx, cy).bgk = gcell(frameno - 1, cx, cy).bgk
Color gcell(frameno, cx, cy).fgk, gcell(frameno, cx, cy).bgk
_PrintString (cx, cy), gcell(frameno, cx, cy).t
End Sub
Sub duplicateframe (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(frameno, cx - 1 + tp, cy).t = Mid$(txt$, tp, 1)
gcell(frameno, cx - 1 + tp, cy).fgk = fk
gcell(frameno, cx - 1 + tp, cy).bgk = bk
End If
Next
drawframe frameno
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(maxframes, maxtx, maxty) As gcelltype
For f = 1 To maxframes
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
frameno = 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(frameno, cx, cy).t = " "
gcell(frameno, cx, cy).fgk = 0
gcell(frameno, cx, cy).bgk = 0
Color gcell(frameno, cx, cy).fgk, gcell(frameno, cx, cy).bgk
_PrintString (cx, cy), gcell(frameno, cx, cy).t
End Sub
Sub playanimation (ff, lf)
For f = ff To lf
Cls
_Limit framerate
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 Frame Rate ?"
Print
Print "Current frame rate is "; framerate
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 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"
Print "N,n - create a new frame (limited to 200 as coded but you can edit that if you wish"
Print "P,p - play 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 framerate for animation"
Print "V,v - eyedropper, copies cell from previous frame"
Print "Z,z - zap the cell, erase it by settinhg it ot 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 frame, be careful this will replace the next frame"
Print "X - Delete animation, prompted to verify delete"
Print "1 - show current frame in top right corner, will not be recodeed in animation"
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, framerate, maxtx, maxty, lastframe, encoding
'encoding = 0
If encoding = 0 Then
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
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 'discrete run length encoding
'each frame 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 lastframe
tframe$ = ""
fframe$ = ""
bframe$ = ""
For y = 1 To maxty
For x = 1 To maxtx
tframe$ = tframe$ + gcell(f, x, y).t
fframe$ = fframe$ + Chr$(gcell(f, x, y).fgk)
bframe$ = bframe$ + Chr$(gcell(f, x, y).bgk)
Next x
Next y
Write #1, tframe$
Write #1, fframe$
Write #1, bframe$
Next f
End If
If encoding = 2 Then 'discrete run length encoding
'each frame 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 lastframe
tframe$ = ""
tf2$ = ""
fframe$ = ""
ff2$ = ""
bframe$ = ""
bf2$ = ""
For y = 1 To maxty
For x = 1 To maxtx
tframe$ = tframe$ + gcell(f, x, y).t
fframe$ = fframe$ + Chr$(gcell(f, x, y).fgk)
bframe$ = bframe$ + Chr$(gcell(f, x, y).bgk)
Next x
Next y
'Write #1, tframe$
' Write #1, fframe$
'Write #1, bframe$
lc$ = ""
rl = 0
rt = 0
For c = 1 To Len(tframe$)
cc$ = Mid$(tframe$, c, 1)
rl = rl + 1
rt = rt + 1
If cc$ <> lc$ Or rt = 80 Or c = Len(tframe$) Then
tf2$ = tf2$ + cc$ + Chr$(rl)
rl = 0
lc$ = cc$
If rt = 80 Then rt = 0
End If
Next c
lc$ = ""
rl = 0
rt = 0
For c = 1 To Len(fframe$)
cc$ = Mid$(fframe$, c, 1)
rl = rl + 1
rt = rt + 1
If cc$ <> lc$ Or rt = 80 Or c = Len(fframe$) Then
ff2$ = ff2$ + cc$ + Chr$(rl)
rl = 0
lc$ = cc$
If rt = 80 Then rt = 0
End If
Next c
lc$ = ""
rl = 0
rt = 0
For c = 1 To Len(bframe$)
cc$ = Mid$(bframe$, c, 1)
rl = rl + 1
rt = rt + 1
If cc$ <> lc$ Or rt = 80 Or c = Len(bframe$) Then
bf2$ = bf2$ + cc$ + Chr$(rl)
rl = 0
rt = 80
lc$ = cc$
If rt = 80 Then rt = 0
End If
Next c
Write #1, tf2$
Write #1, ff2$
Write #1, bf2$
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, framerate, maxtx, maxty, lastframe, encoding
'encoding = 1
If encoding = 0 Then 'no encoding just read each cell
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
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 frame 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 lastframe
Input #1, tframe$
Input #1, fframe$
Input #1, bframe$
For y = 1 To maxty
For x = 1 To maxtx
gcell(f, x, y).t = Mid$(tframe$, (y - 1) * 80 + x, 1)
gcell(f, x, y).fgk = Asc(Mid$(fframe$, (y - 1) * 80 + x, 1))
gcell(f, x, y).bgk = Asc(Mid$(bframe$, (y - 1) * 80 + x, 1))
Next x
Next y
Next f
End If
If encoding = 2 Then 'discrete run length encoding
'each frame breaks the data down into a channel for the the charcter, a channel for foreground and a channel for background
For f = 1 To lastframe
tf2$ = ""
ff2$ = ""
bf2$ = ""
Input #1, tf2$
Input #1, ff2$
Input #1, bf2$
Print tf2$
Print ff2$
Print bf2$
tx = 0
ty = 1
For c = 1 To Len(tf2$)
ca$ = Mid$(tf2$, c, 1)
c = c + 1
cb$ = Mid$(tf2$, c, 1)
For n = 1 To Val(cb$)
tx = tx + 1
If tx = 81 Then
tx = 1
ty = ty + 1
End If
gcell(f, tx, ty).t = ca$
Next n
Next c
tx = 0
ty = 1
For c = 1 To Len(ff2$)
ca$ = Mid$(ff2$, c, 1)
c = c + 1
cb$ = Mid$(ff2$, c, 1)
For n = 1 To Val(cb$)
tx = tx + 1
If tx = 81 Then
tx = 1
ty = ty + 1
End If
gcell(f, tx, ty).fgk = Val(ca$)
Next n
Next c
tx = 0
ty = 1
For c = 1 To Len(bf2$)
ca$ = Mid$(bf2$, c, 1)
c = c + 1
cb$ = Mid$(bf2$, c, 1)
For n = 1 To Val(cb$)
tx = tx + 1
If tx = 81 Then
tx = 1
ty = ty + 1
End If
gcell(f, tx, ty).fgk = Val(ca$)
Next n
Next c
Next f
End If
Close #1
Locate 3, 1
Print filename$; " loaded"
Print "press any key to continue"
any$ = Input$(1)
End Sub