Run a tiny basic interpreter inside a qb64 program. Sorry no string variables at this point.  I implemented a crude but simple means of passing variables into and out of the array space the interpreter uses. Will also load and save tiny basic programs. I added a few commands to the interpreter but most of the original work was done by one Ed Davis.

'tiny basic in a subroutine

' vesion 0.1.j2823

' a tiny basic interpreter that can run in a  qb64 program

'based on code by Ed Davis  posted in a facebbok group

'

'it's crude and sloppy and not done yet but it works due to the good work of people before me.

'

'the original tiny basic implmentation this was based on used integer basic and only allowed 26 single letter variables

'altered things (poorly for now) to allow a larger number of variables and floating point numbers.

'there isn't support for string variables for now.

' valid variable names must start with a letter and may contain any mixture of alphanumeric characters  and $

'variable names are not case sensistive so Aaa and AAA woudl be the smae variable.

'it's sloppy but A100A woudl be a valid variable name

'

'eventually I'll get string variables into this and some simple graphics, there's some bits of code in here now to get that going

'but it's nowhere near done yet

'

'all output from the interperter will go to current program screen when the interpreter is called

'code will immediatley execute if typed without a line number

'line numbers from 1 to 9999 are valid



'$dynamic

Screen _NewImage(800, 500, 32)





Const true = -1, false = 0, c_maxlines = 9999, c_maxvars = 200, c_at_max = 1000, c_g_stack = 100

Dim Shared As String c_tab, c_squote, c_dquote

c_tab = Chr$(9): c_squote = Chr$(39): c_dquote = Chr$(34)



Dim Shared pgm(c_maxlines) As String ' program stored here

Dim Shared vars(c_maxvars) As Double



Dim Shared var_type(c_maxvars) As String 'not really using this yet

Dim Shared var_name(c_maxvars) As String

Dim Shared var_string(c_maxvars) As String

Dim Shared stringflag As String



Dim Shared pen_x, pen_y As Single





Dim Shared gstackln(c_g_stack) As Integer ' gosub line stack

Dim Shared gstacktp(c_g_stack) As Integer ' gosub textp stack

Dim Shared gsp As Long

Dim Shared atarry(0 To c_at_max) As Double ' the @ array

Dim Shared forvar(c_maxvars) As Integer

Dim Shared forlimit(c_maxvars) As Integer

Dim Shared forline(c_maxvars) As Integer

Dim Shared forpos(c_maxvars) As Integer



Dim Shared As String tok, toktype ' current token, and it's type

Dim Shared As String tok2, toktype2 ' current token, and it's type

Dim Shared As String thelin, thech ' current program line, current character

Dim Shared As Integer curline, textp ' position in current line

Dim Shared num As Double ' last number read by scanner

Dim Shared As Integer errors, tracing, need_colon

Dim Shared dump_array(0 To c_at_max) As Double



declare function accept(s as string)

declare function expression(minprec as double)

declare function getfilename$(action as string)

declare function getvarindex

declare function inputexpression(s as string)

declare function parenexpr&



Dim pl$(1 To 12)





pl$(1) = "cls"

pl$(2) = "print" + Chr$(34) + "Hello" + Chr$(34)

pl$(3) = "for x = 1 to 10"

pl$(4) = "print x"

pl$(5) = " a = a +x: @(x)=a"

pl$(6) = "next x"

pl$(7) = "print" + Chr$(34) + "Done" + Chr$(34)

pl$(8) = "print a"

pl$(9) = "arraydump"

pl$(10) = "print " + Chr$(34) + "Type Run to execute the program and Quit to exit" + Chr$(34)







Call tiny_basic("list", pl$())

Cls

Print "Back in main program": Print

Print "Variables passed from interpreter"

For x = 1 To 10

    Print dump_array(x)

Next x

ReDim pl$(2)

Print

Print "press any key to coniunue": Sleep



pl$(1) = "print " + Chr$(34) + "Type your own program" + Chr$(34) + ":print :help"

Call tiny_basic("run", pl$())

End







Sub tiny_basic (icmd$, pl$())

    Dim loadlines, prox

    loadlines = UBound(pl$)

    For prox = 1 To loadlines

        pgm(prox) = pl$(prox)

    Next

    icmd$ = LCase$(icmd$)

    Select Case icmd$

        Case "run"

            tok = "run"

            Call docmd

        Case "list"

            tok = "list"

            Call docmd

        Case "new"

            tok = "new"

            Call docmd

    End Select



    If Command$ <> "" Then

        toktype = "string": tok = c_dquote + Command$

        Call loadstmt

        tok = "run": Call docmd

    Else

        ' Call help

    End If

    Do

        errors = false

        Line Input "tinyb> ", pgm(0)

        If pgm(0) <> "" Then

            Call initlex(0)

            If toktype = "number" Then

                Call validlinenum

                If Not errors Then pgm(num) = Mid$(pgm(0), textp)

            Else

                Call docmd

            End If

        End If

    Loop Until toktype = "exit"

    ReDim pgm(0 To c_maxlines) As String

End Sub

Sub docmd

    Do

        If tracing And Left$(tok, 1) <> ":" Then Print curline; tok; thech; Mid$(thelin, textp)

        need_colon = true

        Select Case tok

            Case "bye", "quit": Call nexttok: toktype = "exit": Exit Sub

            Case "end", "stop": Call nexttok: Exit Sub

            Case "clear": Call nexttok: Call clearvars: Exit Sub

            Case "help": Call nexttok: Call help: Exit Sub

            Case "list": Call nexttok: Call liststmt: Exit Sub

            Case "load", "old": Call nexttok: Call loadstmt: Exit Sub

            Case "new": Call nexttok: Call newstmt: Exit Sub

            Case "run": Call nexttok: Call runstmt

            Case "save": Call nexttok: Call savestmt: Exit Sub

            Case "tron": Call nexttok: tracing = true

            Case "troff": Call nexttok: tracing = false

            Case "cls": Call nexttok: Cls

            Case "for": Call nexttok: Call forstmt

            Case "gosub": Call nexttok: Call gosubstmt

            Case "goto": Call nexttok: Call gotostmt

            Case "if": Call nexttok: Call ifstmt

            Case "input": Call nexttok: Call inputstmt

            Case "next": Call nexttok: Call nextstmt

            Case "print", "?": Call nexttok: Call printstmt

            Case "pen": Call nexttok: Call penstmt

            Case "return": Call nexttok: Call returnstmt

            Case "@": Call nexttok: Call arrassn

            Case "arraydump": Call nexttok: Call arraydump 'puts @() into array dump_array() for use in main program

            Case "arrayload": Call nexttok: Call arrayload 'reads dump_array into @() to pass data from main program

            Case ":", "" ' handled below

            Case "beep": Call nexttok: Call dobeep

            Case Else

                If tok = "let" Then Call nexttok

                If toktype = "ident" Then

                    Call assign

                Else

                    Print "Unknown token '"; tok; "' at line:"; curline; " Col:"; textp; " : "; thelin: errors = true

                End If

        End Select



        If errors Then Exit Sub

        If tok = "" Then

            While tok = ""

                If curline = 0 Or curline >= c_maxlines Then Exit Sub

                Call initlex(curline + 1)

            Wend

        ElseIf tok = ":" Then Call nexttok

        ElseIf need_colon And Not accept(":") Then

            Print ": expected but found: "; tok

            Exit Sub

        End If

    Loop

End Sub



Sub help

    Print "ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ Tiny Basic (QBASIC) --------ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿"

    Print "³ bye, clear, cls, end/stop, help, list, load/save, new, run, tron/off³Û"

    Print "³ for <var> = <expr1> to <expr2> ... next <var>                      ³Û"

    Print "³ gosub <expr> ... return                                            ³Û"

    Print "³ goto <expr>                                                        ³Û"

    Print "³ if <expr> then <statement>                                          ³Û"

    Print "³ input [prompt,] <var>                                              ³Û"

    Print "³ <var>=<expr>                                                        ³Û"

    Print "³ arraydump                                                          ³Û"

    Print "³ beep, print <expr|string>[,<expr|string>][;]                        ³Û"

    Print "³ rem <anystring>  or ' <anystring>                                  ³Û"

    Print "³ Operators: ^, * / \ mod + - < <= > >= = <>, not, and, or            ³Û"

    Print "³ Integer variables a..z, and array @(expr)                          ³Û"

    Print "³ Functions: abs(expr), asc(ch), rnd(expr), rnd(expr),sgn(expr)      ³Û"

    Print "³            sin(expr), cos(expr), tan(expr)                          ³Û"

    Print "³            sindeg(expr), cosdeg(expr), tandeg(expr)                ³Û"

    Print "ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙÛ"

    Print "  ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß"

End Sub



Sub assign

    Dim var As Long

    var = getvarindex: Call nexttok

    Call expect("=")

    vars(var) = expression(0)

    If stringflag <> "" Then

        var_string(var) = stringflag

    End If

    If tracing Then Print "*** "; Chr$(var + Asc("a")); " = "; vars(var)



End Sub



Sub dobeep

    Beep

End Sub



Sub arraydump

    'dump array so it can be passed to main program

    For x = 1 To c_at_max

        dump_array(x) = atarry(x)

    Next x

End Sub

Sub arrayload

    'loads array from dump_aeeay to pass varaibles from main program

    For x = 1 To c_at_max

        atarry(x) = dump_array(x)

    Next x



End Sub



Sub arrassn ' array assignment: @(expr) = expr

    Dim As Long n, atndx



    atndx = parenexpr

    If tok <> "=" Then

        Print "Array Assign: Expecting '=', found:"; tok: errors = true

    Else

        Call nexttok ' skip the "="

        n = expression(0)

        atarry(atndx) = n

        If tracing Then Print "*** @("; atndx; ") = "; n

    End If

End Sub



Sub forstmt ' for i = expr to expr

    Dim As Long var, n, forndx



    var = getvarindex

    Call assign

    ' vars(var) has the value; var has the number value of the variable in 0..25

    forndx = var

    forvar(forndx) = vars(var)

    If tok <> "to" Then

        Print "For: Expecting 'to', found:"; tok: errors = true

    Else

        Call nexttok

        n = expression(0)

        forlimit(forndx) = n

        ' need to store iter, limit, line, and col

        forline(forndx) = curline

        If tok = "" Then forpos(forndx) = textp Else forpos(forndx) = textp - 2

    End If

End Sub



Sub gosubstmt ' for gosub: save the line and column

    gsp = gsp + 1

    gstackln(gsp) = curline

    gstacktp(gsp) = textp

    Call gotostmt

End Sub



Sub gotostmt

    num = expression(0)

    Call validlinenum

    Call initlex(num)

End Sub



Sub ifstmt

    need_colon = false

    If expression(0) = 0 Then Call skiptoeol: Exit Sub

    If tok = "then" Then Call nexttok

    If toktype = "number" Then Call gotostmt

End Sub



Sub inputstmt ' "input" [string ","] var

    Dim var As Double, st As String

    If toktype = "string" Then

        Print Mid$(tok, 2);

        Call nexttok

        Call expect(",")

    Else

        Print "? ";

    End If

    var = getvarindex: Call nexttok

    Line Input st

    If st = "" Then st = "0"



    Select Case Left$(st, 1)

        Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"

            vars(var) = Val(st)

        Case "-"

            If Mid$(st, 2, 1) >= "0" And Mid$(st, 2, 1) <= "9" Then vars(var) = Val(st)

        Case Else

            'vars(var) = Asc(st)

            Print "string tok "; tok

            var_string(var) = tok

            Print

    End Select

End Sub



Sub liststmt

    Dim i As Integer

    For i = 1 To c_maxlines

        If pgm(i) <> "" Then Print i; " "; pgm(i)

    Next i

    Print

End Sub



Sub loadstmt

    Dim n As Long, filename As String



    Call newstmt

    filename = getfilename("Load")

    If filename = "" Then Exit Sub

    Open filename For Input As #1

    n = 0

    While Not EOF(1)

        Line Input #1, pgm(0)

        Call initlex(0)

        If toktype = "number" And num > 0 And num <= c_maxlines Then

            n = num

        Else

            n = n + 1: textp = 1

        End If

        pgm(n) = Mid$(pgm(0), textp)

    Wend

    Close #1

    curline = 0

End Sub



Sub newstmt

    Dim i As Integer

    Call clearvars

    For i = 1 To c_maxlines

        pgm(i) = ""

    Next i

End Sub



Sub nextstmt

    Dim forndx As Long

    ' tok needs to have the variable

    forndx = getvarindex

    forvar(forndx) = forvar(forndx) + 1

    vars(forndx) = forvar(forndx)

    If forvar(forndx) <= forlimit(forndx) Then

        curline = forline(forndx)

        textp = forpos(forndx)

        Call initlex2

    Else

        Call nexttok

    End If

End Sub



' "print" [[#num "," ] expr { "," [#num ","] expr }] [","] {":" stmt} eol

' expr can also be a literal string

Sub penstmt

    penx_x = Val(tok)

    Call nexttok

    pen_y = Val(tok)



    PSet (pen_x, pen_y), _RGB32(255, 255, 255)

End Sub







Sub printstmt

    Dim As Single printnl, printwidth, n

    Dim junk As String



    printnl = true

    Do While tok <> ":" And tok <> "" And tok <> "else"

        printnl = true

        printwidth = 0

        If accept("#") Then

            If num <= 0 Then Print "Expecting a print width, found:"; tok: Exit Sub

            printwidth = num

            Call nexttok

            If Not accept(",") Then Print "Print: Expecting a ',', found:"; tok: Exit Sub

        End If



        If toktype = "string" Then

            junk = Mid$(tok, 2)

            Call nexttok

        Else

            n = expression(0)

            junk = LTrim$(Str$(n))

        End If

        printwidth = printwidth - Len(junk)

        If printwidth <= 0 Then Print junk; Else Print Space$(printwidth); junk;



        If accept(",") Or accept(";") Then printnl = false Else Exit Do

    Loop



    If printnl Then Print

End Sub











Sub returnstmt ' exit sub from a subroutine

    curline = gstackln(gsp)

    textp = gstacktp(gsp)

    gsp = gsp - 1

    Call initlex2

End Sub



Sub runstmt

    Call clearvars

    Call initlex(1)

End Sub



Sub savestmt

    Dim i As Long, filename As String



    filename = getfilename("Save")

    If filename = "" Then Exit Sub

    Open filename For Output As #1

    For i = 1 To c_maxlines

        If pgm(i) <> "" Then Print #1, i; pgm(i)

    Next i

    Close #1

End Sub











Function getfilename$ (action As String)

    Dim filename As String

    If toktype = "string" Then

        filename = Mid$(tok, 2)

    Else

        Print action; ": ";

        Line Input filename

    End If

    If filename <> "" Then

        If InStr(filename, ".") = 0 Then filename = filename + ".bas"

    End If

    getfilename = filename

End Function



Sub validlinenum

    If num <= 0 Or num > c_maxlines Then Print "Line number out of range": errors = true

End Sub



Sub clearvars

    Dim i As Integer

    For i = 1 To c_maxvars

        vars(i) = 0

        var_name(i) = ""

        var_string(i) = ""

    Next i

    gsp = 0

End Sub



Function parenexpr&

    Call expect("("): If errors Then Exit Function

    parenexpr = expression(0)

    Call expect(")")

End Function



Function expression (minprec As Double)

    Dim n As Double



    ' handle numeric operands - numbers and unary operators

    If 0 Then ' to allow elseif

    ElseIf toktype = "number" Then n = num: Call nexttok

    ElseIf tok = "(" Then n = parenexpr

    ElseIf tok = "not" Then Call nexttok: n = Not expression(3)

    ElseIf tok = "abs" Then Call nexttok: n = Abs(parenexpr)

    ElseIf tok = "asc" Then Call nexttok: expect ("("): n = Asc(Mid$(tok, 2, 1)): Call nexttok: expect (")")

    ElseIf tok = "rnd" Then Call nexttok: n = (Rnd * parenexpr)

    ElseIf tok = "irnd" Then Call nexttok: n = Int(Rnd * parenexpr) + 1

    ElseIf tok = "sgn" Then Call nexttok: n = Sgn(parenexpr)

    ElseIf tok = "sin" Then Call nexttok: n = Sin(parenexpr)

    ElseIf tok = "cos" Then Call nexttok: n = Cos(parenexpr)

    ElseIf tok = "tan" Then Call nexttok: n = Tan(parenexpr)

    ElseIf tok = "sindeg" Then Call nexttok: n = Sin(parenexpr * _Pi / 360)

    ElseIf tok = "cosdeg" Then Call nexttok: n = Cos(parenexpr * _Pi / 360)

    ElseIf tok = "tandeg" Then Call nexttok: n = Tan(parenexpr * _Pi / 360)

    ElseIf toktype = "ident" Then n = vars(getvarindex): Call nexttok

    ElseIf tok = "@" Then Call nexttok: n = atarry(parenexpr)

    ElseIf tok = "-" Then Call nexttok: n = -expression(7)

    ElseIf tok = "+" Then Call nexttok: n = expression(7)

    Else Print "syntax error: expecting an operand, found: ", tok: errors = true: Exit Function

    End If



    Do ' while binary operator and precedence of tok >= minprec

        If 0 Then ' to allow elseif

        ElseIf minprec <= 1 And tok = "or" Then Call nexttok: n = n Or expression(2)

        ElseIf minprec <= 2 And tok = "and" Then Call nexttok: n = n And expression(3)

        ElseIf minprec <= 4 And tok = "=" Then Call nexttok: n = Abs(n = expression(5))

        ElseIf minprec <= 4 And tok = "<" Then Call nexttok: n = Abs(n < expression(5))

        ElseIf minprec <= 4 And tok = ">" Then Call nexttok: n = Abs(n > expression(5))

        ElseIf minprec <= 4 And tok = "<>" Then Call nexttok: n = Abs(n <> expression(5))

        ElseIf minprec <= 4 And tok = "<=" Then Call nexttok: n = Abs(n <= expression(5))

        ElseIf minprec <= 4 And tok = ">=" Then Call nexttok: n = Abs(n >= expression(5))

        ElseIf minprec <= 5 And tok = "+" Then Call nexttok: n = n + expression(6)

        ElseIf minprec <= 5 And tok = "-" Then Call nexttok: n = n - expression(6)

        ElseIf minprec <= 6 And tok = "*" Then Call nexttok: n = n * expression(7)

        ElseIf minprec <= 6 And tok = "/" Then Call nexttok: n = n / expression(7)

        ElseIf minprec <= 6 And tok = "\" Then Call nexttok: n = n \ expression(7)

        ElseIf minprec <= 6 And tok = "mod" Then Call nexttok: n = n Mod expression(7)

        ElseIf minprec <= 8 And tok = "^" Then Call nexttok: n = CLng(n ^ expression(9))

        Else Exit Do

        End If

    Loop



    expression = n

End Function



Function inputexpression (s As String)

    Dim As Long save_curline, save_textp

    Dim As String save_thelin, save_thech, save_tok, save_toktype



    save_curline = curline: save_textp = textp: save_thelin = thelin: save_thech = thech: save_tok = tok: save_toktype = toktype



    pgm(0) = s

    Call initlex(0)

    inputexpression = expression(0)



    curline = save_curline: textp = save_textp: thelin = save_thelin: thech = save_thech: tok = save_tok: toktype = save_toktype

End Function



Function getvarindex

    If toktype <> "ident" Then Print "Not a variable:"; tok: errors = true: Exit Function

    ' Print "***(getvarindex)*** tok "; tok

    foundv = 0

    Do

        vv = vv + 1

        If vv < c_maxvars Then

            If var_name(vv) = tok Then

                foundv = vv

            ElseIf var_name(vv) = "" Then

                var_name(vv) = tok

                foundv = vv

            End If

        End If

    Loop Until foundv <> 0 Or vv > c_maxvars

    getvarindex = foundv

End Function



Sub expect (s As String)

    If accept(s) Then Exit Sub

    Print "("; curline; ") expecting "; s; " but found "; tok; " =>"; pgm(curline): errors = true

End Sub



Function accept (s As String)

    accept = false

    If tok = s Then accept = true: Call nexttok

End Function



Sub initlex (n As Integer)

    curline = n: textp = 1

    Call initlex2

End Sub



Sub initlex2

    need_colon = false

    thelin = pgm(curline)

    thech = " "

    Call nexttok

End Sub



Sub nexttok

    tok = "": toktype = ""

    While thech <= " "

        If thech = "" Then Exit Sub

        Call getch

    Wend

    tok = thech: Call getch

    Select Case tok

        Case "a" To "z", "A" To "Z": Call readident: If tok = "rem" Then Call skiptoeol

        Case "0" To "9": Call readdbl

        Case c_squote: Call skiptoeol

        Case c_dquote: Call readstr

        Case "#", "(", ")", "*", "+", ",", "-", "/", ":", ";", "<", "=", ">", "?", "@", "\", "^":

            toktype = "punct"

            If (tok = "<" And (thech = ">" Or thech = "=")) Or (tok = ">" And thech = "=") Then

                tok = tok + thech

                Call getch

            End If

        Case Else: Print "("; curline; ") "; "What?"; tok; " : "; thelin: errors = true

    End Select

End Sub





Sub skiptoeol

    tok = "": toktype = ""

    textp = Len(thelin) + 1

End Sub



Sub readdbl

    toktype = "number"

    While thech >= "0" And thech <= "9" Or thech = "." Or thech = "-"

        tok = tok + thech

        Call getch

    Wend

    num = Val(tok)

End Sub



Sub readident

    toktype = "ident"

    While (thech >= "a" And thech <= "z") Or (thech >= "A" And thech <= "Z") Or thech = "$" Or (thech >= "0" And thech <= "9")

        tok = tok + thech

        Call getch

    Wend

    tok = LCase$(tok)

End Sub



Sub readstr ' store double quote as first char of string, to distinguish from idents

    toktype = "string"

    While thech <> c_dquote ' while not a double quote

        If thech = "" Then Print "String not terminated": errors = true: Exit Sub

        tok = tok + thech

        Call getch

    Wend

    Call getch ' skip closing double quote

End Sub



Sub getch

    If textp > Len(thelin) Then

        thech = ""

    Else

        thech = Mid$(thelin, textp, 1)

        textp = textp + 1

    End If

End Sub

Just starting to figure out how to document the meta-programming features in BAM, and I decided to pick an easy one first.

Not very many use cases for the "now" macro (scroll to the bottom of the page for the link below), but it is pretty handy for program documentation and program intro screens.

https://basicanywheremachine.neocities.o...3Anow#Home

I installed the lastest KDE Neon linux distro today, but the QB64PE setup script fails with this error.  What would be the best step to fix this?

- Dav

Doing some reading up on gaussian blur this evening. Here's my go at the algorithm as I understand it.

Attached Files

Thumbnail(s)
   

There are some here who work with Linux. My favorite editor on the command line has always been Vim (on KDE it was jedit). Today I only have WSL2 under Windows, as a hobby.

You can customize Vim for each programming language if you want. In case anyone is interested, my source code in Vim looks the same under WSL2 as it used to under SuSE, namely like this (GCC):



The settings in the .exrc and .vimrc look like this. They have to be filed separately in each sub-forum - that is, for each programming language.





Forget! Result:

https://basicanywheremachine-news.blogsp...r-ide.html

Forum is currently cutting off images on the right side.

An alternate way to draw Laser Bolts:

Attached Files

Thumbnail(s)
   

working on a larger image generation projects and realized a little piece of it looked like crop circles, so here we go with a goofy low end crop circle demo:

'crop circles version 0.1

'by James D. Jarvis, July 2023

'this is modifed from a larger image generation program I am working on so if you read the code some of thsi is goign to be strange

'there are likely stubs and variables not actually used in the cropcircle generation that are used in the original, but it works for a goofy little demo

ymax = 800

xmax = 800

'$dynamic

Screen _NewImage(xmax, ymax, 32)

Dim flrklr As _Unsigned Long

tilescale = 4

Type roomtype

    fill As Integer

    rx As Integer

    ry As Integer

    nw As Integer

    sw As Integer

    ew As Integer

    ww As Integer

    cnx As Integer

End Type

Dim Shared rm(0) As roomtype

Dim Shared floorklr As _Unsigned Long

Dim Shared wallklr As _Unsigned Long

Dim Shared emptyklr As _Unsigned Long

floorklr = _RGB32(220, 220, 0)

wallklr = _RGB32(50, 50, 50)

emptyklr = _RGB32(80, 200, 15)



Type band_type

    rad As Integer

    s As Integer

    e As Integer

    spoke As Integer

    thk As Single

End Type



Dim Shared band(0) As band_type

Dim Shared oring(0) As band_type

Dim Shared tessfix

Dim Shared roomfix, excludeturrets

Dim Shared fillcellchance, defaulthallwidth

Dim Shared bumpchance, antennachance

bumpchance = 20

antennachance = 60

floorgrid = 0

forcegeneration = 0

linkgeneration = 0

tessfix = 0

roomfix = 0

fillcellchance = 50

firstpass = 1

Cls

Do



    Cls , emptyklr



    'grassfill 0, 0, xmax, ymax



    cb = 2 + Int(Rnd * 8)

    ReDim band(cb) As band_type

    mr = Int(_Height / 4 + Rnd * _Height / 6)

    mrp = Int(mr / cb)

    r = 0

    For c = 1 To cb

        r = r + Int((mrp / 3) * Int(2 + Rnd * 2))

        band(c).rad = r

        If c = 1 Then

            band(c).s = Int(Rnd * 360)

            band(c).e = band(c).s + band(c).s + (10 * Int(Rnd * 36))

        Else

            band(c).s = band(c - 1).spoke - (Int(1 + Rnd * 60) * 3)

            band(c).e = band(c - 1).spoke + (Int(1 + Rnd * 60) * 3)

            ppx1 = cx + band(c - 1).rad * Cos(0.01745329 * band(c - 1).spoke)

            ppy1 = cy + band(c - 1).rad * Sin(0.01745329 * band(c - 1).spoke)

            ppx2 = cx + band(c).rad * Cos(0.01745329 * band(c - 1).spoke)

            ppy2 = cy + band(c).rad * Sin(0.01745329 * band(c - 1).spoke)

            fatline ppx1, ppy1, ppx2, ppy2, 2, floorklr

        End If

        bsiz = band(c).e - band(c).s

        band(c).spoke = Int(band(c).s + Rnd * bsiz)



        If Rnd * 100 < bumpchance Then

            rs = band(c).s: re = band(c).e

            bsiz = re - rs

            nb = Int((1 + Rnd * 12) / Int(1 + Rnd * 4))

            If nb < 1 Then nb = 1

            For bb = 1 To nb

                srangle = Int(rs + Rnd * bsiz)

                erangle = srangle + (Int(2 + Rnd * 11) * 3)

                bd = Int(1 + Rnd * 5) * tilescale

                If Rnd * 200 < bumpchance Then bd = bd * 2



                For d = 0.5 To bd Step 0.5

                    fatarc cx, cy, 2, band(c).rad + d, srangle, erangle, floorklr

                Next d

            Next bb

        End If



    Next



    roomcount = 0

    lastcount = 0

    For b = 1 To cb

        rs = band(b).s: re = band(b).e

        bsiz = re - rs

        mrbc = (bsiz * 0.01745329 * band(b).rad) / ((tilescale * tilescale) * 4)

        roomcount = roomcount + Int(1 + Rnd * mrbc)

        ReDim _Preserve rm(roomcount) As roomtype

        For r = lastcount + 1 To roomcount

            rangle = Int(rs + Rnd * bsiz)

            'rangle = Int(Rnd * 90) * 4

            rm(r).rx = cx + band(b).rad * Cos(0.01745329 * rangle)

            rm(r).ry = cy + band(b).rad * Sin(0.01745329 * rangle)

            rm(r).nw = 3 + Int(Rnd * 6) * tilescale

            rm(r).sw = 3 + Int(Rnd * 6) * tilescale

            rm(r).ew = 3 + Int(Rnd * 6) * tilescale

            rm(r).ww = 3 + Int(Rnd * 6) * tilescale



            If (Rnd * 101) < fillcellchance Then

                rm(r).fill = Int(1 + Rnd * 10) * (tilescale / 2)

            Else

                rm(r).fill = 0

            End If

            If rm(r).fill = 0 Then

                ' Circle (rm(r).rx, rm(r).ry), rm(r).nw, floorklr

                fatarc rm(r).rx, rm(r).ry, 2, rm(r).nw, 0, 359, floorklr

            Else

                fcirc rm(r).rx, rm(r).ry, rm(r).fill, floorklr

            End If

        Next r

        lastcount = roomcount

    Next b



    For c = 1 To cb

        cx = _Width \ 2: cy = _Height \ 2



        fatarc cx, cy, 2, band(c).rad, band(c).s, band(c).e, floorklr





        If c > 1 Then

            k = Int(c / 2 + Rnd * (c * 1.2))



            For n = 1 To k

                rs = band(c - 1).s: re = band(c - 1).e

                bsiz = re - rs

                ang = Int(rs + Rnd * bsiz)

                ppx1 = cx + band(c - 1).rad * Cos(0.01745329 * ang)

                ppy1 = cy + band(c - 1).rad * Sin(0.01745329 * ang)

                ppx2 = cx + band(c).rad * Cos(0.01745329 * ang)

                ppy2 = cy + band(c).rad * Sin(0.01745329 * ang)

                fatline ppx1, ppy1, ppx2, ppy2, 2, floorklr

            Next

        End If



        If c = cb Then

            rs = band(c).s: re = band(c).e

            bsiz = re - rs

            ang = -1 * Int(rs + Rnd * bsiz)

            fx = 0

            fy = 0

            ppx2 = cx + band(c).rad * Cos(0.01745329 * ang)

            ppy2 = cy + band(c).rad * Sin(0.01745329 * ang)

            cc = cb

            Do

                cc = cc - 1

                xc = cx + band(cc).rad * Cos(0.01745329 * ang)

                yc = cy + band(cc).rad * Sin(0.01745329 * ang)

                If Point(xc, yc) <> emptyklr Then

                    fx = xc

                    fy = yc

                End If



            Loop Until fx <> 0 And fy <> 0 Or cc = 1

            If fx = 0 Then

                fx = cx

                fy = cy

                rs = band(1).s: re = band(1).e

                bsiz = re - rs

                ang = Int(rs + Rnd * bsiz)

                tx = cx + band(1).rad * Cos(0.01745329 * ang)

                ty = cy + band(1).rad * Sin(0.01745329 * ang)



                fatline cx, cy, tx, ty, 2, floorklr

            End If

            fatline fx, fy, ppx2, ppy2, 2, floorklr



        End If

    Next c

    For a = 1 To 5

        If Rnd * 100 < antennachance Then

            tb = Int(1 + Rnd * cb)

            rs = band(tb).s: re = band(tb).e

            bsiz = re - rs

            bangle = Int(rs + Rnd * bsiz)

            DB = mr + 20

            dx = cx + DB * Cos(0.01745329 * bangle)

            dy = cy + DB * Sin(0.01745329 * bangle)

            ppx2 = cx + band(tb).rad * Cos(0.01745329 * bangle)

            ppy2 = cy + band(tb).rad * Sin(0.01745329 * bangle)

            fatline dx, dy, ppx2, ppy2, 2, floorklr

            Select Case Int(1 + Rnd * 16)

                ' Select Case 14

                Case 1, 2

                    fcirc dx, dy, Int(5 + Rnd * 10), floorklr

                Case 3, 4, 5, 6, 7, 8

                    fangs = bangle - Int(2 + Rnd * 10)

                    fange = bangle + Int(2 + Rnd * 10)

                    bd = Int(1 + Rnd * 5) * tilescale



                    For d = 0.5 To bd Step 0.5

                        fatarc cx, cy, 2, DB + d, fangs, fange, floorklr

                    Next d

                Case 10, 11, 12

                    fanga = Int(2 + Rnd * 10) * 10



                    bd = Int(2 + Rnd * 10) * tilescale



                    For da = bangle - fanga To bangle + fanga

                        DB = mr + 20

                        nx = dx + bd * Cos(0.01745329 * da)

                        ny = dy + bd * Sin(0.01745329 * da)

                        fatline dx, dy, nx, ny, 2, floorklr

                    Next da

                Case 13, 14, 15, 16

                    orrc = Int(2 + Rnd * 3)

                    ReDim oring(orrc) As band_type

                    r2 = 0

                    For o = 1 To orrc

                        r2 = r2 + Int(2 + Rnd * 2) * tilescale

                        oring(o).rad = r2

                        oring(o).s = 0

                        oring(o).e = 359

                        oring(o).thk = 0.75

                        fatarc dx, dy, 2, oring(o).rad, 0, 359, floorklr

                    Next o





            End Select



        End If

    Next

    Do

        redraw = 0

        Do

            _Limit 60

            kk$ = InKey$

            If firstpass = 1 Then

                firstpass = 0

                redraw = 1

                kk$ = "go"

            End If

        Loop Until kk$ <> ""





        Select Case kk$

            Case "c" 'copy to clipboard.... this is only supported in windows

                _ClipboardImage = dngi&



            Case "m", "M"

                rrr$ = Str$(tilescale)

                getroun$ = _InputBox$("Shape Magnitude", "Enter new magnitude (4) is standard.", rrr$)

                tilescale = Int(Val(getroun$))

                If tilescale < 1 Then tilescale = 1

            Case Else

                redraw = 1

        End Select

    Loop Until redraw = 1



Loop Until kk$ = Chr$(27)





Sub fcirc (CX As Long, CY As Long, R, klr As _Unsigned Long)

    'draw a filled circle with the quickest filled circle routine in qb64, not my development

    Dim subRadius As Long, RadiusError As Long

    Dim X As Long, Y As Long

    subRadius = Abs(R)

    RadiusError = -subRadius

    X = subRadius

    Y = 0

    If subRadius = 0 Then PSet (CX, CY): Exit Sub

    Line (CX - X, CY)-(CX + X, CY), klr, 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), klr, BF

                Line (CX - Y, CY + X)-(CX + Y, CY + X), klr, BF

            End If

            X = X - 1

            RadiusError = RadiusError - X * 2

        End If

        Y = Y + 1

        Line (CX - X, CY - Y)-(CX + X, CY - Y), klr, BF

        Line (CX - X, CY + Y)-(CX + X, CY + Y), klr, BF

    Wend

End Sub





Sub fatarc (cx, cy, thk, r, sang, eang, klr As _Unsigned Long)



    For rangle = sang To eang Step 0.5

        ax = cx + r * Cos(0.01745329 * rangle)

        ay = cy + r * Sin(0.01745329 * rangle)

        fcirc ax, ay, thk, klr

    Next rangle

End Sub



Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)

    'draw a line with dots with a radial thickness of r    from x0,y0 to x1,y1 in color klr

    If r > 0.5 Then

        If Abs(y1 - y0) < Abs(x1 - x0) Then

            If x0 > x1 Then



                lineLow x1, y1, x0, y0, r, klr

            Else



                lineLow x0, y0, x1, y1, r, klr

            End If

        Else

            If y0 > y1 Then

                lineHigh x1, y1, x0, y0, r, klr

            Else

                lineHigh x0, y0, x1, y1, r, klr

            End If

        End If

    Else

        Line (x0, y0)-(x1, y1), klr 'line with r of <= 0.5 don't render properly so we force them to be 1 pixel wide on screen

    End If

End Sub

Sub lineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)

    dx = x1 - x0

    dy = y1 - y0

    yi = 1

    If dy < 0 Then

        yi = -1

        dy = -dy

    End If

    d = (dy + dy) - dx

    y = y0

    For x = x0 To x1

        fcirc x, y, r, klr

        If d > 0 Then

            y = y + yi

            d = d + ((dy - dx) + (dy - dx))

        Else

            d = d + dy + dy

        End If

    Next x

End Sub

Sub lineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)

    dx = x1 - x0

    dy = y1 - y0

    xi = 1

    If dx < 0 Then

        xi = -1

        dx = -dx

    End If

    D = (dx + dx) - dy

    x = x0

    For y = y0 To y1

        fcirc x, y, r, klr

        If D > 0 Then

            x = x + xi

            D = D + ((dx - dy) + (dx - dy))

        Else

            D = D + dx + dx

        End If

    Next y

End Sub



Function inscreen (xx, yy)

    'check if point is inside the boreders of the current screen

    ii = 1

    If xx < 1 Or xx > _Width - 1 Then ii = 0

    If yy < 1 Or yy > _Height - 1 Then ii = 0

    inscreen = ii

End Function

Sub paintifborder (xx, yy, klr As _Unsigned Long)

    If xx = 0 Or xx = _Width Or yy = 0 Or yy = _Height Then

        PSet (xx, yy), klr

    End If

End Sub

Sub grassfill (x1, y1, x2, y2)

    Cls

    Line (x1, y1)-(x2, y2), _RGB32(40, 240, 40), BF

    For yy = y1 To y2

        For xx = x1 To x2 Step 2

            bx = Int(Rnd * 2)

            Line (xx + bx, yy)-(xx + bx, yy - Int(Rnd * 3)), _RGB32(55 + Int(Rnd * 10), 225 + Int(Rnd * 10), 15 + Int(Rnd * 10))





        Next

    Next





End Sub

The wife and I are sitting on the couch after dinner and I have my laptop in front of me working on a program cursing, swearing, and muttering as I go.

She tells me "The working day is over, time for some rest or fun"

I of course reply to her "I'm having fun."