Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 492
» Latest member: Feederumn
» Forum threads: 2,829
» Forum posts: 26,526

Full Statistics

Latest Threads
Aloha from Maui guys.
Forum: General Discussion
Last Post: mrbcx
1 hour ago
» Replies: 6
» Views: 80
another variation of "10 ...
Forum: Programs
Last Post: Jack002
3 hours ago
» Replies: 1
» Views: 78
Rock Jockey 2.0 is ready ...
Forum: Games
Last Post: NakedApe
6 hours ago
» Replies: 20
» Views: 562
Button rack or hotkey fun...
Forum: Utilities
Last Post: Jack002
7 hours ago
» Replies: 6
» Views: 384
ANSIPrint
Forum: a740g
Last Post: bplus
10 hours ago
» Replies: 11
» Views: 193
Audio Spectrum Analyser
Forum: Programs
Last Post: Jack002
Yesterday, 01:56 AM
» Replies: 7
» Views: 154
_mem
Forum: Help Me!
Last Post: hsiangch_ong
Yesterday, 01:50 AM
» Replies: 13
» Views: 297
pan around a large image ...
Forum: Programs
Last Post: hsiangch_ong
Yesterday, 01:32 AM
» Replies: 0
» Views: 26
trouble building ansiprin...
Forum: Help Me!
Last Post: hsiangch_ong
Yesterday, 12:57 AM
» Replies: 2
» Views: 61
decfloat -- again
Forum: Programs
Last Post: Jack002
01-08-2025, 10:30 PM
» Replies: 42
» Views: 2,928

 
  FillTriangle and FillQuad
Posted by: SMcNeill - 09-23-2023, 06:03 AM - Forum: SMcNeill - Replies (4)

Two simple little routines to quickly and efficiently fill triangles and quadrilaterals:

Code: (Select All)
SUB FillTriangle (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
    $CHECKING:OFF
    STATIC a&, m AS _MEM
    IF a& = 0 THEN a& = _NEWIMAGE(1, 1, 32): m = _MEMIMAGE(a&)
    _MEMPUT m, m.OFFSET, K
    _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
    $CHECKING:ON
END SUB

SUB FillQuad (x1, y1, x2, y2, x3, y3, x4, y4, K AS _UNSIGNED LONG)
    FillTriangle x1, y1, x2, y2, x3, y3, K
    FillTriangle x3, y3, x4, y4, x1, y1, K
END SUB

Print this item

  Isometric Mapping Demo
Posted by: SMcNeill - 09-23-2023, 05:50 AM - Forum: SMcNeill - Replies (2)

I was thinking of working up a simple little game which utilizes isometric mapping to create a pseudo-3d environment, and I couldn't find a demo of anything similar on the forums.  So, in the spirit of "can do", I did, and here's what I came up with some time ago and now retweaked and improved for QB64PE:

Code: (Select All)
SCREEN _NEWIMAGE(1024, 720, 32)
_SCREENMOVE _MIDDLE

DIM SHARED GridSize AS INTEGER
DIM Kolor AS _UNSIGNED LONG
CONST Red = &HFFFF0000, Green = &HFF00FF00
GridSize = 16 'My demo map is only going to be 16x16 pixels


DIM grid(9, 9) AS _BYTE 'create a grid to layout our map

FOR i = 0 TO 9 'and let's create that map.  It's just going to be 4 walls and a floor...
    grid(i, 0) = 1 'wall
    grid(i, 9) = 1
    grid(0, i) = 1
    grid(9, i) = 1
NEXT

FOR y = 1 TO 8
    FOR x = 1 TO 8
        grid(x, y) = 2 'floor
    NEXT
NEXT


'Now, let's just draw grids one at a time to compare.
_PRINTSTRING (100, 80), "Normal 2D grid"
FOR y = 0 TO 9
    FOR x = 0 TO 9
        'normal grid first
        IF grid(x, y) = 1 THEN Kolor = Red ELSE Kolor = Green
        xpos = x * GridSize + 100: ypos = y * GridSize + 100
        xpos2 = xpos + GridSize: ypos2 = ypos + GridSize
        LINE (xpos, ypos)-(xpos2, ypos2), Kolor, BF
        LINE (xpos, ypos)-(xpos2, ypos2), &HFFFFFFFF, B
        'and that's all it takes for the normal grid.  Can't get any simpler for 2d maps!
    NEXT
NEXT

SLEEP

_PRINTSTRING (350, 80), "Normal 2D grid in Isometic Perspective"
FOR y = 0 TO 9
    FOR x = 0 TO 9
        'And now, let's do the same thing with our isometic map.
        IF grid(x, y) = 1 THEN Kolor = Red ELSE Kolor = Green
        xpos = x * GridSize + 100: ypos = y * GridSize + 100
        xpos2 = xpos + GridSize: ypos2 = ypos + GridSize
        IsoLine xpos, ypos, xpos2, ypos2, 500, 0, Kolor
        'And that's basically all the takes to rotate our map to make it a 2D isometic perspective
    NEXT
NEXT

SLEEP

_PRINTSTRING (350, 360), "Normal 2D grid in 3D Isometic Perspective"
FOR y = 0 TO 9
    FOR x = 0 TO 9
        'And here, I'm going to make it a 3D isometic map
        IF grid(x, y) = 1 THEN Kolor = Red ELSE Kolor = Green
        IF grid(x, y) = 1 THEN z = 16 ELSE z = 0 'Give my walls a height of 16, for a cube

        xpos = x * GridSize + 100: ypos = y * GridSize + 100
        xpos2 = xpos + GridSize: ypos2 = ypos + GridSize
        IsoLine3D xpos, ypos, xpos2, ypos2, z, 500, 300, Kolor
    NEXT
NEXT


FUNCTION CX2I (x AS LONG, y AS LONG) 'Convert Cartesian X To Isometic coordinates
    CX2I = x - y
END FUNCTION

FUNCTION CY2I (x AS LONG, y AS LONG) 'Convert Cartesian Y To Isometic coordinates
    CY2I = (x + y) / 2
END FUNCTION

SUB IsoLine (x, y, x2, y2, xoffset, yoffset, kolor AS _UNSIGNED LONG)
    'since we're drawing a diamond and not a square box, we can't use Line BF.
    'We have to manually down the 4 points of the line.
    LINE (CX2I(x, y) + xoffset, CY2I(x, y) + yoffset)-(CX2I(x2, y) + xoffset, CY2I(x2, y) + yoffset), kolor
    LINE -(CX2I(x2, y2) + xoffset, CY2I(x2, y2) + yoffset), kolor
    LINE -(CX2I(x, y2) + xoffset, CY2I(x, y2) + yoffset), kolor
    LINE -(CX2I(x, y) + xoffset, CY2I(x, y) + yoffset), kolor
    PAINT (CX2I(x, y) + xoffset, CY2I(x, y) + 4), kolor 'and fill the diamond solid
    LINE (CX2I(x, y) + xoffset, CY2I(x, y) + yoffset)-(CX2I(x2, y) + xoffset, CY2I(x2, y) + yoffset), &HFFFFFFFF
    LINE -(CX2I(x2, y2) + xoffset, CY2I(x2, y2) + yoffset), &HFFFFFFFF
    LINE -(CX2I(x, y2) + xoffset, CY2I(x, y2) + yoffset), &HFFFFFFFF
    LINE -(CX2I(x, y) + xoffset, CY2I(x, y) + yoffset), &HFFFFFFFF
END SUB

SUB IsoLine3D (x, y, x2, y2, z, xoffset, yoffset, kolor AS _UNSIGNED LONG)
    'Like IsoLine, we're going to have to draw our lines manually.
    'only in this case, we also need a Z coordinate to tell us how THICK/TALL/HIGH to make our tile

    'Let's just do all the math first this time.
    'We need to turn those 4 normal points into 4 isometric points (x, y, x1, y1)

    TempX1 = CX2I(x, y) + xoffset: TempY1 = CY2I(x, y) + yoffset
    TempX2 = CX2I(x2, y) + xoffset: TempY2 = CY2I(x2, y) + yoffset
    TempX3 = CX2I(x2, y2) + xoffset: TempY3 = CY2I(x2, y2) + yoffset
    TempX4 = CX2I(x, y2) + xoffset: TempY4 = CY2I(x, y2) + yoffset

    'The top
    FillQuad TempX1, TempY1 - z, TempX2, TempY2 - z, TempX3, TempY3 - z, TempX4, TempY4 - z, kolor
    LINE (TempX1, TempY1 - z)-(TempX2, TempY2 - z), -1 'and redraw the grid
    LINE -(TempX3, TempY3 - z), -1
    LINE -(TempX4, TempY4 - z), -1
    LINE -(TempX1, TempY1 - z), -1

    IF z <> 0 THEN 'no need to draw any height, if there isn't any.
        'the left side
        FillQuad TempX4, TempY4 - z, TempX4, TempY4, TempX3, TempY3, TempX3, TempY3 - z, kolor
        LINE (TempX4, TempY4 - z)-(TempX4, TempY4), -1 'redraw the grid lines
        LINE -(TempX3, TempY3), -1
        LINE -(TempX3, TempY3 - z), -1
        LINE -(TempX4, TempY4 - z), -1
        'and then for the right side
        FillQuad TempX3, TempY3 - z, TempX3, TempY3, TempX2, TempY2, TempX2, TempY2 - z, kolor
        LINE (TempX3, TempY3 - z)-(TempX3, TempY3), -1 'redraw the grid lines
        LINE -(TempX2, TempY2), -1
        LINE -(TempX2, TempY2 - z), -1
        LINE -(TempX3, TempY3 - z), -1
    END IF
END SUB

SUB FillTriangle (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
    DIM D AS LONG
    STATIC a&
    D = _DEST
    IF a& = 0 THEN a& = _NEWIMAGE(1, 1, 32): _DONTBLEND a& '<< fix ??
    _DEST a&
    PSET (0, 0), K
    _DEST D
    _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
END SUB

SUB FillQuad (x1, y1, x2, y2, x3, y3, x4, y4, K AS _UNSIGNED LONG)
    FillTriangle x1, y1, x2, y2, x3, y3, K
    FillTriangle x3, y3, x4, y4, x1, y1, K
END SUB

Print this item

  Base-128 Encoding and Decoding
Posted by: SMcNeill - 09-23-2023, 05:32 AM - Forum: SMcNeill - No Replies

Code: (Select All)
_CONTROLCHR OFF

test$ = "abc"
a$ = B256to128$(test$)
b$ = B128to256$(a$)
PRINT test$, a$, b$
PRINT LEN(test$), LEN(a$), LEN(b$)

SLEEP

FOR i = 0 TO 255
    t$ = CHR$(i)
    PRINT i, t$,
    a$ = B256to128(t$)
    PRINT a$,
    b$ = B128to256(a$)
    PRINT b$
    IF t$ <> b$ THEN
        PRINT "DON'T MATCH!!"
        END
    END IF
NEXT

PRINT
PRINT "All characters match before and after encoding and decoding."



FUNCTION B256to128$ (text$)
    FOR i = 1 TO LEN(text$)
        a = ASC(text$, i) '                      get the ASCII value of our character
        b$ = RIGHT$("00000000" + _BIN$(a), 8) '  convert it to binary
        temp$ = temp$ + b$ '                      add the binary to a single long string
    NEXT
    padding$ = STRING$(7 - LEN(temp$) MOD 7, "0")
    temp$ = temp$ + padding$ '                    add necessay padding to make it suitable for base-128 encoding
    FOR i = 1 TO LEN(temp$) STEP 7
        c$ = MID$(temp$, i, 7) '                  get 7 characters from our 8 byte represention
        c = VAL("&B" + c$) '                      that's the character value of our base 128-character
        temp1$ = temp1$ + CHR$(c + 65) '              add that to our new string
    NEXT
    B256to128$ = temp1$
END FUNCTION

FUNCTION B128to256$ (text$)
    FOR i = 1 TO LEN(text$)
        a = ASC(text$, i) - 65
        b$ = RIGHT$("0000000" + _BIN$(a), 7)
        temp$ = temp$ + b$
    NEXT
    temp$ = LEFT$(temp$, 8 * INT(LEN(temp$) / 8)) 'remove padding
    FOR i = 1 TO LEN(temp$) STEP 8
        b$ = "&B" + MID$(temp$, i, 8)
        temp1$ = temp1$ + CHR$(VAL(b$))
    NEXT
    B128to256$ = temp1$
END FUNCTION

Print this item

  Working on Base-85 Encoder/Decoder Functions
Posted by: Dav - 09-23-2023, 03:35 AM - Forum: Works in Progress - Replies (16)

When I learned QB64-PE allows resources to be loaded from memory it re-kindled my interest in encoding methods to put small files in BAS code, like Base64 is used in several programs found here.  One step more space efficient than Base64 is Base85 (also called ASCII85) which outputs smaller encoded data and uses a larger character set, so I started trying to figure it out.  It's been a real challenge as I am not very math savvy and there were no BASIC sources of Base85 out there I could find to study.

Here's what I have so far.  This will take 4 bytes of binary data, convert it to an integer, divide that up and map them to a characterset, outputting 5 bytes of printable characters that can be included in BAS code.  The decoder reverses the process. I have tested these functions on a few files, and they seem to encode/decode ok here - but they is VERY SLOW.  If you would like to try them and/or add some improvements please do (Speed it up if you can).   I'm also working on Base91 too, but it's not ready to post yet.

- Dav

Edit: Updated version.  Now encode/decode much faster.

Code: (Select All)

'==========
'BASE85.BAS - v0.30
'==========
'Base85 Encoder/Decoder Functions.
'Coded by Dav for QB64-PE 3.8.0, SEP/2023

'CREDIT:  Thanks to RhoSigma for helping me make these lightning fast!!


a1$ = Space$(1000000) ' make a 1MB string to test encoder/decoder speed

Print
Print "Original size:"; Len(a1$); "bytes."
Print

t1# = Timer
Print "Encoding"; Len(a1$); "bytes....";
a2$ = Base85Encode$(a1$)
Print Timer - t1#; "secs, output size:"; Len(a2$)
Print
t1# = Timer
Print "Decoding"; Len(a2$); "bytes....";
a3$ = Base85Decode$(a2$)
Print Timer - t1#; "secs, output:"; Len(a3$)
Print

If a1$ = a3$ Then
    Print "Original Data and Decoded Data Match!"
    Print Len(a1$), Len(a3$)
Else
    Print "Original Data and Decoded DO NOT Match!"
    Print Len(a1$), Len(a3$)
End If



Function Base85Encode$ (in$)
    For i = 39 To 125 'Make 85 character set to use
        If i <> 64 And i <> 96 Then c$ = c$ + Chr$(i)
    Next
    Dim v As _Unsigned Long

    t$ = in$ 'make a working copy so in$ isn't changed

    If Len(t$) Mod 4 > 0 Then 'pad needed bytes on end
        a = 5 - Len(t$) Mod 4
        t$ = t$ + Space$(a - 1)
    End If

    out$ = Space$(Len(t$) * 1.25): outb& = 1

    For i& = 1 To Len(t$) Step 4
        v = CVL(Mid$(t$, i&, 4))
        For j& = 4 To 0 Step -1
            p& = 85 ^ j&
            r& = v \ p&
            v = v Mod p&
            Mid$(out$, outb&, 1) = Mid$(c$, r& + 1, 1)
            outb& = outb& + 1
        Next
    Next
    Base85Encode$ = LTrim$(RTrim$(Str$(a))) + out$
End Function

Function Base85Decode$ (in$)
    For i = 39 To 125 'Make an 85 character set
        If i <> 64 And i <> 96 Then c$ = c$ + Chr$(i)
    Next
    Dim v As _Unsigned Long
    t$ = in$ 'use a working copy so in$ isn't changed
    a = Val(Mid$(t$, 1, 1)) 'grab pad number

    out$ = Space$(Len(t$) / 1.25 - 1): outb& = 1

    For i& = 2 To Len(in$) Step 5: v = 0
        For j& = 0 To 4: p& = 85 ^ (4 - j&)
            cv& = InStr(c$, Mid$(t$, i& + j&, 1)) - 1
            v = v + cv& * p&
        Next

        Mid$(out$, outb&, 4) = MKL$(v)
        outb& = outb& + 4

    Next
    Base85Decode$ = Mid$(out$, 1, Len(out$) - a + 1)
End Function

Print this item

  Update to _MEM examples in wiki
Posted by: SMcNeill - 09-23-2023, 02:45 AM - Forum: Wiki Discussion - Replies (2)

I was looking at our page on _MEM in the wiki this evening, and none of our examples would work 100% as written on it.  Our first example was using a LONG for reference as an _OFFSET, which isn't allowed.  The second example just didn't have much of an explanation to it and was confusing as written without some comments to showcase what it was trying to accomplish.  The third example fell victim to the the changes to recursive functionality, back around version 2.something, so it wouldn't work at all either.

https://qb64phoenix.com/qb64wiki/index.php/MEM

I've updated those examples.  Prettified them. (Thanks to Rho's "EXPORT AS WIKI PAGE" addition to the IDE -- that's an EXCELLENT addition/tool for us!!)  Take a look at them and let me know if they work as advertised now, and if they pretty much explain what each of them is trying to do and showcase for us.  

I'll make edits, updates, additions, whatever, as you guys suggest on them.  Wink

Print this item

  Binary file write
Posted by: eoredson - 09-23-2023, 02:44 AM - Forum: Help Me! - Replies (9)

Here is some annoying code for you:

Code: (Select All)
Type struct
    s As String
End Type

Dim structx As struct
structx.s = "abc": Print structx.s
Print Len(struct)
structx.s = "abcdef": Print structx.s
Print Len(struct)

Open "testfile.xxx" For Binary As #1
' UDT must have fixed size.
Put 1, 1, structx
Code: (Select All)
Dim x2(1 To 1024) As String
For l = 1 To 1024
    x2(l) = Str$(l)
Next
Open "filetest.xxx" For Binary As #1
' Cannot pass array of variable-length strings.
Put 1, 1, x2()
Maybe these can be tweaked someday!?

Erik.

Print this item

  cprint and cfprint text mode routines
Posted by: James D Jarvis - 09-23-2023, 12:02 AM - Forum: Utilities - Replies (14)

cprint and cfprint are 2 text mode routines that allow printing to specific location on a text screen (or text image) with colored text without changing global text values. cfprint prints in just a foreground text color without changing the existing background color at the location simulating a part of _printmode _keepbackground.  
there is also an "internal function" thebit$ that extracts a row of bits from a starting position to an end postion in a value. It is used here to read the background color for cfprint.

Code: (Select All)
Sub cprint (x, y, fg, bg, txt$)
    'print color text txt$ at location x,y color fg,bg without altering global color values
    'txt$ may  contain control characters without using  _controlchr
    'use on screen mode 0 screens only
    Dim o As _MEM
    ii& = _Dest
    o = _MemImage(ii&)
    w = (_Width(ii&)) * 2
    ts = (y - 1) * w + (x - 1) * 2
    n = 0
    If fg > 15 Then
        ff = fg - 16
        bb = 1
    Else
        ff = fg
        bb = 0
    End If
    c = bb * 128 + ff + bg * 16
    For cx = 1 To Len(txt$)
        v = Asc(Mid$(txt$, cx, 1))
        _MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
        _MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
    Next cx
    _MemFree o
End Sub
Sub cfprint (x, y, fg, txt$)
    'print color text txt$ at location x,y color fg without altering global color values or background colors under txt$
    'txt$ may  contain control characters without using  _controlchr
    'this simulates some of the behavior of _printmode _keepbackground
    'use on screen mode 0 screens only
    Dim o As _MEM
    ii& = _Dest
    o = _MemImage(ii&)
    w = (_Width(ii&)) * 2
    ts = (y - 1) * w + (x - 1) * 2
    n = 0
    If fg > 15 Then
        ff = fg - 16
        bb = 1
    Else
        ff = fg
        bb = 0
    End If
    For cx = 1 To Len(txt$)
        v = Asc(Mid$(txt$, cx, 1))
        c1 = _MemGet(o, o.OFFSET + ts + (cx - 1) * 2 + 1, _Unsigned _Byte)
        ccb$ = thebit$(c1, 6, 4)
        bg = Val("&B" + ccb$)
        c = bb * 128 + ff + bg * 16
        _MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
        _MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
    Next cx
    _MemFree o
End Sub
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

Print this item

  How to text and background colors in screen 0?
Posted by: James D Jarvis - 09-22-2023, 07:51 PM - Forum: Help Me! - Replies (3)

How do I get the color of text and the color of the background in screen 0 from a particular character? I figured out how to grab both  using mem but I'm not certain how to split those up from the value I grabbed.

Here's a sample program where a section of characters and the overall color attributes is read from a screen and saved into an array so the characters (with color attributes) can be reprinted elsewhere on the screen.  getctext let's me grab a run of characters and their overall color attributes. putctext let's me slap that run of characters back on the screen with the accurate color atributes but I'm just not sure how to break the color attributes apart.

Code: (Select All)
'$dynamic
ms = _NewImage(80, 28, 0)
Screen ms
Dim tx(0, 0)
Randomize Timer
For y = 1 To 12
    For x = 1 To 80
        Color Int(Rnd * 32), Int(Rnd * 16)
        _PrintString (x, y), Chr$(65 + Rnd * 26)
    Next x
Next y
getctext 1, 1, 960, ms, tx()
putctext 1, 15, tx(), ms




Sub getctext (x, y, cl, hndl, ar())
    'get text with color attributes from tetx screen at hndl upt ot cl charcaters starting at x,y and retunf that as a two dimensional array
    Dim o As _MEM
    ReDim ar(cl, 2)
    A$ = ""
    o = _MemImage(hndl)
    w = (_Width(hndl)) * 2
    ts = (y - 1) * w + (x - 1) * 2
    n = 0
    For px = 0 To (cl * 2 - 1) Step 2
        v = _MemGet(o, o.OFFSET + ts + px, _Unsigned _Byte) 'a PEEK
        c = _MemGet(o, o.OFFSET + ts + px + 1, _Unsigned _Byte)
        n = n + 1
        ar(n, 1) = v: ar(n, 2) = c
    Next px
    _MemFree o
End Sub
Sub putctext (x, y, ar(), hndl)
    'take a two dimensional array representing a colored text string ( ar() )  and place the charcters with proper color attributes on the screen
    Dim o As _MEM
    cl = UBound(ar)
    A$ = ""
    o = _MemImage(hndl)
    w = (_Width(hndl)) * 2
    ts = (y - 1) * w + (x - 1) * 2
    n = 0
    For cx = 1 To cl
        v = ar(cx, 1)
        c = ar(cx, 2)
        _MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
        _MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
    Next cx
    _MemFree o
End Sub


I'd also like to write a routine like this pritntctext(x,y,txt$,tcolor,bgcolor)  but I can't figure out how to correctly pull the text color and background colors out of that byte.   Anyone know how the color data is shoved in those 8 bits? I do know how it get and change bits , just not the order and how that one byte holds both the foreground and background.

Print this item

  SaveTextImage & LoadTextImage
Posted by: SMcNeill - 09-22-2023, 02:00 PM - Forum: SMcNeill - Replies (1)

A couple of quick little routines to grab a SCREEN 0 text screen and save it in extended binary format so it can be reloaded instantly with all its settings intact.  This is great for saving little splash screens for use with SCREEN 0 games, and it compresses all the relevant data down to a very trivial size for us.  

My 85 x 25 default size SCREEN 0 image here compresses down to all of 538 bytes for me -- and that's preserving all the screen data 100% perfectly.  There's no data corruption here from it confusing spaces for non-breaking spaces (chr$(255)) or null characters (chr$(0)).  It saves information for if you're using blinking values or not.  Everything which is normally in our SCREEN 0 memory is dumped to the drive with a short, descriptive header which helps set its proper sizes and such.  Run time is going to be minimal as it's just grabbing and moving a single chunk of _MEM data, saving and loading it for us.

Expect this to be expanded upon in the future, once we get some sort of _MemFont function in QB64PE, so that I can embed custom font data into these little snapshots and save them when we grab our images for loading back later.  Wink

Code: (Select All)
CLS , 4 'create a screen
FOR i = 0 TO 31
    COLOR i, 15 - (i MOD 16)
    LOCATE (i MOD 16) + 1, (i \ 16) * 40 + 1: PRINT "Hello Color"; i
NEXT
SaveTextImage 0, "TextScreen0.SAV" 'and save it to disk
SLEEP
CLS 'clear it so it's obvious what we load
SLEEP
foo = LoadTextImage("TextScreen0.SAV") 'load it back from disk
SCREEN foo
SLEEP


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

Like usual, I don't swear that it's 100% glitch free, but if you guys find an issue with these little routines, just report it and I'll fix whatever it is ASAP.

Print this item

  why am I seeing the spaces?
Posted by: James D Jarvis - 09-21-2023, 12:33 AM - Forum: Help Me! - Replies (10)

Why am I seeing the colored spaces in this program? Shouldn't     _printmode _keepbackground  be prohibiting this?


[Image: image.png]

Code: (Select All)
Screen _NewImage(512, 384, 32)
rootpath$ = Environ$("SYSTEMROOT") 'normally "C:\WINDOWS"
fontfile$ = rootpath$ + "\Fonts\comic.ttf" 'TTF file in Windows
style$ = "" 'font style is not case sensitive

f& = _LoadFont(fontfile$, 16, style$)
_Font f&
Line (1, 1)-(510, 382), _RGB32(50, 50, 50), BF
_PrintMode _KeepBackground
Color _RGB32(255, 255, 255), _RGB32(170, 70, 70)
Do
    Input txt$
    Print _PrintWidth(txt$), txt$
Loop Until txt$ = "END"

Print this item