Maybe this is how the forums are organized, or maybe it's just he kind of work(s) people make public... What I'm seeing is a lot of people have mastered the QB64 code snippet, demonstrating how to do this-or-that in isolation. What I'm looking for is the section where people's finished works are featured. Everything looks like a half-working program in progress, or a paste from something coded years ago without much regard for future integrations.
Where can I find the best, most polished programs written by the members, not just small demos?
Posted by: bplus - 06-01-2022, 01:21 AM - Forum: bplus
- No Replies
Oldie but goodie:
Code: (Select All)
Option _Explicit
_Title "b+QB64 Asteroids M11" 'started 2018-07-13
'2020 - Oct and Nov: Special thanks to SierraKen who has been helpful with suggestions, ideas and fixes.
Randomize Timer
' Far far away in a universe where Newton's 1st Law of Motion is not obeyed... ;-))
' New Controls
' key a or left arrow = turn left
' key s or right arrow = turn right
' enter or spacebar = "hyperspace" show up somewhere else better or worse use when collision is imminent
' key k or up arrow = thrust just a burst in direction you are pointed but doesn't last
' fire! owwha, owha, owha... is now continuous
' 2020-10-27 remove the alternate subs and get down below 200 LOC almost there now! new shooter action font and background
' 2020-10-28 another makeover explosions and split asteroids
' 2020-10-29 fix baby rock management, break between lives
' 2020-10-29 fix left/right gun, fix explosions over many frames to eliminate pause in action, speed up 60 fps
' 2020-10-30 m3 SierraKen's idea to angle shooter with mousewheel also finish WASD options, more rocks, points system
' points:
' The higher the speed the better speed range .5 to 2.5, diff = 2 * 50 = 100 s - .5 * 50
' DELETE The lower the color the better color range 10 to 60, diff = 50 * 2 = 100 50 - (c - 10) * 2
' The smaller the size the better size range 10 to 100, diff = 90 * 1.1111 = 100 90 - (sz -10) * 1.1111
' ((speed - .5) * 50 + (90 - (r - 10)) * 1.1111) / 2 = 100 best score per hit
' 2020-10-30 increase level of difficulty, fix double lives lost, add an ending after all lives spent.
' 2020-10-31 M4 They are Here - the aliens have accepted my invitaion for war games don't get caught in their beam.
' rework ending and variable LONG suffix. Aliens on the attack 100 points before or after transformed into the Bolder of Death.
' 2020-11-01 M5 FX Moving through space, Oh yeah, more aliens!
' 2020-11-01 M6 add play again and save high game , continuous shoot
' 2020-11-01 M7 fix hits count when hit alien ship or Bolder of Death. Fix lights on aliens ship. I want to see collsions with ship.
' Ken recommends removing text in middle of screen, yeah, distracting. Makeover ship as with mouse x, y it's center. Add Splash screen.
' Show mouse in between lives so can be in screen center when press key to start next run.
' 2020-11-03 M9 watching videos on Asteroids, I found a view and description of the control panel, it is:
' 2 buttons on left and lower button in middle and 2 buttons on right level with 2 on left.
' 2 buttons on left are left and right turns they will be Keys A and S
' The middle will be spacebar for Hypespace or these days we might call it worm hole, jump to another location better or worse!
' 2 buttons on right K and L: K will be a thruster of sorts you eventually come to a stop (not what Newton would like) L is the fire button.
' So let's try that. I am impressed by hitting thruster and shooting all around as you dift in direction gun was pointed when hit thruster.
' Lighten rocks and change points, based now only on size and speed of Asteroids.
' 2020-11-04 M9 Install new update to thrust control. Thanks to SierraKen for finding out what happened to Hyperspace jump when press
' spacebar a 2nd time in a life. Oh also Boulders of Death are now more like smooth colored spheres. Ahhhh Fixed the crashing at the borders
' now fly out one side and come back in on the other! This is getting good! Adding some sound effects.
' 2020-11-05 M10 set some constants for starting game so can just change them to level of play desired.
' speed points = 50 * (rockSpeed - minRockSpeed)/rockSpeedRange > fastest rock gets 50 points
' size points = 50 * (rockSizeRange - (rockSize - minRockSize))/rockSizeRange > smallest rock gets 50 points
' points = points + 50 * ( (rockSpeed - minRockSpeed)/rockSpeedRange + (rockSizeRange - (rockSize - minRockSize))/rockSizeRange )
' Dav's comments: Add arrow keys for left right turns and up for thrust, continuous fire now! A little score board in top left corner.
' Dav I am keeping spacebar for Hyperspace but also Enter, don't need fire button now.
' Try the A for left and the right arrow for right turns.
' 2020-11-05 p is for pause
' 2020-11-06 Move it or lose it!
' 2020-11-06 Put the dang mouse back in! Press m for mouse target rich environment! Use left and right mouse buttons to aim guns,
' 2020-11-08 add mouse mode you can enter at splash screen,
' 2021-09-24 b+QB64 Asteroids M11 best mouse only
' fix p for play again because it is also pause
' don't like enter to start next life, spacebar preferred
Type alienType
x As Single
y As Single
dx As Single
dy As Single
ls As Long ' lights offset and gray scale
c As _Unsigned Long ' color
live As Long
attackFrame As Long
fireX As Single
fireY As Single
transform As Long
End Type
Type particle
x As Single
y As Single
dx As Single
dy As Single
size As Single
kolor As _Unsigned Long
End Type
Type bullet
x As Single
y As Single
dx As Single
dy As Single
live As Long
End Type
Type shipType
x As Single
y As Single
live As Long
speed As Single ' just a constant now when Thrust is applied
thrustAngle As Single ' ship/gun angle at moment Thrust is pressed
angle As Single ' rotated position ship/gun now A or S keypress or hold down
thrust As Long ' this now tracks how many frames ship will move at speed and thrustAngle
End Type
Type rock
x As Single
y As Single
r As Long ' radius
ra As Single ' rotation position a = a + spin
heading As Single ' heading from which dx, dy are calc with speed
speed As Single ' speed
spin As Single ' rotation direction and amount
seed As Long ' for drawing rocks with RND USING
c As Long ' color rgb(c, c, c)
live As Long ' need this to track rocks still active like bullets
explodeFrame As Long ' after a rock is hit by bullet, it explodes and in more than one frame
End Type
ReDim Shared aliens(1 To 5) As alienType
Dim Shared dots(2000) As particle ' explosions
Dim Shared b(nBullets) As bullet
Dim Shared ship As shipType
Dim Shared r(nRocks) As rock
Dim Shared lives As Long
Dim Shared points As Long
Dim Shared rocks As Long 'rocks is the minimum number of parent rocks to have on screen automatic replace when hit or out of bounds
Dim HS As Long, fnt As Long, fnt2 As Long ' file LOAD handles
Dim i As Long, bullets As Long, fire As Long ' index and bullets
Dim r As Long, newRockN As Long, maxBabyRocks As Long, br As Long, hits As Long ' rock stuff
Dim ai As Long, alienN As Long ' alien index and number
Dim kh As Long 'key hit for ship thrust k or up arrow or hyperspace jump spacebar
Dim hs$, s$, k$, t, lastt 'high score, general string and times for bullets
Dim rockPoints As Long, roundPoints As Long ' various points scores
'Dim mouseMode As Long 'either key press hyperdrive and thrust or mouse moves
ship.speed = 3.5 'this would be a constant but ship has to declared as Ship Type first, Hyperspace jump
If _FileExists("Asteroids High Score.txt") Then
Open "Asteroids High Score.txt" For Input As #1
Input #1, HS
Close #1
End If
hs$ = "High Score:" + Str$(HS)
'a little splash screen
rocks = 7: alienN = 3
For i = 1 To nRocks
newRock i
If i > rocks Then r(i).live = 0
Next
For i = 1 To alienN
newAlien i
Next
i = 0
Do
drawStars 0
i = i + 1
If i Mod 30 = 29 And rocks < nRocks Then rocks = rocks + 1: r(rocks).live = 1
For r = 1 To nRocks
If r(r).live Then drawRock r
Next
For i = 1 To alienN
drawAliens i
Next
_Font fnt2
s$ = "*** b+QB64 Asteroids ***"
_PrintString ((_Width - _PrintWidth(s$)) / 2, 60), s$
_PrintString ((_Width - _PrintWidth(hs$)) / 2, 140), hs$
s$ = "A or arrow = Left Spin"
_PrintString ((_Width - _PrintWidth(s$)) / 2, 300), s$
s$ = "S or arrow = Right Spin"
_PrintString ((_Width - _PrintWidth(s$)) / 2, 380), s$
's$ = "Space or Enter = Hyper Jump"
'_PrintString ((_Width - _PrintWidth(s$)) / 2, 380), s$
s$ = "p = Pause or end Pause"
_PrintString ((_Width - _PrintWidth(s$)) / 2, 460), s$
s$ = "Mouse L/R Button = Guns"
_PrintString ((_Width - _PrintWidth(s$)) / 2, 540), s$
_Font fnt
If _KeyDown(27) Then System
k$ = InKey$
_Display
_Limit 60
Loop Until Len(k$)
_MouseHide
restart:
If _FileExists("Asteroids High Score.txt") Then
Open "Asteroids High Score.txt" For Input As #1
Input #1, HS
Close #1
End If
hs$ = " High Score:" + Str$(HS)
lives = 10: alienN = 1: rocks = startRocks ' always active rocks
points = 0: hits = 0: bullets = 0
'If k$ = "m" Then ' undocumented use of mouse
'mouseMode = -1:
alienN = 3: rocks = 5 ' M11 mouse mode assumed only other key is space or enter for hyper jump
'End If
While lives > 0 And _KeyDown(27) = 0 ' init start restart
ReDim aliens(1 To alienN) As alienType
For ai = 1 To alienN
newAlien ai
Next
For i = 1 To nRocks 'reset rocks mainly clear baby rocks
newRock (i)
If i > rocks Then r(i).live = 0
Next
ship.x = xmax / 2 'avoids explosions top left corner at start, dang still get some!
ship.y = ymax / 2
ship.angle = 0
ship.thrustAngle = 0
ship.thrust = 0
ship.live = 1
rockPoints = 0
roundPoints = 0
While ship.live And _KeyDown(27) = 0
For ai = 1 To alienN
drawAliens ai
Next
For i = 1 To nRocks
If r(i).live Then 'make sure if we crash into a ship it is a live rock, not one sitting on side waiting to be called up
drawRock i ' while drawing rocks the ship could be blown up
If ((r(i).x - ship.x) ^ 2 + (r(i).y - ship.y) ^ 2) ^ .5 < r(i).r + 20 Then 'rock collides with ship?
For br = 1 To 200 Step 5
Circle ((ship.x + r(i).x) / 2, (ship.y + r(i).y) / 2), br, _RGB32(255 - br, 255 - 2 * br, 0)
Next
drawRock i
drawship
ship.live = 0
If i <= rocks Then newRock i Else r(i).live = 0
End If
End If
Next
For i = 1 To nRocks 'smoke up the place with rock debris fields still flying out from hit frames ago
If r(i).explodeFrame Then
r(i).explodeFrame = r(i).explodeFrame + 1
If r(i).explodeFrame > .25 * r(i).r Then
r(i).explodeFrame = 0
If i <= rocks Then newRock i ' now replace the rock
Else
explode r(i).x, r(i).y, r(i).r, r(i).explodeFrame
End If
End If
Next
If ship.live Then
For ai = 1 To alienN
If Sqr((aliens(ai).x - ship.x) ^ 2 + (aliens(ai).y - ship.y) ^ 2) < 55 Then 'aliens and ship collisde boom boom
For br = 1 To 200 Step 5
Circle ((ship.x + aliens(ai).x) / 2, (ship.y + aliens(ai).y) / 2), br, _RGB32(255 - br, 255 - 2 * br, 0)
Next
drawship
ship.live = 0
_Continue
Else
drawship
End If
Next
'If mouseMode Then
While _MouseInput: Wend
ship.x = _MouseX: ship.y = _MouseY
If _MouseButton(1) Then ship.angle = pi
If _MouseButton(2) Then ship.angle = 0
'End If
' ship controls update
'a key or left arrow = left spin
If _KeyDown(97) Or _KeyDown(19200) Then ship.angle = ship.angle - pi / 48
's key or right arrow = right spin
If _KeyDown(115) Or _KeyDown(19712) Then ship.angle = ship.angle + pi / 48
'l is Fire! JUST CONTINUOUS FIRE
fire = 0
'IF _KEYDOWN(108) THEN
t = Timer(.01)
If lastt = 0 Or t - lastt > .15 Then fire = 1: Sound 2088, .01: lastt = t
'END IF
kh = _KeyHit
Select Case kh
Case 112 ' p for pause
kh = 0
While _KeyHit <> 112: _Limit 60: Wend
'Case 107, 18432 'thrust k key or up arrow
' If mouseMode = 0 Then
' Sound 488, .01
' ship.thrustAngle = ship.angle: ship.thrust = 120
' End If
'Case 13, 32 ' space = hyperspace jump
' 'If mouseMode = 0 Then
' Randomize Timer
' ship.x = (xmax - 300) * Rnd + 150: ship.y = (ymax - 300) * Rnd + 150: ship.thrust = 0
' 'End If
End Select
For i = 0 To nBullets ' handle bullets
If b(i).live = 0 And fire = 1 Then 'have inactive bullet to use
b(i).x = ship.x + 2 * bSpeed * Cos(ship.angle)
b(i).y = ship.y + 2 * bSpeed * Sin(ship.angle)
b(i).dx = bSpeed * Cos(ship.angle)
b(i).dy = bSpeed * Sin(ship.angle)
b(i).live = -1
bullets = bullets + 1
fire = 0
End If
If b(i).live Then 'new location
b(i).x = b(i).x + b(i).dx
b(i).y = b(i).y + b(i).dy
If b(i).x > 0 And b(i).x < xmax And b(i).y > 0 And b(i).y < ymax Then 'in bounds draw it
'bullet hit aliens?
For ai = 1 To alienN
If Sqr((aliens(ai).x - b(i).x) ^ 2 + (aliens(ai).y - b(i).y) ^ 2) < 30 Then
For br = 1 To 120
Circle (aliens(ai).x, aliens(ai).y), br / 3, plasma~&(0)
Next
_Display
_Delay .05
hits = hits + 1
roundPoints = roundPoints + 100
points = points + 100
aliens(ai).live = 0
newAlien ai
b(i).live = 0
_Continue
End If
Next
For r = 1 To nRocks 'check for collision with rock
If r(r).live Then
If Sqr((r(r).x - b(i).x) ^ 2 + (r(r).y - b(i).y) ^ 2) < r(r).r Then 'its a hit!
r(r).explodeFrame = 1 'linger with explosion
r(r).live = 0
hits = hits + 1
rockPoints = 50 * ((r(r).speed - minRockSpeed) / rockSpeedRange + (rockSizeRange - (r(r).r - minRockSize)) / rockSizeRange)
roundPoints = roundPoints + rockPoints
points = points + rockPoints
If r(r).r > 30 Then ' split rock into ? new ones
maxBabyRocks = Int((r(r).r - 10) / 10)
maxBabyRocks = irnd&(2, maxBabyRocks) ' pick a number of baby Rocks
For br = 1 To maxBabyRocks
' new rock
newRockN = freeRock& ' get inactive rock number
newRock newRockN ' new identity and activate
r(newRockN).r = (r(r).r - 10) / maxBabyRocks ' split in equal parts minus 20% mass
r(newRockN).x = r(r).x + irnd&(-30, 30) ' thrown from parent
r(newRockN).y = r(r).y + irnd&(-30, 30)
r(newRockN).c = r(r).c ' same color as parent
r(newRockN).heading = rrnd(ship.angle - .75 * pi, ship.angle + .75 * pi)
Next
End If ' big enough to split
b(i).live = 0 'kill bullet
End If ' hit rock
End If 'rock is there
Next ' rock
If b(i).live Then fcirc b(i).x, b(i).y, 3, _RGB32(255, 255, 0) 'draws bullet
Else
b(i).live = 0 'out of bounds
End If ' bullet is in bounds
End If ' bullet live
Next ' bullet
End If ' if ship still live
_Display
If ship.live = 0 Then
lives = lives - 1
If lives Mod 4 = 0 Then rocks = rocks + 1
If lives Mod 4 = 2 Then alienN = alienN + 1
s$ = "Lives:" + Str$(lives) + " Hits:" + Str$(hits) + " Bullets:" + Str$(bullets) + " Shooting:" + Str$(Int(hits * 100 / bullets)) + "%"
_PrintString ((_Width - _PrintWidth(s$)) / 2, ymax / 2 - 80), s$
_Font fnt2
s$ = Str$(points) + hs$
_PrintString ((_Width - _PrintWidth(s$)) / 2, ymax / 2), s$
_Font fnt
s$ = "Press enter to enter next life."
_PrintString ((_Width - _PrintWidth(s$)) / 2, ymax / 2 + 120), s$
_Display
kh = 0
While kh <> 13
kh = _KeyHit
Wend 'wait for enter key
Else
_Limit 60 ' if ship dies let's rest and regroup before restart next life
End If
Wend
_Display
Wend
If points > HS Then
Open "Asteroids High Score.txt" For Output As #1
Print #1, points
Close #1
End If
ship.x = -200: ship.y = -200 'get it out of the way
i = 0
Do
drawStars 0
i = i + 1
If i Mod 30 = 29 And rocks < nRocks Then rocks = rocks + 1: r(rocks).live = 1
For r = 1 To nRocks
If r(r).live Then drawRock r
Next
s$ = "Lives:" + Str$(lives) + " Hits:" + Str$(hits) + " Bullets:" + Str$(bullets) + " Shooting:" + Str$(Int(hits * 100 / bullets)) + "%"
_PrintString ((_Width - _PrintWidth(s$)) / 2, ymax / 2 - 80), s$
_Font fnt2
s$ = Str$(points)
If points > HS Then s$ = s$ + " a New Record!" Else s$ = Str$(points) + hs$
_PrintString ((_Width - _PrintWidth(s$)) / 2, ymax / 2), s$
_Font fnt
s$ = "Press q to quit, p or a to Play Again..."
_PrintString ((_Width - _PrintWidth(s$)) / 2, ymax / 2 + 120), s$
If _KeyDown(Asc("a")) Or _KeyDown(Asc("p")) Then GoTo restart
_Display
_Limit 60
Loop Until _KeyDown(Asc("q"))
System
Sub drawStars (moving)
Type starType
x As Single
y As Single
size As Single
c As Integer
End Type
Static beenHere, stars(200) As starType, cy As Long
Dim i As Long
If beenHere = 0 Then 'static part
For i = 0 To 100
stars(i).x = Rnd * xmax: stars(i).y = Rnd * ymax: stars(i).size = .3
stars(i).c = irnd&(80, 140)
Next
For i = 101 To 150
stars(i).x = Rnd * xmax: stars(i).y = Rnd * ymax: stars(i).size = .6
stars(i).c = irnd&(110, 170)
Next
For i = 151 To 195
stars(i).x = Rnd * xmax: stars(i).y = Rnd * ymax: stars(i).size = 1.2
stars(i).c = irnd&(140, 200)
Next
For i = 196 To 200
stars(i).x = Rnd * xmax: stars(i).y = Rnd * ymax: stars(i).size = 2.4
stars(i).c = irnd&(170, 235)
Next
cy = ymax / 2
beenHere = 1
End If
For i = 0 To cy
Line (0, i)-(xmax, i), _RGB32(0, 0, .1 * i + 4)
Line (0, ymax - i)-(xmax, ymax - i), _RGB(0, 0, .1 * i + 4)
Next
For i = 0 To 200
If moving Then
stars(i).x = stars(i).x + .2 * stars(i).size ^ stars(i).size
If stars(i).x > xmax Then stars(i).x = -1 * Rnd * 20
End If
fcirc stars(i).x, stars(i).y, stars(i).size, _RGB32(stars(i).c - 10, stars(i).c, stars(i).c + 10)
Next
End Sub
Sub newAlien (i As Long)
Dim side As Long, heading
Randomize Timer * Rnd 'to avoid making twins
side = irnd&(1, 4) 'bring rock in from one side, need to set heading according to side
If Rnd < .6 Then
aliens(i).fireX = ship.x: aliens(i).fireY = ship.y
Else
aliens(i).fireX = irnd(10, xmax - 10): aliens(i).fireY = irnd(10, ymax - 10)
End If
aliens(i).attackFrame = irnd(50, 400) ' EDIT a tweak to survive a little long before getting murdered with low lives over and over...
Select Case side
Case 1
aliens(i).x = -10
aliens(i).y = rrnd(80, ymax - 80)
Case 2
aliens(i).x = xmax + 10
aliens(i).y = rrnd(80, ymax - 80)
Case 3
aliens(i).x = rrnd(80, xmax - 80)
aliens(i).y = -10
Case 4
aliens(i).x = rrnd(80, xmax - 80)
aliens(i).y = ymax + 10
End Select
heading = _Atan2(aliens(i).fireY - aliens(i).y, aliens(i).fireX - aliens(i).x)
aliens(i).dx = alienSpeed * Cos(heading)
aliens(i).dy = alienSpeed * Sin(heading)
aliens(i).live = 0
aliens(i).transform = 0
aliens(i).c = _RGB32(irnd(128, 255), irnd(0, 255), irnd(0, 255))
End Sub
Function plasma~& (new As Long)
Static r, g, b, cnt, beenHere
If beenHere = 0 Or new Then
r = Rnd: g = Rnd: b = Rnd: beenHere = 1: cnt = 0
End If
cnt = cnt + .2
plasma~& = _RGB32(127 + 127 * Sin(r * cnt), 127 + 127 * Sin(g * cnt), 127 + 127 * Sin(b * cnt))
End Function
Sub drawAliens (i As Long) 'shipType
Dim light As Long, heading, r As Long, g As Long, b As Long
If aliens(i).live Then
Sound 6000 + i * 200, .07
If aliens(i).transform = 0 Then
r = _Red32(aliens(i).c): g = _Green32(aliens(i).c): b = _Blue32(aliens(i).c)
fellipse aliens(i).x, aliens(i).y, 6, 15, _RGB32(r, g - 120, b - 100)
fellipse aliens(i).x, aliens(i).y, 18, 11, _RGB32(r, g - 60, b - 50)
fellipse aliens(i).x, aliens(i).y, 30, 7, _RGB32(r, g, b)
For light = 0 To 5
fcirc aliens(i).x - 30 + 11 * light + aliens(i).ls, aliens(i).y, 1, _RGB32(aliens(i).ls * 50, aliens(i).ls * 50, aliens(i).ls * 50)
Next
aliens(i).ls = aliens(i).ls + 1
If aliens(i).ls > 5 Then aliens(i).ls = 0
Else
drawBall aliens(i).x, aliens(i).y, 30, aliens(i).c
End If
'time to shoot?
aliens(i).x = aliens(i).x + aliens(i).dx
aliens(i).y = aliens(i).y + aliens(i).dy
If Sqr((aliens(i).fireX - aliens(i).x) ^ 2 + (aliens(i).fireY - aliens(i).y) ^ 2) < 5 Then 'transform into the bolder of death
aliens(i).transform = 1
heading = _Atan2(ship.y - aliens(i).y, ship.x - aliens(i).x)
aliens(i).dx = 2.5 * Cos(heading)
aliens(i).dy = 2.5 * Sin(heading)
End If
If aliens(i).x < -10 Or aliens(i).x > xmax + 10 Then
If aliens(i).y < -10 Or aliens(i).y > ymax + 10 Then ' out of bounds goodbye bolder of death!
aliens(i).live = 0 'man we dodged a bullet here!!!!
newAlien i 'reset the trap
End If
End If
Else
If aliens(i).attackFrame Then
aliens(i).attackFrame = aliens(i).attackFrame - 1
If aliens(i).attackFrame = 0 Then
aliens(i).live = 1
End If
End If
End If
End Sub
Function freeRock&
Dim i As Long
For i = rocks + 1 To nRocks ' look for inactive rock number
If r(i).live = 0 And r(i).explodeFrame = 0 Then freeRock& = i: Exit Function
Next
End Function
Sub explode (x As Long, y As Long, r As Long, frm As Long)
Dim maxParticles As Long, i As Long, rounds As Long, loopCount As Long
maxParticles = r * 4
For i = 1 To r
NewDot i, x, y, r
Next
rounds = r
For loopCount = 0 To frm
If _KeyDown(27) Then End
For i = 1 To rounds
dots(i).x = dots(i).x + dots(i).dx
dots(i).y = dots(i).y + dots(i).dy
fcirc dots(i).x, dots(i).y, dots(i).size, dots(i).kolor
Next
If rounds < maxParticles Then
For i = 1 To r
NewDot (rounds + i), x, y, r
Next
rounds = rounds + r
End If
Next
End Sub
Sub NewDot (i As Long, x As Long, y As Long, r As Long)
Dim angle, rd
angle = pi * 2 * Rnd
rd = Rnd * 30
dots(i).x = x + rd * Cos(angle)
dots(i).y = y + rd * Sin(angle)
dots(i).size = Rnd * r * .05
rd = Rnd 'STxAxTIC recommended for rounder spreads
dots(i).dx = rd * 10 * (10 - 2 * dots(i).size) * Cos(angle)
dots(i).dy = rd * 10 * (10 - 2 * dots(i).size) * Sin(angle)
rd = 20 + Rnd * 70
dots(i).kolor = _RGBA32(rd, rd, rd, 80)
End Sub
Sub drawship 'simple red iso triangle pointed towards radianAngle
Dim x1 As Long, y1 As Long, x2 As Long, y2 As Long, x3 As Long, y3 As Long
Dim x4 As Long, y4 As Long, x5 As Long, y5 As Long
If ship.thrust > 0 Then
'burn out flame as thruster dies out
x4 = ship.x + .5 * ship.thrust * Cos(ship.angle - 17 / 18 * pi)
y4 = ship.y + .5 * ship.thrust * Sin(ship.angle - 17 / 18 * pi)
x5 = ship.x + .5 * ship.thrust * Cos(ship.angle - 19 / 18 * pi)
y5 = ship.y + .5 * ship.thrust * Sin(ship.angle - 19 / 18 * pi)
ftri ship.x, ship.y, x4, y4, x5, y5, &H99FFFF88
ship.thrust = ship.thrust - 1
End If
'draw ship dead or alive thrust or not, calculate 3 points of triangle ship
fcirc ship.x, ship.y, 30, &H05FFFFFF
x1 = ship.x + 30 * Cos(ship.angle) ' front point
y1 = ship.y + 30 * Sin(ship.angle) '
x2 = ship.x + 30 * Cos(ship.angle + .6666 * pi) ' wing
y2 = ship.y + 30 * Sin(ship.angle + .6666 * pi)
x3 = ship.x + 30 * Cos(ship.angle - .6666 * pi) ' other wing
y3 = ship.y + 30 * Sin(ship.angle - .6666 * pi)
ftri ship.x, ship.y, x1, y1, x2, y2, _RGB32(80, 120, 80, 80)
ftri ship.x, ship.y, x1, y1, x3, y3, _RGB32(60, 100, 60, 80)
Line (x1, y1)-(ship.x, ship.y), _RGB32(255, 255, 128)
Line (x1, y1)-(x2, y2), _RGB32(255, 180, 40)
Line (x1, y1)-(x3, y3), _RGB32(255, 180, 40)
End Sub
Sub drawRock (iRock)
Randomize Using r(iRock).seed 'this prevents having to save a particular sequence of random number
Dim dx, dy, j As Long, rRad As Single, leg As Single, x0 As Long, y0 As Long, rc As Long, c~&, x1 As Long, y1 As Long, xoff, yoff, i As Long
Dim x2 As Long, y2 As Long
dx = r(iRock).speed * Cos(r(iRock).heading)
dy = r(iRock).speed * Sin(r(iRock).heading) 'update location
r(iRock).ra = r(iRock).ra + r(iRock).spin
If r(iRock).x + dx + r(iRock).r < 0 Or r(iRock).x + dx - r(iRock).r > xmax Or r(iRock).y + dy + r(iRock).r < 0 Or r(iRock).y + dy - r(iRock).r > ymax Then
If iRock <= rocks Then newRock iRock Else r(iRock).live = 0
Exit Sub ' reassigned get out of here
Else
r(iRock).x = r(iRock).x + dx
r(iRock).y = r(iRock).y + dy
End If
For j = 10 To 3 Step -1 ' rock drawing (see demo program where developed code)
rRad = .1 * j * r(iRock).r
leg = rRad * (Rnd * .7 + .3)
x0 = r(iRock).x + leg * Cos(r(iRock).ra)
y0 = r(iRock).y + leg * Sin(r(iRock).ra)
rc = r(iRock).c + 30 * Rnd - 15
c~& = _RGB32(rc + 5, rc - 10, rc + 5)
x1 = x0
y1 = y0
xoff = Rnd * 20 - 10 + r(iRock).x
yoff = Rnd * 20 - 10 + r(iRock).y
For i = 1 To 12
leg = rRad * (Rnd * .35 + .65)
If i = 12 Then
x2 = x0: y2 = y0
Else
x2 = xoff + leg * Cos(i * polyAngle + r(iRock).ra)
y2 = yoff + leg * Sin(i * polyAngle + r(iRock).ra)
End If
ftri r(iRock).x, r(iRock).y, x1, y1, x2, y2, c~&
x1 = x2: y1 = y2
Next
Next
End Sub
Sub newRock (iRock)
Dim side As Long
Randomize Timer * Rnd 'to avoid making twins
side = irnd&(1, 4) 'bring rock in from one side, need to set heading according to side
Select Case side
Case 1
r(iRock).x = -100
r(iRock).y = rrnd(80, ymax - 80)
If Rnd < .25 Then r(iRock).heading = _Atan2(ship.y - r(iRock).y, ship.x - r(iRock).x) Else r(iRock).heading = 3 * pi / 2 + Rnd * pi
Case 2
r(iRock).x = xmax + 100
r(iRock).y = rrnd(80, ymax - 80)
If Rnd < .25 Then r(iRock).heading = _Atan2(ship.y - r(iRock).y, ship.x - r(iRock).x) Else r(iRock).heading = pi / 2 + Rnd * pi
Case 3
r(iRock).x = rrnd(80, xmax - 80)
r(iRock).y = -100
If Rnd < .25 Then r(iRock).heading = _Atan2(ship.y - r(iRock).y, ship.x - r(iRock).x) Else r(iRock).heading = Rnd * pi
Case 4
r(iRock).x = rrnd(80, xmax - 80)
r(iRock).y = ymax + 100
If Rnd < .25 Then r(iRock).heading = _Atan2(ship.y - r(iRock).y, ship.x - r(iRock).x) Else r(iRock).heading = pi + Rnd * pi
End Select
r(iRock).speed = rrnd(minRockSpeed, maxRockSpeed) 'speed, rotation angle, radius, gray coloring, spin, seed, hit for explosion
r(iRock).ra = Rnd * 2 * pi
r(iRock).r = irnd&(minRockSize * 3, maxRockSize) 'every parent rock can be split up into at least 2 - 10 size rocks
r(iRock).c = irnd&(60, 110) ' Ken request increase in rock color
r(iRock).spin = rrnd(-pi / 20, pi / 20)
r(iRock).seed = Int(Rnd * 64000) - 32000
r(iRock).explodeFrame = 0
r(iRock).live = 1
End Sub
Function irnd& (n1, n2) 'return an integer between 2 numbers
Dim l%, h%
If n1 > n2 Then l% = n2: h% = n1 Else l% = n1: h% = n2
irnd& = Int(Rnd * (h% - l% + 1)) + l%
End Function
Function rrnd (n1, n2) ' return number (expecting reals =_single, double, _float depending on default / define setup)
rrnd = (n2 - n1) * Rnd + n1
End Function
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim red As Long, grn As Long, blu As Long, rr As Long, f
red = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - rr / r
fcirc x, y, rr, _RGB32(red * f, grn * f, blu * f)
Next
End Sub
Sub fellipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
If xr = 0 Or yr = 0 Then Exit Sub
Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
Dim x As Long, y As Long
w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
Line (CX - xr, CY)-(CX + xr, CY), C, BF
Do While y < yr
y = y + 1
x = Sqr((h2w2 - y * y * w2) \ h2)
Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
Loop
End Sub
Sub ftri (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)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
Sub fcirc (x As Long, y As Long, R As Long, C As _Unsigned Long) 'vince version
Dim x0 As Long, y0 As Long, e As Long
x0 = R: y0 = 0: e = 0
Do While y0 < x0
If e <= 0 Then
y0 = y0 + 1
Line (x - x0, y + y0)-(x + x0, y + y0), C, BF
Line (x - x0, y - y0)-(x + x0, y - y0), C, BF
e = e + 2 * y0
Else
Line (x - y0, y - x0)-(x + y0, y - x0), C, BF
Line (x - y0, y + x0)-(x + y0, y + x0), C, BF
x0 = x0 - 1: e = e - 2 * x0
End If
Loop
Line (x - R, y)-(x + R, y), C, BF
End Sub
The zip has source and font file if you don't have Windows.
Option _Explicit
DefSng A-Z: DefLng I-N: DefStr S
Const TRUE = -1, FALSE = 0
Dim Shared mx, my, m1Hit, m1Rpt, m1Dn, m1End, m2Hit, m2Dn ' for MouseCk
_Title "MicroFontEditor"
Screen _NewImage(1024, 768, 256)
Color 0, 15
Cls
' == MAIN start ==
' 96 (16x6) (iCols, iRows) Characters, each has
' 24 (4x6) (ix, iy) Cells, each has
' 100 (10x10) (iu, iv) Pixels
Const nCols = 16, nRows = 6
Const xHI = 16 * 6, yHI = 6 * 8, uHI = xHI * 10, vHI = yHI * 10
Dim Shared s480 As String * 480, s5 As String * 5, sFont
Dim i, s, iCol, iRow, iu, iv, ix, iy, icolor, iBit
sFont = sFont + "€€€€€€€û€€€à€à€”¾”¾”ªÿª„¢„ˆ¢†¹Í²…€€ð€€€œ¢Á€€Á¢œ€ˆªœªˆˆˆ¾ˆˆ"
sFont = sFont + "€‡†€€ˆˆˆˆˆ€ƒƒ€€‚„ˆ ¾ÅÉѾ€¡ÿ¡ÃÅɱ¢ÉÉɶŒ”¤ÿ„úÉÉÉƾÉÉɦÃÄÈÐà"
sFont = sFont + "¶ÉÉɶ²ÉÉɾ€€¶€€€¶€€€ˆ”¢€€”””€€¢”ˆ€ ÀÅÈ°¾ÁÝż¿ÈÈÈ¿ÿÉÉɶ¾ÁÁÁ¢"
sFont = sFont + "ÿÁÁÁ¾ÿÉÉÉÁÿÈÈÈÀ¾ÁÁŦÿˆˆˆÿ€ÁÿÁ€‚ÁþÀÿˆ”¢Áÿÿ ÿÿ ˜„ÿ¾ÁÁÁ¾"
sFont = sFont + "ÿÄÄĸ¸ÄÄÄÿÿÈÌʱ²ÉÉɦÀÀÿÀÀþþü‚‚üþ†þÁ¶ˆ¶ÁÀ°°ÀÃÅÉÑကÿÁ€"
sFont = sFont + " ˆ„‚€Áÿ€€„ˆˆ„€Àà €‚•••þ‘‘‘ŽŽ‘‘‘‘Ž‘‘‘þŽ•••Œ€ˆ¿È ˆ•••Ž"
sFont = sFont + "ÿ€€Þ€€Þ€€ÿ„Š‘‘€€þŸŸŸˆŸŽ‘‘‘Ž’’’ŒŒ’’’Ÿˆˆˆ•••‚"
sFont = sFont + "€þ‘ž‚Ÿœ‚‚œž†ž‘Š„Š‘™……‚œ‘“•™‘€ˆ¶Á€€€÷€€€Á¶ˆ€ˆˆ„ˆˆ„ˆ"
s480 = sFont
doAllChars
For i = 0 To 127 ' axes labels
If i < 16 Then Locate 1, 2 + iLerpLH(5, 117, i, 0, 15): Print "x" + Hex$(i);
If i < 6 Then Locate 1 + iLerpLH(3, 28, i, 0, 5), 1: Print Hex$(i + 2) + "x";
Next i
' -- print static info
Locate 34, 1
Print " MicroFont V1.0" + Chr$(13)
Print " Use mouse to invert cell colors."
Print " Right-click to copy/paste a character"
Print " ESC to exit"
Do ' ------------- MAIN LOOP ------------------------
_Limit 300
MouseCk ' get mouse data
If iBox(64, 36, "Font (8 Strings) to clipboard") Then doCopyClip
If iBox(64, 37, "Load internal font") Then dofill 1
If iBox(64, 38, "Clear characters") Then dofill 0
If iBox(64, 39, "Random characters") Then dofill 2
' ----------- now look at the characters ------------
If Not isIn(mx, 26, 986) Or Not isIn(my, 26, 506) Then icolor = 99: GoTo Continue1
iCol = iLerpLH(0, 15, mx, 26, 986) ' 976 = 26+16*6*10; character column
iRow = iLerpLH(0, 5, my, 26, 506) ' 506 = 26+6*8*10; row
ix = iLerpLH(0, 5, (mx + 34) Mod 60, 0, 60) ' +34 = -26; cell x
iy = iLerpLH(0, 7, (my + 54) Mod 80, 0, 80) ' +54 = -36; y
If iCol > 15 Or iRow > 5 Or ix > 4 Or iy > 6 Then GoTo Continue1 ' is in borders
If m2Hit Then copyPaste: GoTo Continue1 ' copy/paste dialog
If m1Dn Then ' if mouse
If m1Hit Then ' get the inverse color
iBit = 1 - igetBit(iCol, iRow, ix, iy)
If iBit Then icolor = 0 Else icolor = 15
ElseIf icolor = 99 Then
GoTo Continue1 ' have no color
End If
setBit iCol, iRow, ix, iy, iBit
doCell iCol, iRow, ix, iy, icolor
End If
Continue1: ' -- end of character check
_Display
Loop While InKey$ <> Chr$(27)
System
' == ROUTINES start ==
Sub doAllChars ()
Dim iCol, iRow, ix, iy, icolor
For iRow = 0 To 5 ' character
For iCol = 0 To 15
For ix = 0 To 4 ' cell
For iy = 0 To 6
If igetBit(iCol, iRow, ix, iy) Then icolor = 0 Else icolor = 15
doCell iCol, iRow, ix, iy, icolor
Next iy
Next ix
Next iCol
Next iRow
End Sub
Sub doCell (iC, iR, iX, iY, icolor) ' draw rectangle, interior
Dim iu, iv
iu = 26 + (iC * 6 + iX) * 10: iv = 26 + (iR * 8 + iY) * 10
Line (iu, iv)-(iu + 10, iv + 10), 7, B
Line (iu + 2, iv + 2)-(iu + 10 - 2, iv + 10 - 2), icolor, BF
End Sub
Function igetBit (iC, iR, iX, iY) ' get bit; 0 or 1
Dim s1 As String * 1, imask, ich
s1 = Mid$(s480, 1 + (iC + iR * 16) * 5 + iX, 1)
imask = 2 ^ (6 - iY) ' 0-6: 1,2,4,8,16,32,64
ich = Asc(s1)
If (ich And imask) Then igetBit = 1 Else igetBit = 0
End Function
Sub setBit (iC, iR, iX, iY, iBit) ' set bit
Dim ipos, imask, icho, ich
ipos = 1 + (iC + iR * 16) * 5 + iX ' position of ch in s480
imask = 2 ^ (6 - iY) ' 0-6: 1,2,4,8,16,32,64
icho = Asc(Mid$(s480, ipos, 1)) ' ch from s480
ich = icho And (255 - imask) ' ch without bit
If iBit Then ich = ich Or imask ' OR bit
Mid$(s480, ipos, 1) = Chr$(ich)
End Sub
Sub copyPaste () ' copy/paste dialog
Dim iC, iR ' column, row
Play "v10t64l64c"
iC = iLerpLH(0, 15, mx, 26, 986) ' 976 = 26+16*6*10
iR = iLerpLH(0, 5, my, 26, 506) ' 506 = 26+6*8*10
s5 = Mid$(s480, 1 + (iC + iR * 16) * 5, 5) ' one character
Log "Right-click to paste or ESC to cancel"
Do ' -- copy/paste dialog
_Limit 30
MouseCk
If m2Hit Then
iC = iLerpLH(0, 15, mx, 26, 986) ' 976 = 26+16*6*10
iR = iLerpLH(0, 5, my, 26, 506) ' 506 = 26+6*8*10
Mid$(s480, 1 + (iC + iR * 16) * 5, 5) = s5 ' paste
doAllChars
Exit Do
End If
_Display
Loop Until InKey$ <> ""
Log ""
End Sub
Function iLerpLH (ivlo, ivhi, x, xlo, xhi) ' linear interp
Dim i
i = ivlo + Int((ivhi + 1 - ivlo) * (x - xlo) / (xhi - xlo))
If i > ivhi Then iLerpLH = ivhi Else iLerpLH = i
End Function
Sub Log (stxt)
Play "v10t64l64c"
If stxt = "" Then
Locate 34, 64: Print Space$(60);
Else
Color , 14: Locate 34, 64: Print stxt: Color , 15
End If
End Sub
Function iBox (iC, iR, sTxt) ' check box
Dim iu, iv
iu = iC * 8: iv = iR * 16
Line (iu + 1, iv - 15)-(iu + 17, iv - 1), 14, BF
Line (iu + 1, iv - 15)-(iu + 17, iv - 1), 0, B
Locate iR, iC + 4: Print sTxt;
If isInXY(mx, my, iu + 1, iv - 15, iu + 17, iv - 1) And m1Hit Then iBox = TRUE
End Function
Sub doCopyClip () ' copy font (8 strings) to clipboard
Dim i, s: For i = 1 To 480 Step 60
s = s + "sFont = sFont + " + Chr$(34) + Mid$(s480, i, 60) + Chr$(34) + Chr$(13)
Next i
_Clipboard$ = s
Log "Font copied to clipboard"
End Sub
Sub dofill (n) ' 0:Clear 1:internal 2: random
Dim i
Select Case n
Case 0: s480 = String$(480, &H80)
Case 1: s480 = sFont ' internal
Case 2: For i = 1 To 480 ' random
Mid$(s480, i, 1) = Chr$(128 + (127 * Rnd) And (127 * Rnd)) ' P(r*r) = .25
Next i
End Select
doAllChars
End Sub
Function isInXY (x, y, xlo, ylo, xhi, yhi)
If x >= xlo And x <= xhi And y >= ylo And y <= yhi Then isInXY = TRUE
End Function
Function isIn (x, a, b) ' ck between
If x >= a And x <= b Then isIn = TRUE
End Function
Function iMsecs () ' milliseconds since midnight UTC
iMsecs = Int(Timer(.001) * 1000 + .5)
End Function
' -- need Dim Shared mx,my,m1Hit,m1Rpt,m1Dn,m1End, m2Hit
Sub MouseCk () ' get mouse info
Static m1Prev, m2Prev, m1Time, m2Time ' for getting DownEdge (Hit) and Repeating
Dim mIn, isw1
m1Hit = 0: m1Rpt = 0: m1Dn = 0: m1End = 0: m2Hit = 0: m2Dn = 0
Do ' go thru all previous mouse data
mIn = _MouseInput
If mIn = 0 Then Exit Do
mx = _MouseX: my = _MouseY
Loop
If _MouseButton(1) Then ' Btn 1 down
m1Dn = TRUE
If Not m1Prev Then ' start of downtime
m1Hit = TRUE: m1Time = iMsecs + 250 ' delay 1/4 sec
Else ' has been down, ck for repeat
If iMsecs > m1Time Then m1Rpt = TRUE: m1Time = iMsecs + 50 ' repeat 20/sec
End If
m1Prev = TRUE ' for next time
Else ' Btn 1 up
If m1Prev Then m1End = TRUE ' end of downtime
m1Prev = FALSE ' for next time
End If
If _MouseButton(2) Then ' Btn 2 down
m2Dn = TRUE
If Not m2Prev Then ' start of downtime
m2Hit = TRUE
Else
m2Prev = FALSE ' for next time
End If
m2Prev = TRUE
Else
m2Prev = FALSE
End If
End Sub
Years ago you could see a single pixel. Nowadays you need a magnifying glass.
A dot-matrix 5x7 font was quite readable. Now it's a micro font.
Just what I wanted to label some things on my plots.
So I made a routine -- MicroFont.
It can be drawn anywhere on the screen.
MicroFont is a self-contained routine at the bottom of the program.
Code: (Select All)
MicroFont(string, ix, iy)
' where string is the text and ix,iy is where it is to be drawn.
The font is loaded once into a static variable.
This demo was the easy part - just using the font.
The hard part was making the font. I will post MicroFontEditor in a separate thread.
Code: (Select All)
_Title "MicroFont 1.0"
Option _Explicit
DefSng A-Z: DefLng I-N: DefStr S
Randomize Timer
Screen _NewImage(1024, 768, 256)
Color 0, 15
Cls
' == MAIN start ==
Dim Shared void, sWord, sWords(100), xy(100, 4), nWords
Dim i, nloop, velocity
Data Twas,brillig,and,the,slithy,toves,/
Data Did,gyre,and,gimble,in,the,wabe,/
Data All,mimsy,were,the,borogoves,/
Data And,the,mome,raths,outgrabe.,~
MicroFont "Demo of MicroFont", 440, 6 ' == DRAWS THE TITLE ==
Circle (440, 6), 2 ' shows the ix, iy used above
loadWords ' load data into array
Do ' == Main loop ==
_Limit 60
nloop = nloop + 1
If nloop = 180 Then velocity = .01 '
If nloop > 180 Then velocity = velocity * 1.01
If velocity > 1 Then velocity = 1
For i = 1 To nWords ' move all words
xy(i, 1) = xy(i, 1) + xy(i, 3) * velocity
xy(i, 2) = xy(i, 2) + xy(i, 4) * velocity
MicroFont sWords(i), xy(i, 1), xy(i, 2) ' draws individual words
If xy(i, 1) < 0 Then xy(i, 3) = Abs(xy(i, 3)) ' bounce
If xy(i, 2) < 6 Then xy(i, 4) = Abs(xy(i, 4))
If xy(i, 1) > 1000 Then xy(i, 3) = -Abs(xy(i, 3))
If xy(i, 2) > 767 Then xy(i, 4) = -Abs(xy(i, 4))
Next i
Loop While InKey$ = ""
System
Sub loadWords ()
Dim ang, ix, iy, sword: ix = 400: iy = 300
Do
Read sword
If sword = "~" Then Exit Do ' ck EOF
If sword = "/" Then ix = 400: iy = iy + 12: GoTo continue1 ' ck EOL
MicroFont sword, ix, iy ' == DRAWS ONE WORD ==
nWords = nWords + 1 ' into array for moving
sWords(nWords) = sword
xy(nWords, 1) = ix
xy(nWords, 2) = iy
ang = Rnd * 6.2832
xy(nWords, 3) = Cos(ang)
xy(nWords, 4) = Sin(ang)
ix = ix + Len(sword) * 6 + 5
continue1:
Loop
End Sub
DefStr S: DefLng I-N ' This is needed
Sub MicroFont (sstr, ixx0, iyy0) ' ==== THIS IS THE MicroFont ROUTINE ====
' -- prints string sstr at position ixx0 and iy0 --
Static sFont, s96
If sFont = "" Then ' load once only
sFont = sFont + "€€€€€€€û€€€à€à€”¾”¾”ªÿª„¢„ˆ¢†¹Í²…€€ð€€€œ¢Á€€Á¢œ€ˆªœªˆˆˆ¾ˆˆ"
sFont = sFont + "€‡†€€ˆˆˆˆˆ€ƒƒ€€‚„ˆ ¾ÅÉѾ€¡ÿ¡ÃÅɱ¢ÉÉɶŒ”¤ÿ„úÉÉÉƾÉÉɦÃÄÈÐà"
sFont = sFont + "¶ÉÉɶ²ÉÉɾ€€¶€€€¶€€€ˆ”¢€€”””€€¢”ˆ€ ÀÅÈ°¾ÁÝż¿ÈÈÈ¿ÿÉÉɶ¾ÁÁÁ¢"
sFont = sFont + "ÿÁÁÁ¾ÿÉÉÉÁÿÈÈÈÀ¾ÁÁŦÿˆˆˆÿ€ÁÿÁ€‚ÁþÀÿˆ”¢Áÿÿ ÿÿ ˜„ÿ¾ÁÁÁ¾"
sFont = sFont + "ÿÄÄĸ¸ÄÄÄÿÿÈÌʱ²ÉÉɦÀÀÿÀÀþþü‚‚üþ†þÁ¶ˆ¶ÁÀ°°ÀÃÅÉÑကÿÁ€"
sFont = sFont + " ˆ„‚€Áÿ€€„ˆˆ„€Àà €‚•••þ‘‘‘ŽŽ‘‘‘‘Ž‘‘‘þŽ•••Œ€ˆ¿È ˆ•••Ž"
sFont = sFont + "ÿ€€Þ€€Þ€€ÿ„Š‘‘€€þŸŸŸˆŸŽ‘‘‘Ž’’’ŒŒ’’’Ÿˆˆˆ•••‚"
sFont = sFont + "€þ‘ž‚Ÿœ‚‚œž†ž‘Š„Š‘™……‚œ‘“•™‘€ˆ¶Á€€€÷€€€Á¶ˆ€ˆˆ„ˆˆ„ˆ"
s96 = s96 + " !##$%&'()*+,-./0123456789:;<=>?"
s96 = s96 + "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_"
s96 = s96 + "`abcdefghijklmnopqrstuvwxyz{|}~"
Mid$(s96, 3, 1) = Chr$(34) ' fix quote "
End If ' end of once only
Dim iposStr, ipos96, ipos480, ix0, iy0, ix, iy, imask, ich
ix0 = ixx0 - 1: iy0 = iyy0 + 1 ' byValue
For iposStr = 1 To Len(sstr) ' one character at a time
ipos96 = InStr(1, s96, Mid$(sstr, iposStr, 1))
If ipos96 = 0 Then ipos96 = 4 ' invalid character -> #
ipos480 = (ipos96 - 1) * 5 ' index to sFont
For ix = 0 To 6: imask = 1 ' OxxxxxO 5 columns in character
If 1 <= ix And ix <= 5 Then ich = Asc(Mid$(sFont, ipos480 + ix, 1))
For iy = 0 To 8 ' OxxxxxxxO 7 rows in character
If ix < 1 Or ix > 5 Or iy < 1 Or iy > 7 Then
PSet (ix0 + ix, iy0 - iy), 15 ' BG
Else ' choose FG or BG
If ich And imask Then ' ck bit
PSet (ix0 + ix, iy0 - iy), 0 ' FG
Else
PSet (ix0 + ix, iy0 - iy), 15 ' BG
End If
imask = imask + imask ' next bit in column
End If
Next iy
Next ix
ix0 = ix0 + 6 ' next char output
Next iposStr
' could modify ix here
End Sub
hello. i downloaded the qb64 wiki with SMcNeill program, then i made a program to clean up the htmls files by removing a useless section at the end of the file. i converted the htmls files to pdfs. as a last step i created a script to assemble all the files into one. it's a big mass of information about qb64 offline. here's the result in case it could be useful to others :
hello Dav
I really really like to use your IDE for my qb64 programming
but i don't see a way to set Font size to something smaller
( easpecially when larger programs is case)
i use in my own editor Consolas 10 in my Windows programs
i specially like dark theme named "Davs Colors"
i remeber that you sayed ..you made it in Purebasic..
As much as it pains me to do so, guys, I'm afraid that I've got to let everyone know that signing up and becoming a wiki contributor/editor is no longer as easily possible as it used to be.
If you take a moment to click on the preview of the image above, you'll quickly see what the issue is: Spam bots are happily posting tons of worthless crap on the wiki endlessly. As quick as we can ban the idiotic things, they swap over to a new account and post something else.... BEEPING spam BEEPERS!!
So registrations are currently closed and the only way to become an editor of the wiki is to now request permissions here, or via our Discord, and make certain that either RhoSigma or I notice your posts. Accounts are now only created by those with sysop permission, and the only people who has that currently are the two of us. We're not trying to keep anyone from helping with the wiki, who legitimately wants to help with the wiki -- but we have to stop the bots from having such easy access to the site.
Apologies for any inconvenience, but I think everyone will understand why we've limited the account creation like we have.
So I'm writing a program that generates large bitmaps and I realized I have pushed my little laptop to the edge but it isn't consistent. I realized as I was falling asleep last night I had accidently used a tad bit more memory than I had originally planned.
Not posting a whole listing as that would be pointless at this stage.
Essentially I'm building a large bitmap by slapping together smaller bit maps. The smallest tiles are 16 x 16 pixels at 32bits.
The source bit maps are under 500K after they are loaded into the program.
Most of the image manipulation happens inside an integer array: Imap(1000,1000,7) ... That's 14MB + a bit of overhead (correct?).
It all builds an image that is up to dm&=_newimage(1000*16,1000*16,32) .... that's 1GB+ overhead (correct?).
I'd expect this to be slow and bog down my computer, it doesn't do so consistently. Undoubtedly due to how windows does memory management. I'm working on speeding it up but really am just asking if my rough memory estimates look correct. Or am I way off?
![[Image: image.png]](https://i.ibb.co/4NTGr7Z/image.png)
