09-16-2022, 07:12 PM
(This post was last modified: 09-16-2022, 07:17 PM by James D Jarvis.)
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.
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