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

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

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:

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

_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

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.

'==========

'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

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. 

Here is some annoying code for you:

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.

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. 

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

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

Lesson22: Hardware Acceleration has been added to the tutorial.

You'll need to update your tutorial folder to get the new programs and assets included with lesson 22.

I've attached the updated tutorial.zip asset file below. Simply move the tutorial folder found in the ZIP file to your QB64 folder. If you already have the tutorial folder allow the files to be overwritten.

Attached Files

  tutorial.zip (Size: 34.91 MB / Downloads: 67)