Welcome, Guest |
You have to register before you can post on our site.
|
Latest Threads |
Trojan infection !
Forum: Help Me!
Last Post: PhilOfPerth
50 minutes ago
» Replies: 2
» Views: 52
|
_IIF limits two question...
Forum: General Discussion
Last Post: NakedApe
2 hours ago
» Replies: 10
» Views: 399
|
Curious if I am thinking ...
Forum: Help Me!
Last Post: bplus
3 hours ago
» Replies: 28
» Views: 318
|
Aloha from Maui guys.
Forum: General Discussion
Last Post: SMcNeill
5 hours ago
» Replies: 17
» Views: 488
|
Glow Bug
Forum: Programs
Last Post: SierraKen
9 hours ago
» Replies: 7
» Views: 112
|
ADPCM compression
Forum: Petr
Last Post: Petr
Yesterday, 03:13 PM
» Replies: 0
» Views: 34
|
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: dbox
Yesterday, 02:47 PM
» Replies: 15
» Views: 216
|
BAM Sample Programs
Forum: QBJS, BAM, and Other BASICs
Last Post: CharlieJV
Yesterday, 02:50 AM
» Replies: 36
» Views: 1,973
|
Audio storage, stereo swi...
Forum: Programs
Last Post: Petr
01-18-2025, 09:03 PM
» Replies: 8
» Views: 373
|
_CONSOLEINPUT is blocking
Forum: General Discussion
Last Post: mdijkens
01-18-2025, 12:24 PM
» Replies: 7
» Views: 134
|
|
|
Load Image 256 |
Posted by: Petr - 05-22-2022, 08:16 AM - Forum: Programs
- Replies (1)
|
|
Hi again.
This function is designed for you to load any image into 8-bit format. I used Ashish's conversion feature, which he published a long time ago, to convert. Here I did not try to speed it up, but to make it work so that any 32-bit image could actually be used as an 8-bit image.
The whole issue of 8-bit images faces one major drawback. If you do anything on an 8-bit screen, you have to compare the color palettes of all the images used so that they are the same and there is no color swapping. Thus, to make sure that, for example, the yellow color in one 8-bit frame does not have a palette number of, for example, 50, but in another frame else number. This needs to be considered when using 8-bit images.
Code: (Select All) 'LOADIMAGE256 experimental ver. 2.0
'1] Load image as 32 bit image
'2] find how much colors image contains. If 256 and less, continue. If more than 256, use Ashish's Dithering program, convert source image to 256 colors and call function LOADIMAGE256 again
'3] create 8 bit image and color palette
'4] THE PROGRAM DOES NOT RESPECT THE DEFAULT Qb64 COLOR PALETTE, Each image has its own!
Screen _NewImage(1700, 800, 256)
img8 = LOADIMAGE256("be.png")
_CopyPalette img8, _Dest
_PutImage (0, 0), img8
Function LOADIMAGE256 (img$)
DefLng A-Z
CompressIntensity = 5
image = _LoadImage(img$, 32)
ReStart: 'if image contains more than 256 colors, is function restarted after Floyd Steinberg Dithering is done by Ashish's function.
ReDim m As _MEM, clr8(255) As _Unsigned Long, Clr32 As _Unsigned Long, test As Long, s As Long
For s = 0 To 255
clr8(s) = 99999
Next s
m = _MemImage(image)
Do Until p& = m.SIZE
_MemGet m, m.OFFSET + p&, Clr32~&
test = 0
'this block prevent for writing the same color more than 1x to palette array
Do Until test > 255
If clr8(test) = Clr32~& Then GoTo NextColor
If clr8(test) = 99999 Then Exit Do
test = test + 1
Loop
'if is empty place in palette, save this color as next palette color
If test > 255 Then
Print "Image contains more than 256 colors, can not be directly copyed as 8 bit image. Using ASHISH's source for dithering... Compress intensity: "; CompressIntensity
img2 = FloydSteinbergDithering(image, CompressIntensity)
CompressIntensity = CompressIntensity - 1
_FreeImage image
image = img2
GoTo ReStart
End If
clr8(test) = Clr32
'color is saved as palette for 8 bit image
NextColor: p& = p& + 4
Loop
image8 = _NewImage(_Width(image), _Height(image), 256)
'set palette
Dim N As _MEM, C As _Unsigned _Byte
N = _MemImage(image8)
For palett = 0 To 255
_PaletteColor palett, clr8(palett), image8
Next
'create 8 bit mask (set colors 0 to 255 to 8 bit image)
For C = 255 To 0 Step -1
clr~& = clr8(C)
R& = 0
R8& = 0
Do Until R& = m.SIZE
_MemGet m, m.OFFSET + R&, Clr32
If Clr32 = clr~& Then _MemPut N, N.OFFSET + R8&, C
R& = R& + 4
R8& = R8& + 1
Loop
Next C
LOADIMAGE256 = _CopyImage(image8, 256)
_MemFree m
_MemFree N
_FreeImage image
_FreeImage image8
End Function
Function FloydSteinbergDithering& (img&, factor As Integer) 'This is not my source, its coded By Ashish
preDest = _Dest
preSource = _Source
Img32 = _CopyImage(img&)
_Dest Img32
_Source img&
For y = 0 To _Height(img&) - 1
For x = 0 To _Width(img&) - 1
col~& = Point(x, y)
oldR = _Red(col~&)
oldG = _Green(col~&)
oldB = _Blue(col~&)
newR = _Round(factor * (oldR / 255)) * (255 / factor)
newG = _Round(factor * (oldG / 255)) * (255 / factor)
newB = _Round(factor * (oldB / 255)) * (255 / factor)
errR = oldR - newR
errG = oldG - newG
errB = oldB - newB
col2~& = Point(x + 1, y)
r = _Red(col2~&) + errR * 7 / 16
g = _Green(col2~&) + errG * 7 / 16
b = _Blue(col2~&) + errB * 7 / 16
PSet (x + 1, y), _RGB(r, g, b)
col2~& = Point(x - 1, y + 1)
r = _Red(col2~&) + errR * 3 / 16
g = _Green(col2~&) + errG * 3 / 16
b = _Blue(col2~&) + errB * 3 / 16
PSet (x - 1, y + 1), _RGB(r, g, b)
col2~& = Point(x, y + 1)
r = _Red(col2~&) + errR * 5 / 16
g = _Green(col2~&) + errG * 5 / 16
b = _Blue(col2~&) + errB * 5 / 16
PSet (x, y + 1), _RGB(r, g, b)
col2~& = Point(x + 1, y + 1)
r = _Red(col2~&) + errR * 1 / 16
g = _Green(col2~&) + errG * 1 / 16
b = _Blue(col2~&) + errB * 1 / 16
PSet (x + 1, y + 1), _RGB(r, g, b)
PSet (x, y), _RGB(newR, newG, newB)
Next x, y
_Dest preDest
_Source preSource
FloydSteinbergDithering& = Img32
End Function
|
|
|
Knapsack 0-1 & rosettacode & qbasic qb64 & WE |
Posted by: DANILIN - 05-22-2022, 06:09 AM - Forum: Programs
- Replies (3)
|
|
Knapsack 0-1 & rosettacode & qbasic qb64 & WE
For all people: send yours algorithms to rosettacode
otherwise forum may disappear even in google search
Classic Knapsack problem is solved in many ways
Contents: http://rosettacode.org/wiki/Knapsack_problem
Long read: rosettacode.org/wiki/Knapsack_problem/0-1
Previous topics and long programs: Knapsack
https://qb64forum.alephc.xyz/index.php?topic=3091
Ordered Combinations Generator
https://qb64forum.alephc.xyz/index.php?topic=2999
My newest program synthesizes all ciphers from 0 & 1
adding an extra register and 0 remain on left in cipher
Number of comparisons decreases from N! to 2^N
for example N=5 N!=120 >> 2^N=32
Random values origin are automatically assigned
quantity and quality and integral of value is obtained
and in general: integral of quantity and quality
and it is possible to divide only anyone will not understand
Program write results to qb64 directory
Code: (Select All) Open "knapsack.txt" For Output As #1
N=7: L=5: a = 2^(N+1): Randomize Timer 'knapsack.bas DANILIN
Dim L(N), C(N), j(N), q(a), q$(a), d(a)
For m=a-1 To (a-1)/2 Step -1: g=m: Do ' sintez shifr
q$(m)=LTrim$(Str$(g Mod 2))+q$(m)
g=g\2: Loop Until g=0
q$(m)=Mid$(q$(m), 2, Len(q$(m)))
Next
For i=1 To N: L(i)=Int(Rnd*3+1) ' lenght & cost
C(i)=10+Int(Rnd*9): Print #1, i, L(i), C(i): Next ' origin
For h=a-1 To (a-1)/2 Step -1
For k=1 To N: j(k)=Val(Mid$(q$(h), k, 1)) ' from shifr
q(h)=q(h)+L(k)*j(k)*C(k) ' 0 or 1
d(h)=d(h)+L(k)*j(k)
Next
If d(h) <= L Then Print #1, d(h), q(h), q$(h)
Next
max=0: m=1: For i=1 To a
If d(i)<=L Then If q(i) > max Then max=q(i): m=i
Next
Print #1,: Print #1, d(m), q(m), q$(m): End
Main thing is very brief and clear to even all
Results is reduced manually:
Code: (Select All) 1 2 17
2 2 14
3 2 17
4 1 11
5 2 18
6 3 14
7 3 10
5 73 1101000
4 62 1100000
2 28 0100000
5 81 0011100 !!!
3 45 0011000
5 76 0010010
2 36 0000100
5 81 0011100
|
|
|
TCP/IP Printing |
Posted by: AtomicSlaughter - 05-21-2022, 09:53 PM - Forum: Utilities
- Replies (2)
|
|
Code: (Select All) Sub TCPPrint (IP As String, Port As String, toPrint As String)
CRLF$ = Chr$(10) + Chr$(13)
x = _OpenClient("TCP/IP:" + Port + ":" + IP)
toPrint = toPrint + CRLF$
Put #x, , CRFF$
End Sub
Sub TCPEndPrint (IP As String, Port As String)
CRFF$ = Chr$(10) + Chr$(12)
x = _OpenClient("TCP/IP:" + Port + ":" + IP)
Put #x, , CRFF$
End Sub
Utility for Sending raw text to a network printer via TCP/IP
Use the first sub to send the data, then when finished send the second sub and it will initiate the form feed and spit the sheet out.
|
|
|
Space(d) Invaders! |
Posted by: Cobalt - 05-21-2022, 09:44 PM - Forum: Works in Progress
- Replies (2)
|
|
SI_ResourcePack_1.MFI (Size: 2.1 MB / Downloads: 73)
With the weather what it is the past 2 days around my place I have taken a bit of a rest from workin to code a little something. Though its not quite done I thought I might share it with you folks and see what you think of it so far.
Space Invaders 2022.
Controls are pretty basic;
Right and Left arrow keys move your defense cannon.
Space bar shoots.
it does track your score, but there is only the initial wave to fight off. Its pretty bare bones at the moment too, so there is only the one scale and no options.
It has some issues with the invaders freezing from time to time. Almost like a time stop special, which I wish I could say was the intent. But alas I haven't quite figured out why they freeze for a very specific amount of time!
There is also the occasional collision issue where your shot will pass through an Invader. Probably because I'm using a very VERY basic POINT approach to detecting if the shot hits an Invader, so if it happens to find one of the blank pixels in the invaders then it will tend to miss. Just haven't added a secondary POINT detection to help fix that.
The Invaders also cannot hit you with their weapons yet, so your invincible at the moment.
Beyond some special graphical elements I would like to add that about all that is left to finish.
Don't forget the MFI file too.
Code: (Select All) 'Space Invaders 2022
'Cobalt
'QB64
TYPE Invader
X AS INTEGER
Y AS INTEGER
Type AS INTEGER
END TYPE
TYPE Player
X AS INTEGER 'where player is
Y AS INTEGER
Shot_X AS INTEGER 'where player's shot is
Shot_Y AS INTEGER '(only 1 at a time allowed)
Hit_X AS INTEGER
Hit_Y AS INTEGER
Hit_Time AS INTEGER
Special AS _BYTE
END TYPE
TYPE Shot
X AS INTEGER
Y AS SINGLE
Type AS _BYTE
END TYPE
TYPE Impacts
X AS INTEGER
Y AS INTEGER
Time AS _BYTE
END TYPE
TYPE Game
Lives AS _BYTE
Level AS _BYTE
Score1 AS LONG
Score2 AS LONG
HScore AS LONG
Frame AS _BYTE
Remain AS _BYTE 'invaders remaining
Speed AS _BYTE
Difficulty AS _BYTE
Win AS _BYTE
UFO AS _BYTE
UFO_Shot AS _BYTE
END TYPE
CONST TRUE = -1, FALSE = NOT TRUE
CONST Key_Right = 19712, Key_Left = 19200, Key_Up = 18432, Key_Down = 20480
CONST Key_Space = 32, Key_Enter = 13
DIM SHARED G AS Game, I(11, 5) AS Invader, P AS Player, P_Shot AS _BYTE
DIM SHARED Layer(8) AS LONG, SFX(16) AS LONG, BGM(4) AS LONG
DIM SHARED Shots(17) AS Shot, Shot_Count AS _BYTE, Hits(16) AS Impacts, Hit_Count AS _BYTE
DIM SHARED Ex AS Invader, Exploding AS _BYTE, UFO AS Invader
'init
RANDOMIZE TIMER
SCREEN _NEWIMAGE(640, 700, 32)
_SCREENMOVE 10, 5
Layer(0) = _DISPLAY
Layer(1) = _NEWIMAGE(640, 700, 32)
'Layer(2) = _LOADIMAGE("invaders.bmp", 32)
'Layer(3) = _LOADIMAGE("spaceinvaders.bmp", 32)
'Layer(4) = _LOADIMAGE("si_cpo.bmp", 32)
'Layer(5) = _LOADIMAGE("invaddx.bmp", 32)
Layer(6) = _NEWIMAGE(640, 700, 32) 'console build layer
Layer(7) = _NEWIMAGE(640, 700, 32) 'shield layer
Layer(8) = _NEWIMAGE(640, 700, 32) 'invader layer
'SFX(1) = _SNDOPEN("SI_shoot.wav")
'SFX(2) = _SNDOPEN("SI_invaderkilled.wav")
'SFX(3) = _SNDOPEN("SI_Explode.wav")
'SFX(4) = _SNDOPEN("SI_fastinvader1.wav")
'SFX(5) = _SNDOPEN("SI_fastinvader2.wav")
'SFX(6) = _SNDOPEN("SI_fastinvader3.wav")
'SFX(7) = _SNDOPEN("SI_fastinvader4.wav")
'SFX(8) = _SNDOPEN("SI_ufo_highpitch.wav")
'SFX(9) = _SNDOPEN("SI_ufo_lowpitch.wav")
MFI_Loader "SI_ResourcePack_1.MFI"
_SNDVOL SFX(1), .5
_SNDVOL SFX(2), .5
_SNDVOL SFX(3), .5
_SNDVOL SFX(4), .5
_SNDVOL SFX(5), .5
_SNDVOL SFX(6), .5
_SNDVOL SFX(7), .5
_SNDVOL SFX(8), .5
_SNDVOL SFX(9), .5
_CLEARCOLOR _RGB32(0), Layer(3)
_CLEARCOLOR _RGB32(4), Layer(3)
_CLEARCOLOR _RGB32(4), Layer(5)
_CLEARCOLOR _RGB32(0), Layer(7)
TAnimate& = _FREETIMER
TSound& = _FREETIMER
ON TIMER(TSound&, .3682) Play_BGS
ON TIMER(TAnimate&, .256) Flip_Frame
_TITLE "Space Invaders 2022"
_DELAY .25
'Build Arcade Console
_PUTIMAGE (0, 0)-STEP(639, 499), Layer(2), Layer(6)
_PUTIMAGE (0, 0)-STEP(639, 499), Layer(5), Layer(6)
_PUTIMAGE (0, 500)-STEP(639, 199), Layer(4), Layer(6), (0, 0)-STEP(5999, 1799)
SI_Print "p1-score", 192, 204, Layer(6)
SI_Print "hi-score", 288, 204, Layer(6)
SI_Print "p2-score", 384, 204, Layer(6)
'--------------------
FOR i%% = 0 TO 3
_PUTIMAGE (160 + 100 * i%%, 352)-STEP(23, 15), Layer(3), Layer(7), (254, 31)-STEP(23, 15)
NEXT i%%
G.Frame = FALSE
G.Remain = 55
G.Speed = 30
P.X = 164: P.Y = 380
FOR y%% = 0 TO 4
FOR x%% = 0 TO 10
I(x%%, y%%).X = 96 + 32 * x%%: I(x%%, y%%).Y = 320 - 20 * y%%: I(x%%, y%%).Type = y%% + 1
NEXT x%%, y%%
TIMER(TAnimate&) ON
TIMER(TSound&) ON
ClearLayerTrans Layer(8)
DO
_PUTIMAGE , Layer(6), Layer(1)
_PUTIMAGE , Layer(7), Layer(1)
FOR y%% = 0 TO 4: FOR x%% = 0 TO 10
PlaceInvader x%%, y%%
NEXT x%%, y%%
IF Move_Counter%% >= G.Speed THEN Move_Counter%% = 0: Move_Invaders
IF INT(RND * 100) >= 75 THEN Invader_Shot
IF NOT G.UFO THEN
IF INT(RND * 100) > 90 THEN
IF Last_UFO%% > 120 THEN 'Only 1 out of 120 ufos appear
Last_UFO%% = 0: Start_UFO
ELSEIF Last_UFO%% <= 120 THEN
Last_UFO%% = Last_UFO%% + 1
END IF
END IF
ELSEIF G.UFO THEN
Move_UFO
Draw_UFO
END IF
Move_Invader_Shot
Draw_Invader_Shot
IF Hit_Count THEN Age_Impacts 'if any hits then age them
IF P.Hit_Time THEN Age_Impact_Player
IF P_Shot THEN Move_Player_Shot
Draw_Impacts
IF P.Hit_Time THEN Draw_Impact_Player
Nul%% = Controls
IF P_Shot THEN Draw_Player_Shot
Draw_Player
IF Exploding THEN Draw_Explode_Invader
Display_Scores
_PRINTSTRING (0, 0), STR$(Last_UFO%%), Layer(8)
_PUTIMAGE , Layer(8), Layer(1)
_PUTIMAGE , Layer(1), Layer(0)
ClearLayerTrans Layer(8)
_LIMIT 60
Move_Counter%% = Move_Counter%% + 1
IF Nul%% = TRUE THEN ExitFlag%% = TRUE
IF G.Remain = 0 THEN ExitFlag%% = TRUE: G.Win = TRUE
LOOP UNTIL ExitFlag%%
STOP_ALL_SNDs
TIMER(TSound&) OFF
TIMER(TAnimate&) OFF
IF G.Win THEN SI_Print "you win!", 288, 304, Layer(0)
SUB Start_UFO
G.UFO = TRUE
IF INT(RND * 100) > 49 THEN
UFO.X = 112
UFO.Type = TRUE
_SNDLOOP SFX(8)
ELSE
UFO.X = 512
UFO.Type = FALSE
_SNDLOOP SFX(9)
END IF
UFO.Y = 224
END SUB
SUB Move_UFO
IF UFO.Type THEN 'moving left to right
UFO.X = UFO.X + 1
ELSE 'moving right to left
UFO.X = UFO.X - 2
END IF
IF INT(RND * 100) > 50 THEN UFO_Shoot
IF UFO.X < 112 OR UFO.X > 512 THEN
_SNDSTOP SFX(8): _SNDSTOP SFX(9)
G.UFO = FALSE
END IF
END SUB
SUB Draw_UFO
_PUTIMAGE (UFO.X, UFO.Y)-STEP(15, 7), Layer(3), Layer(8), (210, 39)-STEP(15, 7)
END SUB
SUB UFO_Shoot
IF UFO.X - 8 >= P.X AND UFO.X + 8 <= P.X + 16 AND G.UFO_Shot = FALSE THEN
Shots(Shot_Count).X = UFO.X + 8
Shots(Shot_Count).Y = UFO.Y + 8
Shots(Shot_Count).Type = 6
Shot_Count = Shot_Count + 1
G.UFO_Shot = TRUE
END IF
END SUB
FUNCTION Controls
Result%% = FALSE
IF _KEYDOWN(Key_Right) THEN
P.X = P.X + 2
IF P.X >= 500 THEN P.X = 500
END IF
IF _KEYDOWN(Key_Left) THEN
P.X = P.X - 2
IF P.X <= 128 THEN P.X = 128
END IF
IF _KEYDOWN(Key_Space) AND P_Shot = FALSE AND P.Hit_Time = 0 THEN Player_Shot
IF _KEYHIT = 27 THEN Result%% = TRUE
Controls = Result%%
END FUNCTION
SUB Player_Shot
_SNDPLAY SFX(1)
P_Shot = TRUE
P.Shot_X = P.X + 7
P.Shot_Y = P.Y
END SUB
SUB PlaceInvader (X%%, Y%%)
SELECT CASE I(X%%, Y%%).Type
CASE 0 'Dead
CASE 1, 2
IF G.Frame THEN
_PUTIMAGE (I(X%%, Y%%).X, I(X%%, Y%%).Y)-STEP(15, 7), Layer(3), Layer(8), (246, 1)-STEP(15, 7)
ELSE
_PUTIMAGE (I(X%%, Y%%).X, I(X%%, Y%%).Y)-STEP(15, 7), Layer(3), Layer(8), (246, 11)-STEP(15, 7)
END IF
CASE 3, 4
IF G.Frame THEN
_PUTIMAGE (I(X%%, Y%%).X, I(X%%, Y%%).Y)-STEP(15, 7), Layer(3), Layer(8), (228, 1)-STEP(15, 7)
ELSE
_PUTIMAGE (I(X%%, Y%%).X, I(X%%, Y%%).Y)-STEP(15, 7), Layer(3), Layer(8), (228, 11)-STEP(15, 7)
END IF
CASE 5
IF G.Frame THEN
_PUTIMAGE (I(X%%, Y%%).X, I(X%%, Y%%).Y)-STEP(15, 7), Layer(3), Layer(8), (210, 1)-STEP(15, 7)
ELSE
_PUTIMAGE (I(X%%, Y%%).X, I(X%%, Y%%).Y)-STEP(15, 7), Layer(3), Layer(8), (210, 11)-STEP(15, 7)
END IF
END SELECT
END SUB
SUB Move_Invaders
STATIC Direction%% 'direction of invader movement
DIM Score(11) AS _BYTE 'track how many invaders are in each column
IF Direction%% THEN 'TRUE
'move all invaders regaurdless of exsistance
FOR y%% = 0 TO 4
FOR x%% = 0 TO 10
I(x%%, y%%).X = I(x%%, y%%).X + 3
Score(x%%) = Score(x%%) + I(x%%, y%%).Type 'monitor how many invaders are in each column
NEXT x%%, y%%
FOR z%% = 10 TO 0 STEP -1 'check right to left if moving right
IF Score(z%%) THEN 'if there are still invaders in this Column
IF I(z%%, 0).X >= 528 THEN
Direction%% = NOT Direction%% 'reverse invader movement
FOR y%% = 0 TO 4
FOR x%% = 0 TO 10
I(x%%, y%%).Y = I(x%%, y%%).Y + 4 'lower invaders each pass
NEXT x%%, y%%
END IF
z%% = -1 'good column so quit after move
END IF
NEXT z%%
ELSE 'FALSE
'move all invaders regaurdless of exsistance
FOR y%% = 0 TO 4
FOR x%% = 0 TO 10
I(x%%, y%%).X = I(x%%, y%%).X - 3
Score(x%%) = Score(x%%) + I(x%%, y%%).Type 'monitor how many invaders are in each column
NEXT x%%, y%%
FOR z%% = 0 TO 10 'check left to right if moving left
IF Score(z%%) THEN 'if there are still invaders in this Column
IF I(z%%, 0).X <= 96 THEN
Direction%% = NOT Direction%% 'reverse invader movement
FOR y%% = 0 TO 4
FOR x%% = 0 TO 10
I(x%%, y%%).Y = I(x%%, y%%).Y + 4 'lower invaders each pass
NEXT x%%, y%%
END IF
z%% = 11 'good column so quit after move
END IF
NEXT z%%
END IF
END SUB
SUB SI_Print (Txt$, X%, Y%, L&)
L%% = LEN(Txt$)
FOR i%% = 1 TO L%%
SELECT CASE ASC(MID$(Txt$, i%%, 1))
CASE 32
X% = X% + 6
CASE 45
_PUTIMAGE (X%, Y%)-STEP(7, 7), Layer(3), L&, (220, 119)-STEP(7, 7)
X% = X% + 8
CASE 48 TO 57
_PUTIMAGE (X%, Y%)-STEP(7, 7), Layer(3), L&, (1 + (ASC(MID$(Txt$, i%%, 1)) - 48) * 10, 146)-STEP(7, 7)
X% = X% + 8
CASE 97 TO 122
_PUTIMAGE (X%, Y%)-STEP(7, 7), Layer(3), L&, (1 + (ASC(MID$(Txt$, i%%, 1)) - 97) * 10, 137)-STEP(7, 7)
X% = X% + 8
END SELECT
NEXT i%%
END SUB
SUB Display_Scores
SI_Print LTRIM$(STR$(G.Score1)), 192, 214, Layer(1)
SI_Print LTRIM$(STR$(G.HScore)), 288, 214, Layer(1)
SI_Print LTRIM$(STR$(G.Score2)), 384, 214, Layer(1)
END SUB
SUB Shot_Impact (id%%)
Hit_Count = Hit_Count + 1
Hits(Hit_Count).X = Shots(id%%).X - 2
Hits(Hit_Count).Y = Shots(id%%).Y
Hits(Hit_Count).Time = 30
END SUB
SUB Shot_Impact_Player
P.Hit_X = P.Shot_X - 2
P.Hit_Y = P.Shot_Y - 3
P.Hit_Time = 30
P_Shot = FALSE
END SUB
SUB Invader_Shot
FOR y%% = 0 TO 4
FOR x%% = 0 TO 10
IF I(x%%, y%%).Type THEN 'make sure invader is alive
IF INT(RND * 100) >= 99 THEN 'random chance of shot
IF INT(RND * 5) = 3 THEN
IF Shot_Count < 15 THEN 'is there room for a shot?
Shots(Shot_Count).X = I(x%%, y%%).X + 8
Shots(Shot_Count).Y = I(x%%, y%%).Y + 4
Shots(Shot_Count).Type = INT(RND * 3) + 1
Shot_Count = Shot_Count + 1
END IF
END IF
END IF
END IF
NEXT x%%, y%%
END SUB
SUB Move_Invader_Shot
FOR i%% = 1 TO Shot_Count
Shots(i%%).Y = Shots(i%%).Y + Shots(i%%).Type / 2
IF Shots(i%%).Y > 400 THEN 'ground\bottom of screen, remove shot
Shots(i%%).Type = 0
Shots(i%%).Y = 0
FOR z%% = i%% TO Shot_Count
SWAP Shots(z%%), Shots(z%% + 1)
NEXT z%%
Shot_Count = Shot_Count - 1
END IF
IF Collide_Invader_Shot(i%%) THEN 'did the invader's shot hit a sheild or player?
Shot_Impact i%%
IF Shots(i%%).Type = 6 THEN G.UFO_Shot = FALSE
Shots(i%%).Type = 0
Shots(i%%).Y = 0
FOR z%% = i%% TO Shot_Count
SWAP Shots(z%%), Shots(z%% + 1)
NEXT z%%
Shot_Count = Shot_Count - 1
END IF
NEXT i%%
END SUB
SUB Move_Player_Shot
P.Shot_Y = P.Shot_Y - 3
IF P.Shot_Y <= 200 THEN Shot_Impact_Player
Test%% = Collide_Player_Shot
IF Test%% = 1 THEN Shot_Impact_Player 'cause impact GFX to display
IF Test%% = TRUE THEN P_Shot = FALSE 'Invader explodes and shot stops
END SUB
SUB Explode_Invader (x%%, y%%)
_SNDPLAY SFX(2)
G.Remain = G.Remain - 1
Ex.Type = 24
Ex.X = I(x%%, y%%).X
Ex.Y = I(x%%, y%%).Y
Exploding = TRUE
END SUB
SUB Draw_Explode_Invader
Ex.Type = Ex.Type - 1
IF Ex.Type = 0 THEN Exploding = FALSE
_PUTIMAGE (Ex.X, Ex.Y)-STEP(15, 7), Layer(3), Layer(1), (264, 1)-STEP(15, 7)
END SUB
SUB Draw_Impacts
FOR i%% = 1 TO Hit_Count
IF Hits(i%%).Time >= 2 THEN
_PUTIMAGE (Hits(i%%).X, Hits(i%%).Y)-STEP(5, 7), Layer(3), Layer(7), (270, 21)-STEP(5, 7)
ELSE
_PUTIMAGE (Hits(i%%).X, Hits(i%%).Y)-STEP(5, 7), Layer(3), Layer(7), (277, 21)-STEP(5, 7)
END IF
NEXT i%%
_CLEARCOLOR _RGB32(1), Layer(7)
END SUB
SUB Draw_Impact_Player
IF P.Hit_Time > 1 THEN
_PUTIMAGE (P.Hit_X, P.Hit_Y)-STEP(5, 7), Layer(3), Layer(7), (270, 21)-STEP(5, 7)
ELSE
_PUTIMAGE (P.Hit_X, P.Hit_Y)-STEP(5, 7), Layer(3), Layer(7), (277, 21)-STEP(5, 7)
END IF
END SUB
SUB Draw_Invader_Shot
STATIC Frame AS _BYTE, FC AS _BYTE
FOR i%% = 1 TO 15
SELECT CASE Shots(i%%).Type
CASE 0 'no shot
CASE 1
_PUTIMAGE (Shots(i%%).X, Shots(i%%).Y)-STEP(2, 7), Layer(3), Layer(1), (210 + 5 * Frame, 21)-STEP(2, 7)
CASE 2
_PUTIMAGE (Shots(i%%).X, Shots(i%%).Y)-STEP(2, 7), Layer(3), Layer(1), (230 + 5 * Frame, 21)-STEP(2, 7)
CASE 3
_PUTIMAGE (Shots(i%%).X, Shots(i%%).Y)-STEP(2, 7), Layer(3), Layer(1), (250 + 5 * Frame, 21)-STEP(2, 7)
CASE 6
_PUTIMAGE (Shots(i%%).X, Shots(i%%).Y)-STEP(2, 7), Layer(3), Layer(1), (250 + 15 * Frame, 21)-STEP(2, 7)
END SELECT
NEXT i%%
FC = FC + 1
IF FC = 7 THEN Frame = Frame + 1: FC = 0
IF Frame = 4 THEN Frame = 0
END SUB
SUB Draw_Player
_PUTIMAGE (P.X, P.Y)-STEP(15, 7), Layer(3), Layer(1), (210, 49)-STEP(15, 7)
END SUB
SUB Draw_Player_Shot
_PUTIMAGE (P.Shot_X, P.Shot_Y)-STEP(2, 7), Layer(3), Layer(1), (250, 21)-STEP(2, 7)
END SUB
FUNCTION Collide_Invader_Shot%% (id%%)
IF _SOURCE <> Layer(7) THEN _SOURCE Layer(7)
IF _RED32(POINT(Shots(id%%).X, Shots(id%%).Y + (3 + (INT(RND * 6) - 3)))) > 1 THEN Result%% = TRUE
Collide_Invader_Shot = Result%%
END FUNCTION
FUNCTION Collide_Player_Shot%%
IF _SOURCE <> Layer(7) THEN _SOURCE Layer(7) 'check for shield impact
IF _RED32(POINT(P.Shot_X, P.Shot_Y)) > 1 THEN Result%% = 1
_SOURCE Layer(8) 'then check for invader hit
IF _RED32(POINT(P.Shot_X, P.Shot_Y)) > 0 OR _RED32(POINT(P.Shot_X, P.Shot_Y + 1)) > 0 THEN 'see which invader was hit
FOR y%% = 0 TO 4
FOR x%% = 0 TO 10
IF P.Shot_X >= I(x%%, y%%).X AND P.Shot_X <= I(x%%, y%%).X + 16 AND P.Shot_Y >= I(x%%, y%%).Y AND P.Shot_Y <= I(x%%, y%%).Y + 8 THEN
'found invader being hit
Hit_Invader x%%, y%%
y%% = 5
x%% = 11
Result%% = TRUE
END IF
NEXT x%%, y%%
'UFO being hit?
IF P.Shot_X >= UFO.X AND P.Shot_X <= UFO.X + 16 AND P.Shot_Y >= UFO.Y AND P.Shot_Y <= UFO.Y + 8 THEN
_SNDPLAY SFX(2)
Ex.Type = 24
Ex.X = UFO.X
Ex.Y = UFO.Y
Exploding = TRUE
Result%% = TRUE
G.Score1 = G.Score1 + 100
_SNDSTOP SFX(8): _SNDSTOP SFX(9)
G.UFO = FALSE
END IF
END IF
Collide_Player_Shot = Result%%
END FUNCTION
SUB Hit_Invader (X%%, Y%%)
STATIC Speedup AS _BYTE
SELECT CASE I(X%%, Y%%).Type
CASE 1, 2
G.Score1 = G.Score1 + 10
CASE 3, 4
G.Score1 = G.Score1 + 20
CASE 5
G.Score1 = G.Score1 + 30
END SELECT
Explode_Invader X%%, Y%%
I(X%%, Y%%).Type = 0
Speedup = Speedup + 1
IF Speedup = 2 THEN Speedup = 0: G.Speed = G.Speed - 1
END SUB
SUB Age_Impacts
FOR i%% = 1 TO Hit_Count
Hits(i%%).Time = Hits(i%%).Time - 1
IF Hits(i%%).Time = 0 THEN
Hits(i%%).Time = 0
Hits(i%%).Y = 0
FOR z%% = i%% TO Hit_Count
SWAP Hits(z%%), Hits(z%% + 1)
NEXT z%%
Hit_Count = Hit_Count - 1
END IF
NEXT i%%
END SUB
SUB Age_Impact_Player
IF P.Hit_Time THEN 'if the player has an impact out there.
P.Hit_Time = P.Hit_Time - 1
END IF
END SUB
SUB Flip_Frame
G.Frame = NOT G.Frame
END SUB
SUB ClearLayer (L&)
old& = _DEST
_DEST L&
CLS ' ,0
_DEST old&
END SUB
SUB ClearLayerTrans (L&)
old& = _DEST
_DEST L&
CLS , 0
_DEST old&
END SUB
SUB Play_BGS
STATIC current_sound AS _BYTE
SELECT CASE current_sound
CASE 0
_SNDPLAY SFX(4)
CASE 1
_SNDPLAY SFX(5)
CASE 2
_SNDPLAY SFX(6)
CASE 3
_SNDPLAY SFX(7)
current_sound = -1
END SELECT
current_sound = current_sound + 1
END SUB
SUB STOP_ALL_SNDs
FOR i%% = 0 TO 9
_SNDSTOP SFX(i%%)
NEXT i%%
END SUB
SUB MFI_Loader (FN$)
DIM Size(128) AS LONG, FOffset(128) AS LONG
OPEN FN$ FOR BINARY AS #1
GET #1, , c~%% 'retrieve number of files
FOR I~%% = 1 TO c~%%
GET #1, , FOffset(I~%%)
GET #1, , Size(I~%%)
FOffset&(I~%%) = FOffset&(I~%%) + 1
NEXT I~%%
Layer(2) = LoadGFX(FOffset(1), Size(1)) 'invaders
Layer(3) = LoadGFX(FOffset(2), Size(2)) 'spaceinvaders(sprites)
Layer(4) = LoadGFX(FOffset(3), Size(3)) 'console control board
Layer(5) = LoadGFX(FOffset(4), Size(4)) 'cabnet decal
SFX(1) = LoadSFX(FOffset(5), Size(5)) '_SNDOPEN("SI_shoot.wav")
SFX(2) = LoadSFX(FOffset(6), Size(6)) '_SNDOPEN("SI_invaderkilled.wav")
SFX(3) = LoadSFX(FOffset(7), Size(7)) '_SNDOPEN("SI_Explode.wav")
SFX(4) = LoadSFX(FOffset(8), Size(8)) '_SNDOPEN("SI_fastinvader1.wav")
SFX(5) = LoadSFX(FOffset(9), Size(9)) '_SNDOPEN("SI_fastinvader2.wav")
SFX(6) = LoadSFX(FOffset(10), Size(10)) '_SNDOPEN("SI_fastinvader3.wav")
SFX(7) = LoadSFX(FOffset(11), Size(11)) '_SNDOPEN("SI_fastinvader4.wav")
SFX(8) = LoadSFX(FOffset(12), Size(12)) '_SNDOPEN("SI_ufo_highpitch.wav")
SFX(9) = LoadSFX(FOffset(13), Size(13)) '_SNDOPEN("SI_ufo_lowpitch.wav")
CLOSE #1
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
END SUB
FUNCTION LoadGFX& (Foff&, Size&)
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
OPEN "temp.dat" FOR BINARY AS #3
dat$ = SPACE$(Size&)
GET #1, Foff&, dat$
PUT #3, , dat$
CLOSE #3
LoadGFX& = _LOADIMAGE("temp.dat", 32)
END FUNCTION
FUNCTION LoadFFX& (Foff&, Size&, Fize%%)
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
OPEN "temp.dat" FOR BINARY AS #3
dat$ = SPACE$(Size&)
GET #1, Foff&, dat$
PUT #3, , dat$
CLOSE #3
LoadFFX& = _LOADFONT("temp.dat", Fize%%, "monospace")
END FUNCTION
FUNCTION LoadSFX& (Foff&, Size&)
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
OPEN "temp.dat" FOR BINARY AS #3
dat$ = SPACE$(Size&)
GET #1, Foff&, dat$
PUT #3, , dat$
CLOSE #3
LoadSFX& = _SNDOPEN("temp.dat")
END FUNCTION
|
|
|
Long Date Function |
Posted by: AtomicSlaughter - 05-21-2022, 09:20 PM - Forum: Utilities
- Replies (2)
|
|
Code: (Select All) Function lDate$
p$ = "th"
If Val(Mid$(Date$, 4, 2)) <= 9 Then
day$ = Right$(Mid$(Date$, 4, 2), 1)
Else
day$ = Mid$(Date$, 4, 2)
End If
If Val(Mid$(Date$, 4, 2)) = 1 Or Val(Mid$(Date$, 4, 2)) = 21 Or Val(Mid$(Date$, 4, 2)) = 31 Then p$ = "st"
If Val(Mid$(Date$, 4, 2)) = 2 Or Val(Mid$(Date$, 4, 2)) = 22 Then p$ = "nd"
If Val(Mid$(Date$, 4, 2)) = 3 Or Val(Mid$(Date$, 4, 2)) = 23 Then p$ = "rd"
Select Case Val(Mid$(Date$, 1, 2))
Case 1: Month$ = "January"
Case 2: Month$ = "February"
Case 3: Month$ = "March"
Case 4: Month$ = "April"
Case 5: Month$ = "May"
Case 6: Month$ = "June"
Case 7: Month$ = "July"
Case 8: Month$ = "August"
Case 9: Month$ = "September"
Case 10: Month$ = "October"
Case 11: Month$ = "November"
Case 12: Month$ = "December"
End Select
lDate = day$ + p$ + " " + Month$ + " " + Mid$(Date$, 7, 4)
End Function
This code adds a function that will print a long date (21 February 2022) to the screen the instead of using date$ that would print 21-02-2022
|
|
|
What do you like to use for adding commas to numerical output? |
Posted by: Pete - 05-21-2022, 08:55 PM - Forum: General Discussion
- Replies (1)
|
|
I've never used PRINT USING in my programs, so I usually code something like this demo...
Code: (Select All) DIM a AS _INTEGER64
DO
INPUT a
a$ = LTRIM$(STR$(ABS(a)))
j = LEN(a$) MOD 3: IF j = 0 THEN j = 3
DO UNTIL j >= LEN(a$)
a$ = MID$(a$, 1, j) + "," + MID$(a$, j + 1)
j = j + 4
LOOP
IF a < 0 THEN a$ = "-" + a$
PRINT a$ ' Output with commas.
LOOP
Pete
|
|
|
INIEditor |
Posted by: AtomicSlaughter - 05-21-2022, 08:40 PM - Forum: Utilities
- No Replies
|
|
Code: (Select All) Type Sections
lineNum As Integer
section As String
End Type
Sub LoadINIFile (FileName As String, iniData() As String, iniSections() As Sections)
ReDim As String iniData(0)
ReDim As Sections iniSections(0)
If _FileExists(FileName) Then
file = FreeFile
Open FileName For Binary As #file
If LOF(file) = 0 Then Exit Sub
Do
Line Input #file, iniData(UBound(iniData))
If InStr(iniData(UBound(iniData)), "[") > 0 Then
iniSections(UBound(iniSections)).section = iniData(UBound(iniData))
iniSections(UBound(iniSections)).lineNum = x
ReDim _Preserve As Sections iniSections(UBound(iniSections) + 1)
End If
ReDim _Preserve iniData(UBound(iniData) + 1)
x = x + 1
Loop Until EOF(file)
Close
End If
iniSections(UBound(iniSections)).section = "End of File"
iniSections(UBound(iniSections)).lineNum = x
End Sub
Sub CheckSection (sec() As Sections, check As String, out1 As Single, out2 As Single, Ret As String)
For i = 0 To UBound(sec)
If LCase$(sec(i).section) = "[" + LCase$(check) + "]" Then
out1 = sec(i).lineNum + 1
out2 = sec(i + 1).lineNum - 1
Print out1, out2
Exit Sub
End If
Next
Ret = "New Section"
End Sub
Function ReadINI$ (FileName As String, Section As String, INIKey As String)
Dim sec(0) As Sections: Dim ini(0) As String
Dim As Single start, finish
LoadINIFile "Config.ini", ini(), sec()
If Section <> "" Then
CheckSection sec(), Section, start, finish, ret$
For i = start To finish
If Left$(LCase$(ini(i)), InStr(ini(i), "=") - 1) = LCase$(INIKey) Then
ReadINI = Right$(ini(i), (Len(ini(i)) - InStr(ini(i), "=")))
End If
Next
Else
Do
If Left$(LCase$(ini(i)), InStr(ini(i), "=") - 1) = LCase$(INIKey) Then
ReadINI = Right$(ini(i), (Len(ini(i)) - InStr(ini(i), "=")))
End If
i = i + 1
Loop Until ini(i) = ""
End If
End Function
Sub DelINI (FileName As String, Section As String, INIKey As String)
Dim sec(0) As Sections: Dim ini(0) As String
Dim As Single start, finish
LoadINIFile "Config.ini", ini(), sec()
If Section <> "" Then
CheckSection sec(), Section, start, finish, ret$
For i = start To finish
If Left$(LCase$(ini(i)), InStr(ini(i), "=") - 1) = LCase$(INIKey) Then
ReDim temp(UBound(ini) - 1) As String
For a = 0 To (i - 1)
temp(a) = ini(a)
Next
For a = i To UBound(temp)
temp(a) = ini(a + 1)
Next
End If
Next
Else
Do
If Left$(LCase$(ini(i)), InStr(ini(i), "=") - 1) = LCase$(INIKey) Then
ReDim temp(UBound(ini) - 1) As String
For a = 0 To i - 1
temp(a) = ini(a)
Next
For a = x To UBound(ini)
temp(x) = ini(x + 1)
Next
End If
i = i + 1
Loop Until ini(i) = ""
End If
Do
If temp(UBound(temp)) = "" Then ReDim _Preserve temp(UBound(temp) - 1)
Loop Until temp(UBound(temp)) <> ""
f = FreeFile
Open FileName For Output As #f
For i = 0 To UBound(temp)
Print #f, temp(i)
Next
Close
End Sub
Sub DelSec (FileName As String, Section As String)
Dim sec(0) As Sections: Dim ini(0) As String
Dim As Single start, finish
LoadINIFile "Config.ini", ini(), sec()
CheckSection sec(), Section, start, finish, ret$
Print start, finish
ReDim Temp(UBound(ini)) As String
For i = 0 To start
Temp(i) = ini(i)
Next
For i = finish To UBound(ini)
Temp(i - finish) = ini(i)
Next
Do
If Temp(UBound(Temp)) = "" Then ReDim _Preserve Temp(UBound(Temp) - 1)
Loop Until Temp(UBound(Temp)) <> ""
f = FreeFile
Open FileName For Output As #f
For i = 0 To UBound(Temp)
Print #f, Temp(i)
Next
Close
End Sub
Sub AddINI (FileName As String, Section As String, INIKey As String, INIData As String)
Dim sec(0) As Sections: Dim ini(0) As String
Dim As Single start, finish
LoadINIFile "Config.ini", ini(), sec()
CheckSection sec(), Section, start, finish, ret$
ReDim temp(UBound(ini) + 1) As String
If ret$ = "New Section" Then
ReDim temp(UBound(ini) + 3)
temp(0) = "[" + Section + "]"
temp(1) = INIKey + "=" + INIData
temp(2) = ""
For i = 3 To UBound(ini)
temp(i) = ini(i - 3)
Next
Else
If Section <> "" Then
For i = 0 To start
'Print ini(start): Sleep
temp(i) = ini(i)
Next
temp(start) = INIKey + "=" + INIData
For i = start + 1 To UBound(ini)
temp(i) = ini(i - 1)
Next
Else
temp(0) = INIKey + "=" + INIData
For i = 1 To UBound(ini)
temp(i) = ini(i - 1)
Next
End If
End If
Do
If temp(UBound(temp)) = "" Then ReDim _Preserve temp(UBound(temp) - 1)
Loop Until temp(UBound(temp)) <> ""
f = FreeFile
Open FileName For Output As #f
For i = 0 To UBound(temp)
Print #f, temp(i)
'Print temp(i): _Delay 1
Next
Close
End Sub
A Simple Ini Editor for qb64
|
|
|
Adding more Logical Operators |
Posted by: Dimster - 05-21-2022, 08:05 PM - Forum: General Discussion
- Replies (15)
|
|
Would it be difficult to add more logical operators to the QB64 language?
I often come across math formulas which use some hieroglyics that I'm constantly looking us to decipher. When it comes to logical operators I see them so often I sometimes wonder if they may be useful in QB64. For example, a couple of them are:
V means the logical OR, so it would be "A V B" v's "A OR B". The inverted V means AND
A pyramid of dots . means "THEREFORE", so "HM = M and S = M . S = HM"
. . . .
(sorry, my depiction of a pyramid of dots leaves a lot to be desired)
And the inverse of the pyramid of dots means "Because" or "Since"
There are more, like << which means "much less than" and >> meaning "much more than" but I find personally I don't need those very much. The V and inverted V (or rotated 180 degree V) are just a short form of OR and AND so perhaps not as revolutionary for QB64, but the pyramid of dots may help with using the logical operator of IMP. (IMP being my pet peeve)
Is it too difficult to add more Logical Operators to QB64 math arsenal?
|
|
|
|