| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
| Fractals |
|
Posted by: bplus - 05-19-2022, 07:34 PM - Forum: bplus
- Replies (14)
|
 |
Here is my favorite of all time! I imagined it in college 1976 let's say, way before I've heard term fractals and it took 40 years to get around to drawing it as imagined thanks to Alpha coloring in QB64, sort of had it with SmallBASIC but needed alpha to get the full spectrum of shading of overlapping squares.
Code: (Select All) _Title "recurring squares 2017-10-26 by bplus"
' Now with Alpha coloring!
'reoccuring squares SmallBASIC translation from
Rem reoccuring squares NaaLaa started 2015-05-14 MGA/B+
Const xmax = 700
Const ymax = 700
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 30 'adjust as needed _MIDDLE needs a delay .5 or more for me
Common Shared dimmer
sq = 700: dir = 1
While 1
Cls
white& = _RGB(255, 255, 255)
fRecStep 0, 0, sq, sq, white&
sqPlus sq / 2, sq / 2, sq / 2
_Display
_Limit 20
dimmer = dimmer + dir
If dimmer > 255 Then dimmer = 255: dir = dir * -1: _Delay .5
If dimmer < 0 Then dimmer = 0: dir = dir * -1: _Delay .5
Wend
Sub fRecStep (x1, y1, x2, y2, c&)
Line (x1, y1)-Step(x2, y2), c&, BF
End Sub
Sub sqPlus (x, y, side)
cx = x - side / 2: cy = y - side / 2
fRecStep cx, cy, side, side, _RGBA(0, 0, 0, dimmer)
If side < 10 Then Exit Sub
ns = side / 2: nc = colorNumber - 35
sqPlus cx, cy, ns
sqPlus cx + side, cy, ns
sqPlus cx, cy + side, ns
sqPlus cx + side, cy + side, ns
End Sub
I have an 40 year old Ink Wash Drawing that looks very close to this snapshot.
|
|
|
| trying to draw a better moon |
|
Posted by: James D Jarvis - 05-19-2022, 02:10 PM - Forum: Help Me!
- Replies (8)
|
 |
working on my alienskies program posted elsewhere and I'm trying to develop a better method of rendering the moons so the craters don't jump off the moon. I'm trying a rendering methods where I draw the craters in a separate image and then I scan that image layer only copying the pixels on that image layer that are inside the space of the moon. That's working but when I attempt to clear the image holding the craters to draw fresh craters it just isn't clearing out the old craters. I suspect it's in the order of my _dest and _source calls but I'm lost and can't see where the error is. Anyone want to take a look and offer advice I'd really appreciate it?
Code: (Select All) 'not better mooon
'arrggghhhh ..... why isn't this working????
Dim Shared imgmax_x, imgmax_y, MS&, cp&
Dim Shared nopaint As _Unsigned Long
imgmax_x = 800
imgmax_y = 600
Randomize Timer
MS& = _NewImage(imgmax_x, imgmax_y, 32)
cp& = _NewImage(imgmax_x, imgmax_y, 32) <- the crater paint image
Screen MS&
nopaint = Point(1, 1)
Do
Cls
_Limit 1
bettermoon
_Display
A$ = InKey$
Loop Until A$ = "q"
Sub bettermoon
mx = 400
my = 300
' mx = Int(Rnd * (imgmax_x / 2)) + (imgmax_x / 4)
' my = Int(Rnd * (imgmax_y / 2)) + (imgmax_x / 4)
mkr = Int(Rnd * 100) + 50: mkg = Int(Rnd * 100) + 50: mkb = Int(Rnd * 100) + 50
mklr& = _RGB32(mkr, mkg, mkb)
' moonsize = Int(((Rnd * 200) + (Rnd * 200)) / 2)
moonsize = Int(((Rnd * 200) + 50 + (Rnd * 200) + 50) / 2)
orb mx, my, moonsize, mklr&, 1.8
kk = 1
ccheck = Int(Rnd * 100)
If ccheck < 90 Then
kk = craters(mx, my, moonsize, mklr&)
End If
moonfuzz mx, my, moonsize, mklr&, 10 + (kk * 3)
' moonshadow mx, my, moonsize, mklr& turned off because I'm focusing on the problem for now
End Sub
Sub orb (XX As Long, YY As Long, Rd As Long, KK As Long, brt As Integer)
'false shaded 3d spheres
Dim nk As Long
nk = 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 moonfuzz (CX As Long, CY As Long, R As Long, C As Long, CHNC As Integer)
'CX and CY are to plot of the circle center R is the radius, c is the primary color, CHNC is the chance for noise to vary from from primary color
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
'checking to see if we should use the base color or slap down some random noise
For tx = CX - X To CX + X
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84)) 'drawing each point in the line because color can change from pixel to pixel
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
For tx = CX - Y To CX + Y
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY - X), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
For tx = CX - Y To CX + Y
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY + X), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
For tx = CX - X To CX + X
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY - Y), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
For tx = CX - X To CX + X
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY + Y), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
'dotc = C let the color stay as drawn by orb
End If
Next tx
Wend
End Sub
Function brighter& (ch&&, p)
'eventually going to replace this sub with a beter one
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
Function craters (mx, my, mrd, mk&)
' put craters on those moons
crmax = mrd * .24
numk = Int(Rnd * 24) + 12
_Dest cp&
Line (0, 0)-(img_maxx - 1, img_maxy - 1), _RGB32(0, 0, 0) ' <---- why isn't this overwritng the old image on cp&
For k = 1 To numk
crad = Int(Rnd * crmax) + 1
cgominx = mx - mrd + crad: cgomax = mx + mrd - crad
cgominy = my - mrd + crad: cgomay = my + mrd - crad
cx = Int(Rnd * (cgomax - cgominx)) + cgominx + 1
cy = Int(Rnd * (cgomay - cgominy)) + cgominy + 1
nk& = mk&
orb cx, cy, crad, nk&, 1.9
Next k
_Dest MS&
cratercopy mx, my, mrd
_Source MS&
_Dest MS&
craters = numk
End Function
Sub cratercopy (CX As Long, CY As Long, R As Long)
'CX and CY are to plot of the circle center R is the radius, c is the primary color, CHNC is the chance for noise to vary from from primary color
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
_Source cp&
_Dest MS&
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
'checking to see if we should use the base color or slap down some random noise
For tx = CX - X To CX + X
dotc& = Point(tx, CY)
If dotc& <> nopaint Then PSet (tx, CY), dotc& 'drawing each point in the line because color can change from pixel to pixel
Next tx
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
For tx = CX - Y To CX + Y
dotc& = Point(tx, CY - X)
If dotc& <> nopaint Then PSet (tx, CY - X), dotc&
Next tx
For tx = CX - Y To CX + Y
dotc& = Point(tx, CY + X)
If dotc& <> nopaint Then PSet (tx, CY + X), dotc&
Next tx
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
For tx = CX - X To CX + X
dotc& = Point(tx, CY - Y)
If dotc& <> nopaint Then PSet (tx, CY - Y), dotc&
Next tx
For tx = CX - X To CX + X
dotc& = Point(tx, CY + Y)
If dotc& <> nopaint Then PSet (tx, CY + Y), dotc&
Next tx
Wend
_Dest cp&
_Dest MS&
End Sub
Sub moonshadow (mx, my, moonsize, mklr&)
'this isn't perfect but it works. It's currentyl commented in the main routine
moffx = mx + Int(Rnd * moonsize) - Int(Rnd * moonsize)
moffy = my + Int(Rnd * moonsize) - Int(Rnd * moonsize)
CircleFill moffx, moffy, moonsize, _RGB32(0, 0, 0)
End Sub
|
|
|
|
| Bouncing Kaleidoscope |
|
Posted by: SierraKen - 05-19-2022, 05:12 AM - Forum: Programs
- No Replies
|
 |
![[Image: Bouncing-Kaleidoscope-by-Sierra-Ken.png]](https://i.ibb.co/GQR61xv/Bouncing-Kaleidoscope-by-Sierra-Ken.png)
This is like my other Kaleidoscope but it is much smaller and bounces off the walls.  I decided to make it a different thread since they are really completely different. I'll post a picture below.
Code: (Select All) 'Bouncing Kaleidoscope by SierraKen
'May 18, 2022
Screen _NewImage(800, 800, 32)
_Title "Bouncing Kaleidoscope by SierraKen"
Randomize Timer
cc = 1
dirx = 1
diry = 1
cenx = 400
ceny = 400
Do
Do
_Limit 100
If c <> 0 Then cc = c
c = Rnd * 100
If c < cc Then
s = -.25
Else
s = .25
End If
cl1 = Int(Rnd * 200) + 1
cl2 = Int(Rnd * 200) + 1
cl3 = Int(Rnd * 200) + 1
cenx = cenx + dirx
ceny = ceny + diry
If cenx > 700 Then dirx = -1 * Rnd * 3
If cenx < 100 Then dirx = 1 * Rnd * 3
If ceny > 700 Then diry = -1 * Rnd * 3
If ceny < 100 Then diry = 1 * Rnd * 3
For t = cc To c Step s
x = (Sin(t) * t) + cenx
y = (Cos(t) * t) + ceny
Circle (x, y), 2, _RGB32(cl1, cl2, cl3)
Next t
lp = lp + 1
Loop Until lp > 20
lp = 0
_Display
Line (0, 0)-(800, 800), _RGB32(0, 0, 0, 10), BF
Loop Until InKey$ = Chr$(27)
|
|
|
|
| Deflate and inflate |
|
Posted by: PhilOfPerth - 05-19-2022, 05:11 AM - Forum: General Discussion
- Replies (10)
|
 |
I've just stumbled across the _deflate and _inflate functions in QB64, and I reckon they may be quite useful.
But I don't think they've been given justice in the explanation of what they can do. Nothing there tells me what the resulting _deflated string will look like, or how it may be used (if it can) while deflated. Can they be treated like normal strings (concatenated, searched, used as a reference base etc.)? I can experiment, but I'm not up to improving the explanations. Hopefully someone can expand on things a bit?
|
|
|
|
source code to a ton of classic arcade/infocom/computer games + programs |
|
Posted by: madscijr - 05-18-2022, 09:47 PM - Forum: General Discussion
- Replies (2)
|
 |
Ever want to look at the source code for MS-DOS, GW-BASIC, Windows file manager or Deluxe Paint?
How about arcade Lunar Lander, Tempest, Gravitar, Frenzy (Berzerk II), Asteroids Deluxe, or Defender?
Or ZZT, Infocom's Hitchhiker's Guide or the original mainframe Zork code in FORTRAN?
For anyone curious about how these work, I came across treasure trove of source code for a ton of classic games & programs.
First/last page for the whole thing:
Here are the direct links for a bunch.
Non-games:
Games:- GitHub - historicalsource/akalabeth: Akalabeth: World of Doom (1979) by Richard Garriott.
- GitHub - historicalsource/asteroids: A flying and rock-shooting game
- GitHub - historicalsource/asteroids-cocktail: Asteroids you can sit down at
- GitHub - historicalsource/asteroids-deluxe: An improved rock-shooting and flying space game
- GitHub - historicalsource/basketball: A basketball game
- GitHub - historicalsource/battlezone: A tank game
- GitHub - historicalsource/centipede: An arcade game that has bugs on purpose
- GitHub - historicalsource/cocktail-lunar-lander: Game about a lunar parking spot you can sit down at
- GitHub - historicalsource/cruisin-usa: A driving and obstacle-avoiding car game.
- GitHub - historicalsource/crystal-castles: A gem-hunting game for bears
- GitHub - historicalsource/defender: A shooting, moving, people-saving, ship-exploding game
- GitHub - historicalsource/defender-1: Defender(1981) by Eugene Jarvis and Sam Dicker
- GitHub - historicalsource/dig-dug: A digging and pumping game
- GitHub - historicalsource/dominos4: A dominos game four people can play
- GitHub - historicalsource/fire-truck: A fire truck driving game
- GitHub - historicalsource/football: A game of X's and O's
- GitHub - historicalsource/football-4-player: A four player football
- GitHub - historicalsource/frenzy: A maze-running and shooting game improving upon a previous maze-running and shooting game
- GitHub - historicalsource/gravitar: A game of caverns and getting into them
- GitHub - historicalsource/hitchhikersguide: The Hitchhiker's Guide to the Galaxy, by Steve Meretzky and Douglas Adams (Infocom)
- GitHub - historicalsource/hitchhikersguide-gold: The Hitchhiker's Guide to the Galaxy (Solid-Gold Edition) by Steve Meretzky and Douglas Adams (Infocom)
- GitHub - historicalsource/indy-4: A race driving game for 4 people
- GitHub - historicalsource/lunar-lander: A game about finding a parking spot in space
- GitHub - historicalsource/millipede: A game with even more bugs
- GitHub - historicalsource/minigolf: A miniature golf game
- GitHub - historicalsource/nba-jam: A fast-paced basketball game
- GitHub - historicalsource/nba-jam-tournament-edition: fast-paced basketball game with new rules
- GitHub - historicalsource/nightdriver: a night racing game
- GitHub - historicalsource/open-ice: a hockey game
- GitHub - historicalsource/orbit-space-wars: A game about ships and orbiting
- GitHub - historicalsource/oregontrail: The Oregon Trail (1975) by Don Rawitsch / MECC.
- GitHub - historicalsource/planetfall: Planetfall, by Steve Meretzky (Infocom)
- GitHub - historicalsource/reconstruction-of-zzt: The Reconstruction of ZZT
- GitHub - historicalsource/red-baron: A historical bi-plane shooting game
- GitHub - historicalsource/restaurant: The Restaurant at the End of the Universe (Incomplete, Unreleased) (Infocom)
- GitHub - historicalsource/sinistar: A shooting, space-flying, avoiding-the-scary-space-monster game
- GitHub - historicalsource/sky-raider: A very complicated bombing game
- GitHub - historicalsource/soccer: A game of what they call football elsewhere
- GitHub - historicalsource/space-duel: A shooting game with ships working together
- GitHub - historicalsource/Spacewar: Spacewar for PDP-6 and PDP-10
- GitHub - historicalsource/sprint-2: a racing game
- GitHub - historicalsource/sprint-4: A four-player racing game
- GitHub - historicalsource/sprint-4-update: An update for the racing game Sprint 4
- GitHub - historicalsource/sprint-8: A racing game for 8 players
- GitHub - historicalsource/starcross: Starcross by Dave Lebling
- GitHub - historicalsource/stargate: A shooting, exploding, transporting, alien fighting game.
- GitHub - historicalsource/star-wars: A space game
- GitHub - historicalsource/super-breakout-cocktail: A wall-smashing game you can sit down at
- GitHub - historicalsource/super-breakout-domestic: A wall smashing game
- GitHub - historicalsource/tank-8: a multi-player tank game with colorful tanks
- GitHub - historicalsource/tempest: A game about shooting downwards
- GitHub - historicalsource/ultra-tank: A tank driving game
- GitHub - historicalsource/video-pinball: A pinball game except it's a video game
- GitHub - historicalsource/warlords: A game of very nearby castles fighting
- GitHub - historicalsource/zil: Zork implementation language
- GitHub - historicalsource/zork1: Zork I (Microcomputer Version) by Infocom
- GitHub - historicalsource/zork-1977-source: Source code for a 1977 version of Zork
- GitHub - historicalsource/zork2: Zork II (Microcomputer Version) (Infocom)
- GitHub - historicalsource/zork3: Zork III (Infocom)
Info on the Infocom language:
Some bonus links for anyone wanting to make a lunar lander game:
Enjoy
|
|
|
|
| Triquad puzzle game |
|
Posted by: Rick3137 - 05-18-2022, 09:25 PM - Forum: Programs
- Replies (6)
|
|
I hope this works on other computers.
This works on my HP windows11 laptop.
Code: (Select All) $NoPrefix
screen1& = NewImage(1360, 748, 256)
Screen screen1&
ScreenMove -2, -2
Dim Shared mx, my, row, column, zone, c1, c2, c3, c4, btn, pieceup, c1a, c2a, c3a, c4a, mz As Integer
Dim Shared gameover, lastzone, mousereleased, playagain, test, tcode1, tcode2, tcode3 As Integer
Dim Shared triquad(80, 4) As Integer
Dim Shared startquad(80, 4) As Integer
Dim Shared quadx(80) As Integer
Dim Shared quady(80) As Integer
playagain = 1: mz = 0: test = 0
Randomize Timer
setupcolors
Color 10, 11
Cls
While playagain = 1
menu
If mz = 1 Then game1setup
If mz = 2 Then game2setup
If mz = 3 Then game3setup
If mz = 4 Then game4setup
If mz = 5 Then game5setup
If mz = 6 Then game6setup
If mz = 7 Then game7setup
If mz = 8 Then game8setup
If mz = 9 Then game9setup
Color 10, 11
gameover = 0: lastzone = 0: pieceup = 0: mousereleased = 0:
snd 1: snd 2: snd 1
If mz < 5 Then mainloop
If mz = 5 Then mainloop2
If mz = 6 Then mainloop2
If mz = 7 Then mainloop3
If mz = 8 Then mainloop3
If mz = 9 Then mainloop3
EndScreen
Color 10, 11
Cls
Wend
End
Sub game1setup
setupdata
shuffle
makeboard
End Sub
Sub game2setup
setupdata
shuffle
makeboard
End Sub
Sub game3setup
setupdata
shuffle
makeboard
End Sub
Sub game4setup
setupdata
shuffle
makeboard
End Sub
Sub game5setup
setupdata2
shuffle2
makeboard2
End Sub
Sub game6setup
setupdata2
shuffle2
makeboard2
End Sub
Sub game7setup
setupdata3
shuffle3
makeboard3
End Sub
Sub game8setup
setupdata3
shuffle3
makeboard3
End Sub
Sub game9setup
setupdata3
shuffle3
makeboard3
End Sub
Sub menu
Color 10
mz = 0
a = 0: k$ = ""
Locate 10, 60: Print "THE GAME OF TRIQUAD"
Locate 12, 40: Print " To solve this puzzle, move all of the squares"
Locate 13, 40: Print " from the left side of the screen to the right side "
Locate 14, 40: Print " of the screen, using the mouse."
Locate 16, 40: Print " All triangles that touch, must be of the same color"
Locate 17, 40: Print " to win ."
Locate 20, 60: Print " SELECT GAME BUTTON WITH MOUSE TO START "
Locate 22, 60: Print " http://rb23.yolasite.com/ "
x = 198
For cnt = 1 To 9
y = 395 ' make 9 menu keys
box x, y, 60, 13
box2 x, y, 60, 10
box x + 10, y + 10, 40, 3
box2 x + 10, y + 10, 40, 10
x = x + 80
Locate 27, 18 + 10 * cnt: Print cnt
Next
Do
k$ = InKey$
If k$ <> "" Then a = 1
If MouseInput Then
mx = MouseX
my = MouseY
btn = MouseButton(1)
If btn = -1 And my > 400 And my < 460 Then ' select menu button (mz)
If mx > 200 And mx < 260 Then mz = 1
If mx > 280 And mx < 340 Then mz = 2
If mx > 360 And mx < 420 Then mz = 3
If mx > 440 And mx < 500 Then mz = 4
If mx > 520 And mx < 580 Then mz = 5
If mx > 600 And mx < 660 Then mz = 6
If mx > 680 And mx < 790 Then mz = 7
If mx > 760 And mx < 820 Then mz = 8
If mx > 840 And mx < 900 Then mz = 9
If mx > 900 Then test = 1
If mx > 900 Then Print " * "
End If
If mz = 1 Then a = 1
If mz = 2 Then a = 1
If mz = 3 Then a = 1
If mz = 4 Then a = 1
If mz = 5 Then a = 1
If mz = 6 Then a = 1
If mz = 7 Then a = 1
If mz = 8 Then a = 1
If mz = 9 Then a = 1
End If
Loop Until a = 1
Color 10, 11
Cls
End Sub
Sub EndScreen
a = 0: k$ = ""
Color 1, 11
Cls
Locate 10, 40
Print " PRESS ESCAPE KEY TO EXIT"
Locate 20, 40
Print " HIT SPACE BAR TO PLAY AGAIN "
Do
k$ = InKey$
If k$ = " " Then a = 1
If k$ = Chr$(27) Then playagain = 0: a = 1
Loop Until a = 1
End Sub
Sub shuffle
Dim t1, t2, t3, t4, q1, q2, q3, q4, r1, r2 As Integer ' temporary variables
If mz < 3 Then
t1 = triquad(3, 1) ' store colors in temporary variables
t2 = triquad(3, 2)
t3 = triquad(3, 3)
t4 = triquad(3, 4)
triquad(3, 1) = 0 ' clear color array
triquad(3, 2) = 0
triquad(3, 3) = 0
triquad(3, 4) = 0
triquad(12, 1) = t1 ' store variables to color array
triquad(12, 2) = t2
triquad(12, 3) = t3
triquad(12, 4) = t4
End If
If mz = 1 Then
q1 = triquad(9, 1) ' store colors in temporary variables
q2 = triquad(9, 2)
q3 = triquad(9, 3)
q4 = triquad(9, 4)
triquad(9, 1) = 0 ' clear color array
triquad(9, 2) = 0
triquad(9, 3) = 0
triquad(9, 4) = 0
triquad(18, 1) = q1 ' store variables to color array
triquad(18, 2) = q2
triquad(18, 3) = q3
triquad(18, 4) = q4
End If
t1 = 0: t2 = 0: t3 = 0: t4 = 0: q1 = 0: q2 = 0: q3 = 0: q4 = 0
' save solution data
For q = 1 To 9
startquad(q, 1) = triquad(q, 1)
startquad(q, 2) = triquad(q, 2)
startquad(q, 3) = triquad(q, 3)
startquad(q, 4) = triquad(q, 4)
Next
makeboard: Sleep 4
For cnt = 1 To 8 ' number of times to shuffle
If test = 0 Then
r1 = Int(Rnd * 9) + 1 ' from 8 or 9???
r2 = Int(Rnd * 9) + 1 ' to
End If
' This test mode makes square 9 the correct move for square 18
If test = 1 Then
r1 = Int(Rnd * 8) + 1 ' from 8 or 9???
r2 = Int(Rnd * 8) + 1 ' to
End If
t1 = triquad(r1, 1) ' store colors in temporary variables
t2 = triquad(r1, 2)
t3 = triquad(r1, 3)
t4 = triquad(r1, 4)
q1 = triquad(r2, 1)
q2 = triquad(r2, 2)
q3 = triquad(r2, 3)
q4 = triquad(r2, 4)
triquad(r2, 1) = t1 ' swap variables and store to color arrays
triquad(r2, 2) = t2
triquad(r2, 3) = t3
triquad(r2, 4) = t4
triquad(r1, 1) = q1
triquad(r1, 2) = q2
triquad(r1, 3) = q3
triquad(r1, 4) = q4
Next
End Sub
Sub shuffle3
Dim t1, t2, t3, t4, q1, q2, q3, q4, r1, r2 As Integer ' temporary variables
t1 = 0: t2 = 0: t3 = 0: t4 = 0: q1 = 0: q2 = 0: q3 = 0: q4 = 0
If mz = 7 Then
t1 = triquad(5, 1) ' store colors in temporary variables
t2 = triquad(5, 2)
t3 = triquad(5, 3)
t4 = triquad(5, 4)
triquad(5, 1) = 0 ' clear color array
triquad(5, 2) = 0
triquad(5, 3) = 0
triquad(5, 4) = 0
triquad(30, 1) = t1 ' store variables to color array
triquad(30, 2) = t2
triquad(30, 3) = t3
triquad(30, 4) = t4
t1 = triquad(25, 1) ' store colors in temporary variables
t2 = triquad(25, 2)
t3 = triquad(25, 3)
t4 = triquad(25, 4)
triquad(25, 1) = 0 ' clear color array
triquad(25, 2) = 0
triquad(25, 3) = 0
triquad(25, 4) = 0
triquad(50, 1) = t1 ' store variables to color array
triquad(50, 2) = t2
triquad(50, 3) = t3
triquad(50, 4) = t4
t1 = triquad(1, 1) ' store colors in temporary variables
t2 = triquad(1, 2)
t3 = triquad(1, 3)
t4 = triquad(1, 4)
triquad(1, 1) = 0 ' clear color array
triquad(1, 2) = 0
triquad(1, 3) = 0
triquad(1, 4) = 0
triquad(26, 1) = t1 ' store variables to color array
triquad(26, 2) = t2
triquad(26, 3) = t3
triquad(26, 4) = t4
t1 = triquad(21, 1) ' store colors in temporary variables
t2 = triquad(21, 2)
t3 = triquad(21, 3)
t4 = triquad(21, 4)
triquad(21, 1) = 0 ' clear color array
triquad(21, 2) = 0
triquad(21, 3) = 0
triquad(21, 4) = 0
triquad(46, 1) = t1 ' store variables to color array
triquad(46, 2) = t2
triquad(46, 3) = t3
triquad(46, 4) = t4
End If
If mz = 8 Then
t1 = triquad(5, 1) ' store colors in temporary variables
t2 = triquad(5, 2)
t3 = triquad(5, 3)
t4 = triquad(5, 4)
triquad(5, 1) = 0 ' clear color array
triquad(5, 2) = 0
triquad(5, 3) = 0
triquad(5, 4) = 0
triquad(30, 1) = t1 ' store variables to color array
triquad(30, 2) = t2
triquad(30, 3) = t3
triquad(30, 4) = t4
t1 = triquad(25, 1) ' store colors in temporary variables
t2 = triquad(25, 2)
t3 = triquad(25, 3)
t4 = triquad(25, 4)
triquad(25, 1) = 0 ' clear color array
triquad(25, 2) = 0
triquad(25, 3) = 0
triquad(25, 4) = 0
triquad(50, 1) = t1 ' store variables to color array
triquad(50, 2) = t2
triquad(50, 3) = t3
triquad(50, 4) = t4
End If
' save solution data
For q = 1 To 25
startquad(q, 1) = triquad(q, 1)
startquad(q, 2) = triquad(q, 2)
startquad(q, 3) = triquad(q, 3)
startquad(q, 4) = triquad(q, 4)
Next
makeboard3: Sleep 4
t1 = 0: t2 = 0: t3 = 0: t4 = 0: q1 = 0: q2 = 0: q3 = 0: q4 = 0
For z = 1 To 11 ' number of times to shuffle
If test = 0 Then
r1 = Int(Rnd * 25) + 1 ' from
r2 = Int(Rnd * 25) + 1 ' to
End If
' This test mode makes square 23,24,25 the correct move for square 48,49,50
If test = 1 Then
r1 = Int(Rnd * 22) + 1 ' from
r2 = Int(Rnd * 22) + 1 ' to
End If
t1 = triquad(r1, 1) ' store colors in temporary variables
t2 = triquad(r1, 2)
t3 = triquad(r1, 3)
t4 = triquad(r1, 4)
q1 = triquad(r2, 1)
q2 = triquad(r2, 2)
q3 = triquad(r2, 3)
q4 = triquad(r2, 4)
triquad(r2, 1) = t1 ' swap variables and store to color arrays
triquad(r2, 2) = t2
triquad(r2, 3) = t3
triquad(r2, 4) = t4
triquad(r1, 1) = q1
triquad(r1, 2) = q2
triquad(r1, 3) = q3
triquad(r1, 4) = q4
Next
End Sub
Sub shuffle2
Dim t1, t2, t3, t4, q1, q2, q3, q4, r1, r2 As Integer
t1 = 0: t2 = 0: t3 = 0: t4 = 0: q1 = 0: q2 = 0: q3 = 0: q4 = 0: r1 = 0: r2 = 0
If mz = 5 Then
t1 = triquad(4, 1) ' store colors in temporary variables
t2 = triquad(4, 2)
t3 = triquad(4, 3)
t4 = triquad(4, 4)
triquad(4, 1) = 0 ' clear color array
triquad(4, 2) = 0
triquad(4, 3) = 0
triquad(4, 4) = 0
triquad(20, 1) = t1 ' store variables to color array
triquad(20, 2) = t2
triquad(20, 3) = t3
triquad(20, 4) = t4
t1 = triquad(16, 1) ' store colors in temporary variables
t2 = triquad(16, 2)
t3 = triquad(16, 3)
t4 = triquad(16, 4)
triquad(16, 1) = 0 ' clear color array
triquad(16, 2) = 0
triquad(16, 3) = 0
triquad(16, 4) = 0
triquad(32, 1) = t1 ' store variables to color array
triquad(32, 2) = t2
triquad(32, 3) = t3
triquad(32, 4) = t4
t1 = triquad(13, 1) ' store colors in temporary variables
t2 = triquad(13, 2)
t3 = triquad(13, 3)
t4 = triquad(13, 4)
triquad(13, 1) = 0 ' clear color array
triquad(13, 2) = 0
triquad(13, 3) = 0
triquad(13, 4) = 0
triquad(29, 1) = t1 ' store variables to color array
triquad(29, 2) = t2
triquad(29, 3) = t3
triquad(29, 4) = t4
End If
' save solution data
For q = 1 To 16
startquad(q, 1) = triquad(q, 1)
startquad(q, 2) = triquad(q, 2)
startquad(q, 3) = triquad(q, 3)
startquad(q, 4) = triquad(q, 4)
Next
makeboard2: Sleep 4
For z = 1 To 11 ' number of times to shuffle
t1 = 0: t2 = 0: t3 = 0: t4 = 0: q1 = 0: q2 = 0: q3 = 0: q4 = 0: r1 = 0: r2 = 0
If test = 0 Then
r1 = Int(Rnd * 16) + 1 ' from
r2 = Int(Rnd * 16) + 1 ' to
End If
' This test mode makes square 14,15,16 the correct move for square 30,31,32 used for testing
If test = 1 Then
r1 = Int(Rnd * 13) + 1 ' from
r2 = Int(Rnd * 13) + 1 ' to
End If
t1 = triquad(r1, 1) ' store colors in temporary variables
t2 = triquad(r1, 2)
t3 = triquad(r1, 3)
t4 = triquad(r1, 4)
q1 = triquad(r2, 1)
q2 = triquad(r2, 2)
q3 = triquad(r2, 3)
q4 = triquad(r2, 4)
triquad(r2, 1) = t1 ' swap variables and store to color arrays
triquad(r2, 2) = t2
triquad(r2, 3) = t3
triquad(r2, 4) = t4
triquad(r1, 1) = q1
triquad(r1, 2) = q2
triquad(r1, 3) = q3
triquad(r1, 4) = q4
Next
End Sub
Sub checkboard
' check to see if game over
Dim p1, p2, p3, p4, c As Integer
c = 0
For cnt = 10 To 18
For cnt2 = 1 To 4
p1 = triquad(cnt, 1): p2 = triquad(cnt, 2): p3 = triquad(cnt, 3): p4 = triquad(cnt, 4)
If cnt = 10 And p2 > 0 And triquad(11, 4) = p2 Then c = c + 1
If cnt = 10 And p3 > 0 And triquad(13, 1) = p3 Then c = c + 1
If cnt = 11 And p2 > 0 And triquad(12, 4) = p2 Then c = c + 1
If cnt = 11 And p3 > 0 And triquad(14, 1) = p3 Then c = c + 1
If cnt = 12 And p3 > 0 And triquad(15, 1) = p3 Then c = c + 1
If cnt = 13 And p2 > 0 And triquad(14, 4) = p2 Then c = c + 1
If cnt = 13 And p3 > 0 And triquad(16, 1) = p3 Then c = c + 1
If cnt = 14 And p2 > 0 And triquad(15, 4) = p2 Then c = c + 1
If cnt = 14 And p3 > 0 And triquad(17, 1) = p3 Then c = c + 1
If cnt = 15 And p3 > 0 And triquad(18, 1) = p3 Then c = c + 1
If cnt = 16 And p2 > 0 And triquad(17, 4) = p2 Then c = c + 1
If cnt = 17 And p2 > 0 And triquad(18, 4) = p2 Then c = c + 1
Next
Next
If c = 48 Then Locate 2, 30: Print " PUZZLE SOLVED "
End Sub
Sub checkboard3
' check to see if game over
Dim p1, p2, p3, p4, c As Integer
c = 0
For cnt = 26 To 50
For cnt2 = 1 To 4
p1 = triquad(cnt, 1): p2 = triquad(cnt, 2): p3 = triquad(cnt, 3): p4 = triquad(cnt, 4)
If cnt = 26 And p2 > 0 And triquad(27, 4) = p2 Then c = c + 1
If cnt = 26 And p3 > 0 And triquad(31, 1) = p3 Then c = c + 1
If cnt = 27 And p2 > 0 And triquad(28, 4) = p2 Then c = c + 1
If cnt = 27 And p3 > 0 And triquad(32, 1) = p3 Then c = c + 1
If cnt = 28 And p2 > 0 And triquad(29, 4) = p2 Then c = c + 1
If cnt = 28 And p3 > 0 And triquad(33, 1) = p3 Then c = c + 1
If cnt = 29 And p2 > 0 And triquad(30, 4) = p2 Then c = c + 1
If cnt = 29 And p3 > 0 And triquad(34, 1) = p3 Then c = c + 1
If cnt = 30 And p3 > 0 And triquad(35, 1) = p3 Then c = c + 1
If cnt = 31 And p2 > 0 And triquad(32, 4) = p2 Then c = c + 1
If cnt = 31 And p3 > 0 And triquad(36, 1) = p3 Then c = c + 1
If cnt = 32 And p2 > 0 And triquad(33, 4) = p2 Then c = c + 1
If cnt = 32 And p3 > 0 And triquad(37, 1) = p3 Then c = c + 1
If cnt = 33 And p2 > 0 And triquad(34, 4) = p2 Then c = c + 1
If cnt = 33 And p3 > 0 And triquad(38, 1) = p3 Then c = c + 1
If cnt = 34 And p2 > 0 And triquad(35, 4) = p2 Then c = c + 1
If cnt = 34 And p3 > 0 And triquad(39, 1) = p3 Then c = c + 1
If cnt = 35 And p3 > 0 And triquad(40, 1) = p3 Then c = c + 1
If cnt = 36 And p2 > 0 And triquad(37, 4) = p2 Then c = c + 1
If cnt = 36 And p3 > 0 And triquad(41, 1) = p3 Then c = c + 1
If cnt = 37 And p2 > 0 And triquad(38, 4) = p2 Then c = c + 1
If cnt = 37 And p3 > 0 And triquad(42, 1) = p3 Then c = c + 1
If cnt = 38 And p2 > 0 And triquad(39, 4) = p2 Then c = c + 1
If cnt = 38 And p3 > 0 And triquad(43, 1) = p3 Then c = c + 1
If cnt = 39 And p3 > 0 And triquad(40, 4) = p2 Then c = c + 1
If cnt = 39 And p3 > 0 And triquad(44, 1) = p3 Then c = c + 1
If cnt = 40 And p3 > 0 And triquad(45, 1) = p3 Then c = c + 1
If cnt = 41 And p2 > 0 And triquad(42, 4) = p2 Then c = c + 1
If cnt = 41 And p3 > 0 And triquad(46, 1) = p3 Then c = c + 1
If cnt = 42 And p2 > 0 And triquad(43, 4) = p2 Then c = c + 1
If cnt = 42 And p3 > 0 And triquad(47, 1) = p3 Then c = c + 1
If cnt = 43 And p2 > 0 And triquad(44, 4) = p2 Then c = c + 1
If cnt = 43 And p3 > 0 And triquad(48, 1) = p3 Then c = c + 1
If cnt = 44 And p2 > 0 And triquad(45, 4) = p2 Then c = c + 1
If cnt = 44 And p3 > 0 And triquad(49, 1) = p3 Then c = c + 1
If cnt = 45 And p3 > 0 And triquad(50, 1) = p3 Then c = c + 1
If cnt = 46 And p2 > 0 And triquad(47, 4) = p2 Then c = c + 1
If cnt = 47 And p2 > 0 And triquad(48, 4) = p2 Then c = c + 1
If cnt = 48 And p2 > 0 And triquad(49, 4) = p2 Then c = c + 1
If cnt = 49 And p2 > 0 And triquad(50, 4) = p2 Then c = c + 1
Next
Next
If c = 160 Then Locate 2, 30: Print " PUZZLE SOLVED "
End Sub
Sub checkboard2
' check to see if game over
Dim p1, p2, p3, p4, c As Integer
c = 0
For cnt = 17 To 32
For cnt2 = 1 To 4
p1 = triquad(cnt, 1): p2 = triquad(cnt, 2): p3 = triquad(cnt, 3): p4 = triquad(cnt, 4)
If cnt = 17 And p2 > 0 And triquad(18, 4) = p2 Then c = c + 1
If cnt = 17 And p3 > 0 And triquad(21, 1) = p3 Then c = c + 1
If cnt = 18 And p2 > 0 And triquad(19, 4) = p2 Then c = c + 1
If cnt = 18 And p3 > 0 And triquad(22, 1) = p3 Then c = c + 1
If cnt = 19 And p2 > 0 And triquad(20, 4) = p2 Then c = c + 1
If cnt = 19 And p3 > 0 And triquad(23, 1) = p3 Then c = c + 1
If cnt = 20 And p3 > 0 And triquad(24, 1) = p3 Then c = c + 1
If cnt = 21 And p2 > 0 And triquad(22, 4) = p2 Then c = c + 1
If cnt = 21 And p3 > 0 And triquad(25, 1) = p3 Then c = c + 1
If cnt = 22 And p2 > 0 And triquad(23, 4) = p2 Then c = c + 1
If cnt = 22 And p3 > 0 And triquad(26, 1) = p3 Then c = c + 1
If cnt = 23 And p2 > 0 And triquad(24, 4) = p2 Then c = c + 1
If cnt = 23 And p3 > 0 And triquad(27, 1) = p3 Then c = c + 1
If cnt = 24 And p3 > 0 And triquad(28, 1) = p3 Then c = c + 1
If cnt = 25 And p2 > 0 And triquad(26, 4) = p2 Then c = c + 1
If cnt = 25 And p3 > 0 And triquad(29, 1) = p3 Then c = c + 1
If cnt = 26 And p2 > 0 And triquad(27, 4) = p2 Then c = c + 1
If cnt = 26 And p3 > 0 And triquad(30, 1) = p3 Then c = c + 1
If cnt = 27 And p2 > 0 And triquad(28, 4) = p2 Then c = c + 1
If cnt = 27 And p3 > 0 And triquad(31, 1) = p3 Then c = c + 1
If cnt = 28 And p3 > 0 And triquad(32, 1) = p3 Then c = c + 1
If cnt = 29 And p2 > 0 And triquad(30, 4) = p2 Then c = c + 1
If cnt = 30 And p2 > 0 And triquad(31, 4) = p2 Then c = c + 1
If cnt = 31 And p2 > 0 And triquad(32, 4) = p2 Then c = c + 1
Next
Next
If c = 96 Then Locate 2, 40: Print " PUZZLE SOLVED "
End Sub
Sub setupdata
Dim z, r1, r2, r3, r4 As Integer
tcode1 = 0
quadx(1) = 50: quadx(2) = 250: quadx(3) = 450: quadx(4) = 50: quadx(5) = 250: quadx(6) = 450: quadx(7) = 50: quadx(8) = 250: quadx(9) = 450
quady(1) = 100: quady(2) = 100: quady(3) = 100: quady(4) = 300: quady(5) = 300: quady(6) = 300: quady(7) = 500: quady(8) = 500: quady(9) = 500
quadx(10) = 700: quadx(11) = 900: quadx(12) = 1100: quadx(13) = 700: quadx(14) = 900: quadx(15) = 1100: quadx(16) = 700: quadx(17) = 900: quadx(18) = 1100
quady(10) = 100: quady(11) = 100: quady(12) = 100: quady(13) = 300: quady(14) = 300: quady(15) = 300: quady(16) = 500: quady(17) = 500: quady(18) = 500
' setup random colors
For z = 1 To 9
If z = 1 Or z = 3 Or z = 5 Or z = 7 Or z = 9 Then
r1 = Int(Rnd * 9) + 1: triquad(z, 1) = r1
r2 = Int(Rnd * 9) + 1: triquad(z, 2) = r2
r3 = Int(Rnd * 9) + 1: triquad(z, 3) = r3
r4 = Int(Rnd * 9) + 1: triquad(z, 4) = r4
End If
Next
If mz = 4 Then
For z = 1 To 9
If z = 1 Or z = 3 Or z = 5 Or z = 7 Or z = 9 Then
r1 = Int(Rnd * 30) + 1
triquad(z, 1) = r1
r2 = Int(Rnd * 30) + 1
triquad(z, 2) = r2
r3 = Int(Rnd * 30) + 1
triquad(z, 3) = r3
r4 = Int(Rnd * 30) + 1
triquad(z, 4) = r4
End If
Next
End If
For z = 10 To 18
triquad(z, 1) = 0
triquad(z, 2) = 0
triquad(z, 3) = 0
triquad(z, 4) = 0
Next
triquad(2, 1) = r1: triquad(2, 2) = triquad(3, 4): triquad(2, 3) = triquad(5, 1): triquad(2, 4) = triquad(1, 2)
triquad(4, 1) = triquad(1, 3): triquad(4, 2) = triquad(5, 4): triquad(4, 3) = triquad(7, 1): triquad(4, 4) = r2
triquad(6, 1) = triquad(3, 3): triquad(6, 2) = r4: triquad(6, 3) = triquad(9, 1): triquad(6, 4) = triquad(5, 2)
triquad(8, 1) = triquad(5, 3): triquad(8, 2) = triquad(9, 4): triquad(8, 3) = r4: triquad(8, 4) = triquad(7, 2)
For z = 1 To 9
r1 = triquad(z, 1)
r2 = triquad(z, 2)
r3 = triquad(z, 3)
r4 = triquad(z, 4)
tcode1 = tcode1 + r1 + r2 * 10 + r3 * 100 + r4 * 1000
Next
End Sub
Sub setupdata3
Dim z, r1, r2, r3, r4 As Integer
' set up locations
quadx(1) = 50: quadx(2) = 150: quadx(3) = 250: quadx(4) = 350: quadx(5) = 450
quadx(6) = 50: quadx(7) = 150: quadx(8) = 250: quadx(9) = 350: quadx(10) = 450
quadx(11) = 50: quadx(12) = 150: quadx(13) = 250: quadx(14) = 350: quadx(15) = 450
quadx(16) = 50: quadx(17) = 150: quadx(18) = 250: quadx(19) = 350: quadx(20) = 450
quadx(21) = 50: quadx(22) = 150: quadx(23) = 250: quadx(24) = 350: quadx(25) = 450
quady(1) = 100: quady(2) = 100: quady(3) = 100: quady(4) = 100: quady(5) = 100
quady(6) = 200: quady(7) = 200: quady(8) = 200: quady(9) = 200: quady(10) = 200
quady(11) = 300: quady(12) = 300: quady(13) = 300: quady(14) = 300: quady(15) = 300
quady(16) = 400: quady(17) = 400: quady(18) = 400: quady(19) = 400: quady(20) = 400
quady(21) = 500: quady(22) = 500: quady(23) = 500: quady(24) = 500: quady(25) = 500
quadx(26) = 650: quadx(27) = 750: quadx(28) = 850: quadx(29) = 950: quadx(30) = 1050
quadx(31) = 650: quadx(32) = 750: quadx(33) = 850: quadx(34) = 950: quadx(35) = 1050
quadx(36) = 650: quadx(37) = 750: quadx(38) = 850: quadx(39) = 950: quadx(40) = 1050
quadx(41) = 650: quadx(42) = 750: quadx(43) = 850: quadx(44) = 950: quadx(45) = 1050
quadx(46) = 650: quadx(47) = 750: quadx(48) = 850: quadx(49) = 950: quadx(50) = 1050
quady(26) = 100: quady(27) = 100: quady(28) = 100: quady(29) = 100: quady(30) = 100
quady(31) = 200: quady(32) = 200: quady(33) = 200: quady(34) = 200: quady(35) = 200
quady(36) = 300: quady(37) = 300: quady(38) = 300: quady(39) = 300: quady(40) = 300
quady(41) = 400: quady(42) = 400: quady(43) = 400: quady(44) = 400: quady(45) = 400
quady(46) = 500: quady(47) = 500: quady(48) = 500: quady(49) = 500: quady(50) = 500
' setup random colors
For z = 1 To 25
r1 = Int(Rnd * 44) + 1
triquad(z, 1) = r1
r2 = Int(Rnd * 44) + 1
triquad(z, 2) = r2
r3 = Int(Rnd * 44) + 1
triquad(z, 3) = r3
r4 = Int(Rnd * 44) + 1
triquad(z, 4) = r4
Next
For z = 26 To 50
triquad(z, 1) = 0
triquad(z, 2) = 0
triquad(z, 3) = 0
triquad(z, 4) = 0
Next
triquad(1, 2) = triquad(2, 4): triquad(2, 2) = triquad(3, 4): triquad(3, 2) = triquad(4, 4): triquad(4, 2) = triquad(5, 4)
triquad(6, 2) = triquad(7, 4): triquad(7, 2) = triquad(8, 4): triquad(8, 2) = triquad(9, 4): triquad(9, 2) = triquad(10, 4)
triquad(11, 2) = triquad(12, 4): triquad(12, 2) = triquad(13, 4): triquad(13, 2) = triquad(14, 4): triquad(14, 2) = triquad(15, 4)
triquad(16, 2) = triquad(17, 4): triquad(17, 2) = triquad(18, 4): triquad(18, 2) = triquad(19, 4): triquad(19, 2) = triquad(20, 4)
triquad(21, 2) = triquad(22, 4): triquad(22, 2) = triquad(23, 4): triquad(23, 2) = triquad(24, 4): triquad(24, 2) = triquad(25, 4)
triquad(1, 3) = triquad(6, 1): triquad(2, 3) = triquad(7, 1): triquad(3, 3) = triquad(8, 1): triquad(4, 3) = triquad(9, 1): triquad(5, 3) = triquad(10, 1)
triquad(6, 3) = triquad(11, 1): triquad(7, 3) = triquad(12, 1): triquad(8, 3) = triquad(13, 1): triquad(9, 3) = triquad(14, 1): triquad(10, 3) = triquad(15, 1)
triquad(11, 3) = triquad(16, 1): triquad(12, 3) = triquad(17, 1): triquad(13, 3) = triquad(18, 1): triquad(14, 3) = triquad(19, 1): triquad(15, 3) = triquad(20, 1)
triquad(16, 3) = triquad(21, 1): triquad(17, 3) = triquad(22, 1): triquad(18, 3) = triquad(23, 1): triquad(19, 3) = triquad(24, 1): triquad(20, 3) = triquad(25, 1)
' makeboard3: Sleep 300
End Sub
Sub setupdata2
' set up locations
Dim z, r1, r2, r3, r4 As Integer
quadx(1) = 50: quadx(2) = 150: quadx(3) = 250: quadx(4) = 350
quadx(5) = 50: quadx(6) = 150: quadx(7) = 250: quadx(8) = 350
quadx(9) = 50: quadx(10) = 150: quadx(11) = 250: quadx(12) = 350
quadx(13) = 50: quadx(14) = 150: quadx(15) = 250: quadx(16) = 350
quady(1) = 200: quady(2) = 200: quady(3) = 200: quady(4) = 200
quady(5) = 300: quady(6) = 300: quady(7) = 300: quady(8) = 300
quady(9) = 400: quady(10) = 400: quady(11) = 400: quady(12) = 400
quady(13) = 500: quady(14) = 500: quady(15) = 500: quady(16) = 500
quadx(17) = 550: quadx(18) = 650: quadx(19) = 750: quadx(20) = 850
quadx(21) = 550: quadx(22) = 650: quadx(23) = 750: quadx(24) = 850
quadx(25) = 550: quadx(26) = 650: quadx(27) = 750: quadx(28) = 850
quadx(29) = 550: quadx(30) = 650: quadx(31) = 750: quadx(32) = 850
quady(17) = 200: quady(18) = 200: quady(19) = 200: quady(20) = 200
quady(21) = 300: quady(22) = 300: quady(23) = 300: quady(24) = 300
quady(25) = 400: quady(26) = 400: quady(27) = 400: quady(28) = 400
quady(29) = 500: quady(30) = 500: quady(31) = 500: quady(32) = 500
' setup random colors
For z = 1 To 16
r1 = Int(Rnd * 23) + 1
triquad(z, 1) = r1
r2 = Int(Rnd * 23) + 1
triquad(z, 2) = r2
r3 = Int(Rnd * 23) + 1
triquad(z, 3) = r3
r4 = Int(Rnd * 23) + 1
triquad(z, 4) = r4
Next
For z = 17 To 32
triquad(z, 1) = 0
triquad(z, 2) = 0
triquad(z, 3) = 0
triquad(z, 4) = 0
Next
triquad(1, 2) = triquad(2, 4): triquad(2, 2) = triquad(3, 4): triquad(3, 2) = triquad(4, 4)
triquad(5, 2) = triquad(6, 4): triquad(6, 2) = triquad(7, 4): triquad(7, 2) = triquad(8, 4)
triquad(9, 2) = triquad(10, 4): triquad(10, 2) = triquad(11, 4): triquad(11, 2) = triquad(12, 4)
triquad(13, 2) = triquad(14, 4): triquad(14, 2) = triquad(15, 4): triquad(15, 2) = triquad(16, 4)
triquad(1, 3) = triquad(5, 1): triquad(5, 3) = triquad(9, 1): triquad(9, 3) = triquad(13, 1)
triquad(2, 3) = triquad(6, 1): triquad(6, 3) = triquad(10, 1): triquad(10, 3) = triquad(14, 1)
triquad(3, 3) = triquad(7, 1): triquad(7, 3) = triquad(11, 1): triquad(11, 3) = triquad(15, 1)
triquad(4, 3) = triquad(8, 1): triquad(8, 3) = triquad(12, 1): triquad(12, 3) = triquad(16, 1)
' printglobals
End Sub
Sub mainloop3
Dim a As Integer
pieceup = 0: btn = 0: row = 0: column = 0: zone = 0
makeboard3
Do
row = 0: column = 0: zone = 0
key$ = InKey$
If key$ <> "" Then Print key$; " "
Do While MouseInput
mx = MouseX
my = MouseY
If my > 100 And my < 190 Then row = 1
If my > 200 And my < 290 Then row = 2
If my > 300 And my < 390 Then row = 3
If my > 400 And my < 490 Then row = 4
If my > 500 And my < 590 Then row = 5
If mx > 50 And mx < 140 Then column = 1
If mx > 150 And mx < 240 Then column = 2
If mx > 250 And mx < 340 Then column = 3
If mx > 350 And mx < 440 Then column = 4
If mx > 450 And mx < 540 Then column = 5
If mx > 650 And mx < 740 Then column = 6
If mx > 750 And mx < 840 Then column = 7
If mx > 850 And mx < 940 Then column = 8
If mx > 950 And mx < 1040 Then column = 9
If mx > 1050 And mx < 1140 Then column = 10
If column = 0 Then row = 0
If row = 0 Then column = 0
getzone3
btn = MouseButton(1)
Loop
If btn = -1 Then
mousereleased = 1
Else
mousereleased = 0
End If
If test = 1 Then printsolution3
If mousereleased = 1 And pieceup = 0 And zone > 0 And triquad(zone, 1) > 0 Then
c1a = triquad(zone, 1): c2a = triquad(zone, 2): c3a = triquad(zone, 3): c4a = triquad(zone, 4)
pickup2
pieceup = 1
zone = 0
Else
If mousereleased = 1 And zone > 0 And pieceup = 1 Then
a = triquad(zone, 1)
If a = 0 Then
putdown3
pieceup = 0
Else
snd 4
c1 = c1a: c2 = c2a: c3 = c3a: c4 = c4a
pieceup = 1
End If
makeboard3
checkboard3
End If
End If
makeboard3
Loop Until key$ = Chr$(27)
End Sub
Sub mainloop2
Dim a As Integer
pieceup = 0: btn = 0: row = 0: column = 0: zone = 0
makeboard2
Do
row = 0: column = 0: zone = 0
key$ = InKey$
If key$ <> "" Then Print key$; " "
Do While MouseInput
mx = MouseX
my = MouseY
If my > 200 And my < 295 Then row = 1
If my > 295 And my < 395 Then row = 2
If my > 395 And my < 495 Then row = 3
If my > 495 And my < 595 Then row = 4
If mx > 50 And mx < 145 Then column = 1
If mx > 145 And mx < 245 Then column = 2
If mx > 245 And mx < 345 Then column = 3
If mx > 345 And mx < 445 Then column = 4
If mx > 545 And mx < 645 Then column = 5
If mx > 645 And mx < 745 Then column = 6
If mx > 745 And mx < 845 Then column = 7
If mx > 845 And mx < 945 Then column = 8
If column = 0 Then row = 0
If row = 0 Then column = 0
getzone2
btn = MouseButton(1)
Loop
If btn = -1 Then
mousereleased = 1
Else
mousereleased = 0
End If
If test = 1 Then printsolution2
If mousereleased = 1 And pieceup = 0 And zone > 0 And triquad(zone, 1) > 0 Then
c1a = triquad(zone, 1): c2a = triquad(zone, 2): c3a = triquad(zone, 3): c4a = triquad(zone, 4)
pickup2
pieceup = 1
' printglobals
zone = 0
Else
If mousereleased = 1 And zone > 0 And pieceup = 1 Then
a = triquad(zone, 1)
If a = 0 Then
putdown2
pieceup = 0
Else
snd 4
c1 = c1a: c2 = c2a: c3 = c3a: c4 = c4a
pieceup = 1
' printglobals
End If
makeboard2
checkboard2
End If
End If
makeboard2
Loop Until key$ = Chr$(27)
End Sub
Sub mainloop
Dim a As Integer
pieceup = 0: btn = 0: row = 0: column = 0: zone = 0
makeboard
Do
row = 0: column = 0: zone = 0
key$ = InKey$
If key$ <> "" Then Print key$; " "
Do While MouseInput
mx = MouseX
my = MouseY
If my > 100 And my < 280 Then row = 1
If my > 300 And my < 480 Then row = 2
If my > 500 And my < 680 Then row = 3
If mx > 50 And mx < 230 Then column = 1
If mx > 250 And mx < 430 Then column = 2
If mx > 450 And mx < 630 Then column = 3
If mx > 700 And mx < 880 Then column = 4
If mx > 900 And mx < 1080 Then column = 5
If mx > 1100 And mx < 1280 Then column = 6
If column = 0 Then row = 0
If row = 0 Then column = 0
getzone
btn = MouseButton(1)
Loop
If btn = -1 Then
mousereleased = 1
Else
mousereleased = 0
End If
If mousereleased = 1 And pieceup = 0 And zone > 0 And triquad(zone, 1) > 0 Then
c1a = triquad(zone, 1): c2a = triquad(zone, 2): c3a = triquad(zone, 3): c4a = triquad(zone, 4)
pickup
pieceup = 1
' printglobals
zone = 0
Else
If mousereleased = 1 And zone > 0 And pieceup = 1 Then
a = triquad(zone, 1)
If a = 0 Then
putdown
pieceup = 0
Else
snd 4
c1 = c1a: c2 = c2a: c3 = c3a: c4 = c4a
pieceup = 1
' printglobals
End If
checkboard
makeboard
End If
End If
makeboard
If test = 1 Then printsolution1
Loop Until key$ = Chr$(27)
End Sub
Sub pickup ()
Dim z, x, y As Integer
z = zone: x = quadx(z): y = quady(z)
c1 = triquad(z, 1): c2 = triquad(z, 2): c3 = triquad(z, 3): c4 = triquad(z, 4)
triquad(z, 1) = 0: triquad(z, 2) = 0: triquad(z, 3) = 0: triquad(z, 4) = 0
snd 1: snd 2
End Sub
Sub putdown ()
Dim z, x, y As Integer
z = zone: x = quadx(z): y = quady(z)
triquad(z, 1) = c1: triquad(z, 2) = c2: triquad(z, 3) = c3: triquad(z, 4) = c4
c1 = 0: c2 = 0: c3 = 0: c4 = 0
snd 2: snd 1: snd 1
End Sub
Sub pickup2 ()
Dim z, x, y As Integer
z = zone: x = quadx(z): y = quady(z)
c1 = triquad(z, 1): c2 = triquad(z, 2): c3 = triquad(z, 3): c4 = triquad(z, 4)
box1$ = " r90 d90 l90 u90 "
bx1$ = " r90 d90 h90 d90 e90 "
box x, y, 90, 0
PSet (x, y), 12
Draw box1$
Draw bx1$
triquad(z, 1) = 0: triquad(z, 2) = 0: triquad(z, 3) = 0: triquad(z, 4) = 0
snd 1: snd 2
End Sub
Sub putdown2 ()
Dim z, x, y As Integer
z = zone: x = quadx(z): y = quady(z)
triquad(z, 1) = c1: triquad(z, 2) = c2: triquad(z, 3) = c3: triquad(z, 4) = c4
makeboard2
c1 = 0: c2 = 0: c3 = 0: c4 = 0
snd 2: snd 1: snd 1
End Sub
Sub putdown3 ()
Dim z, x, y As Integer
z = zone: x = quadx(z): y = quady(z)
triquad(z, 1) = c1: triquad(z, 2) = c2: triquad(z, 3) = c3: triquad(z, 4) = c4
makeboard3
c1 = 0: c2 = 0: c3 = 0: c4 = 0
snd 2: snd 1: snd 1
Locate 5, 20: Print z
End Sub
Sub printsolution1
a = 10
For z = 1 To 9
Locate 2, a: Print startquad(z, 1)
Locate 3, a: Print startquad(z, 2)
Locate 4, a: Print startquad(z, 3)
Locate 5, a: Print startquad(z, 4)
a = a + 4
Next
End Sub
Sub printsolution2
a = 10
For z = 1 To 16
Locate 2, a: Print startquad(z, 1)
Locate 3, a: Print startquad(z, 2)
Locate 4, a: Print startquad(z, 3)
Locate 5, a: Print startquad(z, 4)
a = a + 4
Next
End Sub
Sub printsolution3
a = 10
For z = 1 To 25
Locate 2, a: Print startquad(z, 1)
Locate 3, a: Print startquad(z, 2)
Locate 4, a: Print startquad(z, 3)
Locate 5, a: Print startquad(z, 4)
a = a + 4
Next
End Sub
Sub printglobals ()
Locate 2, 2: Print mx
Locate 3, 2: Print my
Locate 4, 10: Print " Row"
Locate 4, 15: Print row
Locate 4, 20: Print " Column"
Locate 4, 30: Print column
Locate 4, 40: Print " Zone"
Locate 4, 50: Print zone
Locate 4, 60: Print " Btn"
Locate 4, 70: Print btn
Locate 4, 80
If pieceup = 1 Then Print " Pieceup "
If pieceup = 0 Then Print " Piecedown"
Locate 4, 100: Print " Mousereleased "
Locate 4, 120: Print mousereleased
Locate 2, 10: Print c1
Locate 2, 14: Print c2
Locate 2, 18: Print c3
Locate 2, 22: Print c4
Locate 2, 120: Print tcode1
Locate 3, 120: Print tcode2
Locate 4, 120: Print tcode3
' JESUS IS COMMING ... PASS IT ON
End Sub
Sub box (x, y, size, clr)
' x and y are upper left side of box
Line (x, y)-(x + size, y + size), clr, BF , 2 ' Solid box
End Sub
Sub box2 (x, y, size, clr)
' x and y are upper left side of box
Line (x, y)-(x + size, y + size), clr, B ' plain box
End Sub
Sub getzone
Dim z, r, c As Integer
c = column
r = row
z = 0
If r = 1 Then
If c = 1 Then z = 1
If c = 2 Then z = 2
If c = 3 Then z = 3
If c = 4 Then z = 10
If c = 5 Then z = 11
If c = 6 Then z = 12
End If
If r = 2 Then
If c = 1 Then z = 4
If c = 2 Then z = 5
If c = 3 Then z = 6
If c = 4 Then z = 13
If c = 5 Then z = 14
If c = 6 Then z = 15
End If
If r = 3 Then
If c = 1 Then z = 7
If c = 2 Then z = 8
If c = 3 Then z = 9
If c = 4 Then z = 16
If c = 5 Then z = 17
If c = 6 Then z = 18
End If
zone = z
End Sub
Sub getzone3
Dim z, r, c As Integer
c = column
r = row
z = 0
If r = 1 Then
If c = 1 Then z = 1
If c = 2 Then z = 2
If c = 3 Then z = 3
If c = 4 Then z = 4
If c = 5 Then z = 5
If c = 6 Then z = 26
If c = 7 Then z = 27
If c = 8 Then z = 28
If c = 9 Then z = 29
If c = 10 Then z = 30
End If
If r = 2 Then
If c = 1 Then z = 6
If c = 2 Then z = 7
If c = 3 Then z = 8
If c = 4 Then z = 9
If c = 5 Then z = 10
If c = 6 Then z = 31
If c = 7 Then z = 32
If c = 8 Then z = 33
If c = 9 Then z = 34
If c = 10 Then z = 35
End If
If r = 3 Then
If c = 1 Then z = 11
If c = 2 Then z = 12
If c = 3 Then z = 13
If c = 4 Then z = 14
If c = 5 Then z = 15
If c = 6 Then z = 36
If c = 7 Then z = 37
If c = 8 Then z = 38
If c = 9 Then z = 39
If c = 10 Then z = 40
End If
If r = 4 Then
If c = 1 Then z = 16
If c = 2 Then z = 17
If c = 3 Then z = 18
If c = 4 Then z = 19
If c = 5 Then z = 20
If c = 6 Then z = 41
If c = 7 Then z = 42
If c = 8 Then z = 43
If c = 9 Then z = 44
If c = 10 Then z = 45
End If
If r = 5 Then
If c = 1 Then z = 21
If c = 2 Then z = 22
If c = 3 Then z = 23
If c = 4 Then z = 24
If c = 5 Then z = 25
If c = 6 Then z = 46
If c = 7 Then z = 47
If c = 8 Then z = 48
If c = 9 Then z = 49
If c = 10 Then z = 50
End If
zone = z
End Sub
Sub getzone2
Dim z, r, c As Integer
c = column
r = row
z = 0
If r = 1 Then
If c = 1 Then z = 1
If c = 2 Then z = 2
If c = 3 Then z = 3
If c = 4 Then z = 4
If c = 5 Then z = 17
If c = 6 Then z = 18
If c = 7 Then z = 19
If c = 8 Then z = 20
End If
If r = 2 Then
If c = 1 Then z = 5
If c = 2 Then z = 6
If c = 3 Then z = 7
If c = 4 Then z = 8
If c = 5 Then z = 21
If c = 6 Then z = 22
If c = 7 Then z = 23
If c = 8 Then z = 24
End If
If r = 3 Then
If c = 1 Then z = 9
If c = 2 Then z = 10
If c = 3 Then z = 11
If c = 4 Then z = 12
If c = 5 Then z = 25
If c = 6 Then z = 26
If c = 7 Then z = 27
If c = 8 Then z = 28
End If
If r = 4 Then
If c = 1 Then z = 13
If c = 2 Then z = 14
If c = 3 Then z = 15
If c = 4 Then z = 16
If c = 5 Then z = 29
If c = 6 Then z = 30
If c = 7 Then z = 31
If c = 8 Then z = 32
End If
zone = z
End Sub
Sub makeboard3
Dim clr1, clr2, clr3, clr4, sx, sy, z As Integer
z = 1
For q = 1 To 50
sx = quadx(z): sy = quady(z)
clr1 = triquad(z, 1)
clr2 = triquad(z, 2)
clr3 = triquad(z, 3)
clr4 = triquad(z, 4)
box1$ = " r90 d90 l90 u90 "
bx1$ = " r90 d90 h90 d90 e90 "
PSet (sx, sy), 45
Draw box1$
Draw bx1$
Paint (sx + 40, sy + 20), clr1, 45
Paint (sx + 70, sy + 40), clr2, 45
Paint (sx + 40, sy + 60), clr3, 45
Paint (sx + 20, sy + 40), clr4, 45
z = z + 1
Next
End Sub
Sub makeboard2
' box 2, 2, 1360, 11
Dim clr1, clr2, clr3, clr4, sx, sy, z As Integer
For z = 1 To 32
sx = quadx(z): sy = quady(z)
clr1 = triquad(z, 1)
clr2 = triquad(z, 2)
clr3 = triquad(z, 3)
clr4 = triquad(z, 4)
box1$ = " r90 d90 l90 u90 "
bx1$ = " r90 d90 h90 d90 e90 "
PSet (sx, sy), 45
Draw box1$
Draw bx1$
Paint (sx + 40, sy + 20), clr1, 45
Paint (sx + 70, sy + 40), clr2, 45
Paint (sx + 40, sy + 60), clr3, 45
Paint (sx + 20, sy + 40), clr4, 45
Next
End Sub
Sub makeboard
Dim clr1, clr2, clr3, clr4, sx, sy, z As Integer
For z = 1 To 18
sx = quadx(z): sy = quady(z)
clr1 = triquad(z, 1)
clr2 = triquad(z, 2)
clr3 = triquad(z, 3)
clr4 = triquad(z, 4)
box1$ = " r180 d180 l180 u180 "
bx1$ = " r180 d180 h180 d180 e180 "
PSet (sx, sy), 45
Draw box1$
Draw bx1$
Paint (sx + 90, sy + 40), clr1, 45
Paint (sx + 120, sy + 90), clr2, 45
Paint (sx + 90, sy + 120), clr3, 45
Paint (sx + 40, sy + 90), clr4, 45
Next
End Sub
Sub setupcolors ()
PaletteColor 0, RGB32(0, 0, 0) ' black
PaletteColor 1, RGB32(255, 255, 255) ' white
PaletteColor 2, RGB32(0, 255, 0) ' green
PaletteColor 3, RGB32(0, 0, 90) ' dark blue
PaletteColor 4, RGB32(50, 80, 0) ' yellow green
PaletteColor 5, RGB32(255, 255, 0) ' yellow
PaletteColor 6, RGB32(0, 255, 255) ' blue green
PaletteColor 7, RGB32(255, 0, 255) ' violet
PaletteColor 8, RGB32(0, 150, 250) ' greenish blue
PaletteColor 9, RGB32(0, 230, 80) ' bluish green
PaletteColor 10, RGB32(200, 200, 255) ' bluish white
PaletteColor 11, RGB32(0, 0, 70) 'very dark blue
PaletteColor 12, RGB32(255, 0, 0) ' red
PaletteColor 13, RGB32(0, 0, 255) ' blue
PaletteColor 14, RGB32(0, 0, 220) ' blue2
PaletteColor 15, RGB32(0, 0, 200) ' blue3
PaletteColor 16, RGB32(180, 0, 0) ' red2
PaletteColor 17, RGB32(90, 0, 0) ' red3
PaletteColor 18, RGB32(0, 180, 0) ' green2
PaletteColor 19, RGB32(0, 90, 0) ' green3
PaletteColor 20, RGB32(180, 0, 180) ' violet2
PaletteColor 21, RGB32(90, 0, 90) ' violet3
PaletteColor 22, RGB32(0, 70, 70) ' bluegreen2
PaletteColor 23, RGB32(0, 120, 120) ' bluegreen3
PaletteColor 24, RGB32(0, 0, 170) ' blue4
PaletteColor 25, RGB32(0, 0, 140) ' blue5
PaletteColor 26, RGB32(0, 0, 120) ' blue6
PaletteColor 27, RGB32(220, 0, 0) ' red4
PaletteColor 28, RGB32(140, 0, 0) ' red5
PaletteColor 29, RGB32(0, 220, 0) ' green4
PaletteColor 30, RGB32(0, 140, 0) ' green5
PaletteColor 31, RGB32(220, 0, 220) ' violet4
PaletteColor 32, RGB32(140, 0, 140) ' violet5
PaletteColor 33, RGB32(0, 180, 180) ' bluegreen4
PaletteColor 34, RGB32(0, 220, 220) ' bluegreen5
PaletteColor 35, RGB32(150, 150, 150) ' gray
PaletteColor 36, RGB32(90, 90, 90) ' dark gray
PaletteColor 37, RGB32(100, 100, 220) ' bluishbrown
PaletteColor 38, RGB32(200, 100, 100) ' redish brown
PaletteColor 39, RGB32(100, 200, 100) ' greenish brown
PaletteColor 40, RGB32(200, 100, 200) ' violet brown
PaletteColor 41, RGB32(0, 50, 0) ' green6
PaletteColor 42, RGB32(40, 0, 40) ' violet6
PaletteColor 43, RGB32(40, 0, 40) ' bluegreen6
PaletteColor 44, RGB32(180, 180, 100) ' yellow brown
PaletteColor 45, RGB32(200, 200, 255) 'off white
End Sub
Sub snd (sd)
' tempo "T80" length of note "L8"
'If sd = 1 Then Play "L8": Play "T40": Play "c"
If sd = 1 Then
Sound 160, 1
Sound 80, 1
End If
If sd = 2 Then
Sound 180, 1
Sound 90, 1
End If
If sd = 3 Then
Sound 200, 1
Sound 100, 1
End If
If sd = 20 Then
For x = 1 To 5
Sound 1000, 1
Sound 1000 - 100 * x, 1
Next
End If
End Sub
|
|
|
|
| Kaleidoscope |
|
Posted by: SierraKen - 05-18-2022, 07:58 PM - Forum: Programs
- Replies (8)
|
|
Possibly the simplest kaleidoscope we have all seen, but I think it came out pretty neat. I was experimenting with circles and came across this. The longer you watch it, the cooler it looks in my opinion. What do you all think? 24 lines of code. lol
Code: (Select All) 'Kaleidoscope by SierraKen
'May 18, 2022
Screen _NewImage(800, 800, 32)
_Title "Kaleidoscope by SierraKen"
Randomize Timer
cc = 1
Do
_Limit 25
If c <> 0 Then cc = c
c = Rnd * 360
If c < cc Then
s = -.25
Else
s = .25
End If
cl1 = Int(Rnd * 200) + 1
cl2 = Int(Rnd * 200) + 1
cl3 = Int(Rnd * 200) + 1
For t = cc To c Step s
x = (Sin(t) * t) + 400
y = (Cos(t) * t) + 400
Circle (x, y), 2, _RGB32(cl1, cl2, cl3)
Next t
Loop Until InKey$ = Chr$(27)
|
|
|
|
| Time - Not a Library |
|
Posted by: TarotRedhand - 05-18-2022, 03:31 PM - Forum: Utilities
- Replies (1)
|
 |
If it wasn't for the fact that of the 26 routines contained in this only 2 of them are public, this would have gone in the libraries section. This is a reworking of something I made years ago. Originally it made use of DOS calls in order to get the information that it uses. Fortunately, after considering what is available in QB64 I was able to get this information via a different method. In the end I only had to change 2 SUBs but there was a single piece of information that I got from the DOS calls that wasn't easily available in QB64. In the end it meant an additional function using an algorithm I found online. So what is it?
What I am posting this time is just a pair of public functions and all that one of the pair does is to get the current date and time from the system. The second function is I hope worthy of your attention. What it does is similar to one of the functions that comes as standard with ANSI C - I've just extended it a little. Basically, what this second function does is to take a string that contains codes embedded in it and it uses this string to produce a second string with dates/times expanded at the point where the codes were in the template string. With this routine you can have the dates/times in whatever format you wish (this includes the year being in Roman numerals. It is at this point that I realise that actions definitely speak louder than words and so suggest you look at the comments contained in the original TIME.BI for an explanation of what these routines do and to run TIMETEST.BAS.
For additional information, read the comments in the original BI file (but don't use it, it won't work!)
TIMid.BI (obsolete)
Code: (Select All) REM ******************************************************
REM * Filespec : time.bas time.bi testtime.bas *
REM * Date : August 8 1997 *
REM * Time : 19:01 *
REM * Revision : 1.00B *
REM * Update : *
REM ******************************************************
REM * Released to the Public Domain *
REM ******************************************************
CONST FALSE% = 0, TRUE% = -1
TYPE When
Second AS INTEGER '| 0..59
Minute AS INTEGER '| 0..59
Hour AS INTEGER '| 0..23
WeekDay AS INTEGER '| 1..7
MonthDay AS INTEGER '| 1..[28 or 29 or 30 or 31]
YearDay AS INTEGER '| 1..[365 or 366]
YearWeek AS INTEGER '| 1..52
Month AS INTEGER '| 1..12
Year AS INTEGER
IsLeapYear AS INTEGER '| TRUE% or FALSE%
END TYPE
REM ******************************************************************
REM * The following 2 routines rely upon the accuracy of the PC's *
REM * internal clock and calendar. i.e. if your PC's clock or *
REM * calendar are inaccurate then the output from these routines *
REM * will be inaccurate to the same degree. *
REM ******************************************************************
DECLARE SUB ThisInstant(Now AS When)
REM ******************************************************************
REM * This routine produces a snapshot of the time and date at the *
REM * instant that it is called and fills the variable Now with the *
REM * information obtained. It uses DOS routines to gather the *
REM * information and so works from 1/1/80 to 31st December 2099. *
REM ******************************************************************
DECLARE SUB FTString(FormatString$, OutputString$, Now AS When)
REM ******************************************************************
REM * This routine produces a string (OutputString$) with time and *
REM * date information embedded within it, as specified by the *
REM * information encoded within FormatString$. The variable Now *
REM * may be used to specify a specific time and date or Now may be *
REM * updated as part of this routine so that the current time and *
REM * date are used instead. *
REM * *
REM * If FormatString$ contains no temporal codes it will simply be *
REM * copied to OutputString$. If during processing of *
REM * FormatString$ an invalid code is encountered, processing will *
REM * cease and an immediate return to SYSTEM occurs with an *
REM * appropriate error message displayed. *
REM * *
REM * There are 29 different temporal codes in all, each of which *
REM * starts with the tilde (CHR$(126), '~') character. The action *
REM * of this routine is to copy everything contained in *
REM * FormatString, except the codes, to OutputString. When a code *
REM * is encountered, it is replaced in OutputString by the *
REM * sub-string that corresponds to that code. In the following *
REM * explanation of the codes and their meanings I have, for *
REM * reasons of brevity, used the word output to signify the *
REM * replacement of a particular code by the sub-string that is *
REM * described immediately following the usage of the word output. *
REM * The codes and their meanings follow hereafter. *
REM * *
REM *----------------------------------------------------------------*
REM * *
REM * ~1 - Set all time output after this to be in 12 hour *
REM * format. *
REM * *
REM * ~2 - Set all time output after this to be in 24 hour *
REM * format. *
REM * *
REM * ~A - Output either am or pm depending on the time. *
REM * *
REM * ~B - Output the month in abbreviated form *
REM * (Jan, Feb etc.). *
REM * *
REM * ~C - Output the full month name *
REM * (January, February etc.). *
REM * *
REM * ~D - Output full date as January 1 1996 etc. *
REM * *
REM * ~E - Output numeric date in dd/mm/yy form. *
REM * *
REM * ~F - Output full date as 1 January 1996 etc. *
REM * *
REM * ~G - Output numeric date in mm/dd/yy form. *
REM * *
REM * ~H - Output the Hour. *
REM * *
REM * ~I - Output the day of the week in abbreviated form. *
REM * (Mon, Tue etc.) *
REM * *
REM * ~J - Output the full name of the day of the week. *
REM * (Monday, Tuesday etc.) *
REM * *
REM * ~K - Output the time in short form HH:MM. *
REM * *
REM * ~L - Output the time in long form HH:MM:SS. *
REM * *
REM * ~M - Output the Minute. *
REM * *
REM * ~N - Output the Numeric day of week (1 = Sunday). *
REM * *
REM * ~O - Output the Numeric day of the month (1, 2, 3 etc.).*
REM * *
REM * ~P - Output the Numeric Month (1 = January). *
REM * *
REM * ~Q - Output the Numeric day of the month with the *
REM * appropriate suffix (1st, 2nd, 3rd, 4th etc.). *
REM * *
REM * ~R - Output the year in ROMAN numerals - MCMXCVI. *
REM * *
REM * ~S - Output the Second. *
REM * *
REM * ~T - Output the total date in the form - *
REM * Sunday 18th February 1996. *
REM * *
REM * ~U - Update (or get new) the information in the *
REM * variable 'Now'. *
REM * *
REM * ~V - Output the date in the form - 18th Feb 96. *
REM * *
REM * ~W - Output the week of the year - 1 to 52. *
REM * *
REM * ~X - Output the day of the year - *
REM * 1 to 365 or 366 in leap year. *
REM * *
REM * ~Y - Output the year in the form 1996. *
REM * *
REM * ~Z - Output the year in the form 96. *
REM * *
REM * ~r - Output the total date in the form - *
REM * Sun 18th Feb 96. *
REM * *
REM * ~~ - Output the character ~ (CHR$(126), '~'). *
REM * *
REM *----------------------------------------------------------------*
REM * *
REM * An example of the usage of this routine is as follows:- *
REM * *
REM * FT$ = "~U~1Today, ~T, at precisely ~L~A, I resigned." *
REM * FTString FT$, Out$, Now *
REM * *
REM * Which should result in Out$ containing the following (assuming *
REM * the dates and times contained) :- *
REM * *
REM * Today, Sunday 18th February 1996, at precisely 12:40pm, I *
REM * resigned. *
REM ******************************************************************
Here is the actual working BI file -
TIME.BI
Code: (Select All) REM ******************************************************
REM * Filespec : time.bas time.bi testtime.bas *
REM * Date : August 8 1997 *
REM * Time : 19:01 *
REM * Revision : 1.00B *
REM * Update : *
REM ******************************************************
REM * Released to the Public Domain *
REM ******************************************************
CONST FALSE% = 0, TRUE% = -1
COMMON SHARED Hours24%
Hours24% = FALSE%
TYPE When
Second AS INTEGER '| 0..59
Minute AS INTEGER '| 0..59
Hour AS INTEGER '| 0..23
WeekDay AS INTEGER '| 1..7
MonthDay AS INTEGER '| 1..[28 or 29 or 30 or 31]
YearDay AS INTEGER '| 1..[365 or 366]
YearWeek AS INTEGER '| 1..52
Month AS INTEGER '| 1..12
Year AS INTEGER
IsLeapYear AS INTEGER '| TRUE% or FALSE%
END TYPE
Now the BM file
TIME.BM
Code: (Select All) REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
FUNCTION DayOfWeek(Year$, Month%, Day%)
DIM Year%, Code%
Year% = VAL(Year$)
Code% = VAL(RIGHT$(YEAR$, 2))
Code% = (Code% + (Code% \ 4)) Mod 7
Code% = Code% + VAL(MID$("033614625035", Month%, 1))
IF (YEAR% >= 2000) THEN
Code% = Code% + 6
END IF
IF (((Year% MOD 400) = 0) AND (Month% > 2))THEN
Code% = Code% + 1
ELSEIF (((Year% MOD 4) = 0) AND ((Year% MOD 100) <> 0) AND (Month% > 2)) THEN
Code% = Code% + 1
END IF
Code% = Code% + Day%
DayOfWeek = 1 + (Code% MOD 7)
END FUNCTION
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetDate(Year%, Month%, Day%, WeekDay%)
DIM TempDate$
TempDate$ = DATE$
Year% = VAL(RIGHT$(TempDate$, 4))
Month% = VAL(LEFT$(TempDate$, 2))
Day% = VAL(MID$(TempDate$, 4, 2))
WeekDay% = DayOfWeek(LTRIM$(STR$(Year%)), Month%, Day%)
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetTime(Hours%, Minutes%, Seconds%)
DIM AllSeconds AS LONG
AllSeconds = TIMER
Hours% = AllSeconds \ 3600
AllSeconds = AllSeconds MOD 3600
Minutes% = AllSeconds \ 60
Seconds% = AllSeconds MOD 60
END SUB
REM ******************************************************************
REM * This routine produces a snapshot of the time and date at the *
REM * instant that it is called and fills the variable Now with the *
REM * information obtained. It uses DOS routines to gather the *
REM * information and so works from 1/1/80 to 31st December 2099. *
REM ******************************************************************
SUB ThisInstant(Now AS When)
GetDate Now.Year, Now.Month, Now.MonthDay, Now.WeekDay
Now.IsLeapYear = FALSE%
IF (Now.Year MOD 400) = 0 THEN
Now.IsLeapYear = TRUE%
ELSEIF ((Now.Year MOD 4) = 0) AND ((Now.Year MOD 100) <> 0) THEN
Now.IsLeapYear = TRUE%
END IF
DayOfYear Now.Month, Now.MonthDay, Now.IsLeapYear, Now.YearDay
WeekOfYear Now.YearDay, Now.YearWeek
GetTime Now.Hour, Now.Minute, Now.Second
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB DayOfYear(Month%, Day%, LeapYear%, YearDay%)
YearDay% = Day%
IF Month% > 1 THEN
SELECT CASE (Month% - 1)
CASE 1
YearDay% = YearDay% + 31
CASE 2
YearDay% = YearDay% + 59
CASE 3
YearDay% = YearDay% + 90
CASE 4
YearDay% = YearDay% + 120
CASE 5
YearDay% = YearDay% + 151
CASE 6
YearDay% = YearDay% + 181
CASE 7
YearDay% = YearDay% + 212
CASE 8
YearDay% = YearDay% + 243
CASE 9
YearDay% = YearDay% + 273
CASE 10
YearDay% = YearDay% + 304
CASE 11
YearDay% = YearDay% + 334
END SELECT
IF ((Month% > 2) AND LeapYear%) THEN
YearDay% = YearDay% + 1
END IF
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB WeekOfYear(YearDay%, Week%)
Week% = YearDay% \ 7
IF ((YearDay% MOD 7) <> 0) THEN
Week% = Week% + 1
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB StringWeekDay(DayCode%, DayString$)
SELECT CASE DayCode%
CASE 1
DayString$ = "Sunday"
CASE 2
DayString$ = "Monday"
CASE 3
DayString$ = "Tuesday"
CASE 4
DayString$ = "Wednesday"
CASE 5
DayString$ = "Thursday"
CASE 6
DayString$ = "Friday"
CASE 7
DayString$ = "Saturday"
END SELECT
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB StringShortDay(DayCode%, DayString$)
SELECT CASE DayCode%
CASE 1
DayString$ = "Sun"
CASE 2
DayString$ = "Mon"
CASE 3
DayString$ = "Tue"
CASE 4
DayString$ = "Wed"
CASE 5
DayString$ = "Thu"
CASE 6
DayString$ = "Fri"
CASE 7
DayString$ = "Sat"
END SELECT
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB StringMonth(MonthCode%, MonthString$)
SELECT CASE MonthCode%
CASE 1
MonthString$ = "January"
CASE 2
MonthString$ = "February"
CASE 3
MonthString$ = "March"
CASE 4
MonthString$ = "April"
CASE 5
MonthString$ = "May"
CASE 6
MonthString$ = "June"
CASE 7
MonthString$ = "July"
CASE 8
MonthString$ = "August"
CASE 9
MonthString$ = "September"
CASE 10
MonthString$ = "October"
CASE 11
MonthString$ = "November"
CASE 12
MonthString$ = "December"
END SELECT
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB StringShortMonth(MonthCode%, MonthString$)
SELECT CASE MonthCode%
CASE 1
MonthString$ = "Jan"
CASE 2
MonthString$ = "Feb"
CASE 3
MonthString$ = "Mar"
CASE 4
MonthString$ = "Apr"
CASE 5
MonthString$ = "May"
CASE 6
MonthString$ = "Jun"
CASE 7
MonthString$ = "Jul"
CASE 8
MonthString$ = "Aug"
CASE 9
MonthString$ = "Sep"
CASE 10
MonthString$ = "Oct"
CASE 11
MonthString$ = "Nov"
CASE 12
MonthString$ = "Dec"
END SELECT
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetHour(Hour%, TempString$)
TempString$ = ""
IF NOT Hours24% THEN
IF Hour% = 0 THEN
TempString$ = "12"
ELSE
IF Hour% > 12 THEN
Hour% = Hour% - 12
END IF
END IF
END IF
IF TempString$ = "" THEN
TempString$ = LTRIM$(RTRIM$(STR$(Hour%)))
DO WHILE LEN(TempString$) < 2
TempString$ = "0" + TempString$
LOOP
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB ShortYear(Year%, TempString$)
TempYear% = (Year% MOD 100)
TempString$ = LTRIM$(RTRIM$(STR$(TempYear%)))
DO WHILE LEN(TempString$) < 2
TempString$ = "0" + TempString$
LOOP
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetSuffix(MonthDay%, TempString$)
IF ((MonthDay% > 3) AND (MonthDay% < 21))THEN
TempString$ = "th"
ELSE
TempMonthDay% = MonthDay% MOD 10
SELECT CASE TempMonthDay%
CASE 0
TempString$ = "th"
CASE 1
TempString$ = "st"
CASE 2
TempString$ = "nd"
CASE 3
TempString$ = "rd"
CASE ELSE
TempString$ = "th"
END SELECT
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetTwoDigits(Number%, TempString$)
TempString$ = LTRIM$(RTRIM$(STR$(Number% MOD 100)))
DO WHILE LEN(TempString$) < 2
TempString$ = "0" + TempString$
LOOP
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetShortTime(Now AS When, TempString$)
GetHour Now.Hour, TempString$
GetTwoDigits Now.Minute, Minute$
TempString$ = TempString$ + ":" + Minute$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetLongTime(Now AS When, TempString$)
GetShortTime Now, TempString$
GetTwoDigits Now.Second, Second$
TempString$ = TempString$ + ":" + Second$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetNumericDateUK(Now AS When, TempString$)
GetTwoDigits Now.MonthDay, MonthDay$
GetTwoDigits Now.Month, Month$
ShortYear Now.Year, Year$
TempString$ = MonthDay$ + "/" + Month$ + "/" + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetNumericDateUSA(Now AS When, TempString$)
GetTwoDigits Now.MonthDay, MonthDay$
GetTwoDigits Now.Month, Month$
ShortYear Now.Year, Year$
TempString$ = Month$ + "/" + MonthDay$ + "/" + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetFullDateUK(Now AS When, TempString$)
MonthDay$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
StringMonth Now.Month, Month$
Year$ = LTRIM$(RTRIM$(STR$(Now.Year MOD 10000)))
TempString$ = MonthDay$ + " " + Month$ + " " + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetFullDateUSA(Now AS When, TempString$)
MonthDay$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
StringMonth Now.Month, Month$
Year$ = LTRIM$(RTRIM$(STR$(Now.Year MOD 10000)))
TempString$ = Month$ + " " + MonthDay$ + " " + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetTotalDateUK(Now AS When, TempString$)
StringWeekDay Now.WeekDay, WeekDay$
MonthDay$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
GetSuffix Now.MonthDay, Suffix$
StringMonth Now.Month, Month$
Year$ = LTRIM$(RTRIM$(STR$(Now.Year MOD 10000)))
TempString$ = WeekDay$ + " " + MonthDay$ + Suffix$ + " " + Month$ + " " + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetShortDateUK(Now AS When, TempString$)
MonthDay$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
GetSuffix Now.MonthDay, Suffix$
StringShortMonth Now.Month, Month$
ShortYear Now.Year, Year$
TempString$ = MonthDay$ + Suffix$ + " " + Month$ + " '" + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetTotalShortDateUK(Now AS When, TempString$)
StringShortDay Now.WeekDay, WeekDay$
MonthDay$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
GetSuffix Now.MonthDay, Suffix$
StringShortMonth Now.Month, Month$
ShortYear Now.Year, Year$
TempString$ = WeekDay$ + " " + MonthDay$ + Suffix$ + " " + Month$ + " '" + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetRomanYear(TheYear%, TempString$)
IF TheYear% <> 0 THEN
TempString$ = ""
TempYear% = TheYear%
DO WHILE TempYear% >= 1000
TempString$ = TempString$ + "M"
TempYear% = TempYear% - 1000
LOOP
IF TempYear% >= 900 THEN
TempString$ = TempString$ + "CM"
TempYear% = TempYear% - 900
END IF
DO WHILE TempYear% >= 500
TempString$ = TempString$ + "D"
TempYear% = TempYear% - 500
LOOP
IF TempYear% >= 400 THEN
TempString$ = TempString$ + "CD"
TempYear% = TempYear% - 400
END IF
DO WHILE TempYear% >= 100
TempString$ = TempString$ + "C"
TempYear% = TempYear% - 100
LOOP
IF TempYear% >= 90 THEN
TempString$ = TempString$ + "XC"
TempYear% = TempYear% - 90
END IF
DO WHILE TempYear% >= 50
TempString$ = TempString$ + "L"
TempYear% = TempYear% - 50
LOOP
IF TeYear% >= 40 THEN
TempString$ = TempString$ + "XL"
TempYear% = TempYear% - 40
END IF
DO WHILE TempYear% >= 10
TempString$ = TempString$ + "X"
TempYear% = TempYear% - 10
LOOP
IF TempYear% >= 9 THEN
TempString$ = TempString$ + "IX"
TempYear% = TempYear% - 9
END IF
DO WHILE TempYear% >= 5
TempString$ = TempString$ + "V"
TempYear% = TempYear% - 5
LOOP
IF TempYear% >= 4 THEN
TempString$ = TempString$ + "IV"
TempYear% = TempYear% - 4
END IF
DO WHILE TempYear% > 0
TempString$ = TempString$ + "I"
TempYear% = TempYear% - 1
LOOP
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetTemporalString(FormatChar$, Now AS When, TempString$)
SELECT CASE LEFT$(FormatChar$, 1)
CASE "1"
Hours24% = FALSE
CASE "2"
Hours24% = TRUE
CASE "A"
IF Now.Hour > 11 THEN
TempString$ = "pm"
ELSE
TempString$ = "am"
END IF
CASE "B"
StringShortMonth Now.Month, TempString$
CASE "C"
StringMonth Now.Month, TempString$
CASE "D"
GetFullDateUSA Now, TempString$
CASE "E"
GetNumericDateUK Now, TempString$
CASE "F"
GetFullDateUK Now, TempString$
CASE "G"
GetNumericDateUSA Now, TempString$
CASE "H"
GetHour Now.Hour, TempString$
CASE "I"
StringShortDay Now.WeekDay, TempString$
CASE "J"
StringWeekDay Now.WeekDay, TempString$
CASE "K"
GetShortTime Now, TempString$
CASE "L"
GetLongTime Now, TempString$
CASE "M"
GetTwoDigits Now.Minute, TempString$
CASE "N"
TempString$ = LTRIM$(RTRIM$(STR$(Now.WeekDay MOD 10)))
CASE "O"
TempString$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
CASE "P"
TempString$ = LTRIM$(RTRIM$(STR$(Now.Month MOD 100)))
CASE "Q"
TempString$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
GetSuffix Now.MonthDay, Suffix$
TempString$ = TempString$ + Suffix$
CASE "R"
GetRomanYear Now.Year, TempString$
CASE "S"
GetTwoDigits Now.Second, TempString$
CASE "T"
GetTotalDateUK Now, TempString$
CASE "U"
ThisInstant Now
CASE "V"
GetShortDateUK Now, TempString$
CASE "W"
TempString$ = LTRIM$(RTRIM$(STR$(Now.YearWeek MOD 100)))
CASE "X"
TempString$ = LTRIM$(RTRIM$(STR$(Now.YearDay MOD 1000)))
CASE "Y"
TempString$ = LTRIM$(RTRIM$(STR$(Now.Year MOD 10000)))
CASE "Z"
ShortYear Now.Year, TempString$
CASE "r"
GetTotalShortDateUK Now, TempString$
CASE "~"
TempString$ = "~"
END SELECT
END SUB
REM ******************************************************************
REM * This routine produces a string (OutputString$) with time and *
REM * date information embedded within it, as specified by the *
REM * information encoded within FormatString$. The variable Now *
REM * may be used to specify a specific time and date or Now may be *
REM * updated as part of this routine so that the current time and *
REM * date are used instead. *
REM * *
REM * If FormatString$ contains no temporal codes it will simply be *
REM * copied to OutputString$. If during processing of *
REM * FormatString$ an invalid code is encountered, processing will *
REM * cease and an immediate return to SYSTEM occurs with an *
REM * appropriate error message displayed. *
REM * *
REM * There are 29 different temporal codes in all, each of which *
REM * starts with the tilde (CHR$(126), '~') character. The action *
REM * of this routine is to copy everything contained in *
REM * FormatString, except the codes, to OutputString. When a code *
REM * is encountered, it is replaced in OutputString by the *
REM * sub-string that corresponds to that code. In the following *
REM * explanation of the codes and their meanings I have, for *
REM * reasons of brevity, used the word output to signify the *
REM * replacement of a particular code by the substring that is *
REM * described immediately following the usage of the word output. *
REM * The codes and their meanings follow hereafter. *
REM * *
REM *----------------------------------------------------------------*
REM * *
REM * ~1 - Set all time output after this to be in 12 hour *
REM * format. *
REM * *
REM * ~2 - Set all time output after this to be in 24 hour *
REM * format. *
REM * *
REM * ~A - Output either am or pm depending on the time. *
REM * *
REM * ~B - Output the month in abbreviated form *
REM * (Jan, Feb etc.). *
REM * *
REM * ~C - Output the full month name *
REM * (January, February etc.). *
REM * *
REM * ~D - Output full date as January 1 1996 etc. *
REM * *
REM * ~E - Output numeric date in dd/mm/yy form. *
REM * *
REM * ~F - Output full date as 1 January 1996 etc. *
REM * *
REM * ~G - Output numeric date in mm/dd/yy form. *
REM * *
REM * ~H - Output the Hour. *
REM * *
REM * ~I - Output the day of the week in abbreviated form. *
REM * (Mon, Tue etc.) *
REM * *
REM * ~J - Output the full name of the day of the week. *
REM * (Monday, Tuesday etc.) *
REM * *
REM * ~K - Output the time in short form HH:MM. *
REM * *
REM * ~L - Output the time in long form HH:MM:SS. *
REM * *
REM * ~M - Output the Minute. *
REM * *
REM * ~N - Output the Numeric day of week (1 = Sunday). *
REM * *
REM * ~O - Output the Numeric day of the month (1, 2, 3 etc). *
REM * *
REM * ~P - Output the Numeric Month (1 = January). *
REM * *
REM * ~Q - Output the Numeric day of the month with the *
REM * appropriate suffix (1st, 2nd, 3rd, 4th etc.). *
REM * *
REM * ~R - Output the year in ROMAN numerals - MCMXCVI. *
REM * *
REM * ~S - Output the Second. *
REM * *
REM * ~T - Output the total date in the form - *
REM * Sunday 18th February 1996. *
REM * *
REM * ~U - Update (or get new) the information in the *
REM * variable 'Now'. *
REM * *
REM * ~V - Output the date in the form - 18th Feb 96. *
REM * *
REM * ~W - Output the week of the year - 1 to 52. *
REM * *
REM * ~X - Output the day of the year - *
REM * 1 to 365 or 366 in leap year. *
REM * *
REM * ~Y - Output the year in the form 1996. *
REM * *
REM * ~Z - Output the year in the form 96. *
REM * *
REM * ~r - Output the total date in the form - *
REM * Sun 18th Feb 96. *
REM * *
REM * ~~ - Output the character ~ (CHR$(126), '~'). *
REM * *
REM *----------------------------------------------------------------*
REM * *
REM * An example of the usage of this routine is as follows:- *
REM * *
REM * FT$ = "~U~1Today, ~T, at precisely ~L~A, I resigned." *
REM * FTString FT$, Out$, Now *
REM * *
REM * Which should result in Out$ containing the following (assuming *
REM * the dates and times contained) :- *
REM * *
REM * Today, Sunday 18th February 1996, at precisely 12:40pm, I *
REM * resigned. *
REM ******************************************************************
SUB FTString(FormatString$, OutputString$, Now AS When)
ValidChars$ = "12ABCDEFGHIJKLMNOPQRSTUVWXYZr~"
IF INSTR(FormatString$, "~") THEN
OutputString$ = ""
FOR Index% = 1 TO LEN(FormatString$)
ch$ = MID$(FormatString$, Index%, 1)
IF ch$ <> "~" THEN
OutputString$ = OutputString$ + ch$
ELSE
Index% = Index% + 1
ch$ = MID$(FormatString$, Index%, 1)
IF INSTR(ValidChars$, ch$) THEN
GetTemporalString ch$, Now, TempString$
IF ch$ <> "U" THEN
OutputString$ = OutputString$ + TempString$
END IF
ELSE
PRINT "Fatal Error in SUB FTString -"
PRINT "Invalid Format character ";ch$;" in "+"";FormatString$
PRINT "Terminating program now!
SYSTEM
END IF
END IF
NEXT
ELSE
OutputString$ = FormatString$
END IF
END SUB
Note - the FUNCTION DayOfWeek() is only valid from the year 1900 onwards.
Finally the test BAS file -
TESTTIME.BAS
Code: (Select All) '$INCLUDE: 'TIME.BI'
DIM Now AS When
ThisInstant Now
CLS
PRINT "Testing ThisInstant"
PRINT
PRINT "It is ";Now.Hour;":";Now.Minute;":";Now.Second
PRINT "On day ";Now.WeekDay;" of week ";Now.YearWeek;" of year ";Now.Year
PRINT "On day ";Now.MonthDay;" of month ";Now.Month", day ";Now.YearDay;
PRINT " of the year"
PRINT Now.Year;" is ";
IF Now.IsLeapYear THEN
PRINT"a leapyear"
ELSE
PRINT"not a leapyear"
END IF
AnyKey
CLS
A$ = "Testing option A - ~A"
B$ = "Testing option B - ~B"
C$ = "Testing option C - ~C"
D$ = "Testing option D - ~D"
E$ = "Testing option E - ~E"
F$ = "Testing option F - ~F"
G$ = "Testing option G - ~G"
H$ = "Testing option H - ~H"
I$ = "Testing option I - ~I"
J$ = "Testing option J - ~J"
K$ = "Testing option K - ~K"
L$ = "Testing option L - ~L"
M$ = "Testing option M - ~M"
N$ = "Testing option N - ~N"
O$ = "Testing option O - ~O"
P$ = "Testing option P - ~P"
Q$ = "Testing option Q - ~Q"
R$ = "Testing option R - ~R"
R2$ = "Testing option r - ~r"
S$ = "Testing option S - ~S"
T$ = "Testing option T - ~T"
V$ = "Testing option V - ~V"
W$ = "Testing option W - ~W"
X$ = "Testing option X - ~X"
Y$ = "Testing option Y - ~Y"
Z$ = "Testing option Z - ~Z"
T1$ = "~1"
T2$ = "~2"
UP$ = "~U"
Start1$ = UP$ + T1$
Start2$ = UP$ + T2$
FTString T2$, Out1$, Now
CLS
FTString A$, Out1$, Now
PRINT Out1$
FTString B$, Out1$, Now
PRINT Out1$
FTString C$, Out1$, Now
PRINT Out1$
FTString D$, Out1$, Now
PRINT Out1$
FTString E$, Out1$, Now
PRINT Out1$
FTString F$, Out1$, Now
PRINT Out1$
FTString G$, Out1$, Now
PRINT Out1$
FTString H$, Out1$, Now
PRINT Out1$
FTString I$, Out1$, Now
PRINT Out1$
FTString J$, Out1$, Now
PRINT Out1$
FTString K$, Out1$, Now
PRINT Out1$
FTString L$, Out1$, Now
PRINT Out1$
FTString M$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString N$, Out1$, Now
PRINT Out1$
FTString O$, Out1$, Now
PRINT Out1$
FTString P$, Out1$, Now
PRINT Out1$
FTString Q$, Out1$, Now
PRINT Out1$
FTString R$, Out1$, Now
PRINT Out1$
FTString R2$, Out1$, Now
PRINT Out1$
FTString S$, Out1$, Now
PRINT Out1$
FTString T$, Out1$, Now
PRINT Out1$
FTString V$, Out1$, Now
PRINT Out1$
FTString W$, Out1$, Now
PRINT Out1$
FTString X$, Out1$, Now
PRINT Out1$
FTString Y$, Out1$, Now
PRINT Out1$
FTString Z$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString T1$, Out1$, Now
FTString A$, Out1$, Now
PRINT Out1$
FTString B$, Out1$, Now
PRINT Out1$
FTString C$, Out1$, Now
PRINT Out1$
FTString D$, Out1$, Now
PRINT Out1$
FTString E$, Out1$, Now
PRINT Out1$
FTString F$, Out1$, Now
PRINT Out1$
FTString G$, Out1$, Now
PRINT Out1$
FTString H$, Out1$, Now
PRINT Out1$
FTString I$, Out1$, Now
PRINT Out1$
FTString J$, Out1$, Now
PRINT Out1$
FTString K$, Out1$, Now
PRINT Out1$
FTString L$, Out1$, Now
PRINT Out1$
FTString M$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString N$, Out1$, Now
PRINT Out1$
FTString O$, Out1$, Now
PRINT Out1$
FTString P$, Out1$, Now
PRINT Out1$
FTString Q$, Out1$, Now
PRINT Out1$
FTString R$, Out1$, Now
PRINT Out1$
FTString R2$, Out1$, Now
PRINT Out1$
FTString S$, Out1$, Now
PRINT Out1$
FTString T$, Out1$, Now
PRINT Out1$
FTString V$, Out1$, Now
PRINT Out1$
FTString W$, Out1$, Now
PRINT Out1$
FTString X$, Out1$, Now
PRINT Out1$
FTString Y$, Out1$, Now
PRINT Out1$
FTString Z$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString Start2$, Out1$, Now
FTString A$, Out1$, Now
PRINT Out1$
FTString B$, Out1$, Now
PRINT Out1$
FTString C$, Out1$, Now
PRINT Out1$
FTString D$, Out1$, Now
PRINT Out1$
FTString E$, Out1$, Now
PRINT Out1$
FTString F$, Out1$, Now
PRINT Out1$
FTString G$, Out1$, Now
PRINT Out1$
FTString H$, Out1$, Now
PRINT Out1$
FTString I$, Out1$, Now
PRINT Out1$
FTString J$, Out1$, Now
PRINT Out1$
FTString K$, Out1$, Now
PRINT Out1$
FTString L$, Out1$, Now
PRINT Out1$
FTString M$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString N$, Out1$, Now
PRINT Out1$
FTString O$, Out1$, Now
PRINT Out1$
FTString P$, Out1$, Now
PRINT Out1$
FTString Q$, Out1$, Now
PRINT Out1$
FTString R$, Out1$, Now
PRINT Out1$
FTString R2$, Out1$, Now
PRINT Out1$
FTString S$, Out1$, Now
PRINT Out1$
FTString T$, Out1$, Now
PRINT Out1$
FTString V$, Out1$, Now
PRINT Out1$
FTString W$, Out1$, Now
PRINT Out1$
FTString X$, Out1$, Now
PRINT Out1$
FTString Y$, Out1$, Now
PRINT Out1$
FTString Z$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString Start1$, Out1$, Now
FTString A$, Out1$, Now
PRINT Out1$
FTString B$, Out1$, Now
PRINT Out1$
FTString C$, Out1$, Now
PRINT Out1$
FTString D$, Out1$, Now
PRINT Out1$
FTString E$, Out1$, Now
PRINT Out1$
FTString F$, Out1$, Now
PRINT Out1$
FTString G$, Out1$, Now
PRINT Out1$
FTString H$, Out1$, Now
PRINT Out1$
FTString I$, Out1$, Now
PRINT Out1$
FTString J$, Out1$, Now
PRINT Out1$
FTString K$, Out1$, Now
PRINT Out1$
FTString L$, Out1$, Now
PRINT Out1$
FTString M$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString N$, Out1$, Now
PRINT Out1$
FTString O$, Out1$, Now
PRINT Out1$
FTString P$, Out1$, Now
PRINT Out1$
FTString Q$, Out1$, Now
PRINT Out1$
FTString R$, Out1$, Now
PRINT Out1$
FTString R2$, Out1$, Now
PRINT Out1$
FTString S$, Out1$, Now
PRINT Out1$
FTString T$, Out1$, Now
PRINT Out1$
FTString V$, Out1$, Now
PRINT Out1$
FTString W$, Out1$, Now
PRINT Out1$
FTString X$, Out1$, Now
PRINT Out1$
FTString Y$, Out1$, Now
PRINT Out1$
FTString Z$, Out1$, Now
PRINT Out1$
AnyKey
END
SUB AnyKey
DO
QQ$ = INKEY$
LOOP UNTIL QQ$ <> ""
END SUB
'$INCLUDE: 'TIME.BM'
TR
|
|
|
|
| Redirect old-forum and wiki search results to Pheonix as appropriate. |
|
Posted by: mpgcan - 05-18-2022, 02:37 PM - Forum: General Discussion
- Replies (4)
|
 |
You know how it goes. Searching for a QB64 solution, search engines return results to the old-forum or old-wiki. Clicking the link only to be informed the server is not found.
With the link returned, you can use part of it to search in either the new-wiki or old-backup forum. This has become very tedious. I thought there must be a better way.
A simple solution is to use Einar Egilsson's Redirector for this. It is a browser add-on for Firefox, Chrome, Edge and Opera. The Redirector allows you to search for a specific URL, substitute it for another URL and force the browser to redirect to this new URL.
How to install redirector on Firefox:
1) Use the following link to get the add-on
https://addons.mozilla.org/en-GB/firefox...edirector/
2) Note: This add-on is not actively monitored for security by Mozilla.
Check out the "Learn more" link. After reading your choice if you wish to continue.
3) Click the Add to Firefox button.
4) Add Redirector? This extension will have permission to:
Click Add button
5) Redirector was added.
Click the check box. Allow this extension to run in Private Windows
Click Okay button.
6) A redirector symbol is displayed at the top right of the browser confirming it is successfully installed.
Configuring redirector:
Redirect from the old QB64 forum to Phoenix's old-archived read only working forum.
1) Click on the redirector symbol in the drop down click "Edit Redirects" button.
2) On the new browser page that opens, click "Create New Redirect"
3) Fill in the form with the following information:
Configuration information:
Description: QB64_forum_old_to_archive
Example URL: https://forum.qb64.org/
Include pattern: https://forum.qb64.org/*
Redirect to: https://qb64forum.alephc.xyz/$1
Pattern type: Wildcard click radio buttom
Pattern Description: Leave blank
Example result: https://qb64forum.alephc.xyz/
To complete it, click the "Save" button.
4) Click "Create New Redirect"
5) Fill in the form with the following information:
Configuration information:
Redirect from the old QB64 Wiki to Pheonix's new QB64 Wiki.
Description: QB64_Wiki_old_to_new
Example URL: https://wiki.qb64.org/wiki/
Include pattern: https://wiki.qb64.org/wiki/*
Redirect to: https://qb64phoenix.com/qb64wiki/index.php/$1
Pattern type: Wildcard click radio buttom
Pattern Description: Leave blank
Example result: https://qb64phoenix.com/qb64wiki/index.php/
To complete it, click the "Save" button.
6) Finally disable the first configuration
"Example redirect, try going to http://example.com/anywordhere"
By clicking the "Disable" button.
Test:
Try the following two links in your browser:
https://forum.qb64.org/index.php?topic=456.0
https://wiki.qb64.org/wiki/$IF
All the best
MPGCAN
|
|
|
|
| Invoke QB64 compiler from commandline |
|
Posted by: doppler - 05-17-2022, 06:40 PM - Forum: Help Me!
- Replies (10)
|
 |
I know it's possible the old forum had the procedure. Also what to look for if the compiler error's ?
I did a mass correction to almost all my code and I am damn lazy to load/recompile all of it.
|
|
|
|
|
