QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Works in Progress v
Minimal Text Animator

Threaded Mode
Minimal Text Animator
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#1
09-15-2022, 08:42 PM
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 Sub
Find
Reply
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#2
09-15-2022, 10:32 PM
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 Sub
Find
Reply
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#3
09-16-2022, 03:33 AM
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 Sub
Find
Reply
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#4
09-16-2022, 04:55 PM (This post was last modified: 09-16-2022, 04:56 PM by 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
Find
Reply
Pete Offline
Ad-mini-strator
*******
Posts: 1,616
Threads: 157
Joined: Apr 2022
Reputation: 77
#5
09-16-2022, 05:17 PM
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
Find
Reply
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#6
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.

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
Find
Reply




Users browsing this thread: 1 Guest(s)