I am curious about the Debug function. I have set watch points and then run my programme - what next?
There is no output of results visible, and no message to say the Debug has operated. Should I get a file with run results, or what?
for multi-precision binary addition and subtraction you need multi-precision shifts to align the decimal point, here are some functions to shift an array of longs
Code: (Select All)
_Title "array-shifter"
$NoPrefix
$Console:Only
Dest Console
Option Explicit
Dim As _Unsigned Long n(2), k
Dim As Long i, ln
Dim As String s
Print "we first shift the array left and then right from 1 to 16"
Print "notice that 0's are shifted in on the left because we shift left then right"
Print "the top row-pair is the original for comparison"
Print "press return to start"
Sleep
For i = 1 To 16
n(0) = &B11111111111111111010101010101010
n(1) = &B10101010101010101010101010101010
n(2) = &B10101010101010111111111111111111
k = i
s = _Bin$(n(0)) + _Bin$(n(1)) + _Bin$(n(2))
ln = (UBound(n) + 1) * 32
If Len(s) < ln Then
s = String$(ln - Len(s), "0") + s
End If
Print s
shiftl n(), k
shiftr n(), k
s = _Bin$(n(0)) + _Bin$(n(1)) + _Bin$(n(2))
If Len(s) < ln Then
s = String$(ln - Len(s), "0") + s
End If
Print s
Print
Next
Print "press return to continue"
Sleep
Cls
Print "we first shift the array right and then left from 1 to 16"
Print "notice that 0's are shifted in on the right because we shift right then left"
Print "the top row-pair is the original for comparison"
Print "press return to start"
Sleep
For i = 1 To 16
n(0) = &B11111111111111111010101010101010
n(1) = &B10101010101010101010101010101010
n(2) = &B10101010101010111111111111111111
k = i
s = _Bin$(n(0)) + _Bin$(n(1)) + _Bin$(n(2))
If Len(s) < ln Then
s = s + String$(ln - Len(s), "0")
End If
Print s
shiftr n(), k
shiftl n(), k
s = _Bin$(n(0)) + _Bin$(n(1)) + _Bin$(n(2))
If Len(s) < ln Then
s = s + String$(ln - Len(s), "0")
End If
Print s
Print
Next
Print "press return to exit"
Function shl32~& (n As _Unsigned Long, k As _Unsigned _Byte, c As _Unsigned Long)
If k > 0 And k < 32 Then
Dim As _Unsigned Long carry: carry = n
Dim As _Unsigned _Byte k32: k32 = 32 - k
carry = _ShR(carry, k32)
n = ShL(n, k)
c = carry
End If
shl32~& = n
End Function
Function shr32~& (n As _Unsigned Long, k As _Unsigned _Byte, c As _Unsigned Long)
If k > 0 And k < 32 Then
Dim As _Unsigned Long carry: carry = n
Dim As _Unsigned _Byte k32: k32 = 32 - k
carry = _ShL(carry, k32)
n = _ShR(n, k)
c = carry
End If
shr32~& = n
End Function
Sub shiftl (n() As _Unsigned Long, k As Long)
Dim As Long i, ub: ub = UBound(n)
Dim As _Unsigned Long carry, c: c = 0
If k > 0 And k < 32 Then
For i = ub To 0 Step -1
n(i) = shl32(n(i), k, carry) + c
c = carry
Next
ElseIf k = 32 Then
For i = 0 To ub - 1
n(i) = n(i + 1)
Next
n(ub) = 0
End If
End Sub
Sub shiftr (n() As _Unsigned Long, k As Long)
Dim As Long i, ub: ub = UBound(n)
Dim As _Unsigned Long carry, c: c = 0
If k > 0 And k < 32 Then
For i = 0 To ub
n(i) = c + shr32(n(i), k, carry)
c = carry
Next
ElseIf k = 32 Then
For i = ub To 1 Step -1
n(i) = n(i - 1)
Next
n(0) = 0
End If
End Sub
This a modification of my earlier minimal text animator. I promise there will be a demo program that shows how to make use of the files produced with ascii graphics for video-game style tiles/sprites (not that it would be all that hard to write your own).
When you run the program you'll see a frame, that's where the tiles will be drawn. The default size is 8 by 8.
Click on the arrows to resize the tiles in the tileset; you'll get asked if you want to continue and then the program will gladly ignore all data you are clipping off if you reduce the size of the tiles in the tile set. Press "h" or "?" for help.
Currently set up for 256 tiles as the maximum but you can of course edit that.
There's some little bits from the previous program hanging about I haven't cleaned out yet btu it's functional.
Code: (Select All)
'ASCII tile maker
'by James D. Jarvis Sept 21,2022 v 0.1c
'
' a very minimal program to create a set of ascii tiles menat for use as sprites and backgrounds
'S - Save file
'L - load file
' can save files unencoded (encodingg 0), or tile channel endcoded (encoding 1)
' currently hardcoded to use encoding 1
'use mouse to draw
'? or H for help to see other commands
'
'nothing fancy here at all, just a minimal program that functions
'$dynamic
Screen _NewImage(80, 25, 0)
_Title "ASCII TileMaker"
Type gcelltype
t As String * 1
fgk As _Byte
bgk As _Byte
End Type
Dim Shared maxtx, maxty, maxtiles, pen$, fg_klr, bg_klr, pen_klr
Dim Shared tileX, tileY, smallerxx, smallerxy, smalleryy, smalleryx, largeryy, largeryx, largerxx, largerxy
Dim Shared showonion, tilerate, lasttile, tileno, tileshow, encoding, hightile
tileX = 8
tileY = 8
smalleryx = tileX + 3
smalleryy = 2
largeryx = tileX + 3
largeryy = tileY + 3
smallerxx = 1
smallerxy = tileY + 4
largerxx = tileX + 2
largerxy = tileY + 4
tilerate = 20
tileshow = -1
encoding = 1
maxtx = _Width
maxty = _Height
maxtiles = 256
pen$ = "*"
showonion = 0
hightile = 1
Print "ASCII TileMaker"
_ControlChr Off
Dim Shared gcell(maxtiles, maxtx, maxty) As gcelltype
For f = 1 To maxtiles
For y = 1 To _Height
For x = 1 To _Width
gcell(f, x, y).t = " "
gcell(f, x, y).fgk = 15
gcell(f, x, y).bgk = 0
Next x
Next y
Next f
tileno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
oflag = 0
Color fg_klr, bg_klr
'main program loop
drawtile tileno
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
_PrintString (1, 1), Str$(mx): _PrintString (12, 1), Str$(my)
If mx > 1 And my > 2 And my < tileY + 3 And mx < tileX + 3 Then
gcell(tileno, mx - 1, my - 2).t = pen$
gcell(tileno, mx - 1, my - 2).fgk = pen_klr
gcell(tileno, mx - 1, my - 2).bgk = bg_klr
Color pen_klr, gcell(tileno, mx - 1, my - 2).bgk
_PrintString (mx, my), gcell(tileno, mx - 1, my - 2).t
End If
tsize = 0
If mx = smalleryx And my = smalleryy Then
aak$ = ynbox$("Resize ALL Tiles?", mx, my)
If aak$ = "Y" Or aak$ = "y" Then
tileY = tileY - 1
If tileY < 2 Then tileY = 2
tsize = 1
End If
End If
If mx = largeryx And my = largeryy Then
aak$ = ynbox$("Resize ALL Tiles?", mx, my)
If aak$ = "Y" Or aak$ = "y" Then
tileY = tileY + 1
If tileY > 20 Then tileY = 20
tsize = 1
End If
End If
If mx = smallerxx And my = smallerxy Then
aak$ = ynbox$("Resize ALL Tiles?", mx, my)
If aak$ = "Y" Or aak$ = "y" Then
tileX = tileX - 1
If tileX < 2 Then tileX = 2
tsize = 1
End If
End If
If mx = largerxx And my = largerxy Then
aak$ = ynbox$("Resize ALL Tiles?", mx, my)
If aak$ = "Y" Or aak$ = "y" Then
tileX = tileX + 1
If tileX > 40 Then tileX = 40
tsize = 1
End If
End If
If aak$ = "N" Or aak$ = "n" Then drawtile tileno
Color 15, 0
End If
Loop
Select Case kk$
Case "n", "N"
Cls
tileno = tileno + 1
hightile = hightile + 1
If hightile > maxtiles Then hightile = maxtiles
' If showonion = 1 And tileno > 1 Then drawonion (tileno - 1)
drawtile tileno
Case "p", "P" 'play the animation
playanimation 1, lasttile
Case ",", "<" 'cycle down through drawn tiles
tileno = tileno - 1
If tileno < 1 Then tileno = hightile
drawtile tileno
Case ".", ">" 'cycle up through drawn tiles
tileno = tileno + 1
If tileno > hightile Then tileno = 1
Cls
drawtile tileno
Case "f", "F"
pen_klr = select_pencolor
Cls
drawtile tileno
Case "b", "B"
bg_klr = select_backgroundcolor
Cls
drawtile tileno
Case "S"
savefile
Cls
drawtile tileno
Case "L"
loadfile
Cls
playanimation 1, lasttile
tileno = 1
Case "h", "H", "?"
helpme
Cls
drawtile tileno
Case "r", "R"
tilerate = newrate
Cls
drawtile tileno
Case "c", "C"
pen$ = Chr$(newchar)
Cls
drawtile tileno
Case "v", "V" 'eyedropper that copies cell from previous tile in the same position.
If tileno > 1 Then eyedropper _MouseX, _MouseY
Case "z", "Z" 'zap a cell .... well erase it
zapcell _MouseX, _MouseY
Case "D" 'duplicate
duplicatetile tileno
tileno = tileno + 1
lasttile = tileno
Cls
drawtile tileno
Case "X"
newanimation
drawtile tileno
Case "1" 'show tilecount
tileshow = tileshow * -1
drawtile tileno
Case "T", "t"
inserttext _MouseX, _MouseY, pen_klr, bg_klr
End Select
kk$ = InKey$
If kk$ = "f" Then _PrintString (1, 1), Str$(tileno)
Loop Until kk$ = Chr$(27)
Sub drawtile (f As Integer)
Cls
For y = 1 To tileY
For x = 1 To tileX
If gcell(f, x, y).t <> " " Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x + 1, y + 2), gcell(f, x, y).t
End If
Next
Next
Color 15, 0
If tileshow = 1 Then
_PrintString (_Width - 4, 1), Str$(tileno)
End If
tbar$ = String$(tileX + 2, Asc("+"))
_PrintString (1, 2), tbar$ + Chr$(30)
For y = 1 To tileY
_PrintString (1, y + 2), "+"
_PrintString (2 + tileX, y + 2), "+"
Next
_PrintString (1, 3 + tileY), tbar$ + Chr$(31)
tbar$ = Chr$(17) + String$(tileX, " ") + Chr$(16)
_PrintString (1, 4 + tileY), tbar$
End Sub
Sub drawonion (f As Integer)
'i don't work and it makes no sense that I'm here in this program
'noted for delete
For y = 1 To _Height
For x = 1 To _Width
Color 24, 0
_PrintString (x, y), gcell(f, x, y).t
Next
Next
Color 15, 0
End Sub
Sub eyedropper (cx, cy)
gcell(tileno, cx, cy).t = gcell(tileno - 1, cx, cy).t
gcell(tileno, cx, cy).fgk = gcell(tileno - 1, cx, cy).fgk
gcell(tileno, cx, cy).bgk = gcell(tileno - 1, cx, cy).bgk
Color gcell(tileno, cx, cy).fgk, gcell(tileno, cx, cy).bgk
_PrintString (cx, cy), gcell(tileno, cx, cy).t
End Sub
Sub duplicatetile (fr)
For cy = 1 To _Height
For cx = 1 To _Width
gcell(fr + 1, cx, cy).t = gcell(fr, cx, cy).t
gcell(fr + 1, cx, cy).fgk = gcell(fr, cx, cy).fgk
gcell(fr + 1, cx, cy).bgk = gcell(fr, cx, cy).bgk
Next cx
Next cy
End Sub
Sub inserttext (cx, cy, fk, bk)
Cls
Print "Enter Text You Wish to Insert"
Input txt$
Cls
For tp = 1 To Len(txt$)
If (cx - 1 + tp) <= _Width Then
gcell(tileno, cx - 1 + tp, cy).t = Mid$(txt$, tp, 1)
gcell(tileno, cx - 1 + tp, cy).fgk = fk
gcell(tileno, cx - 1 + tp, cy).bgk = bk
End If
Next
drawtile tileno
End Sub
Sub newanimation
Cls
Print "Erase Animation and Start New One?"
Print " Y or N "
nflag = 0
Do
k$ = Input$(1)
Select Case k$
Case "Y", "y"
ask$ = "Y"
nflag = 1
Case "N", "n"
ask$ = "N"
nflag = 1
End Select
Loop Until nflag = 1
If ask$ = "Y" Then
ReDim gcell(maxtiles, maxtx, maxty) As gcelltype
For f = 1 To maxtiles
For y = 1 To _Height
For x = 1 To _Width
gcell(f, x, y).t = " "
gcell(f, x, y).fgk = 15
gcell(f, x, y).bgk = 0
Next x
Next y
Next f
tileno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
oflag = 0
Color fg_klr, bg_klr
End If
End Sub
Sub zapcell (cx, cy)
gcell(tileno, cx, cy).t = " "
gcell(tileno, cx, cy).fgk = 0
gcell(tileno, cx, cy).bgk = 0
Color gcell(tileno, cx, cy).fgk, gcell(tileno, cx, cy).bgk
_PrintString (cx, cy), gcell(tileno, cx, cy).t
End Sub
Sub playanimation (ff, lf)
For f = ff To lf
Cls
_Limit tilerate
For y = 1 To _Height
For x = 1 To _Width
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Next
Next
_Display
Next f
_AutoDisplay
Color 15, 0
End Sub
Function select_pencolor
Cls
Color 15, 0
Print "SELECT PEN COLOR"
Print
Print " 0.",: Color 0, 0: Print Chr$(219),: Color 15, 0: Print "16.",: Color 16, 0: Print Chr$(219): Color 15, 0
Print " 1.",: Color 1, 0: Print Chr$(219),: Color 15, 0: Print "17.",: Color 17, 0: Print Chr$(219): Color 15, 0
Print " 2.",: Color 2, 0: Print Chr$(219),: Color 15, 0: Print "18.",: Color 18, 0: Print Chr$(219): Color 15, 0
Print " 3.",: Color 3, 0: Print Chr$(219),: Color 15, 0: Print "19.",: Color 19, 0: Print Chr$(219): Color 15, 0
Print " 4.",: Color 4, 0: Print Chr$(219),: Color 15, 0: Print "20.",: Color 20, 0: Print Chr$(219): Color 15, 0
Print " 5.",: Color 5, 0: Print Chr$(219),: Color 15, 0: Print "21.",: Color 21, 0: Print Chr$(219): Color 15, 0
Print " 6.",: Color 6, 0: Print Chr$(219),: Color 15, 0: Print "22.",: Color 22, 0: Print Chr$(219): Color 15, 0
Print " 7.",: Color 7, 0: Print Chr$(219),: Color 15, 0: Print "23.",: Color 23, 0: Print Chr$(219): Color 15, 0
Print " 8.",: Color 8, 0: Print Chr$(219),: Color 15, 0: Print "24.",: Color 24, 0: Print Chr$(219): Color 15, 0
Print " 9.",: Color 9, 0: Print Chr$(219),: Color 15, 0: Print "25.",: Color 25, 0: Print Chr$(219): Color 15, 0
Print "10.",: Color 10, 0: Print Chr$(219),: Color 15, 0: Print "26.",: Color 26, 0: Print Chr$(219): Color 15, 0
Print "11.",: Color 11, 0: Print Chr$(219),: Color 15, 0: Print "27.",: Color 27, 0: Print Chr$(219): Color 15, 0
Print "12.",: Color 12, 0: Print Chr$(219),: Color 15, 0: Print "28.",: Color 28, 0: Print Chr$(219): Color 15, 0
Print "13.",: Color 13, 0: Print Chr$(219),: Color 15, 0: Print "29.",: Color 29, 0: Print Chr$(219): Color 15, 0
Print "14.",: Color 14, 0: Print Chr$(219),: Color 15, 0: Print "30.",: Color 30, 0: Print Chr$(219): Color 15, 0
Print "15.",: Color 15, 0: Print Chr$(219),: Color 15, 0: Print "31.",: Color 31, 0: Print Chr$(219): Color 15, 0
Do
Locate 20, 3: Input "enter color from 0 to 31 ", kk$
Loop Until Val(kk$) > -1 Or Val(kk$) < 32
select_pencolor = Val(kk$)
End Function
Function newrate
Cls
Print "Change tile Rate ?"
Print
Print "Current tile rate is "; tilerate
Print
Do
Locate 20, 3: Input "enter rate from 1 to 60 ", kk$
Loop Until Val(kk$) > 0 Or Val(kk$) < 61
newrate = Val(kk$)
End Function
Function ynbox$ (msg$, mx, my)
tx = mx: ty = my
lr = Len(msg$) + 4
If tx + lr > _Width Then tx = _Width - (lr + 5)
If ty + 4 > _Height Then ty = _Height + 5
_PrintString (tx, ty), String$(lr, Asc("*"))
_PrintString (tx, ty + 1), "* " + msg$ + " *"
_PrintString (tx, ty + 2), "*" + String$(lr - 2, Asc(".")) + "*"
_PrintString (tx + lr / 2 - 4, ty + 2), " Y or N "
_PrintString (tx, ty + 3), String$(lr, Asc("*"))
Do
ak$ = Input$(1)
Loop Until UCase$(ak$) = "Y" Or UCase$(ak$) = "N"
ynbox$ = ak$
End Function
Function select_backgroundcolor
Cls
Color 15, 0
Print "SELECT Background COLOR"
Print
Print " 0.",: Color 0, 0: Print Chr$(219),: Color 15, 0
Print " 1.",: Color 1, 0: Print Chr$(219): Color 15, 0
Print " 2.",: Color 2, 0: Print Chr$(219),: Color 15, 0
Print " 3.",: Color 3, 0: Print Chr$(219): Color 15, 0
Print " 4.",: Color 4, 0: Print Chr$(219),: Color 15, 0
Print " 5.",: Color 5, 0: Print Chr$(219): Color 15, 0
Print " 6.",: Color 6, 0: Print Chr$(219),: Color 15, 0
Print " 7.",: Color 7, 0: Print Chr$(219): Color 15, 0
Print " 8.",: Color 8, 0: Print Chr$(219),: Color 15, 0
Print " 9.",: Color 9, 0: Print Chr$(219): Color 15, 0
Print "10.",: Color 10, 0: Print Chr$(219),: Color 15, 0
Print "11.",: Color 11, 0: Print Chr$(219): Color 15, 0
Print "12.",: Color 12, 0: Print Chr$(219),: Color 15, 0
Print "13.",: Color 13, 0: Print Chr$(219): Color 15, 0
Print "14.",: Color 14, 0: Print Chr$(219),: Color 15, 0
Print "15.",: Color 15, 0: Print Chr$(219): Color 15, 0
Do
Locate 20, 1: Input "enter color from 0 to 31", kk$
Loop Until Val(kk$) > -1 Or Val(kk$) < 32
select_backgroundcolor = Val(kk$)
End Function
Sub helpme
Cls
Print "HELP"
Print
Print "S - Save file "
Print "L - load file "
Print "use mosue to draw, click on arrows to resize the tileset (be careful)"
Print "N,n - create a new tile (limited to 200 as coded but you can edit that if you wish"
Print "P,p - play tiles as animation"
Print "C,c - change pen foreground color , you'll have to enter color number afterward"
Print "B,b - change pen background color, you'll have to enter color number afterward"
Print "R,r - change tile rate for animation playback.....not all that important relly"
Print "V,v - eyedropper, copies cell from previous tile"
Print "Z,z - zap the cell, erase it by setting it to a space with a foreground and background of zero"
Print "T,t - insert text string, will be prompeted for text to insert"
Print "D - Duplicate tile, be careful this will replace the next tile"
Print "X - Delete tiles, prompted to verify delete"
Print "1 - show current tile in top right corner, will not be recodeed"
Print "esc - to quit program.... be careful this just dumps you out and you'll lose any work currently"
Print
Print "Press any key to continue"
any$ = Input$(1)
End Sub
Function newchar
Dim mc(0 To 256, 2)
Cls
x = 0
y = 3
newc = -1
Print "Click on the Character you wish to use."
For c = 0 To 255
x = x + 2
If x > 60 Then
x = 2
y = y + 2
End If
_PrintString (x, y), Chr$(c)
mc(c, 1) = x
mc(c, 2) = y
Next c
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
c = 0
Do
If mc(c, 1) = mx And mc(c, 2) = my Then newc = c
c = c + 1
If c = 256 Then newc = -2
Loop Until newc <> -1
If newc = -2 Then newc = -1
End If
Color 15, 0
Loop
Loop Until newc <> -1
newchar = newc
End Function
Sub savefile
Locate 1, 1
Print "Enter file name "
Locate 2, 1
Input filename$
Open filename$ For Output As #1
Write #1, tilerate, tileX, tileY, hightile, encoding
'encoding = 0
If encoding = 0 Then
For f = 1 To hightile
For y = 1 To tileY
For x = 1 To tileX
Write #1, gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk,
Print gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk,
Next x
Next y
Next f
End If
If encoding = 1 Then
For f = 1 To hightile
ttile$ = ""
ftile$ = ""
btile$ = ""
For y = 1 To tileY
For x = 1 To tileX
ttile$ = ttile$ + gcell(f, x, y).t
ftile$ = ftile$ + Chr$(gcell(f, x, y).fgk)
btile$ = btile$ + Chr$(gcell(f, x, y).bgk)
Next x
Next y
Write #1, ttile$
Write #1, ftile$
Write #1, btile$
Next f
End If
Close #1
Locate 3, 1
Print filename$; " saved"
Print "press any key to continue"
any$ = Input$(1)
End Sub
Sub loadfile
Locate 1, 1
Print "Enter file name "
Locate 2, 1
Input filename$
Open filename$ For Input As #1
Input #1, tilerate, tileX, tileY, hightile, encoding
'encoding = 1
If encoding = 0 Then 'no encoding just read each cell
For f = 1 To hightile
For y = 1 To tileY
For x = 1 To tileX
Input #1, gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Print gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Next x
Next y
Next f
End If
If encoding = 1 Then 'discrete run length encoding
'each tile breaks the data down into a channel for the the charcter, a channel for foreground and a channel for background
' encoding is limited to line by line
For f = 1 To hightile
Input #1, ttile$
Input #1, ftile$
Input #1, btile$
For y = 1 To tileY
For x = 1 To tileX
gcell(f, x, y).t = Mid$(ttile$, (y - 1) * tileY + x, 1)
gcell(f, x, y).fgk = Asc(Mid$(ftile$, (y - 1) * tileY + x, 1))
gcell(f, x, y).bgk = Asc(Mid$(btile$, (y - 1) * tileY + x, 1))
Next x
Next y
Next f
End If
Close #1
Locate 3, 1
Print filename$; " loaded"
Print "press any key to continue"
any$ = Input$(1)
End Sub
I'm a horrible nerd; I'm into tabletop RPGS and Basic programming. I'm always working on utility programs for my gaming needs. Here's an early in progress version of a dungeon generator. It's got a few rough edges that haven't been filed-off just yet.
Code: (Select All)
'polygon dungeon
'By James D. Jarvis, Sept 2022
Screen _NewImage(800, 600, 32)
Cls
Randomize Timer
Dim Shared shape(8)
shape(1) = 120: shape(2) = 90: shape(3) = 72: shape(4) = 60: shape(5) = 45: shape(6) = 40: shape(7) = 30: shape(8) = 6
Dim p As _Unsigned Long
Dim Shared Kwall As _Unsigned Long
Dim Shared Kfill As _Unsigned Long
Dim Shared kfloor As _Unsigned Long
Type roomtype
x As Integer
y As Integer
r As Integer
turn As Integer
shape As Integer
End Type
Kwall = _RGB32(240, 240, 240)
Kfill = _RGB32(160, 160, 160)
kfloor = _RGB32(250, 230, 210)
Dim Shared room(60) As roomtype
numrooms = 20 + Int(Rnd * 30)
Line (0, 0)-(800, 600), _RGB32(160, 160, 160), BF
For x = 1 To numrooms
If room(x).x + room(x).r > 798 Then flag$ = "bad"
If room(x).y + room(x).r > 598 Then flag$ = "bad"
If Point(room(x).x, room(x).y) <> Kfill Then flag$ = "bad"
Loop Until flag$ = "good"
rotpoly room(x).x, room(x).y, room(x).r, shape(room(x).shape), room(x).turn, Kwall
Paint (room(x).x, room(x).y), kfloor, Kwall
Next x
For x = 1 To numrooms - 1
' Line Input ; A$
Select Case Int(1 + Rnd * 4)
Case 1 'straight line connect
fatline room(x).x, room(x).y, room(x + 1).x, room(x + 1).y, 2, kfloor
Case 2, 3, 4 'right angle jank
targetx = room(x + 1).x
targety = room(x + 1).y
sx = room(x).x: sy = room(x).y
Do
s = Int(1 + Rnd * 6)
On s GOTO skip1, skip2, skip3
skip0:
If targetx < startx Then
tx = tx - Int(3 + Rnd * 8)
If tx < targetx Then tx = targetx
End If
skip1:
If targetx > startx Then
tx = tx + Int(3 + Rnd * 8)
If tx > targetx Then tx = targetx
End If
skip2:
If targety < starty Then
ty = ty - Int(3 + Rnd * 8)
If ty < targety Then ty = targety
End If
skip3:
If targety > starty Then
ty = ty + Int(3 + Rnd * 8)
If ty > targety Then ty = targety
End If
fatline sx, sy, tx, ty, 2, kfloor
sx = tx: sy = ty
If Abs(target - tx) < 12 And Abs(target - tx) < 12 Then
tx = targetx: ty = targety
fatline sx, sy, tx, ty, 2, kfloor
End If
Loop Until tx = targetx And ty = targety
End Select
Next x
For x = 1 To numrooms
Color _RGB32(40, 0, 0), kfloor
pt$ = _Trim$(Str$(x))
pw = _PrintWidth(pt$)
_PrintString (room(x).x - pt / 2, room(x).y - 8), pt$
Next x
Sub circleBF (cx As Long, cy As Long, r As Long, klr As _Unsigned Long)
rsqrd = r * r
y = -r
While y <= r
x = Sqr(rsqrd - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), klr, BF
y = y + 1
Wend
End Sub
Sub rotpoly (cx, cy, rr, shapedeg, turn, klr As _Unsigned Long)
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
Line (cx + x, cy + y)-(cx + x, cy + y), klr
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
Line -(cx + x2, cy + y2), klr
Next
End Sub
Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)
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
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 = (2 * dy) - dx
d = (dy + dy) - dx
y = y0
For x = x0 To x1
circleBF x, y, r, klr
If d > 0 Then
y = y + yi
' D = D + (2 * (dy - dx))
d = d + ((dy - dx) + (dy - dx))
Else
' D = D + 2 * dy
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 = (2 * dx) - dy
D = (dx + dx) - dy
x = x0
For y = y0 To y1
circleBF x, y, r, klr
If D > 0 Then
x = x + xi
' D = D + (2 * (dx - dy))
D = D + ((dx - dy) + (dx - dy))
Else
' D = D + 2 * dx
D = D + dx + dx
End If
Next y
End Sub
A little graphics demo using a simple polygon drawing routine. If 360 is evenly divisible by the shapedeg variable you get a closed polygon. This would be speedier without using PAINT but I wanted ROTPOLY to be a simple as possible.
Code: (Select All)
'just playing with a subroutine
Screen _NewImage(800, 600, 32)
Dim klr As _Unsigned Long
For d = 0 To 360
_Limit 60
Cls
klr = _RGB32(d / 2, d / 2, d / 2)
rotpoly 400, 300, 100, 72, d, klr
Paint (400, 300), klr, klr
For n = 0 To 50
klr = _RGB32(d / 2 + n * 2, d / 4 + n * 2, d / 2 + n * 2)
rotpoly 400 + n * Sin(0.01745329 * d), 300 + n * Cos(0.01745329 * d), 100 - n, 72, d + n, klr
Paint (400 + n * Sin(0.01745329 * d), 300 + n * Cos(0.01745329 * d)), klr, klr
klr2 = _RGB32(d / 2 + n * 2, d / 4 + n * 2, d / 4 + n * 2)
rotpoly 150 + n * Sin(0.01745329 * d), 150 + n * Cos(0.01745329 * d), 80 - n, 60, d + 30, klr2
Paint (150 + n * Sin(0.01745329 * d), 150 + n * Cos(0.01745329 * d)), klr2, klr2
klr3 = _RGB32(d / 4 + n * 2, d / 4 + n * 2, d / 2 + n * 2)
rotpoly 600 + n * Sin(0.01745329 * d), 100 + n * Cos(0.01745329 * d), 90 - n, 90, d + n, klr3
Paint (600 + n * Sin(0.01745329 * d), 100 + n * Cos(0.01745329 * d)), klr3, klr3
klr4 = _RGB32(n * 2 + 30, d / 2 + 20, d / 2)
rotpoly 600 + n * Sin(0.01745329 * d), 400 + n * Cos(0.01745329 * d), 90 - n, 6, (d + n) * 2, klr4
Paint (600 + n * Sin(0.01745329 * d), 400 + n * Cos(0.01745329 * d)), klr4, klr4
klr5 = _RGB32(255 - n * 2, 255 - d / 2 + 20, 255 - d / 2)
rotpoly 120 + n * Sin(0.01745329 * d), 400 + n * Cos(0.01745329 * d), 90 - n, 120, d + n, klr5
Paint (120 + n * Sin(0.01745329 * d), 400 + n * Cos(0.01745329 * d)), klr5, klr5
klr6 = _RGB32(n * 2 + 30, d / 2 + 20, d / 2)
rotpoly 600 + n * Sin(0.01745329 * d), 400 + n * Cos(0.01745329 * d), 90 - n, 6, n * Sin(0.01745329 * d), klr6
Next
_Display
Next
Sub rotpoly (cx, cy, rr, shapedeg, turn, klr As _Unsigned Long)
'CX and CY are the center of the polygon
'rr is the outer radius of the polygon
'shapedeg is the angle the polygon will be drawn with
'turn is the degrees the polygon will be draw rotated from it's center
'klr is the color of the line drawn by the polygon
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
Line (cx + x, cy + y)-(cx + x, cy + y), klr
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
Line -(cx + x2, cy + y2), klr
Next
End Sub
The Symbolic Instruction Code Kit, which contains a QB64 program named SIC64.BAS
and several smaller utility programs. The source code is public domain and can be
found on several sites, including, filegate.net and keepandshare.com
This program uses a recursive descent parser to interpret a psuedo-basic language
written in a line oriented fashion and can be used for small programming chores.
The archive also contains some further imbedded .zip files which contain several
QB64 sample programs, and some .SIC programs which are used by the SIC engine.
Thank you,
Erik Jon Oredson
You may contact me at my email:
eoredson@gmail.com
Version list:
Code: (Select All)
Version v64.0a r5.8a:
Fixes total bytes in ListFiles.
Adds bytes copied in StatusLine when loading file.
Adds Dot.Display when reading/writing files in Sub ScrnEdit.
Adds Timer to Sub Edit.Status.Line in Sub Scrnedit.
Removes _unsigned from all file handle variables.
Fixes Control-R search/replace display in Sub Scrnedit.
Fixes Function DisplayWinError$ with ErrorBuffer$ as ASCIIZ.
Version v64.0a r5.9a:
Fixes Analyze.bas, Indent.bas, Renumber.bas
Renames Syntax2.doc to Syntax.doc
Stores/restores read-only bit in output file in Sub Scrnedit.
Replaces all Common Shared with Dim Shared in sic.inc
Version v64.0a r5.9a (09/30/2022):
Adds quotes in filename for load/save.
Adds Linux compatible in scrnedit.
Adds load filename in Scrnedit to program array.
Version v64.0a r5.9a (10/30/2022)
Adds (Z)extended display to Directories/Filenames in Menu3.
Adds $Z drive serial number macro to SetPrompts.
Renamed sic.inc to sic16.inc to avoid old filename collision.
Version v64.0a r6.0a:
Adds multiple file numbers to closefile.
Adds debug commands to program run array.
Adds screen saver timer trap and settings.
Make sure all Inkey$ modified to InkeyX$ to trap Keypress for screen saver.
Version v64.0a r6.1a:
Adds dialog.inc file for reading filename.
Edits call GetOpenFilename for reading filename in Call ScrnEdit.
Version v64.0a r6.2a:
Adds range of files to close in CloseFile.
Adds MakeBeep to File# breaks.
Fixes Rem $Debug: spacing.
Adds file trap to lock/unlock.
Adds file record trap to debug.
Affects Sub Get/Put and Sub Lock/Unlock.
Version v64.0a r6.3a:
Adds TO keyword to lock/unlock.
Fixes spacing in Sub ReadProgram.
Version v64.0a r6.4a:
Fixes print after keyboardline input.
Adds more dialog box function calls.
Removes Cls in dialog box call.
Version v64.0a r6.5a:
Modifies titlebar icon.
Adds multiple $Debug statements when separated by colons.
Version v64.0a r6.6a:
Removes call to GetConfigFilename$ in Sub ReadConfig and Sub WriteConfig.
Removes CreateFile And CreateFileA in library function declarations.
Writes Sub CreateFileA to test file, create file, and append file.
Version v64.0a r6.7a:
Fixes problem when started from netpath/cdrom.
Adds C:\ and \\server\share\ to main input loop.
Adds CD/MD/RD directory access commands.
Fixes problem using directory path in ReadConfig.
Version v64.0a r6.8a:
Adds CD... to main menu.
Fixes multipaths to CD/MD/RD.
Also detects removing drive in RD.
Adds realtime clock to KeyboardLine2$
Version v64.0a r7.1a:
Fixes display line length in input in KeyboardLine2$
When entered Tab/Insert/Enter char.
Adds KeyboardTimer to toggle realtime display prompt.
Adds KeyboardTimer in config file.
Adds Width command to main menu.
Also adds screen width 40 to ScrnEdit/Dirs/Files/Drives.
Now sets TabStop constant to 8.
Version v64.0a r7.2a:
Fixes MediaExists in Sub FreeSpace and TotalSpace.
Improves drive list in Volume in Sub Menu.
Adds [Z]Destroy drive to Volume to Sub Menu.
Fixes ListBreakTime in Sub DebugCommand.
Fixes error trap in Debug and Whatis.
Adds multiple spec to files and dirs list.
Attached files:
SIC87F.ZIP for VBdos
SICK64F2.ZIP for QB64
![[Image: sic64.png]](https://i.ibb.co/mGWMSbC/sic64.png)
