Minimal Text Animator

[James D Jarvis]

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 Sub