Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

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

Print this item

  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

   

Print this item

  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

Print this item

Lightbulb I know a challenge: TheDRAW
Posted by: BDS107 - 08-02-2022, 10:25 AM - Forum: Utilities - Replies (16)

I know a challenge: reprogramming TheDRAW in QB64. But many items can be extracted like the BBS animation.
Other things can be included, such as choice between blinking or 16 background colors, saving to DATA statements, better support for 80x25, 80x43, 80x50 or more etc.
Unfortunately I'm not the best programmer to program something like this myself.
Not sure if anyone already has or uses such a program? Currently I am using TheDRAW from a DOSBOX.

See also https://en.wikipedia.org/wiki/TheDraw
http://www.syaross.org/thedraw

Print this item

  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.  Smile

Print this item

  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?  Tongue

Print this item

  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.

Print this item

  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

Print this item

  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

Print this item

  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!

Print this item