Welcome, Guest |
You have to register before you can post on our site.
|
Forum Statistics |
» Members: 499
» Latest member: Blayk
» Forum threads: 2,852
» Forum posts: 26,717
Full Statistics
|
Latest Threads |
BAM Sample Programs
Forum: QBJS, BAM, and Other BASICs
Last Post: CharlieJV
24 minutes ago
» Replies: 36
» Views: 1,955
|
Glow Bug
Forum: Programs
Last Post: SierraKen
43 minutes ago
» Replies: 2
» Views: 25
|
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: dbox
3 hours ago
» Replies: 12
» Views: 175
|
Audio storage, stereo swi...
Forum: Programs
Last Post: Petr
6 hours ago
» Replies: 8
» Views: 342
|
_CONSOLEINPUT is blocking
Forum: General Discussion
Last Post: mdijkens
Yesterday, 12:24 PM
» Replies: 7
» Views: 121
|
Most efficient way to bui...
Forum: General Discussion
Last Post: ahenry3068
01-17-2025, 11:36 PM
» Replies: 9
» Views: 135
|
QBJS - ANSI Draw
Forum: QBJS, BAM, and Other BASICs
Last Post: madscijr
01-17-2025, 11:24 PM
» Replies: 4
» Views: 131
|
Fun with Ray Casting
Forum: a740g
Last Post: a740g
01-17-2025, 05:50 AM
» Replies: 10
» Views: 248
|
Very basic key mapping de...
Forum: SMcNeill
Last Post: a740g
01-17-2025, 02:33 AM
» Replies: 1
» Views: 53
|
Methods in types
Forum: General Discussion
Last Post: bobalooie
01-17-2025, 01:02 AM
» Replies: 0
» Views: 61
|
|
|
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
|
|
|
Customizable Program Display |
Posted by: SMcNeill - 08-02-2022, 05:00 AM - Forum: Works in Progress
- Replies (14)
|
|
Here's a little showcase of something which I'm working on for a personal little project of mine, which I thought folks might like to take a look at -- an user customizable-display program.
Code: (Select All) 'Set compiler and global progeam options
'All variables and arrays are dynamic by default
'$Dynamic
'Allow the use of color names for 32-bit screen mode
$Color:32
''$INCLUDE:'Keyboard Library.BI'
_Define A-Z As LONG 'default variable type is long
_Title "Title TBD"
'Types and global variables
Dim Shared As Long ScreenWidth, ScreenHeight, DisplayScreen, WorkScreen, ReDrawScreen
Dim Shared As Long Font(10), FontSize, Brightness
Dim Shared As Long True, False
'Defaut vaues for global variables
ScreenWidth = 1280
ScreenHeight = 720
DisplayScreen = _NewImage(ScreenWidth, ScreenHeight, 32)
WorkScreen = _NewImage(ScreenWidth, 32000, 32)
True = -1: False = 0
ReDrawScreen = 0
Font(0) = _LoadFont("courbd.ttf", 6, "monospace")
Font(1) = _LoadFont("courbd.ttf", 8, "monospace")
Font(2) = _LoadFont("courbd.ttf", 10, "monospace")
Font(3) = _LoadFont("courbd.ttf", 12, "monospace")
Font(4) = _LoadFont("courbd.ttf", 14, "monospace")
Font(5) = _LoadFont("courbd.ttf", 16, "monospace")
Font(6) = _LoadFont("courbd.ttf", 18, "monospace")
Font(7) = _LoadFont("courbd.ttf", 22, "monospace")
Font(8) = _LoadFont("courbd.ttf", 28, "monospace")
Font(9) = _LoadFont("courbd.ttf", 36, "monospace")
Font(10) = _LoadFont("courbd.ttf", 48, "monospace")
FontSize = 8 'starting font size
Brightness = 5
Screen DisplayScreen
_Delay .2
_Dest WorkScreen
_Font Font(FontSize)
Color _RGB32(255 \ Brightness), 0
Do
ProcessInput
Cls , 0
Print _Width(DisplayScreen), _Height(DisplayScreen)
_PutImage , WorkScreen, DisplayScreen, (0, 0)-Step(_Width(DisplayScreen), _Height(DisplayScreen))
_Limit 60
_Display
Loop
Sub ProcessInput
While _MouseInput: MouseScroll = MouseScroll + _MouseWheel: Wend
K = _KeyHit
If _KeyDown(100306) Or _KeyDown(100305) Then CTRL = True Else CTRL = False
If _KeyDown(100304) Or _KeyDown(100303) Then SHIFT = True Else SHIFT = False
If _KeyDown(100308) Or _KeyDown(100307) Then ALT = True Else ALT = False
Select Case K
Case 19200 'left
If CTRL Then
If ScreenWidth >= 650 Then ScreenWidth = ScreenWidth - _FontWidth: AutoResize
ElseIf ALT Then
If FontSize > 0 Then FontSize = FontSize - 1: _Font Font(FontSize): AutoResize
End If
Case 18432 'up
If CTRL Then
If ScreenHeight >= 410 Then ScreenHeight = ScreenHeight - _FontHeight: AutoResize
ElseIf ALT Then
If Brightness > 1 Then Brightness = Brightness - 1: Color _RGB32(255 \ Brightness), 0
End If
Case 19712 'right
If CTRL Then
If ScreenWidth <= _DesktopWidth - 10 Then ScreenWidth = ScreenWidth + _FontWidth: AutoResize
ElseIf ALT Then
If FontSize < 10 Then FontSize = FontSize + 1: _Font Font(FontSize): AutoResize
End If
Case 20480 'down
If CTRL Then
If ScreenHeight <= _DesktopHeight - 10 Then ScreenHeight = ScreenHeight + _FontHeight: AutoResize
ElseIf ALT Then
If Brightness < 10 Then Brightness = Brightness + 1: Color _RGB32(255 \ Brightness), 0
End If
Case 27
System
End Select
End Sub
Sub AutoResize
Static OldFontSize
W = _Width(DisplayScreen): H = _Height(DisplayScreen)
FW = _FontWidth: FH = _FontHeight
RW = ScreenWidth: RH = ScreenHeight
RW = _Round(RW / FW) * FW
RH = _Round(RH / FH) * FH
ScreenWidth = RW: ScreenHeight = RH
tempscreen = _NewImage(RW, RH, 32)
Screen tempscreen
_FreeImage DisplayScreen
DisplayScreen = tempscreen
tempscreen = _NewImage(RW, 32000, 32) 'create the newly sized WorkScreen
_Dest tempscreen 'can't freeimage a screen if it's in use?
_FreeImage WorkScreen 'free the old WorkScreen
WorkScreen = tempscreen
_Dest WorkScreen
_Font Font(FontSize)
Color _RGB32(255 \ Brightness), 0
OldFontSize = FontSize
ReDrawScreen = -1
End Sub
''$INCLUDE:'Keyboard Library.BM'
Now, since I couldn't get $RESIZE:ON to work the way I was wanting, with a limit for size, I took it out of this program. Instead, the user here now has several options, all of which are keyboard operated:
CTRL + Arrow Keys = Resize the screen. You can make this program bigger or smaller, on the fly.
ALT + Left/Right Arrow = Increase or Decrease the size of the font on the screen. Notice that this can also change the size of the screen slightly to suit the new fontwidth and fontheight.
ALT + Up/Down Arrow = Increase or Decrease the brightness of the text on the screen. Late at night, I tend to do things with the lights off and while sitting in the dark a lot of the times, and a bright display ends up hurting my eyes. This corrects that issue by allowing us to adjust the brightness of the text so that we can might it more intense in times of high surrounding light, or turn it waaay down, if we prefer, for use in the dark.
Now, we're not actually doing anything with this program as of yet, but it does use two distinct screens for us -- a WorkScreen and a DisplayScreen. The WorkScreen is 32000 pixels in height, so we can print multiple pages of text upon it, and then display segments upon the DisplayScreen, for ease of scrolling up and down with screens which hold more than a single page of information.
I'll be adding word wrap along with the auto-resizing features, and then the basic interface will more-or-less be done for my needs. If you guys want, I'll post a version of this with a nice long page of junk and word wrap to bring it all together, but I thought I'd go ahead and share it as it is, in case anyone else would ever be interested in making use of this type of user-interactive interface. Personally, I think it'd make a nice little way to allow the user some display options for something like a text-adventure game, or any type of program which would be heavy on text usage.
As I get older, I find it's always nice to be able to make text a little bigger/smaller and brighter/dimmer, depending on the state of my poor eyes. What we have here is basically just a little plug-in routine which is ready built to handle most of that for us already. With just a few minor enhancements, I imagine this will be something which I might end up making a lot of use of in the future.
|
|
|
Resize breaking |
Posted by: SMcNeill - 08-01-2022, 07:01 PM - Forum: Help Me!
- Replies (11)
|
|
An example of some code which I'm having issues with, which may be a glitch in QB64, or might be a glitch in poor Steve. I thought I'd post it here to share so others could test it out and see what's wrong with it.
Code: (Select All) 'Set compiler and global progeam options
'All variables and arrays are dynamic by default
'$Dynamic
'Allow the screen to be resized, but handle operations manually.
$Resize:On
'Allow the use of color names for 32-bit screen mode
$Color:32
_Define A-Z As LONG 'default variable type is long
_Title "Test Glitch"
'Types and global variables
Dim Shared As Long ScreenWidth, ScreenHeight, DisplayScreen, WorkScreen, ReDrawScreen
Dim Shared As Long Font(10), FontSize
'Defaut vaues for global variables
ScreenWidth = 1280
ScreenHeight = 720
DisplayScreen = _NewImage(1024, 720, 32)
WorkScreen = _NewImage(1024, 32000, 32)
ReDrawScreen = 0
Font(0) = _LoadFont("courbd.ttf", 6, "monospace")
Font(1) = _LoadFont("courbd.ttf", 8, "monospace")
Font(2) = _LoadFont("courbd.ttf", 10, "monospace")
Font(3) = _LoadFont("courbd.ttf", 12, "monospace")
Font(4) = _LoadFont("courbd.ttf", 14, "monospace")
Font(5) = _LoadFont("courbd.ttf", 16, "monospace")
Font(6) = _LoadFont("courbd.ttf", 18, "monospace")
Font(7) = _LoadFont("courbd.ttf", 22, "monospace")
Font(8) = _LoadFont("courbd.ttf", 28, "monospace")
Font(9) = _LoadFont("courbd.ttf", 36, "monospace")
Font(10) = _LoadFont("courbd.ttf", 48, "monospace")
FontSize = 8 'starting font size
Screen DisplayScreen
_Delay .2
_Dest WorkScreen
_Font Font(FontSize)
clearFlag = _Resize
Do
AutoResize
Cls , 0
Print _Width(DisplayScreen), _Height(DisplayScreen)
_PutImage , WorkScreen, DisplayScreen, (0, 0)-Step(_Width(DisplayScreen), _Height(DisplayScreen))
_Limit 60
_Display
Loop
Sub AutoResize
Static OldFontSize
W = _Width(DisplayScreen): H = _Height(DisplayScreen)
FW = _FontWidth: FH = _FontHeight
If _Resize Then
Do
_Delay .1
Loop Until _Resize = 0 'wait for the user to finish their resize event
RW = _ResizeWidth: RH = _ResizeHeight
If RW < 640 Then RW = 640
If RW > _DesktopWidth Then RW = _DesktopWidth
If RH < 400 Then RH = 400
If RH > _DesktopHeight Then RH = _DesktopHeight
GoTo resize_event
End If
If OldFontSize <> FontSize Then
RW = W: RH = H
GoTo resize_event
End If
Exit Sub
resize_event:
RW = (RW \ FW) * FW
RH = (RH \ FH) * FH
tempscreen = _NewImage(RW, 32000, 32) 'create the newly sized WorkScreen
_Dest tempscreen 'can't freeimage a screen if it's in use?
_FreeImage WorkScreen 'free the old WorkScreen
WorkScreen = tempscreen
_Dest WorkScreen
_Font Font(FontSize)
tempscreen = _NewImage(RW, RH, 32)
Screen tempscreen
_FreeImage DisplayScreen
DisplayScreen = tempscreen
OldFontSize = FontSize
ReDrawScreen = -1
Do
_Delay .1
Loop Until _Resize = 0
End Sub
Now, at the moment, this doesn't do much except print the width and height of the screen for us. Generally, it works as it should, with one exception -- if we drag the size below the minimum bounds set by the program (640x400).
The first time we snap below 640 width, the program does as it should and resizes back up to 640.
If we then grab it and resize it down below 640 width a second time, the screen loses that snap-ability and refuses to resize. Oddest thing however, is that it still reports itself as being 640 wide, even when it's obviously not.
I've no clue where the glitch is in the matrix on this one!
To add to the oddness, you can then drag the width back to the right a few times, and pass that 640 mark, and after a few attempts, the resize routine will start working just peachy fine again -- as long as you don't go below the 640 limit.
So what's the glitch here guys? Is QB64 doing something oddish, or is it just me with a broken head?
|
|
|
File path within program |
Posted by: james2464 - 08-01-2022, 05:52 PM - Forum: Help Me!
- Replies (2)
|
|
Hi,
I'm following the tutorial at qb64sourcecode.com and because the sound files don't work I'm trying to understand why. Can anyone explain the way this command works? I've copied and pasted the tutorial folder in a few places and I got it working on one computer but not on a second one. So I clearly don't get it. The folder containing qb64.exe is where the tutorial folder is pasted, yet the "piano" and task 14 programs don't work.
Phaser& = _SndOpen(".\tutorial\task14\Phaser.ogg")
I was under the impression that this points to a location relative to the qb64.exe itself. But yeah I have no idea now.
Edit: I can get this to work by removing all the folder info and just leaving the file name. Example ("Phaser.ogg") So I'm still unclear about ".\" At this point I'm assuming I must have installed qb64 in the wrong place in order for the tutorial paths to work as is. Either way thanks to the wiki I can test this with the '_fileexists' command.
|
|
|
Don't make me REPETEND myself... |
Posted by: Pete - 07-31-2022, 08:57 PM - Forum: General Discussion
- Replies (23)
|
|
So Jack got me working on string math again. I don't know whether to thank him or shoot him (refers to avatar) but, here we go again...
I was thinking if I ever want to address using repetends (repeating decimals) to make even simple string equations like 1 / 3 * 3 = 1, instead of .999... then I might need to explore how to identify those repeating decimal occurrences.
Below is a sample program (non idiot-proof so don't post it accepted invalid data) that I hope detects all instances of repetends. I coded the first part, and then added (pasted) in the division routine from my string math program.
Try inputting 1 as the numerator and 97 as the denominator and you will largest repetend I know of, 96 digits befor the sequence repeats!
Code: (Select All) WIDTH 170, 42
_SCREENMOVE 0, 0
DO
DIM SHARED runningtotal$, limit&&
limit&& = 200
LINE INPUT "Numerator: "; a$
LINE INPUT "Denominator: "; b$
calcdiv a$, b$
COLOR 14, 0: PRINT runningtotal$; " ";: COLOR 7, 0
IF INSTR(runningtotal$, ".") THEN
x$ = MID$(runningtotal$, INSTR(runningtotal$, ".") + 1)
x$ = MID$(x$, LEN(b$) - LEN(a$) + 2)
FOR i = 1 TO LEN(x$)
k = j
j = INSTR(i + 1, x$, MID$(x$, 1, i))
IF j = k THEN EXIT FOR
NEXT
SELECT CASE j
CASE 0
IF MID$(x$, 1, 2) <> MID$(x$, 2, 2) OR LEN(x$) < 2 THEN
msg$ = "Non-repetend."
ELSE
IF MID$(runningtotal$, INSTR(runningtotal$, ".") + 1, 1) <> MID$(x$, 1, 1) THEN
msg$ = "Eventual infinite repetend."
ELSE
msg$ = "Repetend infinite."
END IF
END IF
CASE ELSE
msg$ = "Repetend length: " + LTRIM$(STR$(j - 1))
END SELECT
ELSE
msg$ = "Non-decimal"
END IF
PRINT msg$
CLEAR
PRINT
LOOP
SUB calcdiv (a$, b$)
stringmatha$ = a$
stringmathb$ = b$
operationdivision% = -1
divbuffer& = LEN(stringmathb$) - LEN(stringmatha$)
IF divbuffer& < 0 THEN divbuffer& = 0
d2dividend$ = stringmatha$
d1divisor$ = stringmathb$
IF LEFT$(d1divisor$, 1) = "0" AND LEN(d1divisor$) = 1 THEN PRINT "Division by zero not allowed.": EXIT SUB
IF LEFT$(d1divisor$, 1) = "-" THEN divsign% = -1: d1divisor$ = MID$(d1divisor$, 2)
IF LEFT$(d2dividend$, 1) = "-" THEN
IF divsign% THEN
divsign% = 0
ELSE
divsign% = -1
END IF
d2dividend$ = MID$(d2dividend$, 2)
END IF
IF INSTR(d1divisor$, ".") <> 0 THEN
DO UNTIL RIGHT$(d1divisor$, 1) <> "0"
d1divisor$ = MID$(d1divisor$, 1, LEN(d1divisor$) - 1) ' Strip off trailing zeros
LOOP
divplace& = LEN(d1divisor$) - INSTR(d1divisor$, ".")
d1divisor$ = MID$(d1divisor$, 1, INSTR(d1divisor$, ".") - 1) + MID$(d1divisor$, INSTR(d1divisor$, ".") + 1) ' Strip off decimal point.
DO UNTIL LEFT$(d1divisor$, 1) <> "0"
d1divisor$ = MID$(d1divisor$, 2) ' Strip off leading zeros for divisors smaller than .1
LOOP
END IF
IF INSTR(d2dividend$, ".") <> 0 THEN
d2dividend$ = d2dividend$ + STRING$(divplace& - LEN(d2dividend$) - INSTR(d2dividend$, "."), "0") ' Add any zeros based on the length of dividend at decimal - length of divisor at decimal. If less than zero, nothing added.
divplace2& = INSTR(d2dividend$, ".")
DO UNTIL RIGHT$(d2dividend$, 1) <> "0"
d2dividend$ = MID$(d2dividend$, 1, LEN(d2dividend$) - 1) ' Strip off trailing zeros
LOOP
d2dividend$ = MID$(d2dividend$, 1, INSTR(d2dividend$, ".") - 1) + MID$(d2dividend$, INSTR(d2dividend$, ".") + 1) ' Strip off decimal point.
ELSE
d2dividend$ = d2dividend$ + STRING$(divplace&, "0") ' Add any zeros based on the length of dividend at decimal - length of divisor at decimal. If less than zero, nothing added.
divplace& = 0
END IF
DO
DO
divremainder& = divremainder& + 1: divremainder$ = divremainder$ + MID$(d2dividend$, divremainder&, 1)
IF MID$(d2dividend$, divremainder&, 1) = "" THEN
IF divremainder$ = STRING$(LEN(divremainder$), "0") AND LEN(quotient$) > LEN(d2dividend$) THEN divflag% = -1: EXIT DO
divcarry& = divcarry& + 1
IF divcarry& = 1 THEN divplace3& = divremainder& - 1
IF divcarry& > limit&& + 1 + divbuffer& THEN
divflag% = -2: EXIT DO
END IF
divremainder$ = divremainder$ + "0" ' No more digits to bring down.
END IF
IF LEN(divremainder$) > LEN(d1divisor$) OR LEN(divremainder$) = LEN(d1divisor$) AND divremainder$ >= d1divisor$ THEN EXIT DO
quotient$ = quotient$ + "0"
LOOP
IF divflag% THEN divflag% = 0: EXIT DO
FOR div_i% = 9 TO 1 STEP -1
stringmatha$ = LTRIM$(STR$(div_i%)): stringmathb$ = d1divisor$
m_product$ = "": GOSUB string_multiply
tempcutd$ = divremainder$ ' divremainder$ can be 00 or other leading zero values.
DO
IF LEN(tempcutd$) = 1 THEN EXIT DO
IF LEFT$(tempcutd$, 1) = "0" THEN
tempcutd$ = MID$(tempcutd$, 2)
ELSE
EXIT DO
END IF
LOOP
IF LEN(tempcutd$) > LEN(m_product$) OR LEN(tempcutd$) = LEN(m_product$) AND m_product$ <= tempcutd$ THEN EXIT FOR
NEXT
quotient$ = quotient$ + LTRIM$(STR$(div_i%))
stringmatha$ = LTRIM$(STR$(div_i%)): stringmathb$ = d1divisor$
m_product$ = "": GOSUB string_multiply
operator$ = "-"
stringmatha$ = divremainder$
stringmathb$ = m_product$
GOSUB string_add_subtract
divremainder$ = stringmatha$
operator$ = "/"
LOOP
IF divplace& = 0 AND divplace2& = 0 THEN divplace& = divplace3&
IF divplace2& THEN divplace& = divplace& + divplace2& - 1
IF quotient$ = "" THEN divplace& = 0 ' dividend is zero.
IF divplace& OR divplace2& THEN
quotient$ = MID$(quotient$, 1, divplace&) + "." + MID$(quotient$, divplace& + 1)
DO UNTIL RIGHT$(quotient$, 1) <> "0"
quotient$ = MID$(quotient$, 1, LEN(quotient$) - 1) ' Strip off trailing zeros
LOOP
IF RIGHT$(quotient$, 1) = "." THEN quotient$ = MID$(quotient$, 1, LEN(quotient$) - 1) ' Strip off abandoned decimal.
END IF
DO UNTIL LEFT$(quotient$, 1) <> "0"
quotient$ = MID$(quotient$, 2) ' Strip off leading zeros
LOOP
IF quotient$ = "" THEN quotient$ = "0": divsign% = 0
operationdivision% = 0
stringmathb$ = quotient$: quotient$ = ""
'''GOSUB limit_round_convert
IF stringmathb$ = "overflow" THEN divsign% = 0: EXIT SUB
'''GOSUB sm_converter
runningtotal$ = stringmathb$: stringmathb$ = ""
IF divsign% THEN runningtotal$ = "-" + runningtotal$
IF stringmathround$ <> "" THEN runningtotal$ = runningtotal$ + stringmathround$
EXIT SUB
string_multiply:
fac1$ = stringmatha$: fac2$ = stringmathb$ ' Make numbers whole numbers and remove any - sign.
IF LEFT$(fac1$, 1) = "-" THEN fac1$ = MID$(fac1$, 2): m_sign% = -1
IF LEFT$(fac2$, 1) = "-" THEN fac2$ = MID$(fac2$, 2): IF m_sign% THEN m_sign% = 0 ELSE m_sign% = -1
IF INSTR(fac1$, ".") <> 0 THEN m_decimal_places& = LEN(fac1$) - INSTR(fac1$, "."): fac1$ = MID$(fac1$, 1, INSTR(fac1$, ".") - 1) + MID$(fac1$, INSTR(fac1$, ".") + 1)
IF INSTR(fac2$, ".") <> 0 THEN m_decimal_places& = m_decimal_places& + LEN(fac2$) - INSTR(fac2$, "."): fac2$ = MID$(fac2$, 1, INSTR(fac2$, ".") - 1) + MID$(fac2$, INSTR(fac2$, ".") + 1)
FOR m_i& = LEN(fac2$) TO 1 STEP -1 ' Multiply each charter top and bottom.
m_k& = m_l&
m_x2$ = MID$(fac2$, m_i&, 1)
FOR m_j& = LEN(fac1$) TO 1 STEP -1
m_x1$ = MID$(fac1$, m_j&, 1)
IF m_product$ <> "" THEN
m_add$ = LTRIM$(STR$(VAL(m_x1$) * VAL(m_x2$))) + STRING$(m_k&, "0")
m_t& = 0: m_xproduct$ = "": m_carry% = 0
DO ' Add multiplied characters together.
m_x3$ = MID$(m_add$, LEN(m_add$) - m_t&, 1)
m_x4$ = MID$(m_product$, LEN(m_product$) - m_t&, 1)
IF m_x3$ = "" AND m_x4$ = "" THEN
IF m_carry% THEN m_xproduct$ = "1" + m_xproduct$
EXIT DO
END IF
m_g% = VAL(m_x3$) + VAL(m_x4$) + m_carry%
IF m_g% >= 10 THEN m_g% = m_g% - 10: m_carry% = 1 ELSE m_carry% = 0
m_xproduct$ = LTRIM$(STR$(m_g%)) + m_xproduct$
m_t& = m_t& + 1
LOOP
m_product$ = m_xproduct$: m_xproduct$ = ""
ELSE
m_product$ = LTRIM$(STR$(VAL(m_x1$) * VAL(m_x2$))) + STRING$(m_k&, "0") ' First loop makes variable here.
END IF
m_k& = m_k& + 1 ' Adds trailing zeros multiplication
NEXT
m_l& = m_l& + 1 ' Used to reset value for m_k& adding one trailing zer for each loop.
NEXT
fac1$ = "": fac2$ = "": m_l& = 0: m_k& = 0: m_t& = 0
IF m_decimal_places& > LEN(m_product$) THEN m_product$ = STRING$(m_decimal_places& - LEN(m_product$), "0") + m_product$ ' Add any leading zeros to a decimal. Ex: .02 * .01 is factored as 002. It needs one leading zero before adding the decimal point, .0002.
IF m_decimal_places& AND m_product$ <> "0" THEN ' Replace any decimal point.
m_product$ = MID$(m_product$, 1, LEN(m_product$) - m_decimal_places&) + "." + MID$(m_product$, LEN(m_product$) - m_decimal_places& + 1)
END IF
DO UNTIL LEFT$(m_product$, 1) <> "0" ' Remove leading zeros.
m_product$ = MID$(m_product$, 2)
LOOP
IF m_decimal_places& THEN
DO UNTIL RIGHT$(m_product$, 1) <> "0" ' Remove trailing zeros in a decimal sum.
m_product$ = MID$(m_product$, 1, LEN(m_product$) - 1)
LOOP
END IF
IF m_product$ = "" THEN m_product$ = "0": m_sign% = 0
IF RIGHT$(m_product$, 1) = "." THEN m_product$ = MID$(m_product$, 1, LEN(m_product$) - 1) ' Remove decimal from the end of an integer total.
IF operationdivision% THEN m_sign% = 0: RETURN
stringmathb$ = m_product$: m_product$ = ""
'''GOSUB limit_round_convert
IF stringmathb$ = "overflow" THEN EXIT SUB
'''GOSUB sm_converter
runningtotal$ = stringmathb$: stringmathb$ = ""
IF m_sign% THEN runningtotal$ = "-" + runningtotal$: m_sign% = 0
RETURN
string_add_subtract:
IF INSTR(stringmatha$, ".") <> 0 THEN ' Evaluate sum for decimal fraction.
sumplace& = LEN(stringmatha$) - INSTR(stringmatha$, ".")
stringmatha$ = MID$(stringmatha$, 1, INSTR(stringmatha$, ".") - 1) + MID$(stringmatha$, INSTR(stringmatha$, ".") + 1) ' Strip out decimal
END IF
IF INSTR(stringmathb$, ".") <> 0 THEN ' Evaluate number for decimal fraction.
numplace& = LEN(stringmathb$) - INSTR(stringmathb$, ".")
stringmathb$ = MID$(stringmathb$, 1, INSTR(stringmathb$, ".") - 1) + MID$(stringmathb$, INSTR(stringmathb$, ".") + 1) ' Strip out decimal
END IF
IF sumplace& > numplace& THEN addsubplace& = sumplace& ELSE addsubplace& = numplace&
IF sumplace& > addsubplace& THEN
stringmatha$ = stringmatha$ + STRING$(sumplace& - addsubplace&, "0")
ELSEIF addsubplace& > sumplace& THEN
stringmatha$ = stringmatha$ + STRING$(addsubplace& - sumplace&, "0")
END IF
IF numplace& > addsubplace& THEN
stringmathb$ = stringmathb$ + STRING$(numplace& - addsubplace&, "0")
ELSEIF addsubplace& > numplace& THEN
stringmathb$ = stringmathb$ + STRING$(addsubplace& - numplace&, "0")
END IF ' END Decimal evaluations.
IF LEFT$(stringmatha$, 1) = "-" THEN sign_input$ = "-" ELSE sign_input$ = "+"
IF LEFT$(stringmathb$, 1) = "-" THEN sign_total$ = "-" ELSE sign_total$ = "+"
addsubsign% = 0
SELECT CASE sign_input$ + operator$ + sign_total$
CASE "+++", "+--"
operator$ = "+"
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
CASE "++-", "+-+"
operator$ = "-"
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
IF VAL(stringmathb$) > VAL(stringmatha$) THEN SWAP stringmatha$, stringmathb$: addsubsign% = -1
CASE "---", "-++"
operator$ = "-"
IF LEFT$(stringmatha$, 1) = "-" THEN stringmatha$ = MID$(stringmatha$, 2)
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
IF VAL(stringmathb$) > VAL(stringmatha$) THEN SWAP stringmatha$, stringmathb$ ELSE addsubsign% = -1
CASE "--+", "-+-"
operator$ = "+"
IF LEFT$(stringmatha$, 1) = "-" THEN stringmatha$ = MID$(stringmatha$, 2)
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
addsubsign% = -1
END SELECT
IF LEN(stringmatha$) > LEN(stringmathb$) THEN
stringmathb$ = STRING$(LEN(stringmatha$) - LEN(stringmathb$), "0") + stringmathb$
ELSEIF LEN(stringmatha$) < LEN(stringmathb$) THEN
stringmatha$ = STRING$(LEN(stringmathb$) - LEN(stringmatha$), "0") + stringmatha$
END IF
addsubx1$ = ""
SELECT CASE operator$
CASE "+", "="
FOR addsubii& = LEN(stringmatha$) TO 1 STEP -1
addsubx1% = VAL(MID$(stringmatha$, addsubii&, 1)) + VAL(MID$(stringmathb$, addsubii&, 1)) + addsubcarry%
IF addsubx1% > 9 THEN addsubx1% = addsubx1% - 10: addsubcarry% = 1 ELSE addsubcarry% = 0
addsubx1$ = LTRIM$(STR$(addsubx1%)) + addsubx1$
NEXT
IF addsubcarry% THEN addsubx1$ = "1" + addsubx1$: addsubcarry% = 0
GOSUB replace_decimal
CASE "-"
FOR addsubii& = LEN(stringmatha$) TO 1 STEP -1
addsubx1% = VAL(MID$(stringmatha$, addsubii&, 1)) - VAL(MID$(stringmathb$, addsubii&, 1)) + addsubcarry%
IF addsubx1% < 0 THEN addsubx1% = addsubx1% + 10: addsubcarry% = -1 ELSE addsubcarry% = 0
addsubx1$ = LTRIM$(STR$(addsubx1%)) + addsubx1$
NEXT
IF addsubx1$ <> "" AND addsubx1$ <> STRING$(LEN(addsubx1$), "0") THEN GOSUB replace_decimal
DO UNTIL LEFT$(addsubx1$, 1) <> "0" ' Remove leading zeros.
addsubx1$ = MID$(addsubx1$, 2)
LOOP
IF addsubx1$ = "" THEN
addsubx1$ = "0": addsubsign% = 0
ELSE
IF addsubcarry% THEN addsubx1$ = "-" + addsubx1$: addsubcarry% = 0
END IF
END SELECT
IF addsubsign% THEN
IF LEFT$(addsubx1$, 1) = "-" THEN addsubx1$ = MID$(addsubx1$, 2) ELSE addsubx1$ = "-" + addsubx1$
END IF
stringmatha$ = addsubx1$: addsubx1$ = ""
IF operationdivision% THEN RETURN
stringmathb$ = stringmatha$: stringmatha$ = ""
IF LEFT$(stringmathb$, 1) = "-" THEN
stringmathb$ = MID$(stringmathb$, 2)
n2sign$ = "-"
ELSE
n2sign$ = ""
END IF
''' GOSUB limit_round_convert
IF stringmathb$ = "overflow" THEN n2sign$ = "": EXIT SUB
''' GOSUB sm_converter
runningtotal$ = n2sign$ + stringmathb$: n2sign$ = ""
RETURN
replace_decimal:
IF addsubplace& THEN
addsubx1$ = STRING$(addsubplace& - LEN(addsubx1$), "0") + addsubx1$
addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - addsubplace&) + "." + MID$(addsubx1$, LEN(addsubx1$) - addsubplace& + 1)
DO UNTIL RIGHT$(addsubx1$, 1) <> "0" ' Remove trailing zeros in a decimal sum.
addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - 1)
addsubplace& = addsubplace& - 1
LOOP
IF RIGHT$(addsubx1$, 1) = "." THEN addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - 1) ' Number is now an integer.
END IF
RETURN
END SUB
For you math folks, if you have a more elegant way to do this, I'd love to see it. Also, please excuse the message for "Eventual infinite repetend." I used this made up term to describe fractions like 1 / 6 where the digits repeat, but not immediately following the decimal point like 1 / 3 does. If you know the correct term for this type of repetend, please let me know.
Pete
|
|
|
Grave Dayz |
Posted by: James D Jarvis - 07-31-2022, 06:12 PM - Forum: Programs
- Replies (2)
|
|
A simple text-mode zombie surviving game.
You're trapped in a graveyard with the newly risen dead all you can do is dig fresh holes and trick them to fall in.
It's a pretty simple "robotron" style game with no shooting. I've only made it to level 4 myself.
Code: (Select All) 'GRAVE DAYZ
'By James D. Jarvis
' inspired by a game from usborne books (but sharing no code)
Randomize Timer
_ControlChr Off
Dim Shared g(60, 30)
Dim Shared D$(6)
Type zombietype
x As Integer 'x position
y As Integer 'y position
k As Integer 'color
m As Integer 'mobility
s As Integer 'strength
End Type
Dim Shared zom(20) As zombietype
Dim Shared zombies, zombiecount
Dim Shared px, py, psta, holes, score, lvl
Dim Shared gameflag$
gameflag$ = "playon"
Width 80, 43
_FullScreen
D$(1) = Chr$(1) 'player
D$(2) = Chr$(2) ' zombies
D$(3) = Chr$(206) 'gravestone
D$(4) = Chr$(35) 'wall
D$(5) = Chr$(177) 'hole
D$(6) = Chr$(42) 'bush
lvl = 1
psta = 250
newgame:
zombies = 5 + Int((1 + lvl) / 2)
zombiecount = zombies
px = Int(30 + Rnd * 3): py = Int(14 + Rnd * 3)
holes = 0
For x = 1 To 60
For y = 1 To 30
g(x, y) = 0
If Rnd * 20 <= lvl Then
p = Int(Rnd * 6) + 1
Select Case p
Case 3
g(x, y) = 3
Case 4
g(x, y) = 3
Case 5
If lvl < 5 Then
If holes < 6 Then
g(x, y) = 3
holes = holes + 1
End If
End If
Case 6
g(x, y) = 6
End Select
End If
If y = 1 Then g(x, y) = 4
If y = 30 Then g(x, y) = 4
If x = 1 Then g(x, y) = 4
If x = 60 Then g(x, y) = 4
Next y
Next x
If g(px, py) <> 0 Then g(px, py) = 0
For z = 1 To zombies
If lvl < 10 Then
c = Int(1 + Rnd * 4)
Select Case c
Case 1
zom(z).x = Int(Rnd * 6) + 2
zom(z).y = Int(Rnd * 6) + 2
Case 2
zom(z).x = Int(Rnd * 6) + 45
zom(z).y = Int(Rnd * 6) + 2
Case 3
zom(z).x = Int(Rnd * 6) + 2
zom(z).y = Int(Rnd * 6) + 24
Case 4
zom(z).x = Int(Rnd * 6) + 45
zom(z).y = Int(Rnd * 6) + 24
End Select
Else
c = Int(1 + Rnd * 4)
Select Case c
Case 1
zom(z).x = Int(Rnd * 59) + 2
zom(z).y = Int(Rnd * 12) + 2
Case 2
zom(z).x = Int(Rnd * 20) + 2
zom(z).y = Int(Rnd * 12) + 2
Case 3
zom(z).x = Int(Rnd * 59) + 2
zom(z).y = Int(Rnd * 12) + 2
Case 4
zom(z).x = Int(Rnd * 20) + 2
zom(z).y = Int(Rnd * 12) + 16
End Select
End If
zom(z).m = Int(1 + (1 + Rnd * lvl) / 5)
zom(z).s = Int(1 + Int((1 + Rnd * lvl) / 4))
zom(z).k = 10
Next z
Do
drawscreen
If psta > 0 Then
waitforK:
kk$ = InKey$
If kk$ = "" Then GoTo waitforK
End If
playermove (kk$)
zombiemove
For z = 1 To zombies
If zom(z).x = px And zom(z).y = py Then gameflag$ = "gotyou"
If g(zom(z).x, zom(z).y) = 5 And zom(z).s > 0 Then
score = score + 50
zombiecount = zombiecount - 1
If Rnd * 25 < lvl Then g(zom(z).x, zom(z).y) = 0 'zombies filling the holes more and more likely as the game goes on
drawscreen
Color 26, 0
For r = 1 To 6
_Limit 10
If r Mod 2 <> 0 Then
_PrintString (zom(z).x, zom(z).y), D$(2)
Else
_PrintString (zom(z).x, zom(z).y), "X"
End If
zom(z).s = 0
Next r
Color 15, 0
End If
Next z
If zombiecount = 0 Then gameflag$ = "nextlevel"
Loop Until gameflag$ <> "playon"
If gameflag$ = "gotyou" Then
For x = 5 To 11
_PrintString (15, x), "*************************************"
Next x
For x = 6 To 10
_PrintString (16, x), "..................................."
Next x
_PrintString (26, 7), "The Zombies Got You"
_PrintString (26, 9), "Play again? (Y/N)"
playask:
aa$ = InKey$
If aa$ = "" Then GoTo playask
aa$ = UCase$(aa$)
If aa$ = "Y" Then
lvl = 1
psta = 200
gameflag$ = "playon"
GoTo newgame
End If
If aa$ = "N" Then
System
Else
GoTo playask
End If
End If
If gameflag$ = "nextlevel" Then
score = lvl * 100
drawscreen
For x = 5 To 11
_PrintString (15, x), "*************************************"
Next x
For x = 6 To 10
_PrintString (16, x), "..................................."
Next x
T$ = "Completed Level " + Str$(level)
_PrintString (22, 7), T$
lvl = lvl + 1
T$ = "Press amy key for level " + Str$(lvl)
_PrintString (22, 9), T$
playask2:
aa$ = InKey$
If aa$ = "" Then GoTo playask
psta = psta + 150
gameflag$ = "playon"
GoTo newgame
End If
Sub drawscreen
Cls
For x = 1 To 60
For y = 1 To 30
If g(x, y) > 0 Then _PrintString (x, y), D$(g(x, y))
Next y
Next x
Color 14, 0
_PrintString (px, py), D$(1)
Color 15, 0
For z = 1 To zombies
Color zom(z).k, 0
If zom(z).s > 0 Then _PrintString (zom(z).x, zom(z).y), D$(2)
Next z
Color 12, 0
_PrintString (65, 3), "GRAVE DAYZ"
Color 15, 0
T$ = "Level " + Str$(lvl)
_PrintString (65, 5), T$
T$ = "Score " + Str$(score)
_PrintString (65, 8), T$
T$ = "Stamina" + Str$(psta)
If psta < 50 Then Color 12, 0
_PrintString (65, 11), T$
Color 10, 0
T$ = "Zombies " + Str$(zombiecount)
_PrintString (65, 13), T$
Color 7, 0
_PrintString (2, 32), "W,A,S,D to move (cost 1 Stamina)"
_PrintString (2, 34), "H to dig a hole (cost 10 stamina)"
_PrintString (2, 36), "You can't walk through walls, gravestones or bushes"
_PrintString (2, 38), "Avoid the zombies, get them all to return to the grave and advance a level!"
Color 15, 0
End Sub
Sub zombiemove
For z = 1 To zombies
zgx = 0
zgy = 0
If zom(z).s > 0 Then
If zom(z).y = py Then
If zom(z).x < px Then
zgx = 1
zgy = 0
End If
If zom(z).x > px Then
zgx = -1
zgy = 0
End If
Else If zom(z).x = px Then
If zom(z).y < py Then
zgx = 0
zgy = 1
End If
If zom(z).y > py Then
zgx = 0
zgy = -1
End If
End If
End If
If g(zom(z).x + zgx, zom(z).y + zgy) < 3 Or g(zom(z).x + zgx, zom(z).y + zgy) > 4 Then
zom(z).x = zom(z).x + zgx
zom(z).y = zom(z).y + zgy
End If
If Int(Rnd * 8) <= zom(z).m And zgx = 0 And zgy = 0 Then
Select Case Int(Rnd * 4)
Case 0
zgy = -1
zgx = 0
Case 1
zgy = 1
zgx = 0
Case 2
zgy = 0
zgx = 1
Case 3
zgy = 0
zgx = -1
End Select
If Int(Rnd * 6) < zom(z).m Then
If px < zom(z).x Then
zgx = -1
zgy = 0
End If
If px > zom(z).x Then
zgx = 1
zgy = 0
End If
End If
If Int(Rnd * 6) < zom(z).m And zgx = 0 Then
If py < zom(z).y Then zgy = -1
If py > zom(z).y Then zgy = 1
End If
If g(zom(z).x + zgx, zom(z).y + zgy) < 3 Or g(zom(z).x + zgx, zom(z).y + zgy) > 4 Then
zom(z).x = zom(z).x + zgx
zom(z).y = zom(z).y + zgy
End If
End If
End If
Next z
End Sub
Sub playermove (kk$)
kk$ = UCase$(kk$)
pgy = 0: pgx = 0
If psta > 0 Then
Select Case kk$
Case "W"
pgy = -1
pgx = 0
Case "A"
pgy = 0
pgx = -1
Case "S"
pgy = 1
pgx = 0
Case "D"
pgy = 0
pgx = 1
Case "H"
If psta > 9 Then
g(px, py) = 5
psta = psta - 10
End If
End Select
If pgy <> 0 Or pgx <> 0 Then
If g(px + pgx, py + pgy) < 3 Then
px = px + pgx
py = py + pgy
psta = psta - 1
End If
End If
End If
End Sub
|
|
|
Hello world! |
Posted by: return_to_zork - 07-31-2022, 05:38 PM - Forum: General Discussion
- Replies (8)
|
|
Hello all,
I didn't see a specific thread for introductions, so I just wanted to take a second to introduce myself. My name is Joe and and I'm a mail carrier by day, aspiring adventure game writer by night. I'm sure this is a common story around here, but I first discovered QBasic on the family computer back when I was in Elementary school (Windows 3.1 days) and instantly fell in love. I remember scouring the early internet and my local library for anything I could read on QB.
I spent a lot of years downloading other peoples' games and programs, learning the ins and outs of the software, and eventually even tried to write my own games. Ultimately, though, I was just a little kid and nothing of substance ever came to fruition. I don't remember the exact day it happened, but at some point I closed QBasic for the final time and never went back to it.
Until now.
Sitting in my home some 25 years later, reflecting back on the good ol' days and I got bit by the bug. The itch to write that text adventure game I always wanted to but never did. I started exploring all the different options for writing an adventure game in 2022 and came across the usual suspects---Quest, Inform, Twine. But none of those were exactly what I was looking for. Until I came across a guy on YouTube doing exactly what I was looking to do myself: Going back and writing the text adventure game he always wanted to, but never did...in QBasic!
My mind was blown. I had no idea QB was even still being used. Then I found QB64, read about the incident that happened, and eventually found my way here. I'm currently working my way through Terry Ritchie's QB64 Game Programming Guide and getting all this rust off (Hey, it's been 25 years!). But I just wanted to say that I'm so glad I found this place.
I was wondering if anyone else on the forum has or is making their own text adventure games (either finished or unfinished) that I might check out while I'm getting my chops back. I'd love to see what other people in the community are working on.
But either way, nice to meet everyone and I hope to be a regular face around here!
|
|
|
|