Welcome, Guest |
You have to register before you can post on our site.
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
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.
|
|
|
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
|
|
|
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.
|
|
|
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.
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.
|
|
|
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?
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"
|
|
|
|