diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..1f5b3eb --- /dev/null +++ b/Dockerfile @@ -0,0 +1,17 @@ +FROM ubuntu:16.04 +WORKDIR /app +ARG QB64_VERSION=1.1-20170120.51 +ENV QB64_VERSION=$QB64_VERSION +ARG QB64_BUILD=2017_02_09__02_14_38 +ENV QB64_BUILD=$QB64_BUILD +ENV DEBIAN_FRONTEND noninteractive +ENV USER root + +ADD http://www.qb64.net/release/official/$QB64_BUILD-$QB64_VERSION/windows/qb64-$QB64_VERSION-win.zip / +COPY dosbox.conf $HOME/.dosboxrc + +RUN apt-get update && apt-get install -y \ + wget unzip dosbox && \ + apt autoremove && rm -r /var/lib/apt/lists/* + +CMD ["nohup", "dosbox"] \ No newline at end of file diff --git a/any.sh b/any.sh new file mode 100644 index 0000000..adf71d1 --- /dev/null +++ b/any.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +xhost +local:docker inspect --format='{{ .Config.Hostname }}' \ +jacknorthrup/qbasic-docker; \ +docker run -it -e DISPLAY=$DISPLAY -v /tmp/.X11-unix:/tmp/.X11-unix \ +jacknorthrup/qbasic-docker /bin/bash \ No newline at end of file diff --git a/BEEp.ico b/app/BEEp.ico similarity index 100% rename from BEEp.ico rename to app/BEEp.ico diff --git a/Sans.txt b/app/Sans.txt similarity index 96% rename from Sans.txt rename to app/Sans.txt index 23c21e9..8cf863c 100644 --- a/Sans.txt +++ b/app/Sans.txt @@ -1,9 +1,9 @@ -"Alphys : How to ask someone out ?" -"Mtt Ex : Roses are red, Violets are blue, my bed has places for two" -"Sans : Twinkle Twinkle Little Star, We can Do it in the Car" - -"SANS: Everything in the Universe is else a potato or not" -"Pap': " -"Pap: I GUESS!" - - +"Alphys : How to ask someone out ?" +"Mtt Ex : Roses are red, Violets are blue, my bed has places for two" +"Sans : Twinkle Twinkle Little Star, We can Do it in the Car" + +"SANS: Everything in the Universe is else a potato or not" +"Pap': " +"Pap: I GUESS!" + + diff --git a/UnderLogoToSeInWindow.png b/app/UnderLogoToSeInWindow.png similarity index 100% rename from UnderLogoToSeInWindow.png rename to app/UnderLogoToSeInWindow.png diff --git a/blocNotes.ico b/app/blocNotes.ico similarity index 100% rename from blocNotes.ico rename to app/blocNotes.ico diff --git a/fbd.bas b/app/fbd.bas similarity index 96% rename from fbd.bas rename to app/fbd.bas index a44765b..a79ac48 100644 --- a/fbd.bas +++ b/app/fbd.bas @@ -1,76 +1,76 @@ -'FunnyBones Departement - -Rem Init Code - -$ExeIcon:'./pngkit.ico' -Const bio$ = "FunnyBones Broadcast, 2015" -_Title bio$ - -Const initial = "1996 10 12" -Const revision = "2023 11 15" - -Rem Main Part, contains main code - -Cls -Print bio$ -Print "Undertale Jokes, that's all. Except for some Game Dev.." -Print - -Dim t As String, c As String -Dim i As Integer - -Do - Print ">"; - If _MouseButton(1) = True Then - 'Code Logic - End If - Line Input t - i = InStr(t, " ") - If i Then c = Left$(t, i - 1) Else c = t - Select Case LCase$(c) - Case "fuck": Print "Pap': Kids are watching !" - Case "bastards": Print "Pap': Kids are watching !" - Case "dickhead": Print "Pap': Kids are watching !" - Case "bastard": Print "Pap': Kids are watching !" - Case "jerk": Print "Like you and Chara" - Case "trash": Print "Like you, and Alphys" - Case "Asshole": Print "Like you" - Case "bitch": Print "Stop." - Case "Gaster": Exit Do - Case "Woshua": Print "Clean Name" - Case "echo": Print Mid$(t, i + 1) - Case "hnd": Shell "Software Enhaced Help.hnd" - Case "exit": Exit Do - Case "cls": Cls - Case "issue": Print "Go to github.com/EvrestRGB/FBD/issues" - Case "puns": Shell "max20_puns.exe" - Case "sans": Shell "max20_sans.exe" - Case "ver": Print "revision: "; revision: Print "" - Case "conduct": Shell "CODE_OF_CONDUCT.md" - Case "links": Shell "links.txt" - Case "ftp": Shell "ftp.exe" - Case "time": Print Time$ - Case "links": - Case "duck": - Print "I see.." - Shell "updated_dack.exe" - Case "help": - Print "EXIT - exit the shell" - Print "CLS - clear the screen" - Print "ECHO - displays written message in Console" - Print "FTP - opens FTP mode" - Print "PUNS - display puns" - Print "SANS - display sans and toriel jokes" - Print "LINKS - display some links" - Print "VER - display version" - Print "HELP - display this help" - Print "HND - advanced software help" - Print "ISSUE - display issue methods" - Print "CONDUCT - Displays code of conduct" - Print - Case Else - Print "Bad command. Running files not implemented yet.": Print - End Select -Loop -System - +'FunnyBones Departement + +Rem Init Code + +$ExeIcon:'./pngkit.ico' +Const bio$ = "FunnyBones Broadcast, 2015" +_Title bio$ + +Const initial = "1996 10 12" +Const revision = "2023 11 15" + +Rem Main Part, contains main code + +Cls +Print bio$ +Print "Undertale Jokes, that's all. Except for some Game Dev.." +Print + +Dim t As String, c As String +Dim i As Integer + +Do + Print ">"; + If _MouseButton(1) = True Then + 'Code Logic + End If + Line Input t + i = InStr(t, " ") + If i Then c = Left$(t, i - 1) Else c = t + Select Case LCase$(c) + Case "fuck": Print "Pap': Kids are watching !" + Case "bastards": Print "Pap': Kids are watching !" + Case "dickhead": Print "Pap': Kids are watching !" + Case "bastard": Print "Pap': Kids are watching !" + Case "jerk": Print "Like you and Chara" + Case "trash": Print "Like you, and Alphys" + Case "Asshole": Print "Like you" + Case "bitch": Print "Stop." + Case "Gaster": Exit Do + Case "Woshua": Print "Clean Name" + Case "echo": Print Mid$(t, i + 1) + Case "hnd": Shell "Software Enhaced Help.hnd" + Case "exit": Exit Do + Case "cls": Cls + Case "issue": Print "Go to github.com/EvrestRGB/FBD/issues" + Case "puns": Shell "max20_puns.exe" + Case "sans": Shell "max20_sans.exe" + Case "ver": Print "revision: "; revision: Print "" + Case "conduct": Shell "CODE_OF_CONDUCT.md" + Case "links": Shell "links.txt" + Case "ftp": Shell "ftp.exe" + Case "time": Print Time$ + Case "links": + Case "duck": + Print "I see.." + Shell "updated_dack.exe" + Case "help": + Print "EXIT - exit the shell" + Print "CLS - clear the screen" + Print "ECHO - displays written message in Console" + Print "FTP - opens FTP mode" + Print "PUNS - display puns" + Print "SANS - display sans and toriel jokes" + Print "LINKS - display some links" + Print "VER - display version" + Print "HELP - display this help" + Print "HND - advanced software help" + Print "ISSUE - display issue methods" + Print "CONDUCT - Displays code of conduct" + Print + Case Else + Print "Bad command. Running files not implemented yet.": Print + End Select +Loop +System + diff --git a/fbdEditor.bas b/app/fbdEditor.bas similarity index 96% rename from fbdEditor.bas rename to app/fbdEditor.bas index 6df6a08..62168ac 100644 --- a/fbdEditor.bas +++ b/app/fbdEditor.bas @@ -1,29 +1,29 @@ -'FBD Editor - -$ExeIcon:'./blocNotes.ico' -Const bio$ = "Funny Bones BBS editor" -_Title bio$ - - -'Sans -Open "C:\Dev\qb64_dev\FBD\Sans.txt" For Output As #1 -Write #1, "Alphys : How to ask someone out ?" -Write #1, "Mtt Ex : Roses are red, Violets are blue, my bed has places for two" -Write #1, "Sans : Twinkle Twinkle Little Star, We can Do it in the Car" -Close #1 - -'Puns -Open "./puns.txt" For Output As #2 -Write #2, "Alphys : How to ask someone out ?" -Write #2, "Mtt Ex : Roses are red, Violets are blue, my bed has places for two" -Write #2, "Sans : Twinkle Twinkle Little Star, We can Do it in the Car" -Close #2 - -'Links -Open "./links.txt" For Output As #3 -Write #3, "Alphys : How to ask someone out ?" -Write #3, "Mtt Ex : Roses are red, Violets are blue, my bed has places for two" -Write #3, "Sans : Twinkle Twinkle Little Star, We can Do it in the Car" -Close #3 - - +'FBD Editor + +$ExeIcon:'./blocNotes.ico' +Const bio$ = "Funny Bones BBS editor" +_Title bio$ + + +'Sans +Open "C:\Dev\qb64_dev\FBD\Sans.txt" For Output As #1 +Write #1, "Alphys : How to ask someone out ?" +Write #1, "Mtt Ex : Roses are red, Violets are blue, my bed has places for two" +Write #1, "Sans : Twinkle Twinkle Little Star, We can Do it in the Car" +Close #1 + +'Puns +Open "./puns.txt" For Output As #2 +Write #2, "Alphys : How to ask someone out ?" +Write #2, "Mtt Ex : Roses are red, Violets are blue, my bed has places for two" +Write #2, "Sans : Twinkle Twinkle Little Star, We can Do it in the Car" +Close #2 + +'Links +Open "./links.txt" For Output As #3 +Write #3, "Alphys : How to ask someone out ?" +Write #3, "Mtt Ex : Roses are red, Violets are blue, my bed has places for two" +Write #3, "Sans : Twinkle Twinkle Little Star, We can Do it in the Car" +Close #3 + + diff --git a/app/indie.png b/app/indie.png new file mode 100644 index 0000000..f5b4c9e Binary files /dev/null and b/app/indie.png differ diff --git a/links.txt b/app/links.txt similarity index 100% rename from links.txt rename to app/links.txt diff --git a/pngkit.ico b/app/pngkit.ico similarity index 100% rename from pngkit.ico rename to app/pngkit.ico diff --git a/puns.txt b/app/puns.txt similarity index 97% rename from puns.txt rename to app/puns.txt index b790381..3794276 100644 --- a/puns.txt +++ b/app/puns.txt @@ -1,139 +1,139 @@ -Toriel : In your life, you will encounter bad people. They'll say that puns are bad. -Sans : Yes . We should PUNish them. -*Bedum tss* - -1. Looks like you had a rough day. But it's going tibia okay. - -2. I know I can be difficult at times. Hope you don't have a bone to pick with me. - -3. I have got a ton of work done today. A skele-ton. - -4. It's easy to tell when a skeleton is lying. You can see right through them. - -5. Sans' funniest pun is about what instrument he plays. A trom-bone. - -6. Sans is very calm, because nothing gets under his skin. - -7. A list of Sans' puns would be sans-tastic. - -8. Sans is quite funny. One could call him... humerus. - -9. Sans gave me a nice culinary presentation. 'Bone appetit', he said. - -10. Sans laughed for quite a while. The joke had really tickled his funny bone. - -11. But first, let me take a skelfie. - -12. Graveyards are so noisy. It's mostly all the coffin'. - -13. I knew where you'd go next. I felt it instinctively, I felt it in my bones. - -14. Sans doesn't need a telephone. He'd rather use a telebone. - -15. Papyrus was standing by the fire for too long. It turned him bone-dry. - -16. Sans is not overweight, he is just a little big-boned! - -17. Couple of days ago, a stray dog came and stole away Papyrus' left leg. You could say Papyrus wasn't left with a leg to stand on. - -18. A skeletal snake would be quite the rattler. - -19. There was once a very hard-working skeleton. He always worked himself down to the bone. - -20. The skeleton wanted a friend to talk to, he was feeling bonely. - -21. If you ever see a fellow skeleton running down the road, jump out of your skin and join them. - -22. Skulls are meant to be eternally single. They literally have no body. - -23. Mr Funny Bones' new stand-up set didn't elicit much applause. Most of his jokes were pretty bare-bones. - -24. A few days ago, Papyrus had a dream about his motorcar. He describes it as an auto-body experience. - -25. Papyrus got mixed up with a biker gang. He's bad to the bone now. - -26. This Sans' puns list is getting pretty long, but we got a femur. - -27. Sans seems like a smart fellow, but he must have had his own embarrassing mishaps in his time. Everyone's got skeletons in the closet. - -28. Papyrus was oft-misunderstood as a child. The first track in his mixtape was Spooky Scary Skeletons. - -29. Couple of days ago, a dog stole Sans' left arm and left femur. But Sans is all right now. - -30. A skeletal ape would be called a babone. - -31. Papyrus ran headfast into a windmill... he's such a bonehead. - -32. One could also call him a numbskull. - -33. Skeletons can't play church music, obviously. They got no organs. - -34. A skeleton's top restaurant order should be spare ribs. - -35. Ultimately, Asgore ended up making Papyrus a nice hedge skullpture. - -36. Papyrus does not like Sans' cooking. He doesn't have the stomach for it. - -37. Sans has a reputation for being lazy. He's almost bone idle. - -38. A skeleton mounted on his newly purchased Harley Davidson motorcycle. 'I'm bone to be wild', he said. - -39. The other day Papyrus did the tiling on his roof. He chose the all-time skeleton-favorite material, shin-gles. - -40. Papyrus prepared his valentine's day gift for his lover. It was a heart-shaped box with bone-bones in it. - -41. Few could traverse the hallway maze made of bones. It was rather marrow. - -42. Sans' favorite band is probably Boney M. - -43. Melee was too dangerous, so the skeleton guard resorted to his trusty bow and marrows. - -44. A French Sans would greet you with the ol' bone-jour. - -45. Some of these puns aren't that hilarious, but come on, throw us a bone. - -46. The teenage skeleton band was into bro culture. They called each other vertebruhs, because they always had each others' backs. - -47. The skeleton did not invite his cousins over because he thought they were marrow-minded. -48. All a lazy skeleton does is sit and boondoggle! - -49. The lazy skeleton should put a little more 'backbone' into his work. - -50. It's the season of dog petting. All the dogs want to be pet. It is just one big 'pupularity' contest. - -51. Careful, the ice is slippery. No one wants to pratfall during a cool technique. - -52. A skewer kabob but with only bones is called kabones. - -53. The skeleton was great at dancing. He was a bone-a-fide opera star. - -54. Fangs for visiting my web-site, spider. -55. I went to a party, and mettaton of new people. - -56. I mistook the 3D hologram cow as the real deal. It looked Toriel. - -57. She was Asgoregeous as the first day I'd seen her. - -58. The aquatic zoo was a bad place to go to. Turns out I hate Alphys. - -59. A challenging and harsh environment builds Chara-cter. - -60. The biggest whistleblower in Undertale lore has got to be Ed Snowdin. - -But first, let me take a Skelfie - -Why are graveyards so noisy? - -How did I know where you would go next? -Oh I felt it in my bones! -Because of all the coffin! - -"Pap: WHY DEOSN'T ANYONE WANT MY SPAGHETTI" -"Sans: I don't know.." -"Pap: SANS..." -"Sans: maybe they think.." -"Pap': IM WARNING YOU SANS" -"Sans: ...your spaghetti is impastable to eat" - -TEM AN JERRY -TORITOS +Toriel : In your life, you will encounter bad people. They'll say that puns are bad. +Sans : Yes . We should PUNish them. +*Bedum tss* + +1. Looks like you had a rough day. But it's going tibia okay. + +2. I know I can be difficult at times. Hope you don't have a bone to pick with me. + +3. I have got a ton of work done today. A skele-ton. + +4. It's easy to tell when a skeleton is lying. You can see right through them. + +5. Sans' funniest pun is about what instrument he plays. A trom-bone. + +6. Sans is very calm, because nothing gets under his skin. + +7. A list of Sans' puns would be sans-tastic. + +8. Sans is quite funny. One could call him... humerus. + +9. Sans gave me a nice culinary presentation. 'Bone appetit', he said. + +10. Sans laughed for quite a while. The joke had really tickled his funny bone. + +11. But first, let me take a skelfie. + +12. Graveyards are so noisy. It's mostly all the coffin'. + +13. I knew where you'd go next. I felt it instinctively, I felt it in my bones. + +14. Sans doesn't need a telephone. He'd rather use a telebone. + +15. Papyrus was standing by the fire for too long. It turned him bone-dry. + +16. Sans is not overweight, he is just a little big-boned! + +17. Couple of days ago, a stray dog came and stole away Papyrus' left leg. You could say Papyrus wasn't left with a leg to stand on. + +18. A skeletal snake would be quite the rattler. + +19. There was once a very hard-working skeleton. He always worked himself down to the bone. + +20. The skeleton wanted a friend to talk to, he was feeling bonely. + +21. If you ever see a fellow skeleton running down the road, jump out of your skin and join them. + +22. Skulls are meant to be eternally single. They literally have no body. + +23. Mr Funny Bones' new stand-up set didn't elicit much applause. Most of his jokes were pretty bare-bones. + +24. A few days ago, Papyrus had a dream about his motorcar. He describes it as an auto-body experience. + +25. Papyrus got mixed up with a biker gang. He's bad to the bone now. + +26. This Sans' puns list is getting pretty long, but we got a femur. + +27. Sans seems like a smart fellow, but he must have had his own embarrassing mishaps in his time. Everyone's got skeletons in the closet. + +28. Papyrus was oft-misunderstood as a child. The first track in his mixtape was Spooky Scary Skeletons. + +29. Couple of days ago, a dog stole Sans' left arm and left femur. But Sans is all right now. + +30. A skeletal ape would be called a babone. + +31. Papyrus ran headfast into a windmill... he's such a bonehead. + +32. One could also call him a numbskull. + +33. Skeletons can't play church music, obviously. They got no organs. + +34. A skeleton's top restaurant order should be spare ribs. + +35. Ultimately, Asgore ended up making Papyrus a nice hedge skullpture. + +36. Papyrus does not like Sans' cooking. He doesn't have the stomach for it. + +37. Sans has a reputation for being lazy. He's almost bone idle. + +38. A skeleton mounted on his newly purchased Harley Davidson motorcycle. 'I'm bone to be wild', he said. + +39. The other day Papyrus did the tiling on his roof. He chose the all-time skeleton-favorite material, shin-gles. + +40. Papyrus prepared his valentine's day gift for his lover. It was a heart-shaped box with bone-bones in it. + +41. Few could traverse the hallway maze made of bones. It was rather marrow. + +42. Sans' favorite band is probably Boney M. + +43. Melee was too dangerous, so the skeleton guard resorted to his trusty bow and marrows. + +44. A French Sans would greet you with the ol' bone-jour. + +45. Some of these puns aren't that hilarious, but come on, throw us a bone. + +46. The teenage skeleton band was into bro culture. They called each other vertebruhs, because they always had each others' backs. + +47. The skeleton did not invite his cousins over because he thought they were marrow-minded. +48. All a lazy skeleton does is sit and boondoggle! + +49. The lazy skeleton should put a little more 'backbone' into his work. + +50. It's the season of dog petting. All the dogs want to be pet. It is just one big 'pupularity' contest. + +51. Careful, the ice is slippery. No one wants to pratfall during a cool technique. + +52. A skewer kabob but with only bones is called kabones. + +53. The skeleton was great at dancing. He was a bone-a-fide opera star. + +54. Fangs for visiting my web-site, spider. +55. I went to a party, and mettaton of new people. + +56. I mistook the 3D hologram cow as the real deal. It looked Toriel. + +57. She was Asgoregeous as the first day I'd seen her. + +58. The aquatic zoo was a bad place to go to. Turns out I hate Alphys. + +59. A challenging and harsh environment builds Chara-cter. + +60. The biggest whistleblower in Undertale lore has got to be Ed Snowdin. + +But first, let me take a Skelfie + +Why are graveyards so noisy? + +How did I know where you would go next? +Oh I felt it in my bones! +Because of all the coffin! + +"Pap: WHY DEOSN'T ANYONE WANT MY SPAGHETTI" +"Sans: I don't know.." +"Pap: SANS..." +"Sans: maybe they think.." +"Pap': IM WARNING YOU SANS" +"Sans: ...your spaghetti is impastable to eat" + +TEM AN JERRY +TORITOS diff --git a/reader.bm b/app/reader.bm similarity index 100% rename from reader.bm rename to app/reader.bm diff --git a/updated_dack.bas b/app/updated_dack.bas similarity index 96% rename from updated_dack.bas rename to app/updated_dack.bas index e8b2cda..1aa1884 100644 --- a/updated_dack.bas +++ b/app/updated_dack.bas @@ -1,141 +1,141 @@ -' *************** D I S C O D U C K **************** -' -' a QB program made as a tribute to the Disco Era. - -Cls -Color 10 -Print " WELCOME TO THE DISCO ERA!" -Print -Print " here we present, DISCO DUCK." -Print -Print " press any key to continue "; -Locate CsrLin, Pos(0) - 2, 1, 6, 8 -While InKey$ = "" -Wend -Cls -Locate , , 0 -Restore duck -GoSub discoduck -Timer On -On Timer(4) GoSub discoduck -Do - Read a$ - For a = 1 To Len(a$) - Select Case Mid$(a$, a, 1) - ' CASE "-" - ' PRINT " " - Case "Y" - Color 14, 0 - Print "Û"; - Case "W" - Color 15, 0 - Print "Û"; - Case "O" - Color 14, 4 - Print "±"; - Case "B" - Color 0, 0 - Print "B"; - Case "d" - Color 12 - Print "D"; - Case "i" - Color 12 - Print "I"; - Case "s" - Color 12 - Print "S"; - Case "c" - Color 12 - Print "C"; - Case "o" - Color 12 - Print "O"; - Case "u" - Color 12 - Print "U"; - Case "k" - Color 12 - Print "K"; - Case "*" - Color 15 - Print "*"; - Case Else - Print " "; - End Select - Color , 0 - Next - Print -Loop Until a$ = "E" -Locate 23, 10 -a$ = "** PRESS ANY KEY TO END **" -For a = 1 To Len(a$) - Select Case Mid$(a$, a, 1) - Case " " - Color 0, 0 - Print "_"; - Case Else - Color 14, 0 - Print Mid$(a$, a, 1); - End Select -Next -Print -Color 0, 0 ' allows a "hidden signal character" to -For y = 1 To 25 'ensure a proper "disco" effect. - For x = 1 To 80 - Locate y, x - If Screen(y, x) = 32 Then Print "°"; - Next -Next -b = 176 -Do - x = CInt(Rnd * 80) - y = CInt(Rnd * 25) - If x < 1 Then x = 1 - If y < 1 Then y = 1 - Locate y, x - Select Case b - Case 176 - b = 178 - Case 178 - b = 176 - End Select - c = Int(Rnd * 15) - cb = Int(Rnd * 7) - Color c, cb - Locate y, x - Select Case Screen(y, x) - Case 176 - Print Chr$(b); - Case 178 - Print Chr$(b); - Case Else - End Select -Loop Until InKey$ <> "" -Color 7, 0 -Cls -Print "the DISCO ERA has ended!" -Print -Print "now, we're back to the present day!" -End -duck: -Data --------- -Data ------ -Data ------ -Data -------------------------------------------YYYYYYY\ -Data -----------------------------------------YYYYWWBBY\ -Data ---*BdBiBsBcBoBBBdBuBcBkB*-------------YYYYYYOOOOOOOO\ -Data --------------------------------YYYYYYYYYYYYYOOOOOOOOOO\ -Data ------------------------YYYYYYYYYYYYYYYYYYYYY\ -Data -------------------YYYYYYYYYYYYYYYYYYYYYYYYYY\ -Data ----------------YYYYYYYYYYYYYYYYYYYYYYYYYY\ -Data -------------YYYYYYYOOYYYYYYYYYYYYYYOO\ -Data --------------------OOYYYYYYYYYYYYYYOO\ -Data --------------------OO--------------OO\ -Data --------------------OO--------------OO\ -Data E -' character E serves as a signal to avoid the OUT OF DATA error. -discoduck: -Play "MB t130 n25 t80 n20 t200 n20 n20 t200 n20" -Return - +' *************** D I S C O D U C K **************** +' +' a QB program made as a tribute to the Disco Era. + +Cls +Color 10 +Print " WELCOME TO THE DISCO ERA!" +Print +Print " here we present, DISCO DUCK." +Print +Print " press any key to continue "; +Locate CsrLin, Pos(0) - 2, 1, 6, 8 +While InKey$ = "" +Wend +Cls +Locate , , 0 +Restore duck +GoSub discoduck +Timer On +On Timer(4) GoSub discoduck +Do + Read a$ + For a = 1 To Len(a$) + Select Case Mid$(a$, a, 1) + ' CASE "-" + ' PRINT " " + Case "Y" + Color 14, 0 + Print "Û"; + Case "W" + Color 15, 0 + Print "Û"; + Case "O" + Color 14, 4 + Print "±"; + Case "B" + Color 0, 0 + Print "B"; + Case "d" + Color 12 + Print "D"; + Case "i" + Color 12 + Print "I"; + Case "s" + Color 12 + Print "S"; + Case "c" + Color 12 + Print "C"; + Case "o" + Color 12 + Print "O"; + Case "u" + Color 12 + Print "U"; + Case "k" + Color 12 + Print "K"; + Case "*" + Color 15 + Print "*"; + Case Else + Print " "; + End Select + Color , 0 + Next + Print +Loop Until a$ = "E" +Locate 23, 10 +a$ = "** PRESS ANY KEY TO END **" +For a = 1 To Len(a$) + Select Case Mid$(a$, a, 1) + Case " " + Color 0, 0 + Print "_"; + Case Else + Color 14, 0 + Print Mid$(a$, a, 1); + End Select +Next +Print +Color 0, 0 ' allows a "hidden signal character" to +For y = 1 To 25 'ensure a proper "disco" effect. + For x = 1 To 80 + Locate y, x + If Screen(y, x) = 32 Then Print "°"; + Next +Next +b = 176 +Do + x = CInt(Rnd * 80) + y = CInt(Rnd * 25) + If x < 1 Then x = 1 + If y < 1 Then y = 1 + Locate y, x + Select Case b + Case 176 + b = 178 + Case 178 + b = 176 + End Select + c = Int(Rnd * 15) + cb = Int(Rnd * 7) + Color c, cb + Locate y, x + Select Case Screen(y, x) + Case 176 + Print Chr$(b); + Case 178 + Print Chr$(b); + Case Else + End Select +Loop Until InKey$ <> "" +Color 7, 0 +Cls +Print "the DISCO ERA has ended!" +Print +Print "now, we're back to the present day!" +End +duck: +Data --------- +Data ------ +Data ------ +Data -------------------------------------------YYYYYYY\ +Data -----------------------------------------YYYYWWBBY\ +Data ---*BdBiBsBcBoBBBdBuBcBkB*-------------YYYYYYOOOOOOOO\ +Data --------------------------------YYYYYYYYYYYYYOOOOOOOOOO\ +Data ------------------------YYYYYYYYYYYYYYYYYYYYY\ +Data -------------------YYYYYYYYYYYYYYYYYYYYYYYYYY\ +Data ----------------YYYYYYYYYYYYYYYYYYYYYYYYYY\ +Data -------------YYYYYYYOOYYYYYYYYYYYYYYOO\ +Data --------------------OOYYYYYYYYYYYYYYOO\ +Data --------------------OO--------------OO\ +Data --------------------OO--------------OO\ +Data E +' character E serves as a signal to avoid the OUT OF DATA error. +discoduck: +Play "MB t130 n25 t80 n20 t200 n20 n20 t200 n20" +Return + diff --git a/desktop.ini b/desktop.ini new file mode 100644 index 0000000..a201503 --- /dev/null +++ b/desktop.ini @@ -0,0 +1,5 @@ +[ViewState] +Mode= +Vid= +FolderType=Pictures +Logo=C:\Dev\qb64_dev\FBD\pngkit.ico diff --git a/dosbox.conf b/dosbox.conf new file mode 100644 index 0000000..d3ab943 --- /dev/null +++ b/dosbox.conf @@ -0,0 +1,4 @@ +[autoexec] +mount c /qb45 +C: +QB.EXE \ No newline at end of file diff --git a/qb45/QB45/HLP/QB45ADVR.HLP b/qb45/QB45/HLP/QB45ADVR.HLP new file mode 100644 index 0000000..6956a54 Binary files /dev/null and b/qb45/QB45/HLP/QB45ADVR.HLP differ diff --git a/qb45/QB45/HLP/QB45ENER.HLP b/qb45/QB45/HLP/QB45ENER.HLP new file mode 100644 index 0000000..290619d Binary files /dev/null and b/qb45/QB45/HLP/QB45ENER.HLP differ diff --git a/qb45/QB45/HLP/QB45QCK.HLP b/qb45/QB45/HLP/QB45QCK.HLP new file mode 100644 index 0000000..6aa1080 Binary files /dev/null and b/qb45/QB45/HLP/QB45QCK.HLP differ diff --git a/qb45/QB45/INC/ADVR_EX/CALL_EX.BAS b/qb45/QB45/INC/ADVR_EX/CALL_EX.BAS new file mode 100644 index 0000000..41adbf0 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/CALL_EX.BAS @@ -0,0 +1,69 @@ +' *** CALL_EX.BAS +' +DEFINT A-Z +CONST MAXFILES = 5, ARRAYDIM = MAXFILES + 1 +DIM File$(1 TO ARRAYDIM) +' Separate command line into arguments. +CALL Comline (Numargs,File$(),ARRAYDIM) +IF Numargs < 3 OR Numargs >MAXFILES THEN + ' Too many or too few files. + PRINT "Use more than 3 and fewer than";MAXFILES;"files" +ELSE + ' Printout list of files. + CALL Printout(File$(),Numargs) +END IF +END + +SUB Comline(NumArgs,Args$(1),MaxArgs) STATIC +' Subroutine to get command line and split into arguments. +' Parameters: NumArgs : Number of args found. +' Args$() : Array in which to return arguments. +' MaxArgs : Maximum number of arguments +CONST TRUE = -1, FALSE = 0 +NumArgs=0 : In=FALSE +' Get the command line using the COMMAND$ function. + Cl$ = COMMAND$ + L = LEN(Cl$) +' Go through the command line a character at a time. + FOR I = 1 TO L + C$ = MID$(Cl$,I,1) + 'Test for a blank or tab. + IF (C$ <> " " AND C$ <> CHR$(9)) THEN + ' Neither blank nor tab. + ' Test already inside an argument. + IF NOT In THEN + ' You've found the start of a new argument. + ' Test for too many arguments. + IF NumArgs=MaxArgs THEN EXIT FOR + NumArgs=NumArgs+1 + In=TRUE + END IF + ' Add the character to the current argument. + Args$(NumArgs)=Args$(NumArgs)+C$ + ELSE + ' Found a blank or a tab. + ' Set "Not in an argument" flag to FALSE. + In=FALSE + END IF + NEXT I +END SUB + +SUB Printout(F$(1),N) STATIC + ' Open target file. + OPEN F$(N) FOR OUTPUT AS #3 + ' Loop executes once for each file. + ' Copy the first N-1 files onto the Nth file. + FOR File = 1 TO N - 1 + OPEN F$(File) FOR INPUT AS #1 + DO WHILE NOT EOF(1) + 'Read file. + LINE INPUT #1, Temp$ + 'Write data to target file. + PRINT #3, Temp$ + PRINT Temp$ + LOOP + CLOSE #1 + NEXT + CLOSE +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/CHR_EX.BAS b/qb45/QB45/INC/ADVR_EX/CHR_EX.BAS new file mode 100644 index 0000000..7249b0a --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/CHR_EX.BAS @@ -0,0 +1,32 @@ +' *** CHR_EX.BAS *** +' +DEFINT A-Z +' Display two double-sided boxes. +CALL DBox(5,22,18,40) +CALL DBox(1,4,4,50) +END + +' Subroutine to display boxes. +' Parameters: +' Urow%, Ucol% : Row and column of upper-left corner. +' Lrow%, Lcol% : Row and column of lower-right corner. +' Constants for extended ASCII graphic characters. +CONST ULEFTC=201, URIGHTC=187, VERTICAL=186, HORIZONTAL=205 +CONST LLEFTC=200, LRIGHTC=188 + +SUB DBox (Urow%, Ucol%, Lrow%, Lcol%) STATIC + ' Draw top of box. + LOCATE Urow%, Ucol% : PRINT CHR$(ULEFTC); + LOCATE ,Ucol%+1 : PRINT STRING$(Lcol%-Ucol%,CHR$(HORIZONTAL)); + LOCATE ,Lcol% : PRINT CHR$(URIGHTC); + ' Draw body of box. + FOR I=Urow%+1 TO Lrow%-1 + LOCATE I,Ucol% : PRINT CHR$(VERTICAL); + LOCATE ,Lcol% : PRINT CHR$(VERTICAL); + NEXT I + ' Draw bottom of box. + LOCATE Lrow%, Ucol% : PRINT CHR$(LLEFTC); + LOCATE ,Ucol%+1 : PRINT STRING$(Lcol%-Ucol%,CHR$(HORIZONTAL)); + LOCATE ,Lcol% : PRINT CHR$(LRIGHTC); +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/CMD_EX.BAS b/qb45/QB45/INC/ADVR_EX/CMD_EX.BAS new file mode 100644 index 0000000..94c58ba --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/CMD_EX.BAS @@ -0,0 +1,57 @@ +' +' *** CMD_EX.BAS -- COMMAND$ function programming example +' +' Default variable type is integer in this module. +DEFINT A-Z + +' Declare the Comline subprogram, as well as the number and +' type of its parameters. +DECLARE SUB Comline(N, A$(),Max) + +DIM A$(1 TO 15) +' Get what was typed on the command line. +CALL Comline(N,A$(),10) +' Print out each part of the command line. +PRINT "Number of arguments = ";N +PRINT "Arguments are: " +FOR I=1 TO N : PRINT A$(I) : NEXT I + +' Subroutine to get command line and split into arguments. +' Parameters: NumArgs : Number of command line args found. +' Args$() : Array in which to return arguments. +' MaxArgs : Maximum number of arguments array +' can return. + +SUB Comline(NumArgs,Args$(1),MaxArgs) STATIC +CONST TRUE=-1, FALSE=0 + + NumArgs=0 : In=FALSE +' Get the command line using the COMMAND$ function. + Cl$=COMMAND$ + L=LEN(Cl$) +' Go through the command line a character at a time. + FOR I=1 TO L + C$=MID$(Cl$,I,1) + 'Test for character being a blank or a tab. + IF (C$<>" " AND C$<>CHR$(9)) THEN + ' Neither blank nor tab. + ' Test to see if you're already + ' inside an argument. + IF NOT In THEN + ' You've found the start of a new argument. + ' Test for too many arguments. + IF NumArgs=MaxArgs THEN EXIT FOR + NumArgs=NumArgs+1 + In=TRUE + END IF + ' Add the character to the current argument. + Args$(NumArgs)=Args$(NumArgs)+C$ + ELSE + ' Found a blank or a tab. + ' Set "Not in an argument" flag to FALSE. + In=FALSE + END IF + NEXT I + +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/COM1_EX.BAS b/qb45/QB45/INC/ADVR_EX/COM1_EX.BAS new file mode 100644 index 0000000..2f11be6 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/COM1_EX.BAS @@ -0,0 +1,21 @@ +' +' *** COM1_EX.BAS - COMMON statement programming example +' +DIM Values(1 TO 50) +COMMON Values(), NumValues + +PRINT "Enter values one per line. Type 'END' to quit." +NumValues = 0 +DO + INPUT "-> ", N$ + IF I >= 50 OR UCASE$(N$) = "END" THEN EXIT DO + NumValues = NumValues + 1 + Values(NumValues) = VAL(N$) +LOOP +PRINT "Leaving COM1_EX.BAS to chain to COM2_EX.BAS" +PRINT "Press any key to chain... " +DO WHILE INKEY$ = "" +LOOP + +CHAIN "com2_ex" + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/COM2_EX.BAS b/qb45/QB45/INC/ADVR_EX/COM2_EX.BAS new file mode 100644 index 0000000..7929faa --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/COM2_EX.BAS @@ -0,0 +1,16 @@ +' +' *** COM2_EX.BAS - COMMON statement programming example +' +DIM X(1 TO 50) +COMMON X(), N + +PRINT +PRINT "Now executing file com2_ex.bas, reached through a CHAIN command" +IF N > 0 THEN + Sum = 0 + FOR I = 1 TO N + Sum = Sum + X(I) + NEXT I + PRINT "The average of the values is"; Sum / N +END IF + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/CSR_EX.BAS b/qb45/QB45/INC/ADVR_EX/CSR_EX.BAS new file mode 100644 index 0000000..d089b2b --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/CSR_EX.BAS @@ -0,0 +1,24 @@ +' +' *** CSR_EX.BAS - CSRLIN function programming example +' +' Move cursor to center of screen, then print message. +' Cursor returned to center of screen. + LOCATE 12,40 + CALL MsgNoMove("A message not to be missed.",9,35) + INPUT "Enter anything to end: ",A$ + +' Print a message without disturbing current +' cursor position. +SUB MsgNoMove (Msg$,Row%,Col%) STATIC + + ' Save the current line. + CurRow%=CSRLIN + ' Save the current column. + CurCol%=POS(0) + ' Print the message at the given position. + LOCATE Row%,Col% : PRINT Msg$; + ' Move the cursor back to original position. + LOCATE CurRow%, CurCol% + +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/DECL_EX.BAS b/qb45/QB45/INC/ADVR_EX/DECL_EX.BAS new file mode 100644 index 0000000..c070317 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/DECL_EX.BAS @@ -0,0 +1,36 @@ +' +' *** DECL_EX.BAS - DECLARE statement programming example +' +' Generate 20 random numbers, store them in an array, and +' sort. The sort subprogram is called without the CALL keyword. +DECLARE SUB Sort(A(1) AS SINGLE, N AS INTEGER) +DIM Array1(1 TO 20) + +' Generate 20 random numbers. +RANDOMIZE TIMER +FOR I=1 TO 20 + Array1(I)=RND +NEXT I + +' Sort the array and call Sort without the CALL keyword. +' Notice the absence of parentheses around the arguments in +' the call to Sort. +Sort Array1(), 20% + +' Print the sorted array. +FOR I=1 TO 20 + PRINT Array1(I) +NEXT I +END + +' Sort subroutine. +SUB Sort(A(1), N%) STATIC + + FOR I= 1 TO N%-1 + FOR J=I+1 TO N% + IF A(I)>A(J) THEN SWAP A(I), A(J) + NEXT J + NEXT I + +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/DEFFN_EX.BAS b/qb45/QB45/INC/ADVR_EX/DEFFN_EX.BAS new file mode 100644 index 0000000..03eab79 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/DEFFN_EX.BAS @@ -0,0 +1,15 @@ +' +' *** DEFFN_EX.BAS - DEF FN function programming example +' +DEF FNFactorial#(X) + STATIC Tmp#, I + Tmp#=1 + FOR I=2 TO X + Tmp#=Tmp#*I + NEXT I + FNFactorial#=Tmp# +END DEF + +INPUT "Enter a number: ",Num +PRINT Num "factorial is" FNFactorial#(Num) + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/DEFSG_EX.BAS b/qb45/QB45/INC/ADVR_EX/DEFSG_EX.BAS new file mode 100644 index 0000000..93144bc --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/DEFSG_EX.BAS @@ -0,0 +1,45 @@ +' *** DEFSG_EX.BAS *** +' +DECLARE SUB CapsOn () +DECLARE SUB CapsOff () +DECLARE SUB PrntMsg (R%,C%,M$) + +CLS +CapsOn +PrntMsg 24,1,"" +LOCATE 12,10 +LINE INPUT "Enter a string (all characters are caps): ",S$ +CapsOff +PrntMsg 24,1," " +PrntMsg 25,1,"Press any key to continue..." +DO WHILE INKEY$="" : LOOP +CLS +END + +SUB CapsOn STATIC +' Turn Caps Lock on + ' Set segment to low memory + DEF SEG = 0 + ' Set Caps Lock on (turn on bit 6 of &H0417) + POKE &H0417,PEEK(&H0417) OR &H40 + ' Restore segment + DEF SEG +END SUB + +SUB CapsOff STATIC +' Turn Caps Lock off + DEF SEG=0 + ' Set Caps Lock off (turn off bit 6 of &H0417) + POKE &H0417,PEEK(&H0417) AND &HBF + DEF SEG +END SUB + +SUB PrntMsg (Row%, Col%, Message$) STATIC +' Print message at Row%, Col% without changing cursor + ' Save cursor position + CurRow%=CSRLIN : CurCol%=POS(0) + LOCATE Row%,Col% : PRINT Message$; + ' Restore cursor + LOCATE CurRow%,CurCol% +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/DRAW_EX.BAS b/qb45/QB45/INC/ADVR_EX/DRAW_EX.BAS new file mode 100644 index 0000000..1f36870 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/DRAW_EX.BAS @@ -0,0 +1,41 @@ +' *** DRAW_EX.BAS *** +' +' Declare procedure. +DECLARE SUB Face (Min$) +' +' Select 640 x 200 pixel high-resolution graphics screen. +SCREEN 2 +DO + CLS + ' Get string containing minutes value. + Min$ = MID$(TIME$,4,2) + ' Draw clock face. + Face Min$ + ' Wait until minute changes or a key is pressed. + DO + ' Print time at top of screen. + LOCATE 2,37 + PRINT TIME$ + ' Test for a key press. + Test$ = INKEY$ + LOOP WHILE Min$ = MID$(TIME$,4,2) AND Test$ = "" +' End program when a key is pressed. +LOOP WHILE Test$ = "" +END +' +' Draw the clock face. +SUB Face (Min$) STATIC + LOCATE 23,30 + PRINT "Press any key to end" + CIRCLE (320,100),175 + ' Convert strings to numbers. + Hr = VAL(TIME$) + Min = VAL(Min$) + ' Convert numbers to angles. + Little = 360 - (30 * Hr + Min/2) + Big = 360 - (6*Min) + ' Draw the hands. + DRAW "TA=" + VARPTR$(Little) + "NU40" + DRAW "TA=" + VARPTR$(Big) + "NU70" +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/FUNC_EX.BAS b/qb45/QB45/INC/ADVR_EX/FUNC_EX.BAS new file mode 100644 index 0000000..6069452 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/FUNC_EX.BAS @@ -0,0 +1,16 @@ +' *** FUNC_EX.BAS *** + +LINE INPUT "Enter a string: ",InString$ +PRINT "The string length is"; StrLen(InString$) + +FUNCTION StrLen(X$) + IF X$ = "" THEN + ' The length of a null string is zero. + StrLen=0 + ELSE + ' Non-null string--make a recursive call. + ' The length of a non-null string is 1 + ' plus the length of the rest of the string. + StrLen=1+StrLen(MID$(X$,2)) + END IF +END FUNCTION diff --git a/qb45/QB45/INC/ADVR_EX/OUT_EX.BAS b/qb45/QB45/INC/ADVR_EX/OUT_EX.BAS new file mode 100644 index 0000000..74c2573 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/OUT_EX.BAS @@ -0,0 +1,34 @@ +'*** OUT statement programming example +' +' Play a scale using speaker and timer +CONST WHOLE=5000!, QRTR=WHOLE/4. +CONST C=523.0, D=587.33, E=659.26, F=698.46, G=783.99, A=880.00 +CONST B=987.77, C1=1046.50 +CALL Sounds(C,QRTR) : CALL Sounds(D,QRTR) +CALL Sounds(E,QRTR) : CALL Sounds(F,QRTR) +CALL Sounds(G,QRTR) : CALL Sounds(A,QRTR) +CALL Sounds(B,QRTR) : CALL Sounds(C1,WHOLE) + +SUB Sounds (Freq!,Length!) STATIC +'Ports 66, 67, and 97 control timer and speaker +' +'Divide clock frequency by sound frequency +'to get number of "clicks" clock must produce + Clicks%=CINT(1193280!/Freq!) + LoByte%=Clicks% AND &H00FF + HiByte%=Clicks%\256 +'Tell timer that data is coming + OUT 67,182 +'Send count to timer + OUT 66,LoByte% + OUT 66,HiByte% +'Turn speaker on by setting bits 0 and 1 of PPI chip. + SpkrOn%=INP(97) OR &H03 + OUT 97,SpkrOn% +'Leave speaker on + FOR I!=1 TO Length! : NEXT I! +'Turn speaker off. + SpkrOff%=INP(97) AND &HFC + OUT 97,SpkrOff% +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/SHARE_EX.BAS b/qb45/QB45/INC/ADVR_EX/SHARE_EX.BAS new file mode 100644 index 0000000..dcb9093 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/SHARE_EX.BAS @@ -0,0 +1,29 @@ +' +' *** SHARE_EX.BAS - SHARED statement programming example +' +DEFINT A-Z +DO + INPUT "Decimal number (input number <= 0 to quit): ",Decimal + IF Decimal <= 0 THEN EXIT DO + INPUT "New base: ",Newbase + N$ = "" + PRINT Decimal "base 10 equals "; + DO WHILE Decimal > 0 + CALL Convert (Decimal,Newbase) + Decimal = Decimal\Newbase + LOOP + PRINT N$ " base" Newbase + PRINT +LOOP + +SUB Convert (D,Nb) STATIC +SHARED N$ + ' Take the remainder to find the value of the current + ' digit. + R = D MOD Nb + ' If the digit is less than ten, return a digit (0...9). + ' Otherwise, return a letter (A...Z). + IF R < 10 THEN Digit$ = CHR$(R+48) ELSE Digit$ = CHR$(R+55) + N$ = RIGHT$(Digit$,1) + N$ +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/SHELL_EX.BAS b/qb45/QB45/INC/ADVR_EX/SHELL_EX.BAS new file mode 100644 index 0000000..74e8c17 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/SHELL_EX.BAS @@ -0,0 +1,46 @@ +' *** SHELL_EX.BAS *** +' +DECLARE FUNCTION GetName$ (DirLine$) +LINE INPUT "Enter target drive and directory: ",PathSpec$ +SHELL "DIR > DIRFILE" 'Store directory listing in DIRFILE. +DO + OPEN "DIRFILE" FOR INPUT AS #1 + INPUT "Enter date (MM-DD-YY): ",MDate$ + PRINT + ' Read DIRFILE, test for input date. + DO + LINE INPUT #1, DirLine$ + ' Test directory line to see if date matches and the line + ' is not one of the special directories ( . or .. ). + IF INSTR(DirLine$,MDate$) > 0 AND LEFT$(DirLine$,1) <> "." THEN + FileSpec$ = GetName$(DirLine$) + ' Don't move temporary file. + IF FileSpec$ <> "DIRFILE" THEN + ' Build DOS command line to copy file. + DoLine$ = "COPY " + FileSpec$ + " " + PathSpec$ + PRINT DoLine$ + ' Copy file. + SHELL DoLine$ + END IF + END IF + LOOP UNTIL EOF(1) +CLOSE #1 + PRINT "New date?" + R$ = INPUT$(1) + CLS +LOOP UNTIL UCASE$(R$) <> "Y" +' KILL "DIRFILE". +END + +FUNCTION GetName$ (DirLine$) STATIC +' This function gets the file name and extension from +' the directory-listing line. + BaseName$ = RTRIM$(LEFT$(DirLine$,8)) + ' Check for extension. + ExtName$ = RTRIM$(MID$(DirLine$,10,3)) + IF ExtName$ <> "" THEN + BaseName$ = BaseName$ + "." + ExtName$ + END IF + GetName$ = BaseName$ +END FUNCTION + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/STAT_EX.BAS b/qb45/QB45/INC/ADVR_EX/STAT_EX.BAS new file mode 100644 index 0000000..edbf118 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/STAT_EX.BAS @@ -0,0 +1,49 @@ +' *** STAT2_EX.BAS - STATIC statement programming example +' +INPUT "Name of file";F1$ +INPUT "String to replace";Old$ +INPUT "Replace with";Nw$ +Rep = 0 : Num = 0 +M = LEN(Old$) +OPEN F1$ FOR INPUT AS #1 +CALL Extension +OPEN F2$ FOR OUTPUT AS #2 +DO WHILE NOT EOF(1) + LINE INPUT #1, Temp$ + CALL Search + PRINT #2, Temp$ +LOOP +CLOSE +PRINT "There were ";Rep;" substitutions in ";Num;" lines." +PRINT "Substitutions are in file ";F2$ +END + +SUB Extension STATIC +SHARED F1$,F2$ + Mark = INSTR(F1$,".") + IF Mark = 0 THEN + F2$ = F1$ + ".NEW" + ELSE + F2$ = LEFT$(F1$,Mark - 1) + ".NEW" + END IF +END SUB + +SUB Search STATIC +SHARED Temp$,Old$,Nw$,Rep,Num,M +STATIC R + Mark = INSTR(Temp$,Old$) + WHILE Mark + Part1$ = LEFT$(Temp$,Mark - 1) + Part2$ = MID$(Temp$,Mark + M) + Temp$ = Part1$ + Nw$ + Part2$ + R = R + 1 + Mark = INSTR(Temp$,Old$) + WEND + IF Rep = R THEN + EXIT SUB + ELSE + Rep = R + Num = Num + 1 + END IF +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/SUB_EX.BAS b/qb45/QB45/INC/ADVR_EX/SUB_EX.BAS new file mode 100644 index 0000000..1b8d688 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/SUB_EX.BAS @@ -0,0 +1,17 @@ +' +' *** SUB1_EX.BAS - SUB statement programming example +' +INPUT "File to be searched";F$ +INPUT "Pattern to search for";P$ +OPEN F$ FOR INPUT AS #1 +DO WHILE NOT EOF(1) + LINE INPUT #1, Test$ + CALL Linesearch(Test$,P$) +LOOP + +SUB Linesearch(Test$,P$) STATIC + Num = Num + 1 + X = INSTR(Test$,P$) + IF X > 0 THEN PRINT "Line #";Num;": ";Test$ +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/TYPE_EX.BAS b/qb45/QB45/INC/ADVR_EX/TYPE_EX.BAS new file mode 100644 index 0000000..befd895 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/TYPE_EX.BAS @@ -0,0 +1,77 @@ +' +' *** TYPE_EX.BAS -- TYPE statement programming example +' +TYPE Card + Value AS INTEGER + Suit AS STRING*9 +END TYPE + +DEFINT A-Z +' Define the Deck as a 52-element array of Cards. +DIM Deck(1 TO 52) AS Card + +' Build, shuffle, and deal the top five cards. +CALL BuildDeck(Deck()) +CALL Shuffle(Deck()) +FOR I%=1 TO 5 + CALL ShowCard(Deck(I%)) +NEXT I% + +' Build the deck--fill the array of Cards with +' appropriate values. +SUB BuildDeck(Deck(1) AS Card) STATIC +DIM Suits(4) AS STRING*9 + + Suits(1)="Hearts" + Suits(2)="Clubs" + Suits(3)="Diamonds" + Suits(4)="Spades" +' This loop controls the suit. + FOR I%=1 TO 4 + ' This loop controls the face value. + FOR J%=1 TO 13 + ' Figure out which card (1...52) you're creating. + CardNum%=J%+(I%-1)*13 + ' Place the face value and suit into the Card. + Deck(CardNum%).Value=J% + Deck(CardNum%).Suit=Suits(I%) + NEXT J% + NEXT I% + +END SUB + +' Shuffle a deck (an array containing Card elements). +SUB Shuffle(Deck(1) AS Card) STATIC + + RANDOMIZE TIMER +' Shuffle by transposing 1000 randomly selected pairs of cards. + FOR I%=1 TO 1000 + CardOne%=INT(52*RND+1) + CardTwo%=INT(52*RND+1) + ' Notice that SWAP works on arrays of user types. + SWAP Deck(CardOne%),Deck(CardTwo%) + NEXT I% + +END SUB + +' Display a single card by converting and printing the +' face value and the suit. +SUB ShowCard (SingleCard AS Card) STATIC + + SELECT CASE SingleCard.Value + CASE 13 + PRINT "King "; + CASE 12 + PRINT "Queen"; + CASE 11 + PRINT "Jack "; + CASE 1 + PRINT "Ace "; + CASE ELSE + PRINT USING " ## ";SingleCard.Value; + END SELECT + + PRINT " ";SingleCard.Suit + +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/UBO_EX.BAS b/qb45/QB45/INC/ADVR_EX/UBO_EX.BAS new file mode 100644 index 0000000..c9c38b0 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/UBO_EX.BAS @@ -0,0 +1,22 @@ +DECLARE SUB PRNTMAT (A!()) +' +' *** UBO_EX.BAS - UBOUND and LBOUND programming examples +' +DIM A(0 TO 3, 0 TO 3) +FOR I% = 0 TO 3 + FOR J% = 0 TO 3 + A(I%, J%) = I% + J% + NEXT J% +NEXT I% +CALL PRNTMAT(A()) +END + +SUB PRNTMAT (A()) STATIC + FOR I% = LBOUND(A, 1) TO UBOUND(A, 1) + FOR J% = LBOUND(A, 2) TO UBOUND(A, 2) + PRINT A(I%, J%); " "; + NEXT J% + PRINT : PRINT + NEXT I% +END SUB + diff --git a/qb45/QB45/INC/ADVR_EX/UCASE_EX.BAS b/qb45/QB45/INC/ADVR_EX/UCASE_EX.BAS new file mode 100644 index 0000000..c625008 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/UCASE_EX.BAS @@ -0,0 +1,34 @@ +' +' *** UCASE_EX.BAS -- UCASE$ function programming example +' +DEFINT A-Z + +FUNCTION YesQues(Prompt$,Row,Col) STATIC + OldRow=CSRLIN + OldCol=POS(0) + ' Print prompt at Row, Col. + LOCATE Row,Col : PRINT Prompt$ "(Y/N):"; + DO + ' Get the user to press a key. + DO + Resp$=INKEY$ + LOOP WHILE Resp$="" + Resp$=UCASE$(Resp$) + ' Test to see if it's yes or no. + IF Resp$="Y" OR Resp$="N" THEN + EXIT DO + ELSE + BEEP + END IF + LOOP + ' Print the response on the line. + PRINT Resp$; + ' Move the cursor back to the old position. + LOCATE OldRow,OldCol + ' Return a Boolean value by returning the result of a test. + YesQues=(Resp$="Y") +END FUNCTION + +DO +LOOP WHILE NOT YesQues("Do you know the frequency?",12,5) + \ No newline at end of file diff --git a/qb45/QB45/INC/ADVR_EX/WINDO_EX.BAS b/qb45/QB45/INC/ADVR_EX/WINDO_EX.BAS new file mode 100644 index 0000000..074f913 --- /dev/null +++ b/qb45/QB45/INC/ADVR_EX/WINDO_EX.BAS @@ -0,0 +1,28 @@ +' +' *** WINDO_EX.BAS -- WINDOW statement programming example +' +PRINT "Press ENTER to start." +INPUT;"",A$ +SCREEN 1 : COLOR 7 'Grey screen. +X = 500 : Xdelta = 50 + +DO + DO WHILE X < 525 AND X > 50 + X = X + Xdelta 'Change window size. + CALL Zoom(X) + FOR I = 1 TO 1000 'Delay loop. + IF INKEY$ <> "" THEN END 'Stop if key pressed. + NEXT + LOOP + X = X - Xdelta + Xdelta = -Xdelta 'Reverse size change. +LOOP + +SUB Zoom(X) STATIC + CLS + WINDOW (-X,-X)-(X,X) 'Define new window. + LINE (-X,-X)-(X,X),1,B 'Draw window border. + CIRCLE (0,0),60,1,,,.5 'Draw ellipse with x-radius 60. + PAINT (0,0),1 'Paint ellipse. +END SUB + \ No newline at end of file diff --git a/qb45/QB45/INC/DEMO1.BAS b/qb45/QB45/INC/DEMO1.BAS new file mode 100644 index 0000000..f17ea4d --- /dev/null +++ b/qb45/QB45/INC/DEMO1.BAS @@ -0,0 +1,56 @@ +5 DEFINT A-Z +10 ' BASICA/GWBASIC Version of Sound Effects Demo Program +15 ' +20 ' Sound effect menu +25 Q = 2 +30 WHILE Q >= 1 +35 CLS +40 PRINT "Sound effects": PRINT +45 COLOR 15, 0: PRINT " B"; : COLOR 7, 0: PRINT "ouncing" +50 COLOR 15, 0: PRINT " F"; : COLOR 7, 0: PRINT "alling" +55 COLOR 15, 0: PRINT " K"; : COLOR 7, 0: PRINT "laxon" +60 COLOR 15, 0: PRINT " S"; : COLOR 7, 0: PRINT "iren" +65 COLOR 15, 0: PRINT " Q"; : COLOR 7, 0: PRINT "uit" +70 PRINT : PRINT "Select: "; +75 Q$ = INPUT$(1): Q = INSTR("BFKSQbfksq", Q$) ' Get valid key +80 IF Q = 0 GOTO 75 +85 CLS ' Take action based on key +90 ON Q GOSUB 100, 200, 300, 400, 500, 100, 200, 300, 400, 500 +95 WEND +100 ' Bounce - loop two sounds down at decreasing time intervals +105 HTONE = 32767: LTONE = 246 +110 PRINT "Bouncing . . ." +115 FOR COUNT = 60 TO 1 STEP -2 +120 SOUND LTONE - COUNT / 2, COUNT / 20 +125 SOUND HTONE, COUNT / 15 +130 NEXT COUNT +135 RETURN +200 ' Fall - loop down from a high sound to a low sound +205 HTONE = 2000: LTONE = 550: DELAY = 500 +210 PRINT "Falling . . ." +215 FOR COUNT = HTONE TO LTONE STEP -10 +220 SOUND COUNT, DELAY / COUNT +225 NEXT COUNT +230 RETURN +300 ' Klaxon - alternate two sounds until a key is pressed +305 HTONE = 987: LTONE = 329 +310 PRINT "Oscillating . . ." +315 PRINT " . . . press any key to end." +320 WHILE INKEY$ = "" +325 SOUND HTONE, 5: SOUND LTONE, 5 +330 WEND +335 RETURN +400 ' Siren - loop a sound from low to high to low +405 HTONE = 780: RANGE = 650 +410 PRINT "Wailing . . ." +415 PRINT " . . . press any key to end." +420 WHILE INKEY$ = "" +425 FOR COUNT = RANGE TO -RANGE STEP -4 +430 SOUND HTONE - ABS(COUNT), .3 +435 COUNT = COUNT - 2 / RANGE +440 NEXT COUNT +445 WEND +450 RETURN +500 ' Quit +505 END + diff --git a/qb45/QB45/INC/DEMO2.BAS b/qb45/QB45/INC/DEMO2.BAS new file mode 100644 index 0000000..9c41550 --- /dev/null +++ b/qb45/QB45/INC/DEMO2.BAS @@ -0,0 +1,76 @@ +DEFINT A-Z +' QB2 Version of Sound Effects Demo Program +' (works under most other BASIC compilers) + +' Sound effects menu +WHILE Q$ <> "Q" + CLS + PRINT "Sound effects": PRINT + COLOR 15, 0: PRINT " B"; : COLOR 7, 0: PRINT "ouncing" + COLOR 15, 0: PRINT " F"; : COLOR 7, 0: PRINT "alling" + COLOR 15, 0: PRINT " K"; : COLOR 7, 0: PRINT "laxon" + COLOR 15, 0: PRINT " S"; : COLOR 7, 0: PRINT "iren" + COLOR 15, 0: PRINT " Q"; : COLOR 7, 0: PRINT "uit" + PRINT : PRINT "Select: "; + + ' Get valid key + Q$ = " " + WHILE INSTR("BFKSQbfksq", Q$) = 0 + Q$ = INPUT$(1) + WEND + + ' Take action based on key + CLS + IF Q$ = "B" OR Q$ = "b" THEN + PRINT "Bouncing . . . " + CALL Bounce(32767, 246) + ELSEIF Q$ = "F" OR Q$ = "f" THEN + PRINT "Falling . . . " + CALL Fall(2000, 550, 500) + ELSEIF Q$ = "S" OR Q$ = "s" THEN + PRINT "Wailing . . ." + PRINT " . . . press any key to end." + CALL Siren(780, 650) + ELSEIF Q$ = "K" OR Q$ = "k" THEN + PRINT "Oscillating . . ." + PRINT " . . . press any key to end." + CALL Klaxon(987, 329) + ELSEIF Q$ = "q" THEN + Q$ = "Q" + END IF +WEND +END + +' Loop two sounds down at decreasing time intervals +SUB Bounce (Hi, Low) STATIC + FOR Count = 60 TO 1 STEP -2 + SOUND Low - Count / 2, Count / 20 + SOUND Hi, Count / 15 + NEXT +END SUB + +' Loop down from a high sound to a low sound +SUB Fall (Hi, Low, Del) STATIC + FOR Count = Hi TO Low STEP -10 + SOUND Count, Del / Count + NEXT +END SUB + +' Alternate two sounds until a key is pressed +SUB Klaxon (Hi, Low) STATIC + WHILE INKEY$ = "" + SOUND Hi, 5 + SOUND Low, 5 + WEND +END SUB + +' Loop a sound from low to high to low +SUB Siren (Hi, Rng) STATIC + WHILE INKEY$ = "" + FOR Count = Rng TO -Rng STEP -4 + SOUND Hi - ABS(Count), .3 + Count = Count - 2 / Rng + NEXT + WEND +END SUB + diff --git a/qb45/QB45/INC/DEMO3.BAS b/qb45/QB45/INC/DEMO3.BAS new file mode 100644 index 0000000..f91acd7 --- /dev/null +++ b/qb45/QB45/INC/DEMO3.BAS @@ -0,0 +1,78 @@ +DECLARE SUB Bounce (Hi%, Low%) +DECLARE SUB Fall (Hi%, Low%, Del%) +DECLARE SUB Siren (Hi%, Range%) +DECLARE SUB Klaxon (Hi%, Low%) +DEFINT A-Z + +' QB 4.5 Version of Sound Effects Demo Program + +' Sound effects menu +DO + CLS + PRINT "Sound effects": PRINT + COLOR 15, 0: PRINT " B"; : COLOR 7, 0: PRINT "ouncing" + COLOR 15, 0: PRINT " F"; : COLOR 7, 0: PRINT "alling" + COLOR 15, 0: PRINT " K"; : COLOR 7, 0: PRINT "laxon" + COLOR 15, 0: PRINT " S"; : COLOR 7, 0: PRINT "iren" + COLOR 15, 0: PRINT " Q"; : COLOR 7, 0: PRINT "uit" + PRINT : PRINT "Select: "; + + ' Get valid key + DO + Q$ = UCASE$(INPUT$(1)) + LOOP WHILE INSTR("BFKSQ", Q$) = 0 + + ' Take action based on key + CLS + SELECT CASE Q$ + CASE IS = "B" + PRINT "Bouncing . . . " + Bounce 32767, 246 + CASE IS = "F" + PRINT "Falling . . . " + Fall 2000, 550, 500 + CASE IS = "S" + PRINT "Wailing . . ." + PRINT " . . . press any key to end." + Siren 780, 650 + CASE IS = "K" + PRINT "Oscillating . . ." + PRINT " . . . press any key to end." + Klaxon 987, 329 + CASE ELSE + END SELECT +LOOP UNTIL Q$ = "Q" +END + +' Loop two sounds down at decreasing time intervals +SUB Bounce (Hi%, Low%) STATIC + FOR Count = 60 TO 1 STEP -2 + SOUND Low - Count / 2, Count / 20 + SOUND Hi, Count / 15 + NEXT Count +END SUB + +' Loop down from a high sound to a low sound +SUB Fall (Hi%, Low%, Del%) STATIC + FOR Count = Hi TO Low STEP -10 + SOUND Count, Del / Count + NEXT Count +END SUB + +' Alternate two sounds until a key is pressed +SUB Klaxon (Hi%, Low%) STATIC + DO WHILE INKEY$ = "" + SOUND Hi, 5 + SOUND Low, 5 + LOOP +END SUB + +' Loop a sound from low to high to low +SUB Siren (Hi%, Range%) + DO WHILE INKEY$ = "" + FOR Count = Range TO -Range STEP -4 + SOUND Hi - ABS(Count), .3 + Count = Count - 2 / Range + NEXT Count + LOOP +END SUB diff --git a/qb45/QB45/INC/EXAMPLES/BALLPSET.BAS b/qb45/QB45/INC/EXAMPLES/BALLPSET.BAS new file mode 100644 index 0000000..b6bd60c --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/BALLPSET.BAS @@ -0,0 +1,103 @@ +DECLARE FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom) + +SCREEN 2 +CLS + +' Define a viewport and draw a border around it: +VIEW (20, 10)-(620, 190), , 1 + +CONST PI = 3.141592653589# + +' Redefine the coordinates of the viewport with logical +' coordinates: +WINDOW (-3.15, -.14)-(3.56, 1.01) + +' Arrays in program are now dynamic: +' $DYNAMIC + +' Calculate the logical coordinates for the top and bottom of a +' rectangle large enough to hold the image that will be drawn +' with CIRCLE and PAINT: +WLeft = -.21 +WRight = .21 +WTop = .07 +WBottom = -.07 + +' Call the GetArraySize function, passing it the rectangle's +' logical coordinates: +ArraySize% = GetArraySize(WLeft, WRight, WTop, WBottom) + +DIM Array(1 TO ArraySize%) AS INTEGER + +' Draw and paint the circle: +CIRCLE (0, 0), .18 +PAINT (0, 0) + +' Store the rectangle in Array: +GET (WLeft, WTop)-(WRight, WBottom), Array +CLS + +' Draw a box and fill it with a pattern: +LINE (-3, .8)-(3.4, .2), , B +Pattern$ = CHR$(126) + CHR$(0) + CHR$(126) + CHR$(126) +PAINT (0, .5), Pattern$ + +LOCATE 21, 29 +PRINT "Press any key to end" + +' Initialize loop variables: +StepSize = .02 +StartLoop = -PI +Decay = 1 + +DO + EndLoop = -StartLoop + FOR X = StartLoop TO EndLoop STEP StepSize + + ' Each time the ball "bounces" (hits the bottom of the + ' viewport), the Decay variable gets smaller, making the + ' height of the next bounce smaller: + Y = ABS(COS(X)) * Decay - .14 + IF Y < -.13 THEN Decay = Decay * .9 + + ' Stop if a key pressed or if Decay is less than .01: + Esc$ = INKEY$ + IF Esc$ <> "" OR Decay < .01 THEN EXIT FOR + + ' Put the image on the screen. The StepSize offset is + ' smaller than the border around the circle, so each time + ' the image moves, it erases any traces left from the + ' previous PUT (it also erases anything else on the + ' screen): + PUT (X, Y), Array, PSET + NEXT X + + ' Reverse direction: + StepSize = -StepSize + StartLoop = -StartLoop +LOOP UNTIL Esc$ <> "" OR Decay < .01 + +Pause$ = INPUT$(1) +END +REM $STATIC +REM $DYNAMIC +FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom) STATIC + + ' Map the logical coordinates passed to this function to + ' their physical-coordinate equivalents: + VLeft = PMAP(WLeft, 0) + VRight = PMAP(WRight, 0) + VTop = PMAP(WTop, 1) + VBottom = PMAP(WBottom, 1) + + ' Calculate the height and width in pixels of the + ' enclosing rectangle: + RectHeight = ABS(VBottom - VTop) + 1 + RectWidth = ABS(VRight - VLeft) + 1 + + ' Calculate size in bytes of array: + ByteSize = 4 + RectHeight * INT((RectWidth + 7) / 8) + + ' Array is integer, so divide bytes by two: + GetArraySize = ByteSize \ 2 + 1 +END FUNCTION diff --git a/qb45/QB45/INC/EXAMPLES/BALLXOR.BAS b/qb45/QB45/INC/EXAMPLES/BALLXOR.BAS new file mode 100644 index 0000000..11635a8 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/BALLXOR.BAS @@ -0,0 +1,81 @@ +DECLARE FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom) + +SCREEN 2 +CLS +VIEW (20, 10)-(620, 190), , 1 + +CONST PI = 3.141592653589# + +WINDOW (-3.15, -.14)-(3.56, 1.01) + +' $DYNAMIC +' The rectangle is smaller than the one in the previous +' program, which means Array is also smaller: +WLeft = -.18 +WRight = .18 +WTop = .05 +WBottom = -.05 + +ArraySize% = GetArraySize(WLeft, WRight, WTop, WBottom) + +DIM Array(1 TO ArraySize%) AS INTEGER + +CIRCLE (0, 0), .18 +PAINT (0, 0) + +GET (WLeft, WTop)-(WRight, WBottom), Array +CLS + +LINE (-3, .8)-(3.4, .2), , B +Pattern$ = CHR$(126) + CHR$(0) + CHR$(126) + CHR$(126) +PAINT (0, .5), Pattern$ + +LOCATE 21, 29 +PRINT "Press any key to end" + +StepSize = .02 +StartLoop = -PI +Decay = 1 + +DO + EndLoop = -StartLoop + FOR X = StartLoop TO EndLoop STEP StepSize + Y = ABS(COS(X)) * Decay - .14 + + ' The first PUT statement places the image on + ' the screen: + PUT (X, Y), Array, XOR + + ' An empty FOR...NEXT loop to delay the program and + ' reduce image flicker: + FOR I = 1 TO 5: NEXT I + + IF Y < -.13 THEN Decay = Decay * .9 + Esc$ = INKEY$ + IF Esc$ <> "" OR Decay < .01 THEN EXIT FOR + + ' The second PUT statement erases the image and + ' restores the background: + PUT (X, Y), Array, XOR + NEXT X + + StepSize = -StepSize + StartLoop = -StartLoop +LOOP UNTIL Esc$ <> "" OR Decay < .01 + +Pause$ = INPUT$(1) +END +REM $STATIC +REM $DYNAMIC +FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom) STATIC + VLeft = PMAP(WLeft, 0) + VRight = PMAP(WRight, 0) + VTop = PMAP(WTop, 1) + VBottom = PMAP(WBottom, 1) + + RectHeight = ABS(VBottom - VTop) + 1 + RectWidth = ABS(VRight - VLeft) + 1 + + ByteSize = 4 + RectHeight * INT((RectWidth + 7) / 8) + GetArraySize = ByteSize \ 2 + 1 +END FUNCTION diff --git a/qb45/QB45/INC/EXAMPLES/BAR.BAS b/qb45/QB45/INC/EXAMPLES/BAR.BAS new file mode 100644 index 0000000..8770d8f --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/BAR.BAS @@ -0,0 +1,219 @@ +' Define type for the titles: +TYPE TitleType + MainTitle AS STRING * 40 + XTitle AS STRING * 40 + YTitle AS STRING * 18 +END TYPE + +DECLARE SUB InputTitles (T AS TitleType) +DECLARE FUNCTION DrawGraph$ (T AS TitleType, Label$(), Value!(), N%) +DECLARE FUNCTION InputData% (Label$(), Value!()) + +' Variable declarations for titles and bar data: +DIM Titles AS TitleType, Label$(1 TO 5), Value(1 TO 5) + +CONST FALSE = 0, TRUE = NOT FALSE + +DO + InputTitles Titles + N% = InputData%(Label$(), Value()) + IF N% <> FALSE THEN + NewGraph$ = DrawGraph$(Titles, Label$(), Value(), N%) + END IF +LOOP WHILE NewGraph$ = "Y" + +END +REM $STATIC +' +' ========================== DRAWGRAPH ========================= +' Draws a bar graph from the data entered in the INPUTTITLES +' and INPUTDATA procedures. +' ============================================================== +' +FUNCTION DrawGraph$ (T AS TitleType, Label$(), Value(), N%) STATIC + + ' Set size of graph: + CONST GRAPHTOP = 24, GRAPHBOTTOM = 171 + CONST GRAPHLEFT = 48, GRAPHRIGHT = 624 + CONST YLENGTH = GRAPHBOTTOM - GRAPHTOP + + ' Calculate max/min values: + YMax = 0 + YMin = 0 + FOR I% = 1 TO N% + IF Value(I%) < YMin THEN YMin = Value(I%) + IF Value(I%) > YMax THEN YMax = Value(I%) + NEXT I% + + ' Calculate width of bars and space between them: + BarWidth = (GRAPHRIGHT - GRAPHLEFT) / N% + BarSpace = .2 * BarWidth + BarWidth = BarWidth - BarSpace + + SCREEN 2 + CLS + + ' Draw y axis: + LINE (GRAPHLEFT, GRAPHTOP)-(GRAPHLEFT, GRAPHBOTTOM), 1 + + ' Draw main graph title: + Start% = 44 - (LEN(RTRIM$(T.MainTitle)) / 2) + LOCATE 2, Start% + PRINT RTRIM$(T.MainTitle); + + ' Annotate Y axis: + Start% = CINT(13 - LEN(RTRIM$(T.YTitle)) / 2) + FOR I% = 1 TO LEN(RTRIM$(T.YTitle)) + LOCATE Start% + I% - 1, 1 + PRINT MID$(T.YTitle, I%, 1); + NEXT I% + + ' Calculate scale factor so labels aren't bigger than 4 digits: + IF ABS(YMax) > ABS(YMin) THEN + Power = YMax + ELSE + Power = YMin + END IF + Power = CINT(LOG(ABS(Power) / 100) / LOG(10)) + IF Power < 0 THEN Power = 0 + + ' Scale min and max down: + ScaleFactor = 10 ^ Power + YMax = CINT(YMax / ScaleFactor) + YMin = CINT(YMin / ScaleFactor) + + ' If power isn't zero then put scale factor on chart: + IF Power <> 0 THEN + LOCATE 3, 2 + PRINT "x 10^"; LTRIM$(STR$(Power)) + END IF + + ' Put tic mark and number for Max point on Y axis: + LINE (GRAPHLEFT - 3, GRAPHTOP)-STEP(3, 0) + LOCATE 4, 2 + PRINT USING "####"; YMax + + ' Put tic mark and number for Min point on Y axis: + LINE (GRAPHLEFT - 3, GRAPHBOTTOM)-STEP(3, 0) + LOCATE 22, 2 + PRINT USING "####"; YMin + + ' Scale min and max back up for charting calculations: + YMax = YMax * ScaleFactor + YMin = YMin * ScaleFactor + + ' Annotate X axis: + Start% = 44 - (LEN(RTRIM$(T.XTitle)) / 2) + LOCATE 25, Start% + PRINT RTRIM$(T.XTitle); + + ' Calculate the pixel range for the Y axis: + YRange = YMax - YMin + + ' Define a diagonally striped pattern: + Tile$ = CHR$(1) + CHR$(2) + CHR$(4) + CHR$(8) + CHR$(16) + CHR$(32) + CHR$(64) + CHR$(128) + + ' Draw a zero line if appropriate: + IF YMin < 0 THEN + Bottom = GRAPHBOTTOM - ((-YMin) / YRange * YLENGTH) + LOCATE INT((Bottom - 1) / 8) + 1, 5 + PRINT "0"; + ELSE + Bottom = GRAPHBOTTOM + END IF + + ' Draw x axis: + LINE (GRAPHLEFT - 3, Bottom)-(GRAPHRIGHT, Bottom) + + ' Draw bars and labels: + Start% = GRAPHLEFT + (BarSpace / 2) + FOR I% = 1 TO N% + + ' Draw a bar label: + BarMid = Start% + (BarWidth / 2) + CharMid = INT((BarMid - 1) / 8) + 1 + LOCATE 23, CharMid - INT(LEN(RTRIM$(Label$(I%))) / 2) + PRINT Label$(I%); + + ' Draw the bar and fill it with the striped pattern: + BarHeight = (Value(I%) / YRange) * YLENGTH + LINE (Start%, Bottom)-STEP(BarWidth, -BarHeight), , B + PAINT (BarMid, Bottom - (BarHeight / 2)), Tile$, 1 + + Start% = Start% + BarWidth + BarSpace + NEXT I% + + LOCATE 1, 1, 1 + PRINT "New graph? "; + DrawGraph$ = UCASE$(INPUT$(1)) + +END FUNCTION +' +' ========================= INPUTDATA ======================== +' Gets input for the bar labels and their values +' ============================================================ +' +FUNCTION InputData% (Label$(), Value()) STATIC + + ' Initialize the number of data values: + NumData% = 0 + + ' Print data-entry instructions: + CLS + PRINT "Enter data for up to 5 bars:" + PRINT " * Enter the label and value for each bar." + PRINT " * Values can be negative." + PRINT " * Enter a blank label to stop." + PRINT + PRINT "After viewing the graph, press any key "; + PRINT "to end the program." + + ' Accept data until blank label or 5 entries: + Done% = FALSE + DO + NumData% = NumData% + 1 + PRINT + PRINT "Bar("; LTRIM$(STR$(NumData%)); "):" + INPUT ; " Label? ", Label$(NumData%) + + ' Only input value if label isn't blank: + IF Label$(NumData%) <> "" THEN + LOCATE , 35 + INPUT "Value? ", Value(NumData%) + + ' If label was blank, decrement data counter and + ' set Done flag equal to TRUE: + ELSE + NumData% = NumData% - 1 + Done% = TRUE + END IF + LOOP UNTIL (NumData% = 5) OR Done% + + ' Return the number of data values input: + InputData% = NumData% + +END FUNCTION +' +' ======================= INPUTTITLES ======================== +' Accepts input for the three different graph titles +' ============================================================ +' +SUB InputTitles (T AS TitleType) STATIC + + ' Set text screen: + SCREEN 0, 0 + + ' Input Titles + DO + CLS + INPUT "Enter main graph title: ", T.MainTitle + INPUT "Enter X-Axis title : ", T.XTitle + INPUT "Enter Y-Axis title : ", T.YTitle + + ' Check to see if titles are OK: + LOCATE 7, 1 + PRINT "OK (Y to continue, N to change)? "; + LOCATE , , 1 + OK$ = UCASE$(INPUT$(1)) + LOOP UNTIL OK$ = "Y" +END SUB diff --git a/qb45/QB45/INC/EXAMPLES/CAL.BAS b/qb45/QB45/INC/EXAMPLES/CAL.BAS new file mode 100644 index 0000000..d8eb9fb --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/CAL.BAS @@ -0,0 +1,176 @@ +DEFINT A-Z ' Default variable type is integer + +' Define a data type for the names of the months and the +' number of days in each: +TYPE MonthType + Number AS INTEGER ' Number of days in the month + MName AS STRING * 9 ' Name of the month +END TYPE + +' Declare procedures used: +DECLARE FUNCTION IsLeapYear% (N%) +DECLARE FUNCTION GetInput% (Prompt$, Row%, LowVal%, HighVal%) + +DECLARE SUB PrintCalendar (Year%, Month%) +DECLARE SUB ComputeMonth (Year%, Month%, StartDay%, TotalDays%) + +DIM MonthData(1 TO 12) AS MonthType + +' Initialize month definitions from DATA statements below: +FOR I = 1 TO 12 + READ MonthData(I).MName, MonthData(I).Number +NEXT + +' Main loop, repeat for as many months as desired: +DO + + CLS + + ' Get year and month as input: + Year = GetInput("Year (1899 to 2099): ", 1, 1899, 2099) + Month = GetInput("Month (1 to 12): ", 2, 1, 12) + + ' Print the calendar: + PrintCalendar Year, Month + + ' Another Date? + LOCATE 13, 1 ' Locate in 13th row, 1st column + PRINT "New Date? "; ' Keep cursor on same line + LOCATE , , 1, 0, 13 ' Turn cursor on and make it one + ' character high + Resp$ = INPUT$(1) ' Wait for a key press + PRINT Resp$ ' Print the key pressed + +LOOP WHILE UCASE$(Resp$) = "Y" +END + +' Data for the months of a year: +DATA January, 31, February, 28, March, 31 +DATA April, 30, May, 31, June, 30, July, 31, August, 31 +DATA September, 30, October, 31, November, 30, December, 31 +' +' ====================== COMPUTEMONTH ======================== +' Computes the first day and the total days in a month. +' ============================================================ +' +SUB ComputeMonth (Year, Month, StartDay, TotalDays) STATIC + SHARED MonthData() AS MonthType + CONST LEAP = 366 MOD 7 + CONST NORMAL = 365 MOD 7 + + ' Calculate total number of days (NumDays) since 1/1/1899. + + ' Start with whole years: + NumDays = 0 + FOR I = 1899 TO Year - 1 + IF IsLeapYear(I) THEN ' If year is leap, add + NumDays = NumDays + LEAP ' 366 MOD 7. + ELSE ' If normal year, add + NumDays = NumDays + NORMAL ' 365 MOD 7. + END IF + NEXT + + ' Next, add in days from whole months: + FOR I = 1 TO Month - 1 + NumDays = NumDays + MonthData(I).Number + NEXT + + ' Set the number of days in the requested month: + TotalDays = MonthData(Month).Number + + ' Compensate if requested year is a leap year: + IF IsLeapYear(Year) THEN + + ' If after February, add one to total days: + IF Month > 2 THEN + NumDays = NumDays + 1 + + ' If February, add one to the month's days: + ELSEIF Month = 2 THEN + TotalDays = TotalDays + 1 + + END IF + END IF + + ' 1/1/1899 was a Sunday, so calculating "NumDays MOD 7" + ' gives the day of week (Sunday = 0, Monday = 1, Tuesday = 2, + ' and so on) for the first day of the input month: + StartDay = NumDays MOD 7 +END SUB +' +' ======================== GETINPUT ========================== +' Prompts for input, then tests for a valid range. +' ============================================================ +' +FUNCTION GetInput (Prompt$, Row, LowVal, HighVal) STATIC + + ' Locate prompt at specified row, turn cursor on and + ' make it one character high: + LOCATE Row, 1, 1, 0, 13 + PRINT Prompt$; + + ' Save column position: + Column = POS(0) + + ' Input value until it's within range: + DO + LOCATE Row, Column ' Locate cursor at end of prompt + PRINT SPACE$(10) ' Erase anything already there + LOCATE Row, Column ' Relocate cursor at end of prompt + INPUT "", Value ' Input value with no prompt + LOOP WHILE (Value < LowVal OR Value > HighVal) + + ' Return valid input as value of function: + GetInput = Value + +END FUNCTION +' +' ====================== ISLEAPYEAR ========================== +' Determines if a year is a leap year or not. +' ============================================================ +' +FUNCTION IsLeapYear (N) STATIC + + ' If the year is evenly divisible by 4 and not divisible + ' by 100, or if the year is evenly divisible by 400, then + ' it's a leap year: + IsLeapYear = (N MOD 4 = 0 AND N MOD 100 <> 0) OR (N MOD 400 = 0) +END FUNCTION +' +' ===================== PRINTCALENDAR ======================== +' Prints a formatted calendar given the year and month. +' ============================================================ +' +SUB PrintCalendar (Year, Month) STATIC +SHARED MonthData() AS MonthType + + ' Compute starting day (Su M Tu ...) and total days + ' for the month: + ComputeMonth Year, Month, StartDay, TotalDays + CLS + Header$ = RTRIM$(MonthData(Month).MName) + "," + STR$(Year) + + ' Calculates location for centering month and year: + LeftMargin = (35 - LEN(Header$)) \ 2 + + ' Print header: + PRINT TAB(LeftMargin); Header$ + PRINT + PRINT "Su M Tu W Th F Sa" + PRINT + + ' Recalculate and print tab to the first day + ' of the month (Su M Tu ...): + LeftMargin = 5 * StartDay + 1 + PRINT TAB(LeftMargin); + + ' Print out the days of the month: + FOR I = 1 TO TotalDays + PRINT USING "## "; I; + + ' Advance to the next line when the cursor + ' is past column 32: + IF POS(0) > 32 THEN PRINT + NEXT + +END SUB diff --git a/qb45/QB45/INC/EXAMPLES/CHECK.BAS b/qb45/QB45/INC/EXAMPLES/CHECK.BAS new file mode 100644 index 0000000..3c9ae08 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/CHECK.BAS @@ -0,0 +1,60 @@ +DIM Amount(1 TO 100) +CONST FALSE = 0, TRUE = NOT FALSE + +' Get account's starting balance: +CLS +INPUT "Type starting balance, then press : ", Balance + +' Get transactions. Continue accepting input until the +' input is zero for a transaction, or until 100 +' transactions have been entered: +FOR TransacNum% = 1 TO 100 + PRINT TransacNum%; + PRINT ") Enter transaction amount (0 to end): "; + INPUT "", Amount(TransacNum%) + IF Amount(TransacNum%) = 0 THEN + TransacNum% = TransacNum% - 1 + EXIT FOR + END IF +NEXT + +' Sort transactions in ascending order, +' using a "bubble sort": +Limit% = TransacNum% +DO + Swaps% = FALSE + FOR I% = 1 TO (Limit% - 1) + + ' If two adjacent elements are out of order, switch + ' those elements: + IF Amount(I%) < Amount(I% + 1) THEN + SWAP Amount(I%), Amount(I% + 1) + Swaps% = I% + END IF + NEXT I% + + ' Sort on next pass only to where the last switch was made: + IF Swaps% THEN Limit% = Swaps% + +' Sort until no elements are exchanged: +LOOP WHILE Swaps% + +' Print the sorted transaction array. If a transaction +' is greater than zero, print it as a "CREDIT"; if a +' transaction is less than zero, print it as a "DEBIT": +FOR I% = 1 TO TransacNum% + IF Amount(I%) > 0 THEN + PRINT USING "CREDIT: $$#####.##"; Amount(I%) + ELSEIF Amount(I%) < 0 THEN + PRINT USING "DEBIT: $$#####.##"; Amount(I%) + END IF + + ' Update balance: + Balance = Balance + Amount(I%) +NEXT I% + +' Print the final balance: +PRINT +PRINT "--------------------------" +PRINT USING "Final Total: $$######.##"; Balance +END diff --git a/qb45/QB45/INC/EXAMPLES/COLORS.BAS b/qb45/QB45/INC/EXAMPLES/COLORS.BAS new file mode 100644 index 0000000..26161ca --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/COLORS.BAS @@ -0,0 +1,45 @@ +SCREEN 1 + +Esc$ = CHR$(27) + +' Draw three boxes and paint the interior of each +' box with a different color: +FOR ColorVal = 1 TO 3 + LINE (X, Y)-STEP(60, 50), ColorVal, BF + X = X + 61 + Y = Y + 51 +NEXT ColorVal + +LOCATE 21, 1 +PRINT "Press ESC to end." +PRINT "Press any other key to continue." + +' Restrict additional printed output to the twenty-third line: +VIEW PRINT 23 TO 23 + +DO + PaletteVal = 1 + DO + + ' PaletteVal is either one or zero: + PaletteVal = 1 - PaletteVal + + ' Set the background color and choose the palette: + COLOR BackGroundVal, PaletteVal + PRINT "Background ="; BackGroundVal; "Palette ="; PaletteVal; + + Pause$ = INPUT$(1) ' Wait for a keystroke. + PRINT + + ' Exit the loop if both palettes have been shown, + ' or if the user pressed the ESC key: + LOOP UNTIL PaletteVal = 1 OR Pause$ = Esc$ + + BackGroundVal = BackGroundVal + 1 + +' Exit this loop if all sixteen background colors have been +' shown, or if the user pressed the ESC key: +LOOP UNTIL BackGroundVal > 15 OR Pause$ = Esc$ + +SCREEN 0 ' Restore text mode and +WIDTH 80 ' eighty-column screen width. diff --git a/qb45/QB45/INC/EXAMPLES/CRLF.BAS b/qb45/QB45/INC/EXAMPLES/CRLF.BAS new file mode 100644 index 0000000..8d4de88 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/CRLF.BAS @@ -0,0 +1,139 @@ +DEFINT A-Z ' Default variable type is integer + +' The Backup$ FUNCTION makes a backup file with +' the same base as FileName$, plus a .BAK extension: +DECLARE FUNCTION Backup$ (FileName$) + +' Initialize symbolic constants and variables: +CONST FALSE = 0, TRUE = NOT FALSE + +CarReturn$ = CHR$(13) +LineFeed$ = CHR$(10) + +DO + CLS + + ' Get the name of the file to change: + INPUT "Which file do you want to convert"; OutFile$ + + InFile$ = Backup$(OutFile$) ' Get the backup file's name. + + ON ERROR GOTO ErrorHandler ' Turn on error trapping. + + NAME OutFile$ AS InFile$ ' Copy the input file to the + ' backup file. + + ON ERROR GOTO 0 ' Turn off error trapping. + + ' Open the backup file for input and the old file + ' for output: + OPEN InFile$ FOR INPUT AS #1 + OPEN OutFile$ FOR OUTPUT AS #2 + + ' The PrevCarReturn variable is a flag that is set to TRUE + ' whenever the program reads a carriage-return character: + PrevCarReturn = FALSE + + ' Read from the input file until reaching + ' the end of the file: + DO UNTIL EOF(1) + + ' Not the end of the file, so read a character: + FileChar$ = INPUT$(1, #1) + + SELECT CASE FileChar$ + + CASE CarReturn$ ' The character is a CR. + + ' If the previous character was also a + ' CR, put a LF before the character: + IF PrevCarReturn THEN + FileChar$ = LineFeed$ + FileChar$ + END IF + + ' In any case, set the PrevCarReturn + ' variable to TRUE: + PrevCarReturn = TRUE + + CASE LineFeed$ ' The character is a LF. + + ' If the previous character was not a + ' CR, put a CR before the character: + IF NOT PrevCarReturn THEN + FileChar$ = CarReturn$ + FileChar$ + END IF + + ' In any case, set the PrevCarReturn + ' variable to FALSE: + PrevCarReturn = FALSE + + CASE ELSE ' Neither a CR nor a LF. + + ' If the previous character was a CR, + ' set the PrevCarReturn variable to FALSE + ' and put a LF before the current character: + IF PrevCarReturn THEN + PrevCarReturn = FALSE + FileChar$ = LineFeed$ + FileChar$ + END IF + + END SELECT + + ' Write the character(s) to the new file: + PRINT #2, FileChar$; + LOOP + + ' Write a LF if the last character in the file was a CR: + IF PrevCarReturn THEN PRINT #2, LineFeed$; + + CLOSE ' Close both files. + PRINT "Another file (Y/N)?" ' Prompt to continue. + + ' Change the input to uppercase (capital letter): + More$ = UCASE$(INPUT$(1)) + +' Continue the program if the user entered a "y" or a "Y": +LOOP WHILE More$ = "Y" +END + +ErrorHandler: ' Error-handling routine + CONST NOFILE = 53, FILEEXISTS = 58 + + ' The ERR function returns the error code for last error: + SELECT CASE ERR + CASE NOFILE ' Program couldn't find file with + ' input name. + PRINT "No such file in current directory." + INPUT "Enter new name: ", OutFile$ + InFile$ = Backup$(OutFile$) + RESUME + CASE FILEEXISTS ' There is already a file named + ' .BAK in this directory: + ' remove it, then continue. + KILL InFile$ + RESUME + CASE ELSE ' An unanticipated error occurred: + ' stop the program. + ON ERROR GOTO 0 + END SELECT +' +' ========================= BACKUP$ ========================== +' This procedure returns a file name that consists of the +' base name of the input file (everything before the ".") +' plus the extension ".BAK" +' ============================================================ +' +FUNCTION Backup$ (FileName$) STATIC + + ' Look for a period: + Extension = INSTR(FileName$, ".") + + ' If there is a period, add .BAK to the base: + IF Extension > 0 THEN + Backup$ = LEFT$(FileName$, Extension - 1) + ".BAK" + + ' Otherwise, add .BAK to the whole name: + ELSE + Backup$ = FileName$ + ".BAK" + END IF +END FUNCTION diff --git a/qb45/QB45/INC/EXAMPLES/CUBE.BAS b/qb45/QB45/INC/EXAMPLES/CUBE.BAS new file mode 100644 index 0000000..efabb8e --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/CUBE.BAS @@ -0,0 +1,26 @@ +' The macro string to draw the cube and paint its sides: +Plot$ = "BR30 BU25 C1 R54 U45 L54 D45 BE20 P1,1 G20 C2 G20" + "R54 E20 L54 BD5 P2,2 U5 C4 G20 U45 E20 D45 BL5 P4,4" + +APage% = 1 ' Initialize values for the active and visual +VPage% = 0 ' pages, as well as the angle of rotation. +Angle% = 0 + +DO + + ' Draw to the active page while showing + ' the visual page: + SCREEN 7, , APage%, VPage% + CLS 1 + + ' Rotate the cube "Angle%" degrees: + DRAW "TA" + STR$(Angle%) + Plot$ + + ' Angle% is some multiple of 15 degrees: + Angle% = (Angle% + 15) MOD 360 + + ' Switch the active and visual pages: + SWAP APage%, VPage% + +LOOP WHILE INKEY$ = "" ' A key press ends the program. + +END diff --git a/qb45/QB45/INC/EXAMPLES/EDPAT.BAS b/qb45/QB45/INC/EXAMPLES/EDPAT.BAS new file mode 100644 index 0000000..14b8384 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/EDPAT.BAS @@ -0,0 +1,211 @@ +DECLARE SUB DrawPattern () +DECLARE SUB EditPattern () +DECLARE SUB Initialize () +DECLARE SUB ShowPattern (OK$) + +DIM Bit%(0 TO 7), Pattern$, Esc$, PatternSize% + +DO + Initialize + EditPattern + ShowPattern OK$ +LOOP WHILE OK$ = "Y" + +END +' +' ======================== DRAWPATTERN ======================= +' Draws a patterned rectangle on the right side of screen +' ============================================================ +' +SUB DrawPattern STATIC +SHARED Pattern$ + + VIEW (320, 24)-(622, 160), 0, 1 ' Set view to rectangle + PAINT (1, 1), Pattern$ ' Use PAINT to fill it + VIEW ' Set view to full screen + +END SUB +' +' ======================== EDITPATTERN ======================= +' Edits a tile-byte pattern +' ============================================================ +' +SUB EditPattern STATIC +SHARED Pattern$, Esc$, Bit%(), PatternSize% + + ByteNum% = 1 ' Starting position. + BitNum% = 7 + Null$ = CHR$(0) ' CHR$(0) is the first byte of the + ' two-byte string returned when a + ' direction key such as UP or DOWN is + ' pressed. + DO + + ' Calculate starting location on screen of this bit: + X% = ((7 - BitNum%) * 16) + 80 + Y% = (ByteNum% + 2) * 8 + + ' Wait for a key press (and flash cursor each 3/10 second): + State% = 0 + RefTime = 0 + DO + + ' Check timer and switch cursor state if 3/10 second: + IF ABS(TIMER - RefTime) > .3 THEN + RefTime = TIMER + State% = 1 - State% + + ' Turn the border of bit on and off: + LINE (X% - 1, Y% - 1)-STEP(15, 8), State%, B + END IF + + Check$ = INKEY$ ' Check for key press. + + LOOP WHILE Check$ = "" ' Loop until a key is pressed. + + ' Erase cursor: + LINE (X% - 1, Y% - 1)-STEP(15, 8), 0, B + + SELECT CASE Check$ ' Respond to key press. + + CASE CHR$(27) ' ESC key pressed: + EXIT SUB ' exit this subprogram + + CASE CHR$(32) ' SPACEBAR pressed: + ' reset state of bit + + ' Invert bit in pattern string: + CurrentByte% = ASC(MID$(Pattern$, ByteNum%, 1)) + CurrentByte% = CurrentByte% XOR Bit%(BitNum%) + MID$ (Pattern$, ByteNum%) = CHR$(CurrentByte%) + + ' Redraw bit on screen: + IF (CurrentByte% AND Bit%(BitNum%)) <> 0 THEN + CurrentColor% = 1 + ELSE + CurrentColor% = 0 + END IF + LINE (X% + 1, Y% + 1)-STEP(11, 4), CurrentColor%, BF + + CASE CHR$(13) ' ENTER key pressed: + DrawPattern ' draw pattern in box on right. + + CASE Null$ + CHR$(75) ' LEFT key: move cursor left + + BitNum% = BitNum% + 1 + IF BitNum% > 7 THEN BitNum% = 0 + + CASE Null$ + CHR$(77) ' RIGHT key: move cursor right + + BitNum% = BitNum% - 1 + IF BitNum% < 0 THEN BitNum% = 7 + + CASE Null$ + CHR$(72) ' UP key: move cursor up + + ByteNum% = ByteNum% - 1 + IF ByteNum% < 1 THEN ByteNum% = PatternSize% + + CASE Null$ + CHR$(80) ' DOWN key: move cursor down + + ByteNum% = ByteNum% + 1 + IF ByteNum% > PatternSize% THEN ByteNum% = 1 + + CASE ELSE + ' User pressed a key other than ESC, SPACEBAR, + ' ENTER, UP, DOWN, LEFT, or RIGHT, so don't + ' do anything. + END SELECT + LOOP +END SUB +' +' ======================== INITIALIZE ======================== +' Sets up starting pattern and screen +' ============================================================ +' +SUB Initialize STATIC +SHARED Pattern$, Esc$, Bit%(), PatternSize% + + Esc$ = CHR$(27) ' ESC character is ASCII 27. + + ' Set up an array holding bits in positions 0 to 7: + FOR I% = 0 TO 7 + Bit%(I%) = 2 ^ I% + NEXT I% + + CLS + + ' Input the pattern size (in number of bytes): + LOCATE 5, 5 + PRINT "Enter pattern size (1-16 rows):"; + DO + LOCATE 5, 38 + PRINT " "; + LOCATE 5, 38 + INPUT "", PatternSize% + LOOP WHILE PatternSize% < 1 OR PatternSize% > 16 + + ' Set initial pattern to all bits set: + Pattern$ = STRING$(PatternSize%, 255) + + SCREEN 2 ' 640 x 200 monochrome graphics mode. + + ' Draw dividing lines: + LINE (0, 10)-(635, 10), 1 + LINE (300, 0)-(300, 199) + LINE (302, 0)-(302, 199) + + ' Print titles: + LOCATE 1, 13: PRINT "Pattern Bytes" + LOCATE 1, 53: PRINT "Pattern View" + + ' Draw editing screen for pattern: + FOR I% = 1 TO PatternSize% + + ' Print label on left of each line: + LOCATE I% + 3, 8 + PRINT USING "##:"; I% + + ' Draw "bit" boxes: + X% = 80 + Y% = (I% + 2) * 8 + FOR J% = 1 TO 8 + LINE (X%, Y%)-STEP(13, 6), 1, BF + X% = X% + 16 + NEXT J% + NEXT I% + + DrawPattern ' Draw "Pattern View" box. + + LOCATE 21, 1 + PRINT "DIRECTION keys........Move cursor" + PRINT "SPACEBAR............Changes point" + PRINT "ENTER............Displays pattern" + PRINT "ESC.........................Quits"; + +END SUB +' +' ======================== SHOWPATTERN ======================= +' Prints the CHR$ values used by PAINT to make pattern +' ============================================================ +' +SUB ShowPattern (OK$) STATIC +SHARED Pattern$, PatternSize% + + ' Return screen to 80-column text mode: + SCREEN 0, 0 + WIDTH 80 + + PRINT "The following characters make up your pattern:" + PRINT + + ' Print out the value for each pattern byte: + FOR I% = 1 TO PatternSize% + PatternByte% = ASC(MID$(Pattern$, I%, 1)) + PRINT "CHR$("; LTRIM$(STR$(PatternByte%)); ")" + NEXT I% + + PRINT + LOCATE , , 1 + PRINT "New pattern? "; + OK$ = UCASE$(INPUT$(1)) +END SUB diff --git a/qb45/QB45/INC/EXAMPLES/ENTAB.BAS b/qb45/QB45/INC/EXAMPLES/ENTAB.BAS new file mode 100644 index 0000000..9785319 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/ENTAB.BAS @@ -0,0 +1,104 @@ +' ENTAB.BAS +' +' Replace runs of spaces in a file with tabs. +' +DECLARE SUB SetTabPos () +DECLARE SUB StripCommand (CLine$) + + +DEFINT A-Z +DECLARE FUNCTION ThisIsATab (Column AS INTEGER) + +CONST MAXLINE = 255 +CONST TABSPACE = 8 +CONST NO = 0, YES = NOT NO + +DIM SHARED TabStops(MAXLINE) AS INTEGER + +StripCommand (COMMAND$) + +' Set the tab positions (uses the global array TabStops). +SetTabPos + +LastColumn = 1 + +DO + + CurrentColumn = LastColumn + +' Replace a run of blanks with a tab when you reach a tab +' column. CurrentColumn is the current column read. +' LastColumn is the last column that was printed. + DO + C$ = INPUT$(1,#1) + IF C$ <> " " AND C$ <> CHR$(9) THEN EXIT DO + CurrentColumn = CurrentColumn + 1 + IF C$=CHR$(9) OR ThisIsATab(CurrentColumn) THEN + ' Go to a tab column if we have a tab and this + ' is not a tab column. + DO WHILE NOT ThisIsATab(CurrentColumn) + CurrentColumn=CurrentColumn+1 + LOOP + PRINT #2, CHR$(9); + LastColumn = CurrentColumn + END IF + LOOP + +' Print out any blanks left over. + DO WHILE LastColumn < CurrentColumn + PRINT #2, " "; + LastColumn = LastColumn + 1 + LOOP + +' Print the non-blank character. + PRINT #2, C$; + +' Reset the column position if this is the end of a line. + IF C$ = CHR$(10) THEN + LastColumn = 1 + ELSE + LastColumn = LastColumn + 1 + END IF + +LOOP UNTIL EOF(1) +CLOSE #1, #2 +END + +'------------------SUB SetTabPos------------------------- +' Set the tab positions in the array TabStops. +' +SUB SetTabPos STATIC + FOR I = 1 TO 255 + TabStops(I) = ((I MOD TABSPACE) = 1) + NEXT I +END SUB +' +'------------------SUB StripCommand---------------------- +' +SUB StripCommand (CommandLine$) STATIC + IF CommandLine$ = "" THEN + INPUT "File to entab: ", InFileName$ + INPUT "Store entabbed file in: ", OutFileName$ + ELSE + SpacePos = INSTR(CommandLine$, " ") + IF SpacePos > 0 THEN + InFileName$ = LEFT$(CommandLine$, SpacePos - 1) + OutFileName$ = LTRIM$(MID$(CommandLine$, SpacePos)) + ELSE + InFileName$ = CommandLine$ + INPUT "Store entabbed file in: ", OutFileName$ + END IF + END IF + OPEN InFileName$ FOR INPUT AS #1 + OPEN OutFileName$ FOR OUTPUT AS #2 +END SUB +'---------------FUNCTION ThisIsATab---------------------- +' Answer the question, "Is this a tab position?" +' +FUNCTION ThisIsATab (LastColumn AS INTEGER) STATIC + IF LastColumn > MAXLINE THEN + ThisIsATab = YES + ELSE + ThisIsATab = TabStops(LastColumn) + END IF +END FUNCTION diff --git a/qb45/QB45/INC/EXAMPLES/FILERR.BAS b/qb45/QB45/INC/EXAMPLES/FILERR.BAS new file mode 100644 index 0000000..1fb3b1c --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/FILERR.BAS @@ -0,0 +1,105 @@ +' Declare symbolic constants used in program: +CONST FALSE = 0, TRUE = NOT FALSE + +DECLARE FUNCTION GetFileName$ () + +' Set up the ERROR trap, and specify the name of the +' error-handling routine: +ON ERROR GOTO ErrorProc + +DO + Restart = FALSE + CLS + + FileName$ = GetFileName$ ' Input file name. + + IF FileName$ = "" THEN + END ' End if pressed. + ELSE + + ' Otherwise, open the file, assigning it the + ' next available file number: + FileNum = FREEFILE + OPEN FileName$ FOR INPUT AS FileNum + END IF + + IF NOT Restart THEN + + ' Input search string: + LINE INPUT "Enter string to locate: ", LocString$ + LocString$ = UCASE$(LocString$) + + ' Loop through the lines in the file, printing them + ' if they contain the search string: + LineNum = 1 + DO WHILE NOT EOF(FileNum) + + ' Input line from file: + LINE INPUT #FileNum, LineBuffer$ + + ' Check for string, printing the line and its + ' number if found: + IF INSTR(UCASE$(LineBuffer$), LocString$) <> 0 THEN + PRINT USING "#### &"; LineNum, LineBuffer$ + END IF + + LineNum = LineNum + 1 + LOOP + + CLOSE FileNum ' Close the file. + + END IF +LOOP WHILE Restart = TRUE + +END + +ErrorProc: + + SELECT CASE ERR + + CASE 64: ' Bad File Name + PRINT "** ERROR - Invalid file name" + + ' Get a new file name and try again: + FileName$ = GetFileName$ + + ' Resume at the statement that caused the error: + RESUME + + CASE 71: ' Disk not ready + PRINT "** ERROR - Disk drive not ready" + PRINT "Press C to continue, R to restart, Q to quit: " + DO + Char$ = UCASE$(INPUT$(1)) + IF Char$ = "C" THEN + RESUME ' Resume where you left off + + ELSEIF Char$ = "R" THEN + Restart = TRUE ' Resume at beginning + RESUME NEXT + + ELSEIF Char$ = "Q" THEN + END ' Don't resume at all + END IF + LOOP + + CASE 53, 76: ' File or path not found + PRINT "** ERROR - File or path not found" + FileName$ = GetFileName$ + RESUME + + CASE ELSE: ' Unforeseen error + + ' Disable error trapping and print standard + ' system message: + ON ERROR GOTO 0 + END SELECT +' +' ======================= GETFILENAME$ ======================= +' Returns a file name from user input +' ============================================================ +' +FUNCTION GetFileName$ STATIC + INPUT "Enter file to search (press ENTER to quit): ", FTemp$ + GetFileName$ = FTemp$ +END FUNCTION diff --git a/qb45/QB45/INC/EXAMPLES/FLPT.BAS b/qb45/QB45/INC/EXAMPLES/FLPT.BAS new file mode 100644 index 0000000..7428885 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/FLPT.BAS @@ -0,0 +1,73 @@ +' +' FLPT.BAS +' +' Displays how a given real value is stored in memory. +' +' +DEFINT A-Z +DECLARE FUNCTION MHex$ (X AS INTEGER) +DIM Bytes(3) + +CLS +PRINT "Internal format of IEEE number (all values in hexadecimal)" +PRINT +DO + + ' Get the value and calculate the address of the variable. + INPUT "Enter a real number (or END to quit): ", A$ + IF UCASE$(A$) = "END" THEN EXIT DO + RealValue! = VAL(A$) + ' Convert the real value to a long without changing any of + ' the bits. + AsLong& = CVL(MKS$(RealValue!)) + ' Make a string of hex digits, and add leading zeroes. + Strout$ = HEX$(AsLong&) + Strout$ = STRING$(8 - LEN(Strout$), "0") + Strout$ + + ' Save the sign bit, and then eliminate it so it doesn't + ' affect breaking out the bytes + SignBit& = AsLong& AND &H80000000 + AsLong& = AsLong& AND &H7FFFFFFF + ' Split the real value into four separate bytes + ' --the AND removes unwanted bits; dividing by 256 shifts + ' the value right 8 bit positions. + FOR I = 0 TO 3 + Bytes(I) = AsLong& AND &HFF& + AsLong& = AsLong& \ 256& + NEXT I + ' Display how the value appears in memory. + PRINT + PRINT "Bytes in Memory" + PRINT " High Low" + FOR I = 1 TO 7 STEP 2 + PRINT " "; MID$(Strout$, I, 2); + NEXT I + PRINT : PRINT + + ' Set the value displayed for the sign bit. + Sign = ABS(SignBit& <> 0) + + ' The exponent is the right seven bits of byte 3 and the + ' leftmost bit of byte 2. Multiplying by 2 shifts left and + ' makes room for the additional bit from byte 2. + Exponent = Bytes(3) * 2 + Bytes(2) \ 128 + + ' The first part of the mantissa is the right seven bits + ' of byte 2. The OR operation makes sure the implied bit + ' is displayed by setting the leftmost bit. + Mant1 = (Bytes(2) OR &H80) + PRINT " Bit 31 Bits 30-23 Implied Bit & Bits 22-0" + PRINT "Sign Bit Exponent Bits Mantissa Bits" + PRINT TAB(4); Sign; TAB(17); MHex$(Exponent); + PRINT TAB(33); MHex$(Mant1); MHex$(Bytes(1)); MHex$(Bytes(0)) + PRINT + +LOOP + +' MHex$ makes sure we always get two hex digits. +FUNCTION MHex$ (X AS INTEGER) STATIC + D$ = HEX$(X) + IF LEN(D$) < 2 THEN D$ = "0" + D$ + MHex$ = D$ +END FUNCTION + diff --git a/qb45/QB45/INC/EXAMPLES/INDEX.BAS b/qb45/QB45/INC/EXAMPLES/INDEX.BAS new file mode 100644 index 0000000..5eeb41d --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/INDEX.BAS @@ -0,0 +1,310 @@ +DEFINT A-Z + +' Define the symbolic constants used globally in the program: +CONST FALSE = 0, TRUE = NOT FALSE + +' Define a record structure for random-file records: +TYPE StockItem + PartNumber AS STRING * 6 + Description AS STRING * 20 + UnitPrice AS SINGLE + Quantity AS INTEGER +END TYPE + +' Define a record structure for each element of the index: +TYPE IndexType + RecordNumber AS INTEGER + PartNumber AS STRING * 6 +END TYPE + +' Declare procedures that will be called: +DECLARE FUNCTION Filter$ (Prompt$) +DECLARE FUNCTION FindRecord% (PartNumber$, RecordVar AS StockItem) + +DECLARE SUB AddRecord (RecordVar AS StockItem) +DECLARE SUB InputRecord (RecordVar AS StockItem) +DECLARE SUB PrintRecord (RecordVar AS StockItem) +DECLARE SUB SortIndex () +DECLARE SUB ShowPartNumbers () + +' Define a buffer (using the StockItem type) and +' define & dimension the index array: +DIM StockRecord AS StockItem, Index(1 TO 100) AS IndexType + +' Open the random-access file: +OPEN "STOCK.DAT" FOR RANDOM AS #1 LEN = LEN(StockRecord) + +' Calculate number of records in the file: +NumberOfRecords = LOF(1) \ LEN(StockRecord) + +' If there are records, read them and build the index: +IF NumberOfRecords <> 0 THEN + FOR RecordNumber = 1 TO NumberOfRecords + + ' Read the data from a new record in the file: + GET #1, RecordNumber, StockRecord + + ' Place part number and record number in index: + Index(RecordNumber).RecordNumber = RecordNumber + Index(RecordNumber).PartNumber = StockRecord.PartNumber + NEXT + + SortIndex ' Sort index in part-number order. +END IF + +DO ' Main-menu loop. + CLS + PRINT "(A)dd records." + PRINT "(L)ook up records." + PRINT "(Q)uit program." + PRINT + LOCATE , , 1 + PRINT "Type your choice (A, L, or Q) here: "; + + ' Loop until user presses, A, L, or Q: + DO + Choice$ = UCASE$(INPUT$(1)) + LOOP WHILE INSTR("ALQ", Choice$) = 0 + + ' Branch according to choice: + SELECT CASE Choice$ + CASE "A" + AddRecord StockRecord + CASE "L" + IF NumberOfRecords = 0 THEN + PRINT : PRINT "No records in file yet. "; + PRINT "Press any key to continue."; + Pause$ = INPUT$(1) + ELSE + InputRecord StockRecord + END IF + CASE "Q" ' End program + END SELECT +LOOP UNTIL Choice$ = "Q" + +CLOSE #1 ' All done, close file and end. +END +' +' ======================== ADDRECORD ========================= +' Adds records to the file from input typed at the keyboard. +' ============================================================ +' +SUB AddRecord (RecordVar AS StockItem) STATIC + SHARED Index() AS IndexType, NumberOfRecords + DO + CLS + INPUT "Part Number: ", RecordVar.PartNumber + INPUT "Description: ", RecordVar.Description + RecordVar.UnitPrice = VAL(Filter$("Unit Price : ")) + RecordVar.Quantity = VAL(Filter$("Quantity : ")) + + NumberOfRecords = NumberOfRecords + 1 + + PUT #1, NumberOfRecords, RecordVar + + Index(NumberOfRecords).RecordNumber = NumberOfRecords + Index(NumberOfRecords).PartNumber = RecordVar.PartNumber + PRINT : PRINT "Add another? "; + OK$ = UCASE$(INPUT$(1)) + LOOP WHILE OK$ = "Y" + + SortIndex ' Re-sort index file. +END SUB +' +' ========================= FILTER =========================== +' Filters all non-numeric characters from a string +' and returns the filtered string. +' ============================================================ +' +FUNCTION Filter$ (Prompt$) STATIC + ValTemp2$ = "" + PRINT Prompt$; ' Print the prompt passed. + INPUT "", ValTemp1$ ' Input a number as + ' a string. + StringLength = LEN(ValTemp1$) ' Get the string's length. + FOR I% = 1 TO StringLength ' Go through the string, + Char$ = MID$(ValTemp1$, I%, 1) ' one character at a time. + + ' Is the character a valid part of a number (i.e., + ' a digit or a decimal point)? If yes, add it to + ' the end of a new string: + IF INSTR(".0123456789", Char$) > 0 THEN + ValTemp2$ = ValTemp2$ + Char$ + + ' Otherwise, check to see if it's a lowercase "l", + ' since users used to typewriters may enter a one + ' value that way: + ELSEIF Char$ = "l" THEN + ValTemp2$ = ValTemp2$ + "1" ' Change the "l" to a "1". + END IF + NEXT I% + + Filter$ = ValTemp2$ ' Return filtered string. + +END FUNCTION +' +' ======================= FINDRECORD ========================= +' Uses a binary search to locate a record in the index. +' ============================================================ +' +FUNCTION FindRecord% (Part$, RecordVar AS StockItem) STATIC + SHARED Index() AS IndexType, NumberOfRecords + + ' Set top and bottom bounds of search: + TopRecord = NumberOfRecords + BottomRecord = 1 + + ' Search until top of range is less than bottom: + DO UNTIL (TopRecord < BottomRecord) + + ' Choose midpoint: + Midpoint = (TopRecord + BottomRecord) \ 2 + + ' Test to see if it's the one wanted (RTRIM$() trims + ' trailing blanks from a fixed string): + Test$ = RTRIM$(Index(Midpoint).PartNumber) + + ' If it is, exit loop: + IF Test$ = Part$ THEN + EXIT DO + + ' Otherwise, if what we're looking for is greater, + ' move bottom up: + ELSEIF Part$ > Test$ THEN + BottomRecord = Midpoint + 1 + + ' Otherwise, move the top down: + ELSE + TopRecord = Midpoint - 1 + END IF + LOOP + + ' If part was found, get record from file using + ' pointer in index and set FindRecord% to TRUE: + IF Test$ = Part$ THEN + GET #1, Index(Midpoint).RecordNumber, RecordVar + FindRecord% = TRUE + + ' Otherwise, if part was not found, set FindRecord% + ' to FALSE: + ELSE + FindRecord% = FALSE + END IF +END FUNCTION +' +' ======================= INPUTRECORD ======================== +' First, INPUTRECORD calls SHOWPARTNUMBERS, which +' prints a menu of part numbers on the top of the screen. +' Next, INPUTRECORD prompts the user to enter a part +' number. Finally, it calls the FINDRECORD and PRINTRECORD +' procedures to find and print the given record. +' ============================================================ +' +SUB InputRecord (RecordVar AS StockItem) STATIC + CLS + ShowPartNumbers ' Call the ShowPartNumbers SUB. + + ' Print data from specified records on the bottom + ' part of the screen: + DO + PRINT "Type a part number listed above "; + INPUT "(or Q to quit) and press : ", Part$ + IF UCASE$(Part$) <> "Q" THEN + IF FindRecord(Part$, RecordVar) THEN + PrintRecord RecordVar + ELSE + PRINT "Part not found." + END IF + END IF + PRINT STRING$(40, "_") + LOOP WHILE UCASE$(Part$) <> "Q" + + VIEW PRINT ' Restore the text viewport to entire screen. +END SUB +' +' ======================= PRINTRECORD ======================== +' Prints a record on the screen +' ============================================================ +' +SUB PrintRecord (RecordVar AS StockItem) STATIC + PRINT "Part Number: "; RecordVar.PartNumber + PRINT "Description: "; RecordVar.Description + PRINT USING "Unit Price :$$###.##"; RecordVar.UnitPrice + PRINT "Quantity :"; RecordVar.Quantity +END SUB +' +' ===================== SHOWPARTNUMBERS ====================== +' Prints an index of all the part numbers in the upper part +' of the screen. +' ============================================================ +' +SUB ShowPartNumbers STATIC + SHARED Index() AS IndexType, NumberOfRecords + + CONST NUMCOLS = 8, COLWIDTH = 80 \ NUMCOLS + + ' At the top of the screen, print a menu indexing all + ' the part numbers for records in the file. This menu is + ' printed in columns of equal length (except possibly the + ' last column, which may be shorter than the others): + ColumnLength = NumberOfRecords + DO WHILE ColumnLength MOD NUMCOLS + ColumnLength = ColumnLength + 1 + LOOP + ColumnLength = ColumnLength \ NUMCOLS + Column = 1 + RecordNumber = 1 + DO UNTIL RecordNumber > NumberOfRecords + FOR Row = 1 TO ColumnLength + LOCATE Row, Column + PRINT Index(RecordNumber).PartNumber + RecordNumber = RecordNumber + 1 + IF RecordNumber > NumberOfRecords THEN EXIT FOR + NEXT Row + Column = Column + COLWIDTH + LOOP + + LOCATE ColumnLength + 1, 1 + PRINT STRING$(80, "_") ' Print separator line. + + ' Scroll information about records below the part-number + ' menu (this way, the part numbers are not erased): + VIEW PRINT ColumnLength + 2 TO 24 +END SUB +' +' ========================= SORTINDEX ======================== +' Sorts the index by part number +' ============================================================ +' +SUB SortIndex STATIC + SHARED Index() AS IndexType, NumberOfRecords + + ' Set comparison offset to half the number of records + ' in index: + Offset = NumberOfRecords \ 2 + + ' Loop until offset gets to zero: + DO WHILE Offset > 0 + Limit = NumberOfRecords - Offset + DO + + ' Assume no switches at this offset: + Switch = FALSE + + ' Compare elements and switch ones out of order: + FOR I = 1 TO Limit + IF Index(I).PartNumber > Index(I + Offset).PartNumber THEN + SWAP Index(I), Index(I + Offset) + Switch = I + END IF + NEXT I + + ' Sort on next pass only to where last + ' switch was made: + Limit = Switch + LOOP WHILE Switch + + ' No switches at last offset, try one half as big: + Offset = Offset \ 2 + LOOP +END SUB diff --git a/qb45/QB45/INC/EXAMPLES/MANDEL.BAS b/qb45/QB45/INC/EXAMPLES/MANDEL.BAS new file mode 100644 index 0000000..0abdeea --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/MANDEL.BAS @@ -0,0 +1,180 @@ +DEFINT A-Z ' Default variable type is integer + +DECLARE SUB ShiftPalette () +DECLARE SUB WindowVals (WL%, WR%, WT%, WB%) +DECLARE SUB ScreenTest (EM%, CR%, VL%, VR%, VT%, VB%) + +CONST FALSE = 0, TRUE = NOT FALSE ' Boolean constants + +' Set maximum number of iterations per point: +CONST MAXLOOP = 30, MAXSIZE = 1000000 + +DIM PaletteArray(15) +FOR I = 0 TO 15 : PaletteArray(I) = I : NEXT I + +' Call WindowVals to get coordinates of window corners: +WindowVals WLeft, WRight, WTop, WBottom + +' Call ScreenTest to find out if this is an EGA machine, +' and get coordinates of viewport corners: +ScreenTest EgaMode, ColorRange, VLeft, VRight, VTop, VBottom + +' Define viewport and corresponding window: +VIEW (VLeft, VTop)-(VRight, VBottom), 0, ColorRange +WINDOW (WLeft, WTop)-(WRight, WBottom) + +LOCATE 24, 10 : PRINT "Press any key to quit."; + +XLength = VRight - VLeft +YLength = VBottom - VTop +ColorWidth = MAXLOOP \ ColorRange + +' Loop through each pixel in viewport and calculate +' whether or not it is in the Mandelbrot Set: +FOR Y = 0 TO YLength ' Loop through every line in + ' the viewport. + LogicY = PMAP(Y, 3) ' Get the pixel's logical y + ' coordinate. + PSET (WLeft, LogicY) ' Plot leftmost pixel in the line. + OldColor = 0 ' Start with background color. + + FOR X = 0 TO XLength ' Loop through every pixel in + ' the line. + LogicX = PMAP(X, 2) ' Get the pixel's logical x + ' coordinate . + MandelX& = LogicX + MandelY& = LogicY + + ' Do the calculations to see if this point is in + ' the Mandelbrot Set: + FOR I = 1 TO MAXLOOP + RealNum& = MandelX& * MandelX& + ImagNum& = MandelY& * MandelY& + IF (RealNum& + ImagNum&) >= MAXSIZE THEN EXIT FOR + MandelY& = (MandelX& * MandelY&) \ 250 + LogicY + MandelX& = (RealNum& - ImagNum&) \ 500 + LogicX + NEXT I + + ' Assign a color to the point: + PColor = I \ ColorWidth + + ' If color has changed, draw a line from the + ' last point referenced to the new point, + ' using the old color: + IF PColor <> OldColor THEN + LINE -(LogicX, LogicY), (ColorRange - OldColor) + OldColor = PColor + END IF + + IF INKEY$ <> "" THEN END + NEXT X + + ' Draw the last line segment to the right edge of + ' the viewport: + LINE -(LogicX, LogicY), (ColorRange - OldColor) + + ' If this is an EGA machine, shift the palette after + ' drawing each line: + IF EgaMode THEN ShiftPalette +NEXT Y + +DO + ' Continue shifting the palette until the user + ' presses a key: + IF EgaMode THEN ShiftPalette +LOOP WHILE INKEY$ = "" + +SCREEN 0, 0 ' Restore the screen to text mode, +WIDTH 80 ' 80 columns. +END + +BadScreen: ' Error handler that is invoked if + EgaMode = FALSE ' there is no EGA graphics card + RESUME NEXT +' +' ======================= ShiftPalette ======================= +' Rotates the palette by one each time it is called. +' ============================================================ +' +SUB ShiftPalette STATIC + SHARED PaletteArray(), ColorRange + + FOR I = 1 TO ColorRange + PaletteArray(I) = (PaletteArray(I) MOD ColorRange) + 1 + NEXT I + PALETTE USING PaletteArray(0) + +END SUB +' +' ======================== ScreenTest ======================== +' Tests to see if user has EGA hardware with SCREEN 8. +' If this causes an error, the EM flag is set to FALSE, +' and the screen is set with SCREEN 1. +' +' Also sets values for corners of viewport (VL = left, +' VR = right, VT = top, VB = bottom), scaled with the +' correct aspect ratio so viewport is a perfect square. +' ============================================================ +' +SUB ScreenTest (EM, CR, VL, VR, VT, VB) STATIC + EM = TRUE + ON ERROR GOTO BadScreen + SCREEN 8, 1 + ON ERROR GOTO 0 + + IF EM THEN ' No error, so SCREEN 8 is OK + VL = 110 : VR = 529 + VT = 5 : VB = 179 + CR = 15 ' 16 colors (0 - 15) + + ELSE ' Error, so use SCREEN 1 + SCREEN 1, 1 + VL = 55 : VR = 264 + VT = 5 : VB = 179 + CR = 3 ' 4 colors (0 - 3) + END IF + +END SUB +' +' ======================== WindowVals ======================== +' Gets window corners as input from the user, or sets +' values for the corners if there is no input. +' ============================================================ +' +SUB WindowVals (WL, WR, WT, WB) STATIC + CLS + PRINT "This program prints the graphic representation of" + PRINT "the complete Mandelbrot Set. The default window is" + PRINT "from (-1000,625) to (250,-625). To zoom in on part" + PRINT "of the figure, input coordinates inside this window." + PRINT + PRINT "Press to see the default window. Press any" + PRINT "other key to input your own window coordinates: "; + LOCATE , , 1 + Resp$ = INPUT$(1) + + ' User didn't press ENTER, so input window corners: + IF Resp$ <> CHR$(13) THEN + PRINT + INPUT "X coordinate of upper left corner: ", WL + DO + INPUT "X coordinate of lower right corner: ", WR + IF WR <= WL THEN + PRINT "Right corner must be greater than left corner." + END IF + LOOP WHILE WR <= WL + INPUT "Y coordinate of upper left corner: ", WT + DO + INPUT "Y coordinate of lower right corner: ", WB + IF WB >= WT THEN + PRINT "Bottom corner must be less than top corner." + END IF + LOOP WHILE WB >= WT + + ELSE ' Pressed ENTER, so set default values. + WL = -1000 + WR = 250 + WT = 625 + WB = -625 + END IF +END SUB diff --git a/qb45/QB45/INC/EXAMPLES/PALETTE.BAS b/qb45/QB45/INC/EXAMPLES/PALETTE.BAS new file mode 100644 index 0000000..fc0857c --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/PALETTE.BAS @@ -0,0 +1,62 @@ +DECLARE SUB InitPalette () +DECLARE SUB ChangePalette () +DECLARE SUB DrawEllipses () +DEFINT A-Z + +DIM SHARED PaletteArray(15) + +SCREEN 8 ' 640 x 200 resolution; 16 colors + +InitPalette +DrawEllipses + +DO + ChangePalette +LOOP WHILE INKEY$ = "" ' Shift palette until key pressed + +END + +' +' ======================= InitPalette ======================== +' This procedure initializes the integer array used to +' change the palette. +' ============================================================ +' +SUB InitPalette STATIC + FOR I = 0 TO 15 + PaletteArray(I) = I + NEXT I +END SUB + +' +' ====================== DrawEllipses ======================== +' This procedure draws fifteen concentric ellipses, and +' paints the interior of each with a different color. +' ============================================================ +' +SUB DrawEllipses STATIC + CONST ASPECT = 1 / 3 + FOR ColorVal = 15 TO 1 STEP -1 + Radius = 20 * ColorVal + CIRCLE (320, 100), Radius, ColorVal, , , ASPECT + PAINT (320, 100), ColorVal + NEXT +END SUB + +' +' ====================== ChangePalette ======================= +' This procedure rotates the palette by one each time it +' is called. For example, after the first call to +' ChangePalette, PaletteArray(1) = 2, PaletteArray(2) = 3, +' . . . , PaletteArray(14) = 15, and PaletteArray(15) = 1 +' ============================================================ +' +SUB ChangePalette STATIC + FOR I = 1 TO 15 + PaletteArray(I) = (PaletteArray(I) MOD 15) + 1 + NEXT I + + ' Shift the color displayed by each of the attributes from + ' one to fifteen: + PALETTE USING PaletteArray(0) +END SUB diff --git a/qb45/QB45/INC/EXAMPLES/PLOTTER.BAS b/qb45/QB45/INC/EXAMPLES/PLOTTER.BAS new file mode 100644 index 0000000..530c63e --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/PLOTTER.BAS @@ -0,0 +1,54 @@ +' Values for keys on the numeric keypad and the spacebar: +CONST UP = 72, DOWN = 80, LFT = 75, RGHT = 77 +CONST UPLFT = 71, UPRGHT = 73, DOWNLFT = 79, DOWNRGHT = 81 +CONST SPACEBAR = " " + +' Null$ is the first character of the two-character INKEY$ +' value returned for direction keys such as UP and DOWN: +Null$ = CHR$(0) + +' Plot$ = "" means draw lines; Plot$ = "B" means move +' graphics cursor, but don't draw lines: +Plot$ = "" + +PRINT "Use the cursor movement keys to draw lines." +PRINT "Press the spacebar to toggle line drawing on and off." +PRINT "Press to begin. Press q to end the program." +DO: LOOP WHILE INKEY$ = "" + +SCREEN 1 +CLS + +DO + SELECT CASE KeyVal$ + CASE Null$ + CHR$(UP) + DRAW Plot$ + "C1 U2" + CASE Null$ + CHR$(DOWN) + DRAW Plot$ + "C1 D2" + CASE Null$ + CHR$(LFT) + DRAW Plot$ + "C2 L2" + CASE Null$ + CHR$(RGHT) + DRAW Plot$ + "C2 R2" + CASE Null$ + CHR$(UPLFT) + DRAW Plot$ + "C3 H2" + CASE Null$ + CHR$(UPRGHT) + DRAW Plot$ + "C3 E2" + CASE Null$ + CHR$(DOWNLFT) + DRAW Plot$ + "C3 G2" + CASE Null$ + CHR$(DOWNRGHT) + DRAW Plot$ + "C3 F2" + CASE SPACEBAR + IF Plot$ = "" THEN Plot$ = "B " ELSE Plot$ = "" + CASE ELSE + ' The user pressed some key other than one of the + ' direction keys, the spacebar, or "q", so + ' don't do anything. + END SELECT + + KeyVal$ = INKEY$ + +LOOP UNTIL KeyVal$ = "q" + +SCREEN 0, 0 +WIDTH 80 +END diff --git a/qb45/QB45/INC/EXAMPLES/QLBDUMP.BAS b/qb45/QB45/INC/EXAMPLES/QLBDUMP.BAS new file mode 100644 index 0000000..ccf99c8 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/QLBDUMP.BAS @@ -0,0 +1,88 @@ +' This program prints the names of QuickLibrary procedures + +DECLARE SUB DumpSym (SymStart AS INTEGER, QHdrPos AS LONG) + +TYPE ExeHdr ' Part of DOS .EXE header + other1 AS STRING * 8 ' Other header information + CParHdr AS INTEGER ' Size of header in paragraphs + other2 AS STRING * 10 ' Other header information + IP AS INTEGER ' Initial IP value + CS AS INTEGER ' Initial (relative) CS value +END TYPE + +TYPE QBHdr ' QLB header + QBHead AS STRING * 6 ' QB specific heading + Magic AS INTEGER ' Magic word: identifies file as + ' a Quick library + SymStart AS INTEGER ' Offset from header to first code symbol + DatStart AS INTEGER ' Offset from header to first data symbol +END TYPE + +TYPE QbSym ' QuickLib symbol entry + Flags AS INTEGER ' Symbol flags + NameStart AS INTEGER ' Offset into name table + other AS STRING * 4 ' Other header info +END TYPE + +DIM EHdr AS ExeHdr, Qhdr AS QBHdr, QHdrPos AS LONG + +INPUT "Enter QuickLibrary file name: ", FileName$ +FileName$ = UCASE$(FileName$) +IF INSTR(FileName$, ".QLB") = 0 THEN FileName$ = FileName$ + ".QLB" + +INPUT "Enter output file name or press ENTER for screen: ", OutFile$ +OutFile$ = UCASE$(OutFile$) +IF OutFile$ = "" THEN OutFile$ = "CON" + +OPEN FileName$ FOR BINARY AS #1 +OPEN OutFile$ FOR OUTPUT AS #2 + +GET #1, , EHdr ' Read the EXE format header. + +QHdrPos = (EHdr.CParHdr + EHdr.CS) * 16 + EHdr.IP + 1 + +GET #1, QHdrPos, Qhdr ' Read the QuickLib format header. + +IF Qhdr.Magic <> &H6C75 THEN PRINT "Not a QB UserLibrary": END + +PRINT #2, "Code Symbols:": PRINT #2, +DumpSym Qhdr.SymStart, QHdrPos ' dump code symbols +PRINT #2, + +PRINT #2, "Data Symbols:": PRINT #2, "" +DumpSym Qhdr.DatStart, QHdrPos ' dump data symbols +PRINT #2, + +END + +SUB DumpSym (SymStart AS INTEGER, QHdrPos AS LONG) + DIM QlbSym AS QbSym + DIM NextSym AS LONG, CurrentSym AS LONG + + ' Calculate the location of the first symbol entry, then read that entry: + NextSym = QHdrPos + SymStart + GET #1, NextSym, QlbSym + + DO + NextSym = SEEK(1) ' Save the location of the next + ' symbol. + CurrentSym = QHdrPos + QlbSym.NameStart + SEEK #1, CurrentSym ' Use SEEK to move to the name + ' for the current symbol entry. + Prospect$ = INPUT$(40, 1) ' Read the longest legal string, + ' plus one additonal byte for the + ' final null character (CHR$(0)). + + ' Extract the null-terminated name: + SName$ = LEFT$(Prospect$, INSTR(Prospect$, CHR$(0))) + + ' Print only those names that do not begin with "__", "$", or "b$" + ' as these names are usually considered reserved: + IF LEFT$(SName$, 2) <> "__" AND LEFT$(SName$, 1) <> "$" AND UCASE$(LEFT$(SName$, 2)) <> "B$" THEN + PRINT #2, " " + SName$ + END IF + + GET #1, NextSym, QlbSym ' Read a symbol entry. + LOOP WHILE QlbSym.Flags ' Flags=0 (false) means end of table. +END SUB + diff --git a/qb45/QB45/INC/EXAMPLES/SEARCH.BAS b/qb45/QB45/INC/EXAMPLES/SEARCH.BAS new file mode 100644 index 0000000..0a87c1b --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/SEARCH.BAS @@ -0,0 +1,50 @@ +DEFLNG A-Z ' Default variable type is long integer. +LINE INPUT "File to search: ", FileName$ +LINE INPUT "Pattern to search for: ", Pattern$ +OPEN FileName$ FOR BINARY AS #1 + +CONST PACKETSIZE = 10000, TRUE = -1 +PatternLength% = LEN(Pattern$) +FileLength = LOF(1) +BytesLeft = FileLength +FileOffset = 0 + +' Keep searching as long as there are enough bytes left in +' the file to contain the pattern you're searching for: +DO WHILE BytesLeft > PatternLength% + + ' Read either 10,000 bytes or the number of bytes left in the file, + ' whichever is smaller, then store them in Buffer$. (If the number + ' of bytes left is less than PACKETSIZE, the following statement + ' still reads just the remaining bytes, since binary I/O doesn't + ' give "read past end" errors): + Buffer$ = INPUT$(PACKETSIZE, #1) + + ' Find every occurrence of the pattern in Buffer$: + Start% = 1 + DO + StringPos% = INSTR(Start%, Buffer$, Pattern$) + IF StringPos% > 0 THEN + + ' Found the pattern, so print the byte position in the file + ' where the pattern starts: + PRINT "Found pattern at byte number"; + PRINT FileOffset + StringPos% + Start% = StringPos% + 1 + FoundIt% = TRUE + END IF + LOOP WHILE StringPos% > 0 + + ' Find the byte position where the next I/O operation would take place, + ' then back up the file pointer a distance equal to the length of the + ' pattern (in case the pattern straddles a 10,000-byte boundary): + FileOffset = SEEK(1) - PatternLength% + SEEK #1, FileOffset + 1 + + BytesLeft = FileLength - FileOffset +LOOP + +CLOSE #1 + +IF NOT FoundIt% THEN PRINT "Pattern not found." + diff --git a/qb45/QB45/INC/EXAMPLES/SINEWAVE.BAS b/qb45/QB45/INC/EXAMPLES/SINEWAVE.BAS new file mode 100644 index 0000000..f80b612 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/SINEWAVE.BAS @@ -0,0 +1,30 @@ +SCREEN 2 + +' View port sized to proper scale for graph: +VIEW (20, 2)-(620, 172), , 1 + +CONST PI = 3.141592653589# + +' Make window large enough to graph sine wave from +' 0 radians to 2ã radians: +WINDOW (0, -1.1)-(2 * PI, 1.1) + +Style% = &HFF00 ' Use to make dashed line. + +VIEW PRINT 23 TO 24 ' Scroll printed output in + ' rows 23 and 24. +DO + PRINT TAB(20); + INPUT "Number of cycles (0 to end): ", Cycles + CLS + LINE (2 * PI, 0)-(0, 0), , , Style% ' Draw the x (horizontal) axis. + IF Cycles > 0 THEN + ' Start at (0,0) and plot the graph: + FOR X = 0 TO 2 * PI STEP .01 + Y = SIN(Cycles * X) ' Calculate the y coordinate. + LINE -(X, Y) ' Draw a line from the last + ' point to the new point. + NEXT X + END IF +LOOP WHILE Cycles > 0 + diff --git a/qb45/QB45/INC/EXAMPLES/STRTONUM.BAS b/qb45/QB45/INC/EXAMPLES/STRTONUM.BAS new file mode 100644 index 0000000..fc644f4 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/STRTONUM.BAS @@ -0,0 +1,34 @@ +DECLARE FUNCTION Filter$ (Txt$, FilterString$) + +' Input a line: +LINE INPUT "Enter a number with commas: ", A$ + +' Look for only valid numeric characters (0123456789.-) in the +' input string: +CleanNum$ = Filter$(A$, "0123456789.-") + +' Convert the string to a number: +PRINT "The number's value = "; VAL(CleanNum$) +END +' +' ========================== FILTER ========================== +' Takes unwanted characters out of a string by +' comparing them with a filter string containing +' only acceptable numeric characters +' ============================================================ +' +FUNCTION Filter$ (Txt$, FilterString$) STATIC + Temp$ = "" + TxtLength = LEN(Txt$) + + FOR I = 1 TO TxtLength ' Isolate each character in + C$ = MID$(Txt$, I, 1) ' the string. + + ' If the character is in the filter string, save it: + IF INSTR(FilterString$, C$) <> 0 THEN + Temp$ = Temp$ + C$ + END IF + NEXT I + + Filter$ = Temp$ +END FUNCTION diff --git a/qb45/QB45/INC/EXAMPLES/TERMINAL.BAS b/qb45/QB45/INC/EXAMPLES/TERMINAL.BAS new file mode 100644 index 0000000..f89390d --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/TERMINAL.BAS @@ -0,0 +1,74 @@ +DEFINT A-Z + +DECLARE SUB Filter (InString$) + +COLOR 7, 1 ' Set screen color. +CLS + +Quit$ = CHR$(0) + CHR$(16) ' Value returned by INKEY$ + ' when ALT+q is pressed. + +' Set up prompt on bottom line of screen and turn cursor on: +LOCATE 24, 1, 1 +PRINT STRING$(80, "_"); +LOCATE 25, 1 +PRINT TAB(30); "Press ALT+q to quit"; + +VIEW PRINT 1 TO 23 ' Print between lines 1 & 23. + +' Open communications (1200 baud, no parity, 8-bit data, +' 1 stop bit, 256-byte input buffer): +OPEN "COM1:1200,N,8,1" FOR RANDOM AS #1 LEN = 256 + +DO ' Main communications loop. + + KeyInput$ = INKEY$ ' Check the keyboard. + + IF KeyInput$ = Quit$ THEN ' Exit the loop if the user + EXIT DO ' pressed ALT+q. + + ELSEIF KeyInput$ <> "" THEN ' Otherwise, if the user has + PRINT #1, KeyInput$; ' pressed a key, send the + END IF ' character typed to the modem. + + ' Check the modem. If characters are waiting (EOF(1) is + ' true), get them and print them to the screen: + IF NOT EOF(1) THEN + + ' LOC(1) gives the number of characters waiting: + ModemInput$ = INPUT$(LOC(1), #1) + + Filter ModemInput$ ' Filter out line feeds and + PRINT ModemInput$; ' backspaces, then print. + END IF +LOOP + +CLOSE ' End communications. +CLS +END +' +' ========================= FILTER ========================== +' Filters characters in an input string. +' ============================================================ +' +SUB Filter (InString$) STATIC + + ' Look for backspace characters and recode them to + ' CHR$(29) (the LEFT cursor key): + DO + BackSpace = INSTR(Instring$, CHR$(8)) + IF BackSpace THEN + MID$(InString$, BackSpace) = CHR$(29) + END IF + LOOP WHILE BackSpace + + ' Look for line-feed characters and remove any found: + DO + LineFeed = INSTR(Instring$, CHR$(10)) + IF LineFeed THEN + InString$ = LEFT$(InString$, LineFeed - 1) + _ + MID$(InString$, LineFeed + 1) + END IF + LOOP WHILE LineFeed + +END SUB diff --git a/qb45/QB45/INC/EXAMPLES/TOKEN.BAS b/qb45/QB45/INC/EXAMPLES/TOKEN.BAS new file mode 100644 index 0000000..dcd4972 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/TOKEN.BAS @@ -0,0 +1,45 @@ +' TOKEN.BAS +' +' Demonstrates a BASIC version of the strtok C function. +' +DECLARE FUNCTION StrTok$(Source$,Delimiters$) + +LINE INPUT "Enter string: ",P$ +' Set up the characters that separate tokens. +Delimiters$=" ,;:().?"+CHR$(9)+CHR$(34) +' Invoke StrTok$ with the string to tokenize. +Token$=StrTok$(P$,Delimiters$) +WHILE Token$<>"" + PRINT Token$ + ' Call StrTok$ with a null string so it knows this + ' isn't the first call. + Token$=StrTok$("",Delimiters$) +WEND + +FUNCTION StrTok$(Srce$,Delim$) +STATIC Start%, SaveStr$ + + ' If first call, make a copy of the string. + IF Srce$<>"" THEN + Start%=1 : SaveStr$=Srce$ + END IF + + BegPos%=Start% : Ln%=LEN(SaveStr$) + ' Look for start of a token (character that isn't delimiter). + WHILE BegPos%<=Ln% AND INSTR(Delim$,MID$(SaveStr$,BegPos%,1))<>0 + BegPos%=BegPos%+1 + WEND + ' Test for token start found. + IF BegPos% > Ln% THEN + StrTok$="" : EXIT FUNCTION + END IF + ' Find the end of the token. + EndPos%=BegPos% + WHILE EndPos% <= Ln% AND INSTR(Delim$,MID$(SaveStr$,EndPos%,1))=0 + EndPos%=EndPos%+1 + WEND + StrTok$=MID$(SaveStr$,BegPos%,EndPos%-BegPos%) + ' Set starting point for search for next token. + Start%=EndPos% + +END FUNCTION diff --git a/qb45/QB45/INC/EXAMPLES/WHEREIS.BAS b/qb45/QB45/INC/EXAMPLES/WHEREIS.BAS new file mode 100644 index 0000000..224d909 --- /dev/null +++ b/qb45/QB45/INC/EXAMPLES/WHEREIS.BAS @@ -0,0 +1,158 @@ +DEFINT A-Z + +' Declare symbolic constants used in program: +CONST EOFTYPE = 0, FILETYPE = 1, DIRTYPE = 2, ROOT = "TWH" + +DECLARE SUB ScanDir (PathSpec$, Level, FileSpec$, Row) + +DECLARE FUNCTION MakeFileName$ (Num) +DECLARE FUNCTION GetEntry$ (FileNum, EntryType) + +CLS +INPUT "File to look for"; FileSpec$ +PRINT +PRINT "Enter the directory where the search should start" +PRINT "(optional drive + directories). Press to begin" +PRINT "the search in the root directory of the current drive." +PRINT +INPUT "Starting directory"; PathSpec$ +CLS + +RightCh$ = RIGHT$(PathSpec$, 1) + +IF PathSpec$ = "" OR RightCh$ = ":" OR RightCh$ <> "\" THEN + PathSpec$ = PathSpec$ + "\" +END IF + +FileSpec$ = UCASE$(FileSpec$) +PathSpec$ = UCASE$(PathSpec$) +Level = 1 +Row = 3 + +' Make the top level call (level 1) to begin the search: +ScanDir PathSpec$, Level, FileSpec$, Row + +KILL ROOT + ".*" ' Delete all temporary files created + ' by the program. + +LOCATE Row + 1, 1: PRINT "Search complete." +END +' +' ======================= GETENTRY ========================== +' This procedure processes entry lines in a DIR listing +' saved to a file. +' =========================================================== +' +FUNCTION GetEntry$ (FileNum, EntryType) STATIC + + ' Loop until a valid entry or end-of-file (EOF) is read: + DO UNTIL EOF(FileNum) + LINE INPUT #FileNum, EntryLine$ + IF EntryLine$ <> "" THEN + + ' Get first character from the line for test: + TestCh$ = LEFT$(EntryLine$, 1) + IF TestCh$ <> " " AND TestCh$ <> "." THEN EXIT DO + END IF + LOOP + + ' Entry or EOF found, decide which: + IF EOF(FileNum) THEN + EntryType = EOFTYPE + GetEntry$ = "" + + ELSE ' Not EOF, either a file or a directory. + + ' Build and return the entry name: + EntryName$ = RTRIM$(LEFT$(EntryLine$, 8)) + + ' Test for extension and add to name if there is one: + EntryExt$ = RTRIM$(MID$(EntryLine$, 10, 3)) + IF EntryExt$ <> "" THEN + GetEntry$ = EntryName$ + "." + EntryExt$ + ELSE + GetEntry$ = EntryName$ + END IF + + ' Determine the entry type, and return that + ' value to the point where GetEntry$ was called: + IF MID$(EntryLine$, 15, 3) = "DIR" THEN + EntryType = DIRTYPE ' Directory + ELSE + EntryType = FILETYPE ' File + END IF + + END IF + +END FUNCTION +' +' ===================== MAKEFILENAME$ ======================= +' This procedure makes a file name from a root string +' ("TWH" - defined as a symbolic constant at the module +' level) and a number passed to it as an argument (Num). +' =========================================================== +' +FUNCTION MakeFileName$ (Num) STATIC + + MakeFileName$ = ROOT + "." + LTRIM$(STR$(Num)) + +END FUNCTION +' +' ======================= SCANDIR =========================== +' This procedure recursively scans a directory for the +' file name entered by the user. +' +' NOTE: The SUB header doesn't use the STATIC keyword +' since this procedure needs a new set of variables +' each time it is invoked. +' =========================================================== +' +SUB ScanDir (PathSpec$, Level, FileSpec$, Row) + + LOCATE 1, 1: PRINT "Now searching"; SPACE$(50); + LOCATE 1, 15: PRINT PathSpec$; + + ' Make a file specification for the temporary file: + TempSpec$ = MakeFileName$(Level) + + ' Get a directory listing of the current directory, and + ' save it in the temporary file: + SHELL "DIR " + PathSpec$ + " > " + TempSpec$ + + ' Get the next available file number: + FileNum = FREEFILE + + ' Open the DIR listing file and scan it: + OPEN TempSpec$ FOR INPUT AS #FileNum + + ' Process the file, one line at a time: + DO + + ' Get an entry from the DIR listing: + DirEntry$ = GetEntry$(FileNum, EntryType) + + ' If entry is a file: + IF EntryType = FILETYPE THEN + + ' If the FileSpec$ string matches, print entry and + ' exit this loop: + IF DirEntry$ = FileSpec$ THEN + LOCATE Row, 1: PRINT PathSpec$; DirEntry$; + Row = Row + 1 + EntryType = EOFTYPE + END IF + + ' If the entry is a directory, then make a recursive + ' call to ScanDir with the new directory: + ELSEIF EntryType = DIRTYPE THEN + NewPath$ = PathSpec$ + DirEntry$ + "\" + ScanDir NewPath$, Level + 1, FileSpec$, Row + LOCATE 1, 1: PRINT "Now searching"; SPACE$(50); + LOCATE 1, 15: PRINT PathSpec$; + END IF + + LOOP UNTIL EntryType = EOFTYPE + + ' Scan on this DIR listing file is finished, so close it: + CLOSE FileNum +END SUB diff --git a/qb45/QB45/INC/QB.BI b/qb45/QB45/INC/QB.BI new file mode 100644 index 0000000..b1c9cfd --- /dev/null +++ b/qb45/QB45/INC/QB.BI @@ -0,0 +1,71 @@ +'*** +' QB.BI - Assembly Support Include File +' +' Copyright 1987 Microsoft Corporation +' +' Purpose: +' This include file defines the types and gives the DECLARE +' statements for the assembly language routines ABSOLUTE, +' INTERRUPT, INTERRUPTX, INT86OLD, and INT86XOLD. +' +'*************************************************************************** +' +' Define the type needed for INTERRUPT +' +TYPE RegType + ax AS INTEGER + bx AS INTEGER + cx AS INTEGER + dx AS INTEGER + bp AS INTEGER + si AS INTEGER + di AS INTEGER + flags AS INTEGER +END TYPE +' +' Define the type needed for INTERUPTX +' +TYPE RegTypeX + ax AS INTEGER + bx AS INTEGER + cx AS INTEGER + dx AS INTEGER + bp AS INTEGER + si AS INTEGER + di AS INTEGER + flags AS INTEGER + ds AS INTEGER + es AS INTEGER +END TYPE +' +' DECLARE statements for the 5 routines +' ------------------------------------- +' +' Generate a software interrupt, loading all but the segment registers +' +DECLARE SUB INTERRUPT (intnum AS INTEGER,inreg AS RegType,outreg AS RegType) +' +' Generate a software interrupt, loading all registers +' +DECLARE SUB INTERRUPTX (intnum AS INTEGER,inreg AS RegTypeX, outreg AS RegTypeX) +' +' Call a routine at an absolute address. +' NOTE: If the routine called takes parameters, then they will have to +' be added to this declare statement before the parameter given. +' +DECLARE SUB ABSOLUTE (address AS INTEGER) +' +' Generate a software interrupt, loading all but the segment registers +' (old version) +' +DECLARE SUB INT86OLD (intnum AS INTEGER,_ + inarray(1) AS INTEGER,_ + outarray(1) AS INTEGER) +' +' Gemerate a software interrupt, loading all the registers +' (old version) +' +DECLARE SUB INT86XOLD (intnum AS INTEGER,_ + inarray(1) AS INTEGER,_ + outarray(1) AS INTEGER) +' diff --git a/qb45/QB45/INC/QB.PIF b/qb45/QB45/INC/QB.PIF new file mode 100644 index 0000000..bd6ee1a Binary files /dev/null and b/qb45/QB45/INC/QB.PIF differ diff --git a/qb45/QB45/INC/QCARDS.BAS b/qb45/QB45/INC/QCARDS.BAS new file mode 100644 index 0000000..3ff096d Binary files /dev/null and b/qb45/QB45/INC/QCARDS.BAS differ diff --git a/qb45/QB45/INC/QCARDS.DAT b/qb45/QB45/INC/QCARDS.DAT new file mode 100644 index 0000000..12a69b1 Binary files /dev/null and b/qb45/QB45/INC/QCARDS.DAT differ diff --git a/qb45/QB45/INC/REMLINE.BAS b/qb45/QB45/INC/REMLINE.BAS new file mode 100644 index 0000000..f2830ba Binary files /dev/null and b/qb45/QB45/INC/REMLINE.BAS differ diff --git a/qb45/QB45/INC/SORTDEMO.BAS b/qb45/QB45/INC/SORTDEMO.BAS new file mode 100644 index 0000000..8eec9bb Binary files /dev/null and b/qb45/QB45/INC/SORTDEMO.BAS differ diff --git a/qb45/QB45/INC/TORUS.BAS b/qb45/QB45/INC/TORUS.BAS new file mode 100644 index 0000000..ef2e1e7 Binary files /dev/null and b/qb45/QB45/INC/TORUS.BAS differ diff --git a/qb45/QB45/LIB/QB.QLB b/qb45/QB45/LIB/QB.QLB new file mode 100644 index 0000000..d3ed3fa Binary files /dev/null and b/qb45/QB45/LIB/QB.QLB differ diff --git a/qb45/QB45/MOUSE.COM b/qb45/QB45/MOUSE.COM new file mode 100644 index 0000000..e7a7cfa Binary files /dev/null and b/qb45/QB45/MOUSE.COM differ diff --git a/qb45/QB45/PACKING.LST.txt b/qb45/QB45/PACKING.LST.txt new file mode 100644 index 0000000..9849b33 --- /dev/null +++ b/qb45/QB45/PACKING.LST.txt @@ -0,0 +1,168 @@ +PACKING.LST File for QuickBASIC Version 4.50 +This package comes with a number of demonstration and utility programs written in BASIC. +========================================================================================= +******** ROOT directory contents ******** +BC.EXE The BASIC command-line compiler invoked by the Run + menu's Make EXE File command or by the bc command + from the DOS command line. +BRUN45.EXE The QuickBASIC run-time module; required for running + executable files created with BRUN45.LIB. +LIB.EXE The Microsoft Library Manager; used to create + stand-alone (.LIB) libraries. +LINK.EXE The Microsoft Overlay Linker; used to create + executable files and Quick libraries. +QB.EXE The QuickBASIC program development environment. +QB.INI The QuickBASIC configuration file. +MOUSE.COM The Mouse driver for use with QuickBASIC programs + that call mouse functions. + + ******** \HLP directory contents ******** + QB45ENER.HLP File containing on-line help information dealing with + the QuickBASIC environment and error messages. + QB45QCK.HLP File containing on-line help on QuickBASIC. + QB45ADVR.HLP File containing on-line help information on QuickBASIC. + + ******** \INC directory contents ******** + DEMO1.BAS A BASICA version of a sound-effects demonstration + program. + DEMO2.BAS The QuickBASIC 2.0 version of DEMO1.BAS. + DEMO3.BAS The QuickBASIC 4.0 (and higher) version of DEMO1.BAS. + QCARDS.BAS Supplied code for the QCARDS database program used + in the Hands On with QuickBASIC tutorial. In Part 2 + of the manual Learning to Use QuickBASIC, you add + the module-level code that completes this program. + QCARDS.DAT Supplied data file for the QCARDS database program. + Keep this file in the current directory as you add + code during the QCARDS.BAS tutorial. + REMLINE.BAS A utility program that converts BASICA programs + saved in ASCII format to QuickBASIC-style programs + by removing unreferenced line numbers. + SORTDEMO.BAS A program that uses multicolored bars and sound to + illustrate various sorting algorithms. + TORUS.BAS A graphics demonstration program that draws a + multicolored doughnut-shaped figure on the screen, + then animates it by shifting colors in the palette. + QB.BI An include file for use with BASIC programs that + call any of the following routines in the QB.QLB + Quick library or in the QB.LIB stand-alone library: + ABSOLUTE, INTERRUPT, INTERRUPTX, INT86OLD, or + INT86XOLD. The QB.BI file defines the types for + arguments passed to these routines and also gives + DECLARE statements for these routines. + NOEM.OBJ (NO EMulation). An object file to link with BASIC + programs that will always be run on machines with an + 8087 or 80287 math coprocessor chip. Linking with + NOEM.OBJ turns off software emulation of the math + chip's function, and reduces the size of the + executable file. + SMALLERR.OBJ An object file to link with BASIC programs that do + not require run-time error messages. Linking with + SMALLERR.OBJ reduces the size of executable files + that do not need run-time error messages. + QB.PIF A file that provides information to aid in running + QuickBASIC under Microsoft Windows. + + \ADVR_EX A directory containing BASIC programs cited in the on-line help. + ******** \ADVR_EX directory contents ******** + CALL_EX.BAS Illustrates using the CALL statement + CHR_EX.BAS Illustrates using the the CHR$ function + CMD_EX.BAS Illustrates using the the COMMAND$ function + COM1_EX.BAS Illustrates using the the COMMON and CHAIN statements + COM2_EX.BAS Module used in COM1_EX.BAS above + CSR_EX.BAS Illustrates using the the CSRLIN function + DECL_EX.BAS Illustrates using the DECLARE statement + DEFFN_EX.BAS Illustrates using the DEF FN statement + DEFSG_EX.BAS Illustrates using the DEF SEG, PEEK, and POKE statements + DRAW_EX.BAS Illustrates using the DRAW statement + FUNC_EX.BAS Illustrates using FUNCTION...END FUNCTION + OUT_EX.BAS Illustrates using the OUT statement + SHARE_EX.BAS Illustrates using the SHARED statement + SHELL_EX.BAS Illustrates using the SHELL statement + STAT_EX.BAS Illustrates using the STATIC statement + SUB_EX.BAS Illustrates using SUB...END SUB + TYPE_EX.BAS Illustrates using TYPE..END TYPE + UBO_EX.BAS Illustrates using the UBOUND and LBOUND functions + UCASE_EX.BAS Illustrates using the UCASE$ function + WINDO_EX.BAS Illustrates using the WINDOW statement + + \EXAMPLES A directory containing BASIC programs printed in the QuickBASIC manuals and other demonstration programs. + ******** \EXAMPLES directory contents ******** + BALLPSET.BAS A program that bounces a ball off the bottom and + sides of the screen by using the PSET option with + the graphics PUT statement. + BALLXOR.BAS A program that bounces a ball off the bottom and + sides of the screen by using the XOR option with + the graphics PUT statement. + BAR.BAS A program that turns input data into a bar chart. + CAL.BAS A program that prints a calendar for any month in + any year from 1899 to 2099. + CHECK.BAS A checkbook-balancing program that sorts and prints a + list of any deposits and withdrawals input by the + user, then prints the final balance in the checking + account. + COLORS.BAS A program showing all combinations of the 16 background + colors and 3 foreground colors (distinct from the + background) in the 2 color palettes available in screen + mode 1. + CRLF.BAS A program that opens an ASCII file, expands any lines + ending with just a carriage return or a line feed to + a carriage-return--line-feed combination, then writes + the adjusted lines to a new file. + CUBE.BAS A program that illustrates simple animation of a + cube by using multiple screen pages in screen mode 7. + EDPAT.BAS A program that allows you to edit a pattern tile + for use in a PAINT statement. With pattern tiles, + you can fill any enclosed graphics area on the screen + with a pattern. + ENTAB.BAS A program that compresses an ASCII file by replacing + runs of spaces with tab characters. + FILERR.BAS A program that searches for a string of characters in + an ASCII file. This program traps and handles common + file-access errors such as the user's entering an + invalid file name or leaving a drive door open. + FLPT.BAS A program that lets you examine the internal format + used by BASIC to store single-precision numbers. + INDEX.BAS A file I/O program that builds and searches an index + of record numbers from a random-access data file. + MANDEL.BAS A program that generates a fractal (a colorful graphic + representation of the properties of certain real + numbers) on the screen. + PALETTE.BAS A program that demonstrates how to give the illusion + of movement by rotating the colors displayed by + the color attributes from 1 to 15. + PLOTTER.BAS A simple line-sketching program that uses BASIC's + DRAW statement. + QLBDUMP.BAS A program that allows you to get a listing of the + PUBLIC code and data symbols in a QuickBASIC Quick + library. + SEARCH.BAS A program that searches any disk file for a pattern + and reports every byte position in the file where + the pattern begins. + SINEWAVE.BAS A program that plots the graph of the sine-wave + function for angle values from 0 to PI radians. + STRTONUM.BAS A program that converts to a numeric value any number + input as a string, after first filtering invalid + numeric characters (such as commas) out of the + string. + TERMINAL.BAS A program that turns your computer into a "dumb" + terminal when used with a modem. + TOKEN.BAS A program that breaks an input string into a series + of tokens (a string of characters delimited by + blank spaces, tabs, or punctuation marks such as + commas or semicolons). + WHEREIS.BAS A program that recursively searches through all + directories on a disk for a specified file name. + + ******** \LIB directory contents ******** + BRUN45.LIB The QuickBASIC run-time-module library; used for + creating executable files from QuickBASIC and DOS. + BQLB45.LIB The library of supporting routines that are used when + creating Quick libraries. + BCOM45.LIB The QuickBASIC alternate run-time-module library; + used for creating executable files from QuickBASIC + and DOS (files created with this library do not + require BRUN45.EXE to run). + QB.LIB The stand-alone library containing support routines + for DOS system calls. + QB.QLB The Quick library containing support routines for + DOS system calls. diff --git a/qb45/QB45/QB.INI b/qb45/QB45/QB.INI new file mode 100644 index 0000000..8ee1a78 Binary files /dev/null and b/qb45/QB45/QB.INI differ diff --git a/updated_dack.exe b/updated_dack.exe deleted file mode 100644 index 5fea951..0000000 Binary files a/updated_dack.exe and /dev/null differ