| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
| Lprinting printer control codes? |
|
Posted by: arnoldhf - 08-03-2022, 08:03 PM - Forum: Help Me!
- Replies (13)
|
 |
I found this under LPRINT:
- Note: Printer escape codes starting with CHR$(27) will not work with LPRINT and may produce text printing errors.
In my QBasic program I made extensive use of ESC for font changes, orientation changes, box shading (many times I did these on the same page as needed), etc.,
In QB64, chr$(27) sent to printer only results in a left arrow character.
these are just some:
LPrint Chr$(27); "&l1E"; 'move to top of page
LPrint Chr$(27); "&l64F"; 'set text length to 64 lines
10 courier10$ = Chr$(27) + "(11U" + Chr$(27) + "(s0p10.00h10.0v0s0b3T" ' courier 10 pitch
LPrint courier10$;
12 courier12$ = Chr$(27) + "(11U" + Chr$(27) + "(s0p12.00h10.0v0s0b3T"
LPrint courier12$;
17 courier17$ = Chr$(27) + "(11U" + Chr$(27) + "(s0p16.67h8.5v0s0b0T"
LPrint courier17$;
110 courierbold10$ = Chr$(27) + "(11U" + Chr$(27) + "(s0p10.00h10.0v0s3b3T"
111 LPrint courierbold10$;
210 courierbold12$ = Chr$(27) + "(11U" + Chr$(27) + "(s0p12.00h10.0v0s3b3T"
211 LPrint courierbold12$;
Any way I can send "printer" command codes like these to the printer in QB64 or accomplish the same results in another fashion?
Thanks,
Arnold
|
|
|
| Functional sound equalization live! |
|
Posted by: Petr - 08-03-2022, 03:56 PM - Forum: Programs
- Replies (22)
|
 |
Hi. I'll put it this way. It's all in the patterns. All of this is contained directly in the sound samples that you load via memsound. The whole science is that you have to create an empty sound signal (basically silence), which must have a sufficient frequency so that the resulting sound does not pulsate. You then modulate this empty signal with the volume of the source signal. Of course, if you use subsampling (this case) you can change the frequency. I will still work on the way to the depths, with the highest probability the intermediate sample will have to be calculated and added to the empty signal.
Just write a valid name of your audio file in the source code. Then run it and use the mouse wheel. Eq level = 100 percent means that the treble is fully equalized.
To be continued again sometime next time. I'm currently concreting the foundations of the fence (today the concrete hardens, so I hopped over to this forum), I don't have time for programming, I'm on my own. Have a nice day.
Edit: Source code updated (SIN is not need...)
Code: (Select All) 'small sound equalizing example writed by Petr Preclik 03-08-2022 (dd-mm-yyyy)
$NoPrefix
Dim a As MEM, a2 As MEM, j As Long, Eq As Double
Dim As Integer Il, Ir, Il2, Ir2
s = SndOpen("b.mp3") 'insert your music file name here
a = MemSound(s, 1)
a2 = MemSound(s, 2)
f = 1
Eq = 1.7
Print "Use the mouse wheel to reduce/add the treble of the sound!"
Do Until j = a.SIZE - 2
MemGet a, a.OFFSET + j, Il
MemGet a, a.OFFSET + j + 2, Ir
MemGet a2, a2.OFFSET + j, Il2
MemGet a2, a2.OFFSET + j + 2, Ir2
j = j + 2
frL = f * (Il / -32768) + f * ((Ir / 32768) / Eq) 'create new silent empty signal. Volume in our new empty signal is drived by volume in original sound file.
frR = f * (Il2 / -32768) + f * ((Ir2 / 32768) / Eq)
SndRaw frL, frR
Do Until SndRawLen = 0
Mouse Mw
Eq = Eq + Mw
Eq = MINMAX(1, 2, Eq)
Locate 3
sLevel = Int((2 - Eq) * 100)
Print "Eq level:"; sLevel; "% "
Loop
Loop
Function MINMAX (Minimum_Value, Maximum_Value, Current_Value)
MINMAX = Current_Value
If Current_Value > Maximum_Value Then MINMAX = Maximum_Value
If Current_Value < Minimum_Value Then MINMAX = Minimum_Value
End Function
Sub Mouse (Mw)
Mw = 0
While MouseInput
Mw = MouseWheel / 10
Wend
End Sub
|
|
|
|
| 3D Orbiting Text |
|
Posted by: SierraKen - 08-03-2022, 03:38 AM - Forum: Programs
- Replies (4)
|
 |
Almost all of this code comes from my Earth and Moon orbiting app I made a couple weeks ago. I decided to make it so you can add text that orbits the Sun instead of Earth. It uses the Comic Sans font. Thanks to Steve for the array idea for the font sizes! Tell me what you think. The text itself doesn't bend or turn, but it does change sizes as it goes away and comes back. You can choose anything up to 5 letters, numbers, or characters in the beginning. To restart and use different text, press the Space Bar.
Code: (Select All) '3D Orbiting Text by SierraKen
'Made on August 2, 2022.
'Thanks to Steve for the font array idea!
Dim starx(1000), stary(1000)
Dim dx(1000), dy(1000)
Dim sz(1000)
Dim speed(1000)
Dim cx As Integer, cy As Integer, ra As Integer, cl As _Unsigned Long
Dim Font(8) As Long
_Title "3D Orbiting Text by SierraKen - Press Space Bar to restart"
Screen _NewImage(800, 600, 32)
Font(0) = _LoadFont("Comic.ttf", 10)
Font(1) = _LoadFont("Comic.ttf", 12)
Font(2) = _LoadFont("Comic.ttf", 14)
Font(3) = _LoadFont("Comic.ttf", 16)
Font(4) = _LoadFont("Comic.ttf", 18)
Font(5) = _LoadFont("Comic.ttf", 22)
Font(6) = _LoadFont("Comic.ttf", 24)
Font(7) = _LoadFont("Comic.ttf", 26)
start:
f = 5
_Font Font(f)
t = 1800
x = 400: y = 300: r = 50
t2 = 1800
cc4 = 100
cc5 = 100
Cls
start2:
Color _RGB32(255, 255, 255)
Print: Print
Print "Type any 5 letter or less word, number, or characters: "
Input text$
Print: Print
If Len(text$) > 5 Then Print "Too long, try again.": GoTo start2:
If Len(text$) < 1 Then Print "You didn't type anything, try again.": GoTo start2:
Cls
Do
_Limit 20
a$ = InKey$
If a$ = Chr$(27) Then End
If a$ = " " Then GoTo start:
'Starfield
fillCircle cx, cy, 5, cl
If sp < .0005 Then sp = .0005
If sp > .1 Then sp = .1
warp = (sp * 100) + 1
If warp > 10 Then warp = 10
warp = Int(warp)
stars = Int(Rnd * 100) + 1
If stars > 25 Then
ss = ss + 1
If ss > 950 Then ss = 1
'Set starting position.
startx = Rnd * 490
starty = Rnd * 390
st = Int(Rnd * 360)
xx = (Sin(st) * startx) + 400
yy = (Cos(st) * starty) + 300
starx(s) = xx
stary(s) = yy
'Set direction to move.
dx(s) = ((xx - 400) / 30)
dy(s) = ((yy - 300) / 30)
'Set size.
sz(s) = Rnd
'Set speed
speed(s) = .1
End If
If yy > 640 Then yy = 0
For tt = 1 To 950
speed(tt) = speed(tt) * (1.05 + sp)
stary(tt) = stary(tt) + dy(tt) * speed(tt)
starx(tt) = starx(tt) + dx(tt) * speed(tt)
cx = starx(tt): cy = stary(tt)
ra = sz(tt) + .5
cl = _RGB32(255, 255, 255)
fillCircle cx, cy, ra, cl
'skip:
Next tt
If t < 90 Then t = 1800
If t2 < 90 Then t2 = 1800
oldx3 = x3
x2 = (Sin(t) * 360) + 400
y2 = (Cos(t) * 180) / _Pi / 1.55 + 300
r2 = (Cos(t) * 180) / _Pi / 1.55 + 50
x3 = (Sin(t2) * r2 * (y3 / y2) * _Pi) + x2
y3 = (Cos(t2) * 80) / _Pi / 2 + y2
r3 = (Cos(t2) * 20) / _Pi / 1.5 + r2 / 5
t = t - .025
t2 = t2 - .3
If r2 < 20 Then f = 0
If r2 < 30 And r2 >= 20 Then f = 1
If r2 < 40 And r2 >= 30 Then f = 2
If r2 < 50 And r2 >= 40 Then f = 3
If r2 < 60 And r2 >= 50 Then f = 4
If r2 < 70 And r2 >= 60 Then f = 5
If r2 < 80 And r2 >= 70 Then f = 6
If r2 >= 80 Then f& = 7
_Font Font(f)
If y2 < 290 Then
'Text
_PrintString (x2 - 30, y2), text$
'Moon
cc4 = 200
For s = .25 To r3 Step .25
cc4 = cc4 - 2
Circle (x3, y3), s, _RGB32(cc4, cc4, cc4)
Next s
cc4 = 0
End If
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(255 - cc2, 255 - cc2, 128 - cc2)
Next sun
cc2 = 0
If y2 >= 290 Then
'Text
_PrintString (x2 - 30, y2), text$
'Moon
cc5 = 200
For s = .25 To r3 Step .25
cc5 = cc5 - 2
Circle (x3, y3), s, _RGB32(cc5, cc5, cc5)
Next s
cc5 = 0
If y3 < y2 Then
'Text
_PrintString (x2 - 30, y2), text$
End If
End If
If x3 > oldx3 And y2 < 290 And (Point(x3 + r3 + 1, y3) <> _RGB32(0, 0, 0) Or Point(x3 + r3 + 1, y3)) <> _RGB32(255, 255, 255) Then
'Text
_PrintString (x2 - 30, y2), text$
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(255 - cc2, 255 - cc2, 128 - cc2)
Next sun
cc2 = 0
End If
_Delay .05
_Display
Cls
Loop
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
|
|
|
|
| latest Lunar Lander Bloatware v0.51 |
|
Posted by: madscijr - 08-03-2022, 02:43 AM - Forum: Programs
- Replies (1)
|
 |
Added some tweaks:
1. Improved the controls
- arrow keys fire rockets at the current power level (you don't have to simultaneously press 1-7)
- 1-7 sets power level
2. Tweaked messages and displays
TODO next:
1. add sound
2. draw slopes where the mountains rise and fall.
the surface is made with little squares drawn with
Code: (Select All) Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), _RGB32(128), BF
Here is the latest version, it works:
Code: (Select All) ' Lunar Lander 1699 LOC bloatware by madscijr
' based on b+ Lander 30 LOC (double parking cheat) 2020-11-13
' BPlus proggies > Lander
' https://staging.qb64phoenix.com/showthread.php?tid=162&page=3&highlight=Lander
' https://staging.qb64phoenix.com/showthread.php?tid=443
' bplus Wrote:
' I got a little 30 LOC starter kit setup in Proggies for Lander.
' You will feel the need to jazz it up, resistance is futile.
' DATE WHO-DONE-IT DID-WHAT
' 2020-11-15 bplus fix off-sides x,
' add alternate keys: a=left d=right w=up
' so now arrow keys or WAD system works
' 2022-07-15 madscijr changed variables to double to move lander a fraction of a pixel at a time
' display velocity, fule, etc. on screen
' 2022-07-31 madscijr arrow keys fire rockets without needing to hold down 1-7,
' rockets are fired at whatever the last set power level
' keys 1-7 set power level
' tweaked text display and end-of-round messages
' DONE:
' Change input to use _BUTTON instead of KeyHit
' Track velocity + lateral momentum + fuel
' Display altitude, velocity, fuel, etc.
' v0.2: Pressing arrow up/down/left/right and 1-7 simultaneously selects which direction to thrust in, and power level.
' v0.5: Pressing 1-7 sets power level (default=1)
' v0.5: Arrow keys can be pressed without 1-7 to fire engine; engine is fired at last set power level
' v0.5: Added some detail to text display and messages at end of round.
' TODO:
' Sound effects: engines, crash, warning beeps (low fuel, moving too fast, etc.)
' Better (graphic) display for fuel gauge, air speed, etc.
' If speed too fast, display in a different color or graphically warn player.
' Simplify flames? Just draw a couple of lines instead of semicircles?
' Change surface of moon to vector lines.
' Rotate lander Asteroids-style like the arcade game (Atari Lunar Lander).
' Map entire moon and scroll horizontally as lander drifts towards edges of screen.
' Zoom in as lander gets close to surface.
' Stars "cheap planetarium"
' Track + display oxygen
' Meteorites, UFOs + other phenomena
' Support game controllers?
' Persist junk on the moon (crashed landers, stranded astronauts, flags / equipment, etc.)
' Get out and walk on the moon, collect rocks, meet moonmen, blast back off, rendevous, go home, splashdown, etc.
' Fly missions related to past missions (rescue stranded astronauts, recover items, etc.)
' Various missions - land, explore, take readings, rescue, salvage, mining, combat, set up moonbase, etc.
' BOOLEAN CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
' FOR THRUST DIRECTION
Const cNone = 0
Const cUp = 1
Const cDown = 2
Const cLeft = 3
Const cRight = 4
' HOLDS INFO ABOUT ROCKET THRUSTERS
Type ThrustType
FuelUsed As Integer
Power As Double
Radius As Single
OffsetX As Single
OffsetY As Single
Color As _Unsigned Long
FlickerIndex As Integer
End Type ' ThrustType
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = TRUE
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' ****************************************************************************************************************************************************************
' ACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' ****************************************************************************************************************************************************************
' =============================================================================
' START THE MAIN ROUTINE
main
' =============================================================================
' FINISH
Screen 0
Print m_ProgramName$ + " finished."
Input "Press <ENTER> to continue", in$
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
_Console Off
End If
' ****************************************************************************************************************************************************************
System ' return control to the operating system
End
' /////////////////////////////////////////////////////////////////////////////
Sub main
' LOCAL VARIABLES
Dim dblGravity As Double: dblGravity = 0.05
Dim iStartFuel As Integer: iStartFuel = 1000
Dim dblMinSpeedY As Double: dblMinSpeedY = 1 ' 0.75
Dim dblMinSpeedX As Double: dblMinSpeedX = .5 ' 0.20
' -----------------------------------------------------------------------------
Dim iFPS As Integer: iFPS = 30
Dim bHorizontalMomentum As Integer: bHorizontalMomentum = FALSE
Dim iLoop As Integer
Dim imgMoon&
ReDim arrMoon(-100 To 200) As Integer
'ReDim arrMoon(-100 To 200) As Double
Dim iHeight As Integer
Dim dblDX As Double
Dim dblDY As Double
'Dim iDX As Integer
'Dim iDY As Integer
Dim dblX As Double
Dim dblY As Double
Dim iX As Integer
Dim iY As Integer
Dim sKey As String
Dim iMinX As Integer
Dim iMaxX As Integer
Dim iMinY As Integer
Dim iMaxY As Integer
Dim iStartY As Integer
Dim dblMinX As Double
Dim dblMaxX As Double
Dim dblMinY As Double
Dim dblMaxY As Double
Dim iFuel As Integer
Dim iEscapeFuel As Integer: iEscapeFuel = 75 ' how much fuel they need to leave
Dim iPowerLevel As Integer
Dim iAvailablePower As Integer
Dim bFlicker As Integer
Dim iThrustDirection As Integer
Dim iOldThrustDirection As Integer
Dim iDrawThrust As Integer
Dim arrThrust(0 To 7) As ThrustType
Dim arrHeight(0 To 2) As Integer
' -----------------------------------------------------------------------------
'RIGHT FLAME:
Dim sngStartRadian1 As Single: sngStartRadian1 = 5.2 ' 0 to 2, -6.1 to 6.1
Dim sngStopRadian1 As Single: sngStopRadian1 = 0.6 ' 0 to 2, -6.1 to 6.1
Dim sngAspect1 As Single: sngAspect1 = -1 ' 0 to 1, -6.1 to 6.1
'LEFT FLAME:
Dim sngStartRadian2 As Single: sngStartRadian2 = 2.5 ' 0 to 2, -6.1 to 6.1
Dim sngStopRadian2 As Single: sngStopRadian2 = 4.1 ' 0 to 2, -6.1 to 6.1
Dim sngAspect2 As Single: sngAspect2 = -1 ' 0 to 1, -6.1 to 6.1
' -----------------------------------------------------------------------------
Dim iLandingSite As Integer
Dim bQuit As Integer: bQuit = FALSE
Dim in$
' INIT THRUSTERS
arrThrust(0).FuelUsed = 0
arrThrust(0).Power = 0
arrThrust(0).Radius = 0
arrThrust(0).OffsetX = 0
arrThrust(0).OffsetY = 0
arrThrust(0).Color = cBlack
arrThrust(0).FlickerIndex = 0
arrThrust(1).FuelUsed = 1
arrThrust(1).Power = .05
arrThrust(1).Radius = 6
arrThrust(1).OffsetX = 0
arrThrust(1).OffsetY = 0
arrThrust(1).Color = cRed
arrThrust(1).FlickerIndex = 2
arrThrust(2).FuelUsed = 2
arrThrust(2).Power = .10
arrThrust(2).Radius = 8
arrThrust(2).OffsetX = -1
arrThrust(2).OffsetY = 1
arrThrust(2).Color = cYellow
arrThrust(2).FlickerIndex = 3
arrThrust(3).FuelUsed = 3
arrThrust(3).Power = .15
arrThrust(3).Radius = 10
arrThrust(3).OffsetX = -2
arrThrust(3).OffsetY = 2
arrThrust(3).Color = cOrange
arrThrust(3).FlickerIndex = 4
arrThrust(4).FuelUsed = 4
arrThrust(4).Power = .20
arrThrust(4).Radius = 12
arrThrust(4).OffsetX = -3
arrThrust(4).OffsetY = 3
arrThrust(4).Color = cRed
arrThrust(4).FlickerIndex = 5
arrThrust(5).FuelUsed = 6
arrThrust(5).Power = .3
arrThrust(5).Radius = 14
arrThrust(5).OffsetX = -4
arrThrust(5).OffsetY = 4
arrThrust(5).Color = cYellow
arrThrust(5).FlickerIndex = 6
arrThrust(6).FuelUsed = 9
arrThrust(6).Power = .4
arrThrust(6).Radius = 18
arrThrust(6).OffsetX = -6
arrThrust(6).OffsetY = 5
arrThrust(6).Color = cOrange
arrThrust(6).FlickerIndex = 7
arrThrust(7).FuelUsed = 12
arrThrust(7).Power = .5
arrThrust(7).Radius = 26
arrThrust(7).OffsetX = -10
arrThrust(7).OffsetY = 9
arrThrust(7).Color = cRed
arrThrust(7).FlickerIndex = 6
' =============================================================================
' INITIALIZE SCREEN
Screen _NewImage(800, 640, 32) ' 40 text rows x 100 text columns
imgMoon& = _NewImage(800, 640, 32)
' =============================================================================
' START NEW GAME
Do
Cls
_KeyClear
' -----------------------------------------------------------------------------
' DRAW RANDOM LUNAR SURFACE
Randomize Timer
iHeight = 30
iLandingSite = RandomNumber%(-9, 108)
For iLoop = -10 To 110
If iLoop = iLandingSite And iLoop <= (iLandingSite + 1) Then
iHeight = arrMoon(iLoop - 1)
Else
' The RND function returns a random number with a value between 0 (inclusive) and 1 (exclusive).
If Rnd < .5 Then iHeight = iHeight + Int(Rnd * 3) - 1
If iHeight > 39 Then iHeight = 39
If iHeight < 25 Then iHeight = 25
End If
Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), _RGB32(128), BF
arrMoon(iLoop) = iHeight
'arrMoon(iLoop) = iHeight * 16
DebugPrint "arrMoon(" + _Trim$(Str$(iLoop)) + " = " + _Trim$(Str$(arrMoon(iLoop)))
_PutImage , 0, imgMoon&
Next iLoop
DebugPrint "--------------------------------------------------------------------------------"
' -----------------------------------------------------------------------------
' SCREEN BOUNDARIES
iMinX = -2
iMaxX = 101
iMinY = 0 - 10
iMaxY = 39
dblMinX = iMinX * 8
dblMaxX = iMaxX * 8
dblMinY = iMinY * 8
dblMaxY = iMaxY * 8 ' 622
' -----------------------------------------------------------------------------
' PUT LANDER IN ORBIT
iStartY = 0
dblX = RandomNumber%(iMinX, iMaxX) * 8
dblY = iStartY * 16
dblDX = 0.0
dblDY = 0.5
iFuel = iStartFuel
bFlicker = FALSE
iThrustDirection = cNone
iOldThrustDirection = cNone
iDrawThrust = 0
iPowerLevel = 1
' -----------------------------------------------------------------------------
' CONFIGURE PRINTING FOR _PrintString
_PrintMode _FillBackground
'_PrintMode _KEEPBACKGROUND
' -----------------------------------------------------------------------------
' MAIN LOOP
While TRUE = TRUE
' REDRAW MOON
DrawMoon imgMoon&
' APPLY GRAVITY
dblDY = dblDY + dblGravity
' WRAP AROUND SCREEN WHY NOT
If dblX < dblMinX Then
dblX = dblMaxX
ElseIf dblX > dblMaxX Then
dblX = dblMinX
End If
' GET AN INTEGER
iX = DblToInt%(dblX) \ 8
iY = DblToInt%(dblY) \ 16
' SHOW INSTRUMENTS + INSTRUCTIONS
DrawText arrMoon(), dblX, dblY, iX, iY, dblDX, dblDY, dblMinSpeedX, dblMinSpeedY, iFuel, sKey
' DRAW LANDER
DrawLander dblX, dblY
' THRUST (CURRENTLY ONLY BOTTOM ENGINE)
If iAvailablePower > 0 Then
If iThrustDirection = cUp Then
' 2 ways we could draw rocket flame LINE and CIRCLE
'
' CIRCLE Parameters
' Can use STEP for relative coordinate moves from the previous graphic coordinates.
' Coordinates designate the center position of the circle. Can be partially drawn offscreen.
' radius% is an INTEGER value for half of the total circle diameter.
' drawColor% is any available color attribute in the SCREEN mode used.
' startRadian! and stopRadian! can be any SINGLE value from 0 to 2 * π to create partial circles or ellipses.
' aspect! SINGLE values of 0 to 1 affect the vertical height and values over 1 affect the horizontal width of an ellipse. Aspect = 1 is a normal circle.
'''LINE (dblX + 04, dblY + 16)-(dblX + 02, dblY + 20), cOrange
'''LINE (dblX + 04, dblY + 16)-(dblX + 06, dblY + 20), cYellow
'''Circle (dblX + 04, dblY + 16), 4, cRed, 0, 2
''Circle (dblX + 04, dblY + 16), 8, cRed, sngStartRadian, sngStopRadian
''Circle (dblX + 32, dblY + 32), 8, cOrange, sngAspect
''Circle (dblX + 64, dblY + 48), 8, cYellow, sngStartRadian, sngStopRadian, sngAspect
'Circle (dblX + 64, dblY + 48), iRadius, cYellow, sngStartRadian, sngStopRadian, sngAspect
If bFlicker = FALSE Then
iDrawThrust = iAvailablePower
Else
iDrawThrust = arrThrust(iAvailablePower).FlickerIndex
End If
Circle _
(dblX + 00 + arrThrust(iDrawThrust).OffsetX, dblY + 20 + arrThrust(iDrawThrust).OffsetY), _
arrThrust(iDrawThrust).Radius, _
arrThrust(iDrawThrust).Color, _
sngStartRadian1, _
sngStopRadian1, _
sngAspect1
Circle _
(dblX + 08 - arrThrust(iDrawThrust).OffsetX, dblY + 20 + arrThrust(iDrawThrust).OffsetY), _
arrThrust(iDrawThrust).Radius, _
arrThrust(iDrawThrust).Color, _
sngStartRadian2, _
sngStopRadian2, _
sngAspect2
End If
End If
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' -----------------------------------------------------------------------------
' HAS LANDER TOUCHED THE SURFACE OR WENT BACK INTO SPACE?
' GET HEIGHT OF SURFACE AROUND LANDER
arrHeight(0) = arrMoon(iX - 1) - 1
arrHeight(1) = arrMoon(iX) - 1
arrHeight(2) = arrMoon(iX + 1) - 1
' DID WE LAND ON EVEN SURFACE?
If iY = arrHeight(0) And iY = arrHeight(1) And iY = arrHeight(2) Then
' DID WE TOUCH DOWN GENTLY ENOUGH?
If dblDY <= dblMinSpeedY Then
' ARE WE MOVING TOO FAST HORIZONTALLY?
If Abs(dblDX) <= dblMinSpeedX Then
' ADJUST LANDER'S VERTICAL POSITION + REDRAW
dblY = (arrHeight(0) * 16) - 5
DrawMoon imgMoon& ' REDRAW MOON
DrawText arrMoon(), dblX, dblY, iX, iY, dblDX, dblDY, dblMinSpeedX, dblMinSpeedY, iFuel, sKey ' REDRAW TEXT
DrawLander dblX, dblY ' REDRAW LANDER
' TOUCH DOWN!
Color cWhite, cDimGray
PrintAt 13, 30, "The Eagle has landed. "
Color cWhite, cDimGray
PrintAt 14, 30, "That's one small step for (wo)man,"
Color cWhite, cDimGray
PrintAt 15, 30, "one giant leap for Earthlings. "
If iFuel < iEscapeFuel Then
Color cWhite, cDimGray
PrintAt 17, 30, "One small problem: "
Color cWhite, cDimGray
PrintAt 18, 30, "Not enough fuel left to leave."
End If
Exit While
Else
' TOO FAST HORIZONTALLY
Color cWhite, cDimGray
PrintAt 20, 30, "Moving too fast sideways."
PrintAt 21, 30, "Landing gear failure. "
Exit While
End If
Else
' TOO FAST VERTICALLY
Color cWhite, cDimGray
PrintAt 20, 30, "Falling too fast. "
PrintAt 21, 30, "Ship destroyed on imact. "
Exit While
End If
' DID WE LAND ON UNEVEN SURFACE?
ElseIf iY >= arrHeight(0) Or iY >= arrHeight(1) Or iY >= arrHeight(2) Or iY > iMaxY Then
' CRASHED DUE TO SPEED OR UNEVEN SURFACE?
If dblDY <= dblMinSpeedY Then
' CRASHED ON UNEVEN SURFACE
Color cWhite, cDimGray
PrintAt 20, 30, "Terrain is too uneven. "
PrintAt 21, 30, "Crash landed on surface. "
Exit While
Else
' TOO FAST VERTICALLY
Color cWhite, cDimGray
PrintAt 20, 30, "Out of control. "
PrintAt 21, 30, "Ship destroyed on imact. "
Exit While
End If
' DID WE LEAVE THE MOON'S ORBIT?
ElseIf iY < iMinY Then
' FLEW OFF INTO SPACE
Color cWhite, cDimGray
PrintAt 20, 30, "Leaving so soon? "
PrintAt 21, 30, "Lost in space. "
Exit While
End If
' =============================================================================
' PROCESS INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
sKey = ""
' -----------------------------------------------------------------------------
' QUIT?
If _Button(KeyCode_Escape%) Then
bQuit = TRUE
Exit While
End If
' -----------------------------------------------------------------------------
' Get power level (1=weakest, 7=strongest)
If _Button(KeyCode_1%) Then
iPowerLevel = 1: sKey = sKey + "1,"
ElseIf _Button(KeyCode_2%) Then
iPowerLevel = 2: sKey = sKey + "2,"
ElseIf _Button(KeyCode_3%) Then
iPowerLevel = 3: sKey = sKey + "3,"
ElseIf _Button(KeyCode_4%) Then
iPowerLevel = 4: sKey = sKey + "4,"
ElseIf _Button(KeyCode_5%) Then
iPowerLevel = 5: sKey = sKey + "5,"
ElseIf _Button(KeyCode_6%) Then
iPowerLevel = 6: sKey = sKey + "6,"
ElseIf _Button(KeyCode_7%) Then
iPowerLevel = 7: sKey = sKey + "7,"
End If
' -----------------------------------------------------------------------------
' Get direction
If _Button(KeyCode_Left%) Then
sKey = sKey + "LEFT,"
iThrustDirection = cLeft
ElseIf _Button(KeyCode_A%) Then
sKey = sKey + "A,"
iThrustDirection = cLeft
ElseIf _Button(KeyCode_Right%) Then
sKey = sKey + "RIGHT,"
iThrustDirection = cRight
ElseIf _Button(KeyCode_D%) Then
sKey = sKey + "D,"
iThrustDirection = cRight
ElseIf _Button(KeyCode_Up%) Then
sKey = sKey + "UP,"
iThrustDirection = cUp
ElseIf _Button(KeyCode_W%) Then
sKey = sKey + "W,"
iThrustDirection = cUp
ElseIf _Button(KeyCode_Down%) Then
sKey = sKey + "DOWN,"
iThrustDirection = cDown
ElseIf _Button(KeyCode_S%) Then
sKey = sKey + "S,"
iThrustDirection = cDown
Else
iThrustDirection = cNone
End If
' -----------------------------------------------------------------------------
' Fire the engines
iAvailablePower = 0
If iThrustDirection <> cNone Then
' Remember previous
iOldThrustDirection = iThrustDirection
' Make sure we have enough fuel for thrust level.
' (Else adjust based on available fuel.)
For iLoop = iPowerLevel To 0 Step -1
If iFuel >= arrThrust(iLoop).FuelUsed Then
iAvailablePower = iLoop
Exit For
End If
Next iLoop
' If we had enough fuel that engines are firing
If iAvailablePower > 0 Then
' Consume fuel
iFuel = iFuel - arrThrust(iAvailablePower).FuelUsed
' Apply force
If iThrustDirection = cLeft Then
dblDX = dblDX - arrThrust(iAvailablePower).Power
'TODO: need a better way to do sound, these sounds don't stop playing when the player releases the controls
'SLIME_BAS_SOUND_11
ElseIf iThrustDirection = cRight Then
dblDX = dblDX + arrThrust(iAvailablePower).Power
'SLIME_BAS_SOUND_11
ElseIf iThrustDirection = cUp Then
dblDY = dblDY - arrThrust(iAvailablePower).Power
'SLIME_BAS_SOUND_11
ElseIf iThrustDirection = cDown Then
dblDY = dblDY + arrThrust(iAvailablePower).Power
'snatch_bas_sound_6
''SLIME_BAS_SOUND_11
End If
' Animate the rocket flames
If iThrustDirection = iOldThrustDirection Then bFlicker = Not (bFlicker)
Else
' Engines off
iOldThrustDirection = cNone: bFlicker = FALSE
End If
Else
' Engines off
iOldThrustDirection = cNone: bFlicker = FALSE
End If
' -----------------------------------------------------------------------------
' MOVE LANDER
dblX = dblX + dblDX
dblY = dblY + dblDY
' -----------------------------------------------------------------------------
' CONTROL GAME SPEED
_Limit iFPS
'_Limit 2
'_Limit 30
Wend
_KeyClear: _Delay 2
' PLAY ANOTHER ROUND OR QUIT?
If bQuit = FALSE Then
Sleep
Color cWhite, cBlack
Else
Exit Do
End If
Loop
End Sub ' main
' (RE)DRAW MOON
Sub DrawMoon (imgMoon&)
_PutImage , imgMoon&, 0
End Sub ' DrawMoon
' SHOW INSTRUMENTS + INSTRUCTIONS
' 800x600 = 40 rows x 100 columns
sub DrawText( _
arrMoon() As Integer, _
dblX as double, dblY as double, _
iX as integer, iY as integer, _
dblDX as double, dblDY as double, _
dblMinSpeedX as double, dblMinSpeedY as double, _
iFuel as integer, sKey as string _
)
Dim sValue$
' SHOW POSITION + SPEED
Color cWhite
PrintAt 1, 1, "Velocity X: " + Left$(DblRoundedToStr$(dblDX, 3), 5) + " "
Color cGray
PrintAt 2, 1, "Max +/- X: " + Left$(DblRoundedToStr$(dblMinSpeedX, 3), 5) + " "
Color cWhite
PrintAt 1, 21, "Latitude : " + _
LeftPadString$(cstr$(iX), 4, " ") + _
" " + _
LeftPadString$(Left$(DblRoundedToStr$(dblX, 3), 5), 5, " ") + _
" "
Color cWhite
PrintAt 3, 1, "Velocity Y: " + Left$(DblRoundedToStr$(dblDY, 3), 5) + " "
Color cGray
PrintAt 4, 1, "Max Y: " + Left$(DblRoundedToStr$(dblMinSpeedY, 3), 5) + " "
Color cWhite
PrintAt 3, 21, "Altitude : " + _
LeftPadString$(cstr$(iY), 4, " ") + _
" " + _
LeftPadString$(Left$(DblRoundedToStr$(dblY, 3), 5), 5, " ") + _
" "
Color cGray
sValue$ = cstr$(arrMoon(iX - 1))
PrintAt 5, 21, "Surface : " + LeftPadString$(sValue$, 4, " ") + " "
sValue$ = cstr$(arrMoon(iX))
PrintAt 6, 21, " " + LeftPadString$(sValue$, 4, " ") + " "
sValue$ = cstr$(arrMoon(iX + 1))
PrintAt 7, 21, " " + LeftPadString$(sValue$, 4, " ") + " "
Color cYellow
If iFuel > 0 Then
PrintAt 8, 1, "Fuel : " + _Trim$(Str$(iFuel)) + " "
Else
PrintAt 8, 1, "Fuel : EMPTY"
End If
Color cLime
PrintAt 10, 1, "Controls : " + RightPadString$(sKey, 10, " ") + " "
Color cDodgerBlue
PrintAt 1, 48, Chr$(34) + "One Small Step" + Chr$(34)
Color cCyan
PrintAt 3, 48, "Land on an even surface."
Color cMagenta
PrintAt 5, 48, "Arrow keys: direction of thrust"
PrintAt 6, 48, " (up slows descent)"
PrintAt 8, 48, "1-7 keys: burn engine"
PrintAt 9, 48, " (1 = weakest)"
Color cOrange
PrintAt 11, 48, "Good Luck!"
End Sub ' DrawText
Sub DrawLander (dblX, dblY)
' DRAW LANDER
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (dblX + 4, dblY + 8), 4, cGray
'Circle (dblX - 2, dblY + 16), 4, cGray, 0, _Pi
'Circle (dblX + 10, dblY + 16), 4, cGray, 0, _Pi
Circle (dblX + 0, dblY + 16), 4, cGray, 0, _Pi
Circle (dblX + 8, dblY + 16), 4, cGray, 0, _Pi
''Circle (dblX + 4, dblY + 8), 4, &HFF00FFFF
''Circle (dblX + 0, dblY + 16), 4, &HFFFFFF00, 0, _Pi
''Circle (dblX + 8, dblY + 16), 4, &HFFFFFF00, 0, _Pi
'LINE [STEP] [(column1, row1)]-[STEP] (column2, row2), color[, [{B|BF}], style%]
''LINE (100, 100)-(200, 200), 10
'LINE (dblX + 4, dblY + 16)-(dblX + 0, dblY + 24), cGray
'LINE (dblX + 4, dblY + 16)-(dblX + 8, dblY + 24), cGray
' LEGS:
Line (dblX - 4, dblY + 16)-(dblX - 4, dblY + 20), cGray
Line (dblX + 12, dblY + 16)-(dblX + 12, dblY + 20), cGray
' FEET
Line (dblX - 5, dblY + 20)-(dblX - 3, dblY + 20), cGray
Line (dblX + 11, dblY + 20)-(dblX + 13, dblY + 20), cGray
End Sub ' DrawLander
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function DblToInt% (dblOld As Double)
Dim dblNew As Double
Dim sValue As String
Dim iPos As Integer
dblNew = RoundDouble#(dblOld, 0)
'sValue = _Trim$(Str$(dblNew))
sValue = DblToStr$(dblNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' DblToInt% = Val(Left$(sValue, iPos - 1))
'Else
' DblToInt% = Val(sValue)
'End If
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function DblToStr$ (n#)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
value$ = UCase$(LTrim$(Str$(n#)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DblRoundedToStr$ (dblValue As Double, intNumPlaces As Integer)
Dim dblNew As Double
dblNew = RoundDouble#(dblValue, intNumPlaces)
DblRoundedToStr$ = DblToStr$(dblNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function FloatToStr$ (n##)
value$ = UCase$(LTrim$(Str$(n##)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") 'only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then
num$ = num$ + Mid$(valu$, n, 1)
End If
Next n
Else
FloatToStr$ = value$
Exit Function
End If
FloatToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' FloatToStr$
' /////////////////////////////////////////////////////////////////////////////
' By sMcNeill from https://www.qb64.org/forum/index.php?topic=896.0
Function IsNum% (text$)
Dim a$
Dim b$
a$ = _Trim$(text$)
b$ = _Trim$(Str$(Val(text$)))
If a$ = b$ Then
IsNum% = TRUE
Else
IsNum% = FALSE
End If
End Function ' IsNum%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim i As Long
result$ = in$(LBound(in$))
For i = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(i)
Next i
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
Function LeftPadString$ (myString$, toWidth%, padChar$)
LeftPadString$ = Right$(String$(toWidth%, padChar$) + myString$, toWidth%)
End Function ' LeftPadString$
' /////////////////////////////////////////////////////////////////////////////
' iRow% and iCol% are 0-based in this version
Sub PrintAt (iRow%, iCol%, sText$)
'_PrintString (iCol% * 8, iRow% * 16), sText$
_PrintString (iCol% * 8, iRow% * 16), sText$
'_PrintString (iCol%, iRow%), sText$
End Sub ' PrintAt
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max.
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
' SET RANDOM SEED
'Randomize ' Initialize random-number generator.
Randomize Timer
' GET RANDOM # Min%-Max%
'RandomNumber = Int((Max * Rnd) + Min) ' generate number
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
Function RightPadString$ (myString$, toWidth%, padChar$)
RightPadString$ = Left$(myString$ + String$(toWidth%, padChar$), toWidth%)
End Function ' RightPadString$
' /////////////////////////////////////////////////////////////////////////////
' https://www.qb64.org/forum/index.php?topic=3605.0
' Quote from: SMcNeill on Today at 03:53:48 PM
'
' Sometimes, you guys make things entirely too complicated.
' There ya go! Three functions to either round naturally,
' always round down, or always round up, to whatever number of digits you desire.
' EDIT: Modified to add another option to round scientific,
' since you had it's description included in your example.
' Receives + returns _FLOAT myVar## (-1.18E-4932 to +1.18E+4932)
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE _FLOAT
Function Round## (num##, digits%)
Round## = Int(num## * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUp## (num##, digits%)
RoundUp## = _Ceil(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDown## (num##, digits%)
RoundDown## = Int(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientific## (num##, digits%)
RoundScientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE DOUBLE
Function RoundDouble# (num#, digits%)
RoundDouble# = Int(num# * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownDouble# (num#, digits%)
RoundDownDouble# = Int(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificDouble# (num#, digits%)
RoundScientificDouble# = _Round(num# * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
'cWhite = _RGB32(254, 254, 254)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
'cEmpty~& = -1
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' BEGIN KEYBOARD CODE FUNCTIONS
' NOTE: ALL CODES ARE FOR _BUTTON, EXCEPT:
' cF10 (_KEYDOWN)
' cAltLeft (_KEYHIT)
' cAltRight (_KEYHIT)
' cPrintScreen (_KEYHIT) <- may slow down pc?
' cPauseBreak (_KEYHIT) <- may not work?
' ################################################################################################################################################################
Function KeyCode_Escape% ()
KeyCode_Escape% = 2
End Function
Function KeyCode_F1% ()
KeyCode_F1% = 60
End Function
Function KeyCode_F2% ()
KeyCode_F2% = 61
End Function
Function KeyCode_F3% ()
KeyCode_F3% = 62
End Function
Function KeyCode_F4% ()
KeyCode_F4% = 63
End Function
Function KeyCode_F5% ()
KeyCode_F5% = 64
End Function
Function KeyCode_F6% ()
KeyCode_F6% = 65
End Function
Function KeyCode_F7% ()
KeyCode_F7% = 66
End Function
Function KeyCode_F8% ()
KeyCode_F8% = 67
End Function
Function KeyCode_F9% ()
KeyCode_F9% = 68
End Function
'_KEYDOWN CODE, NOT _BUTTON CODE
Function KeyCode_F10% ()
KeyCode_F10% = 17408
End Function
Function KeyCode_F11% ()
KeyCode_F11% = 88
End Function
Function KeyCode_F12% ()
KeyCode_F12% = 89
End Function
'_KEYHIT CODE, NOT _BUTTON CODE
Function KeyCode_PrintScreen% ()
KeyCode_PrintScreen% = -44
End Function
Function KeyCode_ScrollLock% ()
KeyCode_ScrollLock% = 71
End Function
'_KEYHIT CODE, NOT _BUTTON CODE
Function KeyCode_PauseBreak% ()
KeyCode_PauseBreak% = 31053
End Function
Function KeyCode_Tilde% ()
KeyCode_Tilde% = 42
End Function
Function KeyCode_1% ()
KeyCode_1% = 3
End Function
Function KeyCode_2% ()
KeyCode_2% = 4
End Function
Function KeyCode_3% ()
KeyCode_3% = 5
End Function
Function KeyCode_4% ()
KeyCode_4% = 6
End Function
Function KeyCode_5% ()
KeyCode_5% = 7
End Function
Function KeyCode_6% ()
KeyCode_6% = 8
End Function
Function KeyCode_7% ()
KeyCode_7% = 9
End Function
Function KeyCode_8% ()
KeyCode_8% = 10
End Function
Function KeyCode_9% ()
KeyCode_9% = 11
End Function
Function KeyCode_0% ()
KeyCode_0% = 12
End Function
Function KeyCode_Minus% ()
KeyCode_Minus% = 13
End Function
Function KeyCode_Equal% ()
KeyCode_Equal% = 14
End Function
Function KeyCode_BkSp% ()
KeyCode_BkSp% = 15
End Function
Function KeyCode_Ins% ()
KeyCode_Ins% = 339
End Function
Function KeyCode_Home% ()
KeyCode_Home% = 328
End Function
Function KeyCode_PgUp% ()
KeyCode_PgUp% = 330
End Function
Function KeyCode_Del% ()
KeyCode_Del% = 340
End Function
Function KeyCode_End% ()
KeyCode_End% = 336
End Function
Function KeyCode_PgDn% ()
KeyCode_PgDn% = 338
End Function
Function KeyCode_NumLock% ()
KeyCode_NumLock% = 326
End Function
Function KeyCode_KeypadSlash% ()
KeyCode_KeypadSlash% = 310
End Function
Function KeyCode_KeypadMultiply% ()
KeyCode_KeypadMultiply% = 56
End Function
Function KeyCode_KeypadMinus% ()
KeyCode_KeypadMinus% = 75
End Function
Function KeyCode_Keypad7Home% ()
KeyCode_Keypad7Home% = 72
End Function
Function KeyCode_Keypad8Up% ()
KeyCode_Keypad8Up% = 73
End Function
Function KeyCode_Keypad9PgUp% ()
KeyCode_Keypad9PgUp% = 74
End Function
Function KeyCode_KeypadPlus% ()
KeyCode_KeypadPlus% = 79
End Function
Function KeyCode_Keypad4Left% ()
KeyCode_Keypad4Left% = 76
End Function
Function KeyCode_Keypad5% ()
KeyCode_Keypad5% = 77
End Function
Function KeyCode_Keypad6Right% ()
KeyCode_Keypad6Right% = 78
End Function
Function KeyCode_Keypad1End% ()
KeyCode_Keypad1End% = 80
End Function
Function KeyCode_Keypad2Down% ()
KeyCode_Keypad2Down% = 81
End Function
Function KeyCode_Keypad3PgDn% ()
KeyCode_Keypad3PgDn% = 82
End Function
Function KeyCode_KeypadEnter% ()
KeyCode_KeypadEnter% = 285
End Function
Function KeyCode_Keypad0Ins% ()
KeyCode_Keypad0Ins% = 83
End Function
Function KeyCode_KeypadPeriodDel% ()
KeyCode_KeypadPeriodDel% = 84
End Function
Function KeyCode_Tab% ()
KeyCode_Tab% = 16
End Function
Function KeyCode_Q% ()
KeyCode_Q% = 17
End Function
Function KeyCode_W% ()
KeyCode_W% = 18
End Function
Function KeyCode_E% ()
KeyCode_E% = 19
End Function
Function KeyCode_R% ()
KeyCode_R% = 20
End Function
Function KeyCode_T% ()
KeyCode_T% = 21
End Function
Function KeyCode_Y% ()
KeyCode_Y% = 22
End Function
Function KeyCode_U% ()
KeyCode_U% = 23
End Function
Function KeyCode_I% ()
KeyCode_I% = 24
End Function
Function KeyCode_O% ()
KeyCode_O% = 25
End Function
Function KeyCode_P% ()
KeyCode_P% = 26
End Function
Function KeyCode_BracketLeft% ()
KeyCode_BracketLeft% = 27
End Function
Function KeyCode_BracketRight% ()
KeyCode_BracketRight% = 28
End Function
Function KeyCode_Backslash% ()
KeyCode_Backslash% = 44
End Function
Function KeyCode_CapsLock% ()
KeyCode_CapsLock% = 59
End Function
Function KeyCode_A% ()
KeyCode_A% = 31
End Function
Function KeyCode_S% ()
KeyCode_S% = 32
End Function
Function KeyCode_D% ()
KeyCode_D% = 33
End Function
Function KeyCode_F% ()
KeyCode_F% = 34
End Function
Function KeyCode_G% ()
KeyCode_G% = 35
End Function
Function KeyCode_H% ()
KeyCode_H% = 36
End Function
Function KeyCode_J% ()
KeyCode_J% = 37
End Function
Function KeyCode_K% ()
KeyCode_K% = 38
End Function
Function KeyCode_L% ()
KeyCode_L% = 39
End Function
Function KeyCode_Semicolon% ()
KeyCode_Semicolon% = 40
End Function
Function KeyCode_Apostrophe% ()
KeyCode_Apostrophe% = 41
End Function
Function KeyCode_Enter% ()
KeyCode_Enter% = 29
End Function
Function KeyCode_ShiftLeft% ()
KeyCode_ShiftLeft% = 43
End Function
Function KeyCode_Z% ()
KeyCode_Z% = 45
End Function
Function KeyCode_X% ()
KeyCode_X% = 46
End Function
Function KeyCode_C% ()
KeyCode_C% = 47
End Function
Function KeyCode_V% ()
KeyCode_V% = 48
End Function
Function KeyCode_B% ()
KeyCode_B% = 49
End Function
Function KeyCode_N% ()
KeyCode_N% = 50
End Function
Function KeyCode_M% ()
KeyCode_M% = 51
End Function
Function KeyCode_Comma% ()
KeyCode_Comma% = 52
End Function
Function KeyCode_Period% ()
KeyCode_Period% = 53
End Function
Function KeyCode_Slash% ()
KeyCode_Slash% = 54
End Function
Function KeyCode_ShiftRight% ()
KeyCode_ShiftRight% = 55
End Function
Function KeyCode_Up% ()
KeyCode_Up% = 329
End Function
Function KeyCode_Left% ()
KeyCode_Left% = 332
End Function
Function KeyCode_Down% ()
KeyCode_Down% = 337
End Function
Function KeyCode_Right% ()
KeyCode_Right% = 334
End Function
Function KeyCode_CtrlLeft% ()
KeyCode_CtrlLeft% = 30
End Function
Function KeyCode_WinLeft% ()
KeyCode_WinLeft% = 348
End Function
' _KEYHIT CODE NOT _BUTTON CODE
Function KeyCode_AltLeft% ()
KeyCode_AltLeft% = -30764
End Function
Function KeyCode_Spacebar% ()
KeyCode_Spacebar% = 58
End Function
' _KEYHIT CODE NOT _BUTTON CODE
Function KeyCode_AltRight% ()
KeyCode_AltRight% = -30765
End Function
Function KeyCode_WinRight% ()
KeyCode_WinRight% = 349
End Function
Function KeyCode_Menu% ()
KeyCode_Menu% = 350
End Function
Function KeyCode_CtrlRight% ()
KeyCode_CtrlRight% = 286
End Function
' ################################################################################################################################################################
' END KEYBOARD CODE FUNCTIONS
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN SOUND ROUTINES
' ################################################################################################################################################################
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RUMBLE SOUNDS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' low warbling rumbly sound (very short version)
Sub SLIME_BAS_SOUND_11
Dim z%
Dim zz%
For z% = 220 To 200 Step -1
Sound Int(100 * Rnd) + 50, .3
For zz% = 1 To 1000: Next zz%
Next z%
End Sub ' SLIME_BAS_SOUND_11
' /////////////////////////////////////////////////////////////////////////////
' medium rumbling type sound
Sub snatch_bas_sound_6
Dim Z As Integer
For Z = 40 To 1 Step -1
'For Z = 10 To 1 Step -1
'Z = 20
Sound Int(60 * Rnd) + 60 + Z, .2
Next Z
End Sub ' snatch_bas_sound_6
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RUMBLE SOUNDS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' END SOUND ROUTINES
' ################################################################################################################################################################
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DEBUGGING ROUTINES #DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub DebugPrint (MyString As String)
If m_bDebug = TRUE Then
'_Echo MyString
ReDim arrLines(-1) As String
Dim iLoop As Integer
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
_Echo arrLines(iLoop)
Next iLoop
End If
End Sub ' DebugPrint
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' #REFERENCE
' =============================================================================
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
|
|
|
|
| Font Sizes |
|
Posted by: SierraKen - 08-03-2022, 01:39 AM - Forum: Help Me!
- Replies (2)
|
|
For a few hours today I was VERY close to converting my orbital Earth animation to text that orbits the Sun instead, up to 5 letters, numbers, or symbols. I even got it working but then I realized that it kept using the _LOADFONT over and over again which got dangerously close to to using too much memory. Then I tried just the _FONT f&, fontsize command but for some reason that couldn't work. Then I tried the RotoZoom method but I couldn't figure out how to remove the darkness from covering up the Sun with _COPYIMAGE (0). Then lastly I tried _PUTIMAGE and for some reason that didn't work at all, even using _NEWIMAGE, although it's been a very long time since I've used those commands. Isn't there an easy way to make the FONT change size by pixel length without having to keep loading more and more of them non-stop? I tried _FONTWIDTH but I couldn't figure that out either. Any ideas? Thanks.
I even tested _FONT in another program and that didn't work either. Also with _FONT fontsize (where fontsize is the variable). I know that's not pixel length and must be the size the font comes with but I checked that on WordPad. I made a few IF/THEN statements changing the number to when the pixel length was at certain amounts.
|
|
|
|
| myframeview - resizable program window |
|
Posted by: James D Jarvis - 08-02-2022, 09:46 PM - Forum: Works in Progress
- No Replies
|
|
This is a resizable program screen demo. Grab the sides with the mouse to resize. The minimize and maximize buttons can inflicted odd changes on the size but it seems stable for now.
Been working on this on and off. The program I originally began this for has moved to the bottom of my fun programming pile for now but this part seems shareable at this point.
I surely used some code from the online examples or from somewhere else in the forums but I lost track of where,what, and who. I appologize for that lapse in record keeping.
Code: (Select All) 'myframeview
'By James D. Jarvis
' a very much in progress resizable program window example
' this creates a program with a 4 panels display with a header, a footer, a sidebar and a canvas all inside the mainframe
' there's a whole bunch of functionality planned for that is not built in yet. Someday each panel may be scrollable and i have the data format setup for that
' some commands have been commented out as I edit away but are still there because they worked in a previous itteration so they may return
' this is currently setup to use 32 bit color but there's nothign fancy goign on in that regaurd.
' this may or may not crash if you resize the window too small , in an earleir itteration it would crash when scaled from the top or minimzed
' that problem isn't in this version (not 100% sure how I fixed that)
'
'while _prinstring even locate would be functional some program logic would be needed to keep track of which frame/panel is being written too
'so I solved that issues as simply as i could with a printat command called prat (see the sub for more details there)
'
'a little barebones functionality is shown for now.there's a very simple easteregg of sorts buried in the program to show hwo writign to different panels can function
'
' in my programmer fantasy panels will be able to be added that can be moved and resized by the user not just hung on the borders likes shown here
'
'$dynamic
$Resize:On
_Title "myframeview"
Randomize Timer
Type paneltype
sh As Long 'screen handle
dx As Integer
dy As Integer
pwid As Integer
pht As Integer
vx As Integer
vy As Integer
vwid As Integer
vht As Integer
scroll_on As String * 3
scroll_show As String * 3
scroll_xbar As String * 1
scroll_ybar As String * 1
scroll_xslider As String * 1
scroll_yslider As String * 1
scroll_x As Integer
scroll_y As Integer
bgk As _Unsigned Long
fgk As _Unsigned Long
txt_fgK As _Unsigned Long 'text foreground color
txt_bgK As _Unsigned Long 'text background color
penx As Integer
peny As Integer
End Type
Dim Shared copyheader, copyfooter, copysidebar
Dim Shared mdisplay As paneltype
Dim Shared canvas As paneltype
Dim Shared header As paneltype
Dim Shared footer As paneltype
Dim Shared sidebar As paneltype
'build main display
'treating the whole program display like a subpanel so functionality wil leventually scale throughout the program
mdisplay.dx = 0
mdisplay.dy = 0
mdisplay.pwid = 800
mdisplay.pht = 600
mdisplay.vx = 0
mdisplay.vy = 0
mdisplay.vwid = 800
mdisplay.vht = 600
mdisplay.sh = _NewImage(mdisplay.pwid, mdisplay.pht, 32)
mdisplay.scroll_on = "_NO"
mdisplay.scroll_show = "_NO"
mdisplay.scroll_xbar = "-"
mdisplay.scroll_ybar = "|"
mdisplay.scroll_xslider = "="
mdisplay.scroll_ybar = "="
mdisplay.scroll_x = 0
mdisplay.scroll_y = 0
mdisplay.bgk = _RGB32(0, 0, 0)
mdisplay.fgk = _RGB32(250, 250, 250)
mdisplay.txt_bgK = _RGB32(0, 0, 0)
mdisplay.txt_fgK = _RGB32(250, 250, 250)
mdisplay.penx = 0
mdisplay.peny = 0
'build canvas
canvas.dx = 0
canvas.dy = 0
canvas.pwid = 1600
canvas.pht = 1200
canvas.vx = 0
canvas.vy = 100
canvas.vwid = 700
canvas.vht = 400
canvas.sh = _NewImage(canvas.pwid, canvas.pht, 32)
canvas.scroll_on = "YES"
canvas.scroll_show = "YES"
canvas.scroll_xbar = "-"
canvas.scroll_ybar = "|"
canvas.scroll_xslider = "="
canvas.scroll_ybar = "="
canvas.scroll_x = 0
canvas.scroll_y = 0
canvas.bgk = _RGB32(130, 0, 0)
canvas.fgk = _RGB32(250, 250, 250)
canvas.txt_bgK = _RGB32(130, 0, 0)
canvas.txt_fgK = _RGB32(250, 250, 250)
canvas.penx = 0
canvas.peny = 0
'build header
header.dx = 0
header.dy = 0
header.pwid = 900
header.pht = 100
header.vx = 0
header.vy = 0
header.vwid = 800
header.vht = 100
header.sh = _NewImage(header.pwid, header.pht, 32)
header.scroll_on = "_NO"
header.scroll_show = "_NO"
header.scroll_xbar = "-"
header.scroll_ybar = "|"
header.scroll_xslider = "="
header.scroll_ybar = "="
header.scroll_x = 0
header.scroll_y = 0
header.bgk = _RGB32(0, 100, 0)
header.fgk = _RGB32(250, 250, 250)
header.txt_bgK = _RGB32(0, 100, 0)
header.txt_fgK = _RGB32(250, 250, 250)
header.penx = 0
header.peny = 0
'build footer
footer.dx = 0
footer.dy = 0
footer.pwid = 900
footer.pht = 600
footer.vx = 0
footer.vwid = mdisplay.pwid
footer.vht = 100
footer.vy = mdisplay.pht - footer.vht
footer.sh = _NewImage(footer.pwid, footer.pht, 32)
footer.scroll_on = "VRT"
footer.scroll_show = "YES"
footer.scroll_xbar = "-"
footer.scroll_ybar = "|"
footer.scroll_xslider = "="
footer.scroll_ybar = "="
footer.scroll_x = 0
footer.scroll_y = 0
footer.bgk = _RGB32(10, 10, 80)
footer.fgk = _RGB32(250, 250, 250)
footer.txt_bgK = _RGB32(10, 10, 80)
footer.txt_fgK = _RGB32(250, 250, 250)
footer.penx = 0
footer.peny = 0
'build sidebar
sidebar.dx = 0
sidebar.dy = 0
sidebar.pwid = 150
sidebar.pht = 400
sidebar.vx = 650
sidebar.vwid = 150
sidebar.vht = 400
sidebar.vy = 100
sidebar.sh = _NewImage(sidebar.pwid, sidebar.pht, 32)
sidebar.scroll_on = "_NO"
sidebar.scroll_show = "_NO"
sidebar.scroll_xbar = "-"
sidebar.scroll_ybar = "|"
sidebar.scroll_xslider = "="
sidebar.scroll_ybar = "="
sidebar.scroll_x = 0
sidebar.scroll_y = 0
sidebar.bgk = _RGB32(50, 50, 50)
sidebar.fgk = _RGB32(250, 250, 250)
sidebar.txt_bgK = _RGB32(50, 50, 50)
sidebar.txt_fgK = _RGB32(250, 250, 250)
sidebar.penx = 0
sidebar.peny = 0
Screen mdisplay.sh
'crude setup
_Dest canvas.sh
Line (0, 0)-(canvas.pwid - 1, canvas.pht - 1), canvas.bgk, BF
Color canvas.txt_fgK, canvas.txt_bgK
prat 1, 1, "CANVAS", "c"
_Dest header.sh
Line (0, 0)-(header.pwid - 1, header.pht - 1), header.bgk, BF
Color header.txt_fgK, header.txt_bgK
prat 1, 1, " HEADER HEADER HEADER HEADER HEADER HEADER HEADER HEADER HEADER HEADER ", "header"
prat 1, 4, "Press a letter to decorate the canvas, esc to quit", "header"
_Dest footer.sh
Line (0, 0)-(footer.pwid - 1, footer.pht - 1), footer.bgk, BF
Color footer.txt_fgK, footer.txt_bgK
prat 1, 1, "Footer", "footer"
_Dest sidebar.sh
Line (0, 0)-(sidebar.pwid - 1, sidebar.pht - 1), sidebar.bgk, BF
Color sidebar.txt_fgK, sidebar.txt_bgK
prat 1, 1, "Sidebar", "siddebar"
'==================================
'main program here
'===================================
'dimension variables for mainprogram
Dim Shared charcount
charcount = 0
Do
_Limit 60
refresh_mdisplay
' _Display
If _Resize Then doresize
any$ = getkey$("abcdefghijklmnopqrstuvwxyz")
txt$ = "Window Size: " + Str$(_Width(mdisplay.sh)) + "," + Str$(_Height(mdisplay.sh))
prat 1, 2, txt$, "footer"
footer.dx = footer.dy + 12: If footer.dy > footer.pht - 100 Then footer.dy = footer.pht - 100
_Dest canvas.sh
cc = Int(Rnd * 13) + 1
mx = canvas.vwid
my = canvas.vht
If any$ <> "" Then charcount = charcount + cc
If any$ >= "a" Or any$ <= "z" Then
lastkeypressed$ = any$
For aax = 1 To cc
_PrintString (Int(Rnd * mx), Int(Rnd * my)), any$
Next
If any$ = "o" Then orb Int(Rnd * mx), Int(Rnd * my), Int(Rnd * 100) + 5, _RGB32(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256)), (Rnd * 7.5) + .2
End If
tt$ = "Last key pressed: " + lastkeypressed$
prat 3, 3, tt$, "footer"
prat 1, 4, "Character Count", "sidebar"
prat 1, 5, Str$(charcount), "sidebar"
Loop Until any$ = Chr$(27)
'and we are done here
'====================================================================
'any garbage collection or closing routines should be here
'====================================================================
System
Function waitkey$ (klist$)
If klist$ = "" Then
Do
_Limit 30
a$ = InKey$
Loop Until a$ <> ""
Else
k$ = klist$ + Chr$(27)
Do
_Limit 30
a$ = InKey$
Loop Until a$ <> "" And InStr(k$, a$)
End If
waitkey$ = a$
End Function
Function getkey$ (klist$)
If klist$ = "" Then
a$ = InKey$
Else
k$ = klist$ + Chr$(27)
a$ = InKey$
If a$ <> "" And InStr(k$, a$) Then getkey$ = a$
End If
End Function
Function brighter& (ch&&, p)
r = _Red(ch&&)
b = _Blue(ch&&)
g = _Green(ch&&)
If p < 0 Then p = 0
If p > 100 Then p = 100
p = p / 100
rdif = 255 - r: rc = rdif * p: brr = Int(r + rc): If brr > 255 Then brr = 255
gdif = 255 - g: gc = gdif * p: bgg = Int(g + gc): If bgg > 255 Then bgg = 255
bdif = 255 - b: bc = bdif * p: bbb = Int(b + bc): If bbb > 255 Then bbb = 255
brighter& = _RGB(brr, bgg, bbb)
End Function
Sub orb (XX As Long, YY As Long, Rd As Long, KK As Long, brt As Integer)
'for false shaded 3-D look
'XX,YY arer screen position Rd is outermost radius of the orb KK is the startign color
'brt is the factor by which color will chnage it is the diffeence from KK to RGB(255,255,255)
'brt is applied each step so your orb will go to white if it is large or the brt value is high
Dim nk As Long
nk = KK ' this solves my problem along with changes to following lines to use nk instead of kk
ps = _Pi
p3 = _Pi / 3
p4 = _Pi / 4
If Rd < 10 Then ps = _Pi / 6 'so small radius orbs look cool too
rdc = p4 / Rd
For c = 0 To Int(Rd * .87) Step ps
nk = brighter&(nk, brt)
CircleFill XX, YY, Rd - (c), nk
XX = XX + rdc * (c * p3) ' could be fiddled with to move the center of the gradient
YY = YY - rdc * (c * 2 * p4) ' could be fiddled with to move the center of the gradient
Next c
End Sub
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
'sub by SMcNeill makes a filled circle without worrying about using the paint comamnd to fill an empty circle
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub doresize
' _AutoDisplay
oldh = mdisplay.pht
oldW = mdisplay.pwid
temp = _NewImage(_ResizeWidth, _ResizeHeight, 32)
Screen temp
_FreeImage mdisplay.sh
mdisplay.sh = temp
newW = _Width(mdisplay.sh): newH = _Height(mdisplay.sh)
mdisplay.pwid = newW
mdisplay.pht = newH
Hchange = oldh - newH
Wchange = oldW = newW
copyfooter = _CopyImage(footer.sh)
_FreeImage footer.sh
footer.vwid = newW
footer.vy = newH - footer.vht
If newW > footer.pwid Then footer.pwid = newW
footer.sh = _NewImage(footer.pwid, footer.pht, 32)
_Dest footer.sh
Line (0, 0)-(footer.pwid - 1, footer.pht - 1), footer.bgk, BF
_PutImage , footer.sh, copyfooter
canvas.vwid = newW - sidebar.vwid
canvas.vht = newH - (footer.vht)
copyheader = _CopyImage(header.sh)
_FreeImage header.sh
header.vwid = newW
If newW > header.pwid Then header.pwid = newW
header.sh = _NewImage(header.pwid, header.pht, 32)
_Dest header.sh
Line (0, 0)-(header.pwid - 1, header.pht - 1), header.bgk, BF
_PutImage (0, 0), copyheader, header.sh
sidebar.vx = newW - sidebar.vwid
sidebar.vht = newH - (footer.vht + header.vht)
copysidebar = _CopyImage(sidebar.sh)
_FreeImage sidebar.sh
If newH > sidebar.pht Then sidebar.pht = newH
sidebar.sh = _NewImage(sidebar.pwid, sidebar.pht, 32)
_Dest sidebar.sh
Line (0, 0)-(header.pwid - 1, sidebar.pht - 1), sidebar.bgk, BF
_PutImage (0, 0), copysidebar, sidebar.sh
refresh_mdisplay
copyheader = _CopyImage(header.sh)
copysidebar = _CopyImage(sidebar.sh)
'_Delay .25
dummy = _Resize 'clear the resize flag after manually setting the screen to the size specified
End Sub
Sub refresh_mdisplay
_Dest mdisplay.sh
_PutImage (canvas.vx, canvas.vy)-(canvas.vx + canvas.vwid - 1, canvas.vy + canvas.vht - 1), canvas.sh, mdisplay.sh, (0, 0)-(canvas.vwid - 1, canvas.vht - 1)
_PutImage (header.vx, header.vy)-(header.vx + header.vwid - 1, header.vy + header.vht - 1), header.sh, mdisplay.sh, (0, 0)-(header.vwid - 1, header.vht - 1)
_PutImage (sidebar.vx, sidebar.vy)-(sidebar.vx + sidebar.vwid - 1, sidebar.vy + sidebar.vht - 1), sidebar.sh, mdisplay.sh, (0, 0)-(sidebar.vwid - 1, sidebar.vht - 1)
_PutImage (footer.vx, footer.vy)-(footer.vx + footer.vwid - 1, footer.vy + footer.vht - 1), footer.sh, mdisplay.sh, (0, 0)-(footer.vwid - 1, footer.dy + footer.vht - 1)
_Display
End Sub
Sub prat (x, y, txt$, h$)
'prit at
'x and Y are text coordinates inside frame/panel h$
'curently haerdcoded: h= header, f=footer, s=sidebar, c = canvas
subh$ = _Trim$(LCase$(h$))
subh$ = Left$(subh$, 1)
xx = (x - 1) * 8
yy = (y - 1) * 16
Select Case subh$
Case "h"
_Dest header.sh
Color header.txt_fgK, header.txt_bgK
_PrintString (xx, yy), txt$
Case "f"
_Dest footer.sh
Color footer.txt_fgK, footer.txt_bgK
_PrintString (xx, yy), txt$
Case "s"
_Dest sidebar.sh
Color sidebar.txt_fgK, sidebar.txt_bgK
_PrintString (xx, yy), txt$
Case "c"
_Dest canvas.sh
Color canvas.txt_fgK, canvas.txt_bgK
_PrintString (xx, yy), txt$
End Select
End Sub
|
|
|
|
| external sub/function |
|
Posted by: MasterGy - 08-02-2022, 09:31 PM - Forum: General Discussion
- Replies (2)
|
|
Hello !
I would like to collect all the sub/functions I have written so far to make a universal 3d engine. I would like sub/function to be in a separate file. attachment. What could be the problem ? it recognizes m_coll.bm, it does not indicate an error there. But it does not recognize the "veletlen" function. why ?
boss-program:
Code: (Select All) Rem $INCLUDE: 'm_coll.bm'
print veletlen (10)
m_coll.bm (sub/function library)
Code: (Select All) FUNCTION veletlen (x)
veletlen = x * RND(1)
END FUNCTION
|
|
|
|
| old showdown |
|
Posted by: James D Jarvis - 08-02-2022, 12:58 PM - Forum: Programs
- Replies (5)
|
|
This is a recreation of the first computer program (and first game) I ever wrote about 40 years ago. It's uses a couple of new-fangled features but is as close as I can remember it.
The original requirements for the assignment was a math function, and user input .
Code: (Select All) 'oldshowdown
'This is a recreation of my very first basic game as best as I can recall.
'originally written in math class on an apple computer in the 7th or 8th grade
'nothing amazing, just personal computing archeology of a sort
Randomize Timer
Cls
Dim p$(3)
For x = 20 To 1 Step -1
_Limit 10
Cls
For y = 1 To x
Print
Next
Print " S H O W D O W N"
_Display
Next
Print: Print
Print " Well Pardner the time has come, Black Bart is calling you out."
_Delay 0.25
Print
Print " You strap on your trusty six-shooter and walk out into the street."
_Delay 0.25
givehint:
hint = Int(1 + Rnd * 3)
p$(1) = " The sun is in your eyes."
p$(2) = " Everything is silent except for a dog barking in the distance."
p$(3) = " Buzzards circle high above the dusty street..."
Print p$(hint)
hint = hint * 3
_Delay 0.25
shoot:
Print " Pick a number from 1 to 9 to fire your shooting iron."
Input s$
sn = Val(s$)
Print
bartshot = Int(1 + Rnd * hint)
Print "Both shots ring out... "
_Delay 0.5
If sn = bartshot Then GoTo youwon
If sn < bartshot Then GoTo bartwon
If sn > bartshot Then GoTo fighton
bartwon:
Print " ... the last thing you hear is Black Bart laughing."
Print
End
youwon:
Print " ... Black Bart smiles..."
_Delay 0.5
Print " ... before dropping where he stands."
Print
Print "The street fills with the townsfolk slapping you on the back and cheering."
Print
End
fighton:
Print "Both of your shots have gone wild, Black Bart shifts to the side and pulls the hammer back on his revolver..."
Print
GoTo givehint
|
|
|
|
| Fonts |
|
Posted by: Dimster - 08-02-2022, 12:55 PM - Forum: General Discussion
- Replies (8)
|
|
I recall there was a thread on how to add different Fonts to your program but I can't seem to find it. Perhaps it was on the deceased forum??? Does anyone know where I might find it again?
Also, the thought comes to mind, would it be useful to have an option for different fonts in the IDE menu TOOLS. I have no clue how difficult that maybe or even if it would get much use.
In terms of using fonts in your program, it's one thing to display a font on the screen, and I assume, a completely different thing to have a particular font print on a printer? Or am I out to lunch on that comment ie a screen dump using LPrint picks up whatever font is displayed.
|
|
|
|
|
