'Ascii Clipdoodle  V 0.5

'an ascii doodle pad that opens control panel apps in other window

'

'

'loadtextimage and savetextimage from SMcNeil at  https://qb64phoenix.com/forum/showthread.php?tid=2022

'

'pickclip04.exe and colorpick1604.exe must be compiled before this program will function properly



Dim Shared reflag

reflag = -1

Dim Shared helpscreen As Long

Dim Shared twd, tht

Type colchr

    chr As _Unsigned _Byte

    ' blink As _Unsigned _Byte 'if directly changing blink bit a vlaue of 255 will turn the blink bit on

    bg As _Unsigned _Byte 'can direcrtly assing vlaues of 0 to 15

    fg As _Unsigned _Byte 'can directly assign values of 0 to 31



End Type

Dim gc As colchr

Dim ga As colchr



twd = 80: tht = 25

helpscreen = _NewImage(twd, tht, 0)



Dim Shared mainscreen As Long

mainscreen = _NewImage(80, 25, 0) 'default size text screen. feel free to change it.

Screen mainscreen

_Title "Ascii ClipDoodle"

Cls

'open  cdoodle.tlk

write_msg "ClipDoodleOn"

Sleep 1

'_Clipboard$ = "ClipDoodleOn" ' "clears" clipboard for use

Shell _DontWait "pickclip04.exe" ' Open the pickclip control panel

Shell _DontWait "colorpick1604.exe" ' Open the colorpick16 control panel

_ControlChr Off

AK = 42

Do

    _Limit 100

    Do While _MouseInput 'mouse status changes only

        _Limit 2000

        x = _MouseX

        y = _MouseY

        px = _MouseX: py = _MouseY

        If _MouseButton(1) Then

            _PrintString (x, y), brush$

        End If

    Loop

    kk$ = InKey$

    Select Case kk$

        Case "t", "T" 'type on current line with current color characteristics

            _KeyClear

            Do

                Do

                    _Limit 60

                    tk$ = InKey$

                Loop Until tk$ <> ""

                If tk$ = Chr$(8) Then

                    tk$ = ""

                    px = px - 1

                End If

                If tk$ <> Chr$(13) And tk$ <> "" Then

                    _PrintString (px, py), tk$

                    px = px + 1

                    If px > _Width Then tk$ = Chr$(13) 'exit type input if attempting to type outside screen

                End If

            Loop Until tk$ = Chr$(13)

        Case "S" 'save text screen

            filef = 0

            file$ = _SaveFileDialog$("Save File", "", "*.SAV", "SAved text screen")

            If file$ <> "" Then

                filef = 1

                _MessageBox "Information", "File will be saved to " + file$

            End If

            If filef = 1 Then

                SaveTextImage 0, file$

                _MessageBox "Image SAved", "Text Images SAVED to " + file$

            End If

            filef = 0

        Case "L", "O" 'load text screen

            file$ = _OpenFileDialog$("Open File", "", "*.SAV", "SAVed text screen", -1)

            If file$ <> "" Then

                _MessageBox "Information", "You selected " + file$

                'mainscreen = LoadTextImage(file$)

                Screen LoadTextImage(file$)

                tht = _Height

                twd = _Width

            End If



        Case "C" 'clear screen

            cc = _MessageBox("CLEAR SCREEN", "Are you sure you want to clear the screen? The image will be lost if it has not been saved. ", "yesnocancel", "warning", 0)

            If cc = 1 Then Cls

        Case Chr$(27)

            cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The image will be lost if it has not been saved. ", "yesnocancel", "warning", 0)

            If cc = 1 Then Else kk$ = ""



        Case "J" 'save as jpeg

            filef = 0

            file$ = _SaveFileDialog$("Save File", "", "*.JPG", "JPEG Image")

            If file$ <> "" Then

                filef = 1

                _MessageBox "Information", "File will be saved to " + file$

            End If

            If filef = 1 Then

                _SaveImage file$, 0, "JPG"



                _MessageBox "JPEG SAved", "Text Images SAVED to " + file$

            End If

            filef = 0

        Case "B" 'scan the image and output a set of traditional basic commands to a file



            filef = 0

            file$ = _SaveFileDialog$("Save as Basic", "", "*.BAS", "Basic Source Code")

            If file$ <> "" Then filef = 1

            If filef = 1 Then

                Open file$ For Output As #22

                subname$ = Mid$(file$, _InStrRev(file$, "\") + 1)

                Print #22, "'" + subname$ + " prints a colored ascii image drawn in aclipdoodle_05"

                Print #22, "'Screen _newimage(" + Str$(_Width(ti&)) + "," + Str$(_Height(ti&)) + ", 0)"

                subname$ = "Print_" + Left$(subname$, Len(subname$) - 4)

                Print #22, "'" + subname$ + " 1,1"

                Print #22, "sub " + subname$ + "(px,py)"

                Print #22, "' color 0,0 is treated as transparent if character 32 is being printed, adjust comments if desired"

                Print #22, " _controlchr off "

                getcolchr 0, 1, 1, ga

                lc = ga.chr: lf = ga.fg: lb = ga.bg

                For y = 1 To tht

                    rl = 0

                    For x = 1 To twd

                        getcolchr 0, x, y, gc

                        If gc.chr = lc And gc.fg = lf And gc.bg = lb Then

                            rl = rl + 1

                        Else

                            If lf = 0 And lb = 0 And lc = 32 Then

                                Print #22, "'color " + Str$(lf) + "," + Str$(lb) + ": _printstring(px+" + Str$(x - (rl + 1)) + ",py+" + Str$(y - 1) + ")," + " string$(" + Str$(rl) + "," + Str$(lc) + ")"

                            Else

                                Print #22, "color " + Str$(lf) + "," + Str$(lb) + ": _printstring(px+" + Str$(x - (rl + 1)) + ",py+" + Str$(y - 1) + ")," + " string$(" + Str$(rl) + "," + Str$(lc) + ")"



                            End If

                            rl = 1

                            lc = gc.chr: lf = gc.fg: lb = gc.bg

                        End If

                    Next x

                    If lf = 0 And lb = 0 And lc = 32 Then

                        Print #22, "'color " + Str$(lf) + "," + Str$(lb) + ": _printstring(px+" + Str$(x - (rl + 1)) + ",py+" + Str$(y - 1) + ")," + " string$(" + Str$(rl) + "," + Str$(lc) + ")"

                    Else

                        Print #22, "color " + Str$(lf) + "," + Str$(lb) + ": _printstring(px+" + Str$(x - (rl + 1)) + ",py+" + Str$(y - 1) + ")," + " string$(" + Str$(rl) + "," + Str$(lc) + ")"

                    End If

                Next y

                Print #22, "end sub"

                Close #22

                _MessageBox "Image Saved", " Created Basic Source file " + file$

            End If

            filef = 0





        Case "R"

            do_resize

        Case "?" 'help

            do_help

    End Select



    ik$ = get_msg$

    If Left$(ik$, 2) = "AC" Then AK = Val(Right$(ik$, Len(ik$) - 2))

    If Left$(ik$, 2) = "CK" Then

        ff$ = " "

        n = 2

        Do

            n = n + 1

            A$ = Mid$(ik$, n, 1)

            If A$ <> "/" Then ff$ = ff$ + A$

        Loop Until A$ = "/"

        bb$ = ""

        Do

            A$ = Mid$(ik$, n, 1)

            If A$ <> "/" Then bb$ = bb$ + A$

            n = n + 1

        Loop Until n > Len(ik$)

        FG = Val(ff$): BG = Val(bb$)

        Color FG, BG

    End If

    brush$ = Chr$(AK)

Loop Until kk$ = Chr$(27)

write_msg "QUITCOLORPICK16"

Sleep 1

write_msg "QUITCLIPPICK"

System

Sub do_help

    ls& = _Dest

    Screen helpscreen

    Cls

    Print "HELP"

    Print "------------------"

    Print "use mouse to draw with ascii characters"

    Print "select character to draw and colors from control panels"

    Print " "

    Print "    <ESC> to quit program"

    Print "    t,T  -  To type a line of text in colors picked"

    Print

    Print "    S    - To Save Screen"

    Print "    L,O  - to Load Saved Screen"

    Print "    J    -save as jpeg file."

    Print "    B    - export image as a standard qb64 Basic source file "

    Print "    C    - to clear screen"

    Print

    Print "press any key to continue"

    Sleep

    Screen ls&

End Sub

Sub do_resize

    ls& = _Dest

    Screen helpscreen

    Cls

    Print "Resize"

    Print "------------------"

    Print "Current size "

    Print "width "; twd, "Height "; tht

    Print "Enter new coordinates"

    Input "Width "; twd

    Input "Height"; tht

    _FreeImage ls&



    Screen _NewImage(twd, tht, 0)

End Sub









Function LoadTextImage& (SaveFile As String) 'create and load to a new Screen 0 screen with our saved image

    Dim As Integer Wide, Tall, Flag: Wide = 80: Tall = 25: Flag = 0

    Dim As String ImageData

    Dim As _MEM M

    f = FreeFile

    Open SaveFile For Binary As #f

    compress$ = Space$(LOF(f))

    Get #f, 1, compress$

    Close #f

    temp$ = _Inflate$(compress$)

    Flag = Asc(temp$, 1): p = 2



    If Flag And 1 Then Wide = CVI(Mid$(temp$, p, 2)): p = p + 2

    If Flag And 2 Then Tall = CVI(Mid$(temp$, p, 2)): p = p + 2

    If Flag And 4 Then _Blink On Else _Blink Off

    If Flag And 8 Then _Font Asc(temp$, p): p = p + 1

    ImageData = Mid$(temp$, p)

    TempImage = _NewImage(Wide, Tall, 0)

    M = _MemImage(TempImage): _MemPut M, M.OFFSET, ImageData: _MemFree M

    LoadTextImage = TempImage

End Function



Sub SaveTextImage (ImageHandle As Long, SaveFile As String)

    Dim As Integer Wide, Tall, Flag

    Dim As Long ImageSize

    Dim As String ImageData

    Dim As _MEM M

    If _PixelSize(ImageHandle) <> 0 Then Error 5: Exit Sub 'only text images for this routine



    M = _MemImage(ImageHandle)

    Wide = _Width(ImageHandle): Tall = _Height(ImageHandle)

    temp$ = "0" 'placeholder for our finalized image flag which holds custom information



    If Wide <> 80 Then Flag = Flag + 1: temp$ = temp$ + MKI$(Wide)

    If Tall <> 25 Then Flag = Flag + 2: temp$ = temp$ + MKI$(Tall)

    If _Blink Then Flag = Flag + 4 'Set a flag saying that this image uses _Blink

    Select Case _Font(ImageHandle)

        Case 8: Flag = Flag + 8: temp$ = temp$ + Chr$(8)

        Case 9: Flag = Flag + 8: temp$ = temp$ + Chr$(9)

        Case 14: Flag = Flag + 8: temp$ = temp$ + Chr$(14)

        Case 15: Flag = Flag + 8: temp$ = temp$ + Chr$(15)

        Case 16 '16 needs no flag as it's the default for screen 0

        Case 17: Flag = Flag + 8: temp$ = temp$ + Chr$(17)

        Case Else

            'To be added once we get a _MemFont to retrieve custom font data back from QB64PE

    End Select

    ImageSize = Wide * Tall * 2

    ImageData = Space$(ImageSize): _MemGet M, M.OFFSET, ImageData: _MemFree M

    temp$ = temp$ + ImageData

    Mid$(temp$, 1) = Chr$(Flag) 'replace our placeholder with the proper value of the custom flag

    compress$ = _Deflate$(temp$)

    f = FreeFile

    Open SaveFile For Output As #f: Close #f

    Open SaveFile For Binary As #f: Put #f, 1, compress$: Close #f

End Sub



Sub write_msg (m$)

    Open "cdoodle.tlk" For Output As #11

    Print #11, m$

    Close #11

End Sub

Function get_msg$

    '-----------------------------------------------

    'get intraprogram messages

    '----------------------------------------------

    Open "cdoodle.tlk" For Input As #11

    ' Line Input #11, g$

    If Not EOF(11) Then Line Input #11, g$

    Close #11

    get_msg$ = g$

End Function



Function thebit$ (n, sb, eb)

    'grabs  bits from starting bit SB to end bit eb

    If eb > sb Then Exit Function

    a$ = ""

    For b = sb To eb Step -1

        If _ReadBit(n, b) = 0 Then a$ = a$ + "0" Else a$ = a$ + "1"

    Next b

    thebit$ = a$

End Function



Sub getcolchr (ii&, x, y, gc As colchr)

    'get the character at screen location x,y and store the vlaues for the charcater, foregroundcolor, backgroundcolor, and blink bit

    Dim o As _MEM

    o = _MemImage(ii&)

    w = (_Width(ii&)) * 2

    tc = (y - 1) * w + (x - 1) * 2

    c1 = _MemGet(o, o.OFFSET + tc + 1, _Unsigned _Byte)

    ccb$ = thebit$(c1, 6, 4)

    bg = Val("&B" + ccb$)

    ccf$ = thebit$(c1, 3, 0)

    fg = Val("&B" + ccf$)

    ' bb = _ReadBit(c1, 7)

    ch = _MemGet(o, o.OFFSET + tc, _Unsigned _Byte)

    gc.chr = ch

    gc.bg = bg

    gc.fg = fg

    ' gc.blink = bb

    _MemFree o

End Sub

Sub putcolchr (x, y, gc As colchr, ii&)

    'put the character held in gc with charcter, foregroundcolor.backgroundcolor, and blink bit

    Dim o As _MEM

    ' ii& = _Dest

    o = _MemImage(ii&)

    w = (_Width(ii&)) * 2

    tc = (y - 1) * w + (x - 1) * 2

    ch = gc.chr

    fg = Val("&b" + thebit$(gc.fg, 3, 0))

    bg = Val("&b" + thebit$(gc.bg, 2, 0))

    ' bb = _ReadBit(gc.blink, 7)

    If gc.fg > 15 Then

        bb = 1

    End If

    c = bb * 128 + fg + bg * 16

    _MemPut o, o.OFFSET + tc, ch As _UNSIGNED _BYTE

    _MemPut o, o.OFFSET + tc + 1, c As _UNSIGNED _BYTE

    _MemFree o

End Sub