OS_Develop/dos_compilers
OS_Develop/dos_compilers
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

microsoft quickbasic v4.5

Browse Source
This commit is contained in:
davidly 2024-07-01 21:19:24 -07:00
parent b2f79aeb5e
commit 888551a4fc
74 changed files with 3591 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
Microsoft QuickBASIC v45/ADVR_EX/CALL_EX.BAS Normal file
View File

@ -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


32
Microsoft QuickBASIC v45/ADVR_EX/CHR_EX.BAS Normal file
View File

@ -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


57
Microsoft QuickBASIC v45/ADVR_EX/CMD_EX.BAS Normal file
View File

@ -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


21
Microsoft QuickBASIC v45/ADVR_EX/COM1_EX.BAS Normal file
View File

@ -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"


16
Microsoft QuickBASIC v45/ADVR_EX/COM2_EX.BAS Normal file
View File

@ -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


24
Microsoft QuickBASIC v45/ADVR_EX/CSR_EX.BAS Normal file
View File

@ -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


36
Microsoft QuickBASIC v45/ADVR_EX/DECL_EX.BAS Normal file
View File

@ -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


15
Microsoft QuickBASIC v45/ADVR_EX/DEFFN_EX.BAS Normal file
View File

@ -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)


45
Microsoft QuickBASIC v45/ADVR_EX/DEFSG_EX.BAS Normal file
View File

@ -0,0 +1,45 @@
' *** DEFSG_EX.BAS ***
'
DECLARE SUB CapsOn ()
DECLARE SUB CapsOff ()
DECLARE SUB PrntMsg (R%,C%,M$)
CLS
CapsOn
PrntMsg 24,1,"<Caps Lock On>"
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


41
Microsoft QuickBASIC v45/ADVR_EX/DRAW_EX.BAS Normal file
View File

@ -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


16
Microsoft QuickBASIC v45/ADVR_EX/FUNC_EX.BAS Normal file
View File

@ -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

34
Microsoft QuickBASIC v45/ADVR_EX/OUT_EX.BAS Normal file
View File

@ -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


29
Microsoft QuickBASIC v45/ADVR_EX/SHARE_EX.BAS Normal file
View File

@ -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


46
Microsoft QuickBASIC v45/ADVR_EX/SHELL_EX.BAS Normal file
View File

@ -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


49
Microsoft QuickBASIC v45/ADVR_EX/STAT_EX.BAS Normal file
View File

@ -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


17
Microsoft QuickBASIC v45/ADVR_EX/SUB_EX.BAS Normal file
View File

@ -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


77
Microsoft QuickBASIC v45/ADVR_EX/TYPE_EX.BAS Normal file
View File

@ -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


22
Microsoft QuickBASIC v45/ADVR_EX/UBO_EX.BAS Normal file
View File

@ -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

34
Microsoft QuickBASIC v45/ADVR_EX/UCASE_EX.BAS Normal file
View File

@ -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)


28
Microsoft QuickBASIC v45/ADVR_EX/WINDO_EX.BAS Normal file
View File

@ -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


BIN
Microsoft QuickBASIC v45/BC.EXE Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/BCOM45.LIB Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/BQLB45.LIB Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/BRUN45.EXE Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/BRUN45.LIB Normal file
View File

Binary file not shown.

56
Microsoft QuickBASIC v45/DEMO1.BAS Normal file
View File

@ -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

76
Microsoft QuickBASIC v45/DEMO2.BAS Normal file
View File

@ -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

78
Microsoft QuickBASIC v45/DEMO3.BAS Normal file
View File

@ -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

31
Microsoft QuickBASIC v45/E.BAS Normal file
View File

@ -0,0 +1,31 @@
100 DIGITS% = 200
110 DIM A%( 200 )
120 HIGH% = DIGITS%
130 X% = 0
140 N% = HIGH% - 1
150 IF N% <= 0 GOTO 200
160 A%[ N% ] = 1
170 N% = N% - 1
180 GOTO 150
200 A%[ 1 ] = 2
210 A%[ 0 ] = 0
220 IF HIGH% <= 9 GOTO 400
230 HIGH% = HIGH% - 1
235 N% = HIGH%
240 IF N% = 0 GOTO 300
250 A%[ N% ] = X% MOD N%
255 rem PRINT "a[n-1]"; A%[ N% - 1 ]
260 X% = ( 10 * A%[ N% - 1 ] ) + ( X% \ N% )
265 rem PRINT "x: "; X%, "n: "; N%
270 N% = N% - 1
280 GOTO 240
300 IF X% >= 10 GOTO 330
310 PRINT USING "#"; X%;
320 GOTO 220
330 PRINT USING "##"; X%;
340 GOTO 220
400 PRINT ""
410 PRINT "done"
420 SYSTEM

103
Microsoft QuickBASIC v45/EXAMPLES/BALLPSET.BAS Normal file
View File

@ -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

81
Microsoft QuickBASIC v45/EXAMPLES/BALLXOR.BAS Normal file
View File

@ -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

219
Microsoft QuickBASIC v45/EXAMPLES/BAR.BAS Normal file
View File

@ -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

176
Microsoft QuickBASIC v45/EXAMPLES/CAL.BAS Normal file
View File

@ -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

60
Microsoft QuickBASIC v45/EXAMPLES/CHECK.BAS Normal file
View File

@ -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 <ENTER>: ", 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

45
Microsoft QuickBASIC v45/EXAMPLES/COLORS.BAS Normal file
View File

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

139
Microsoft QuickBASIC v45/EXAMPLES/CRLF.BAS Normal file
View File

@ -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
' <filename>.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

26
Microsoft QuickBASIC v45/EXAMPLES/CUBE.BAS Normal file
View File

@ -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

211
Microsoft QuickBASIC v45/EXAMPLES/EDPAT.BAS Normal file
View File

@ -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

104
Microsoft QuickBASIC v45/EXAMPLES/ENTAB.BAS Normal file
View File

@ -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

105
Microsoft QuickBASIC v45/EXAMPLES/FILERR.BAS Normal file
View File

@ -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 <ENTER> 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

73
Microsoft QuickBASIC v45/EXAMPLES/FLPT.BAS Normal file
View File

@ -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

310
Microsoft QuickBASIC v45/EXAMPLES/INDEX.BAS Normal file
View File

@ -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 <ENTER>: ", 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

180
Microsoft QuickBASIC v45/EXAMPLES/MANDEL.BAS Normal file
View File

@ -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 <ENTER> 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

62
Microsoft QuickBASIC v45/EXAMPLES/PALETTE.BAS Normal file
View File

@ -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

54
Microsoft QuickBASIC v45/EXAMPLES/PLOTTER.BAS Normal file
View File

@ -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 <ENTER> 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

88
Microsoft QuickBASIC v45/EXAMPLES/QLBDUMP.BAS Normal file
View File

@ -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

50
Microsoft QuickBASIC v45/EXAMPLES/SEARCH.BAS Normal file
View File

@ -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."

30
Microsoft QuickBASIC v45/EXAMPLES/SINEWAVE.BAS Normal file
View File

@ -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

34
Microsoft QuickBASIC v45/EXAMPLES/STRTONUM.BAS Normal file
View File

@ -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

74
Microsoft QuickBASIC v45/EXAMPLES/TERMINAL.BAS Normal file
View File

@ -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

45
Microsoft QuickBASIC v45/EXAMPLES/TOKEN.BAS Normal file
View File

@ -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

158
Microsoft QuickBASIC v45/EXAMPLES/WHEREIS.BAS Normal file
View File

@ -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 <ENTER> 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

BIN
Microsoft QuickBASIC v45/LIB.EXE Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/LINK.EXE Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/MOUSE.COM Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/NOEM.OBJ Normal file
View File

Binary file not shown.

71
Microsoft QuickBASIC v45/QB.BI Normal file
View File

@ -0,0 +1,71 @@
'***
' QB.BI - Assembly Support Include File
'
' Copyright <C> 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)
'

BIN
Microsoft QuickBASIC v45/QB.EXE Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/QB.INI Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/QB.LIB Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/QB.PIF Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/QB.QLB Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/QB45ADVR.HLP Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/QB45ENER.HLP Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/QB45QCK.HLP Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/QCARDS.BAS Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/QCARDS.DAT Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/REMLINE.BAS Normal file
View File

Binary file not shown.

20
Microsoft QuickBASIC v45/SIEVE.BAS Normal file
View File

@ -0,0 +1,20 @@
1 SIZE% = 8190
2 DIM FLAGS%(8191)
3 PRINT "10 iterations"
4 FOR X% = 1 TO 10
5 COUNT% = 0
6 FOR I% = 0 TO SIZE%
7 FLAGS%(I%) = 1
8 NEXT I%
9 FOR I% = 0 TO SIZE%
10 IF FLAGS%(I%) = 0 THEN 18
11 PRIME% = I% + I% + 3
12 K% = I% + PRIME%
13 IF K% > SIZE% THEN 17
14 FLAGS%(K%) = 0
15 K% = K% + PRIME%
16 GOTO 13
17 COUNT% = COUNT% + 1
18 NEXT I%
19 NEXT X%
20 PRINT COUNT%," PRIMES"

BIN
Microsoft QuickBASIC v45/SMALLERR.OBJ Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/SORTDEMO.BAS Normal file
View File

Binary file not shown.

BIN
Microsoft QuickBASIC v45/TORUS.BAS Normal file
View File

Binary file not shown.

121
Microsoft QuickBASIC v45/TTT.BAS Normal file
View File

@ -0,0 +1,121 @@
1 REM Tic Tac Toe solving app that learns what WOPR learned: you can't win
2 REM Only three starting positions are examined. Others are just reflections of these
3 REM b% -- The board
4 REM al% -- Alpha, for pruning
5 REM be% -- Beta, for pruning
6 REM l% -- Top-level loop iteration
7 REM wi% -- The winning piece (0 none, 1 X, 2, O )
8 REM re% -- Resulting score of 4000/minmax board position. 5 draw, 6 X win, 4 Y win
9 REM sx% -- Stack array for "recursion" X can be P, V, A, or B for those variables.
10 REM v% -- Value of a board position
11 REM st% -- Stack Pointer. Even for alpha/beta pruning Minimize plys, Odd for Maximize
12 REM p% -- Current position where a new piece is played
14 REM rw% -- Row in the Winner function (2000)
15 REM cw% -- Column in the Winner function (2000)
18 REM mc% -- Move count total for debugging. Should be a multiple of 6493
19 REM Note: Can't use real recursion with GOSUB because stack is limited to roughly 5 deep
20 REM BASIC doesn't support goto/gosub using arrays for target line numbers
23 li% = val( command$ )
24 if 0 = li% then li% = 1
30 DIM b%(9)
32 DIM sp%(10)
34 DIM sv%(10)
36 DIM sa%(10)
37 DIM sb%(10)
38 mc% = 0
39 PRINT "start time: "; TIME$
40 FOR l% = 1 TO li%
41 mc% = 0
42 al% = 2
43 be% = 9
44 b%(0) = 1
45 GOSUB 4000
58 al% = 2
59 be% = 9
60 b%(0) = 0
61 b%(1) = 1
62 GOSUB 4000
68 al% = 2
69 be% = 9
70 b%(1) = 0
71 b%(4) = 1
72 GOSUB 4000
73 b%(4) = 0
74 REM print "mc: "; mc%; " l is "; l%
80 NEXT l%
82 REM print elap$
83 PRINT "end time: "; TIME$
84 print "iterations: "; li%
85 PRINT "final move count "; mc%
88 SYSTEM
100 END
2000 wi% = b%(0)
2010 IF 0 = wi% GOTO 2100
2020 IF wi% = b%(1) AND wi% = b%(2) THEN RETURN
2030 IF wi% = b%(3) AND wi% = b%(6) THEN RETURN
2100 wi% = b%(3)
2110 IF 0 = wi% GOTO 2200
2120 IF wi% = b%(4) AND wi% = b%(5) THEN RETURN
2200 wi% = b%(6)
2210 IF 0 = wi% GOTO 2300
2220 IF wi% = b%(7) AND wi% = b%(8) THEN RETURN
2300 wi% = b%(1)
2310 IF 0 = wi% GOTO 2400
2320 IF wi% = b%(4) AND wi% = b%(7) THEN RETURN
2400 wi% = b%(2)
2410 IF 0 = wi% GOTO 2500
2420 IF wi% = b%(5) AND wi% = b%(8) THEN RETURN
2500 wi% = b%(4)
2510 IF 0 = wi% THEN RETURN
2520 IF wi% = b%(0) AND wi% = b%(8) THEN RETURN
2530 IF wi% = b%(2) AND wi% = b%(6) THEN RETURN
2540 wi% = 0
2550 RETURN
4000 REM minmax function to find score of a board position
4010 REM recursion is simulated with gotos
4030 st% = 0
4040 v% = 0
4060 re% = 0
4100 mc% = mc% + 1
4102 REM gosub 3000
4104 IF st% < 4 THEN GOTO 4150
4105 GOSUB 2000
4106 IF 0 = wi% THEN GOTO 4140
4110 IF wi% = 1 THEN re% = 6: GOTO 4280
4115 re% = 4
4116 GOTO 4280
4140 IF st% = 8 THEN re% = 5: GOTO 4280
4150 IF st% AND 1 THEN v% = 2 ELSE v% = 9
4160 p% = 0
4180 IF 0 <> b%(p%) THEN GOTO 4500
4200 IF st% AND 1 THEN b%(p%) = 1 ELSE b%(p%) = 2
4210 sp%(st%) = p%
4230 sv%(st%) = v%
4245 sa%(st%) = al%
4246 sb%(st%) = be%
4260 st% = st% + 1
4270 GOTO 4100
4280 st% = st% - 1
4290 p% = sp%(st%)
4310 v% = sv%(st%)
4325 al% = sa%(st%)
4326 be% = sb%(st%)
4328 b%(p%) = 0
4330 IF st% AND 1 THEN GOTO 4340
4331 IF re% = 4 THEN GOTO 4530
4332 IF re% < v% THEN v% = re%
4334 IF v% < be% THEN be% = v%
4336 IF be% <= al% THEN GOTO 4520
4338 GOTO 4500
4340 IF re% = 6 THEN GOTO 4530
4341 IF re% > v% THEN v% = re%
4342 IF v% > al% THEN al% = v%
4344 IF al% >= be% THEN GOTO 4520
4500 p% = p% + 1
4505 IF p% < 9 THEN GOTO 4180
4520 re% = v%
4530 IF st% = 0 THEN RETURN
4540 GOTO 4280

3
Microsoft QuickBASIC v45/m.bat Normal file
View File

@ -0,0 +1,3 @@
ntvdm -r:. -c bc %1.bas %1.obj %1.lst /O
ntvdm -r:. -c link %1,,%1,.\,nul.def