📄 svgamod2.bas
字号:
'*************************************************************************
MOUSEHIDE
SETVIEW 0, 0, GETMAXX, 48
FILLVIEW 0
DRWSTRING 1, 7, 0, TITLE$, 10, 0
A$ = "MOUSERANGESET (X1,Y1,X2,Y2)"
DRWSTRING 1, 7, 0, A$, 10, 16
SETVIEW 0, 0, GETMAXX, GETMAXY
SPCNG = (GETMAXY - 32) \ 3
X1 = SPCNG
Y1 = 32 + SPCNG
X2 = GETMAXX - SPCNG
Y2 = GETMAXY - SPCNG
DRWBOX 1, 15, X1, Y1, X2, Y2
MOUSESHOW
MOUSERANGESET X1, Y1, X2, Y2
GETKEY RET$
MOUSERANGESET 0, 0, GETMAXX, GETMAXY
IF (RET$ = "S") OR (RET$ = "Q") THEN
MOUSEEXIT '*MUST BE CALLED TO DISABLE MOUSE FUNCTIONS
FILLSCREEN 0
SETVIEW 0, 0, GETMAXX, GETMAXY
EXIT SUB
END IF
'*************************************************************************
'* SHOW MOUSECURSORSET USE THE MAGNIFIER
'*************************************************************************
SETVIEW 0, 0, GETMAXX, 31
FILLVIEW 0
DRWSTRING 1, 7, 0, TITLE$, 10, 0
A$ = "MOUSECURSORSET (XHotSpot,YHotSpot,MouseCursor$)"
DRWSTRING 1, 7, 0, A$, 10, 16
SETVIEW 0, 32, GETMAXX, GETMAXY
MOUSECURSORSET MAGMOUSECURSOR
GETKEY RET$
IF (RET$ = "S") OR (RET$ = "Q") THEN
MOUSEEXIT '*MUST BE CALLED TO DISABLE MOUSE FUNCTIONS
FILLSCREEN 0
SETVIEW 0, 0, GETMAXX, GETMAXY
EXIT SUB
END IF
'*************************************************************************
'* SHOW MOUSECURSORSET USE THE BIG ARROW
'*************************************************************************
SETVIEW 0, 32, GETMAXX, GETMAXY
MOUSECURSORSET BIGMOUSECURSOR
GETKEY RET$
IF (RET$ = "S") OR (RET$ = "Q") THEN
MOUSEEXIT '*MUST BE CALLED TO DISABLE MOUSE FUNCTIONS
FILLSCREEN 0
SETVIEW 0, 0, GETMAXX, GETMAXY
EXIT SUB
END IF
'*************************************************************************
'* SHOW MOUSECURSORSET USE THE STOPWATCH
'*************************************************************************
MOUSECURSORSET STWMOUSECURSOR
GETKEY RET$
IF (RET$ = "S") OR (RET$ = "Q") THEN
MOUSEEXIT '*MUST BE CALLED TO DISABLE MOUSE FUNCTIONS
FILLSCREEN 0
SETVIEW 0, 0, GETMAXX, GETMAXY
EXIT SUB
END IF
'*************************************************************************
'* SHOW MOUSECURSORDEFAULT
'*************************************************************************
MOUSEHIDE
SETVIEW 0, 0, GETMAXX, 31
FILLVIEW 0
DRWSTRING 1, 7, 0, TITLE$, 10, 0
A$ = "MOUSECURSORDEFAULT ()"
DRWSTRING 1, 7, 0, A$, 10, 16
MOUSESHOW
SETVIEW 0, 32, GETMAXX, GETMAXY
MOUSECURSORDEFAULT
GETKEY RET$
MOUSEEXIT '*MUST BE CALLED TO DISABLE MOUSE FUNCTIONS
FILLSCREEN 0
SETVIEW 0, 0, GETMAXX, GETMAXY
END SUB
SUB DOPCX (RET$)
DEFINT A-Z
REM $DYNAMIC
'*************************************************************************
'* SET UP THE TITLE
'*************************************************************************
TITLE$ = "DEMO 8: PCX functions"
'*************************************************************************
'* SHOW PCX GET INFO
'*************************************************************************
SETVIEW 0, 0, GETMAXX, GETMAXY
FILLSCREEN 0
DRWSTRING 1, 7, 0, TITLE$, 10, 0
LP:
A$ = "Please provide the name and full path (if not in the current drive/directory)"
B$ = "of a PCX file you would like to see..."
C$ = "Filename:"
DRWSTRING 1, 7, 0, A$, 10, 64
DRWSTRING 1, 7, 0, B$, 10, 80
DRWSTRING 1, 7, 0, C$, 10, 96
FILENAME$ = "_"
LENGTH = 0
EXT = 0
WHILE EXT = 0
DRWSTRING 1, 15, 0, FILENAME$, 82, 96
A$ = ""
WHILE LEN(A$) < 1 OR LEN(A$) > 1
A$ = INKEY$
WEND
A = ASC(A$)
IF A > 31 AND A < 128 THEN
FILENAME$ = LEFT$(FILENAME$, LENGTH) + A$ + "_"
LENGTH = LENGTH + 1
ELSE
IF A = 8 AND LENGTH > 0 THEN
DRWSTRING 1, 15, 0, STRING$(LENGTH + 1, 32), 82, 96
LENGTH = LENGTH - 1
FILENAME$ = LEFT$(FILENAME$, LENGTH) + "_"
ELSEIF A = 13 THEN
EXT = 1
END IF
END IF
WEND
FILENAME$ = LEFT$(FILENAME$, LENGTH)
IF LEN(FILENAME$) < 1 THEN
EXIT SUB '* OOPS! NO NAME GIVEN SO LET'S JUST BAIL OUT!
END IF
SHOWPCX RET$, FILENAME$
IF RET$ = "S" OR RET$ = "Q" THEN
FILLSCREEN 0
EXIT SUB
END IF
DRWSTRING 1, 7, 0, TITLE$, 10, 0
A$ = "Would you like to see another (Y/N) ?"
DRWSTRING 1, 7, 0, A$, 10, 64
EXT = 0
SOUND 700, .75
WHILE EXT = 0
A$ = ""
WHILE A$ = ""
A$ = INKEY$
WEND
IF A$ = "Y" OR A$ = "y" THEN
GOTO LP
ELSEIF A$ = "N" OR A$ = "n" THEN
EXT = 1
ELSE
SOUND 100, 5
END IF
WEND
FILLSCREEN 0
END SUB
SUB SHOWHOUSE
DEFINT A-Z
REM $DYNAMIC
SHARED OPLOTARRY() AS P2DType
SHARED PLOTARRY() AS P2DType
'*************************************************************************
'* THIS ROUTINE IS CALLED BY DO3D
'*************************************************************************
'*************************************************************************
'* ERASE THE OLD HOUSE
'*************************************************************************
DRWLINE 1, 0, OPLOTARRY(10).X, OPLOTARRY(10).Y, OPLOTARRY(11).X, OPLOTARRY(11).Y
DRWLINE 1, 0, OPLOTARRY(10).X, OPLOTARRY(10).Y, OPLOTARRY(12).X, OPLOTARRY(12).Y
DRWLINE 1, 0, OPLOTARRY(10).X, OPLOTARRY(10).Y, OPLOTARRY(13).X, OPLOTARRY(13).Y
FOR I = 0 TO 2
DRWLINE 1, 0, OPLOTARRY(I).X, OPLOTARRY(I).Y, OPLOTARRY(I + 1).X, OPLOTARRY(I + 1).Y
DRWLINE 1, 0, OPLOTARRY(I + 4).X, OPLOTARRY(I + 4).Y, OPLOTARRY(I + 4 + 1).X, OPLOTARRY(I + 4 + 1).Y
DRWLINE 1, 0, OPLOTARRY(I).X, OPLOTARRY(I).Y, OPLOTARRY(I + 4).X, OPLOTARRY(I + 4).Y
NEXT I
DRWLINE 1, 0, OPLOTARRY(3).X, OPLOTARRY(3).Y, OPLOTARRY(7).X, OPLOTARRY(7).Y
DRWLINE 1, 0, OPLOTARRY(0).X, OPLOTARRY(0).Y, OPLOTARRY(3).X, OPLOTARRY(3).Y
DRWLINE 1, 0, OPLOTARRY(4).X, OPLOTARRY(4).Y, OPLOTARRY(7).X, OPLOTARRY(7).Y
DRWLINE 1, 0, OPLOTARRY(3).X, OPLOTARRY(3).Y, OPLOTARRY(8).X, OPLOTARRY(8).Y
DRWLINE 1, 0, OPLOTARRY(8).X, OPLOTARRY(8).Y, OPLOTARRY(2).X, OPLOTARRY(2).Y
DRWLINE 1, 0, OPLOTARRY(7).X, OPLOTARRY(7).Y, OPLOTARRY(9).X, OPLOTARRY(9).Y
DRWLINE 1, 0, OPLOTARRY(9).X, OPLOTARRY(9).Y, OPLOTARRY(6).X, OPLOTARRY(6).Y
DRWLINE 1, 0, OPLOTARRY(8).X, OPLOTARRY(8).Y, OPLOTARRY(9).X, OPLOTARRY(9).Y
'*************************************************************************
'* DRAW THE NEW HOUSE
'*************************************************************************
DRWLINE 1, 8, PLOTARRY(10).X, PLOTARRY(10).Y, PLOTARRY(11).X, PLOTARRY(11).Y
DRWLINE 1, 8, PLOTARRY(10).X, PLOTARRY(10).Y, PLOTARRY(12).X, PLOTARRY(12).Y
DRWLINE 1, 8, PLOTARRY(10).X, PLOTARRY(10).Y, PLOTARRY(13).X, PLOTARRY(13).Y
FOR I = 0 TO 2
DRWLINE 1, 10, PLOTARRY(I).X, PLOTARRY(I).Y, PLOTARRY(I + 1).X, PLOTARRY(I + 1).Y
DRWLINE 1, 10, PLOTARRY(I + 4).X, PLOTARRY(I + 4).Y, PLOTARRY(I + 4 + 1).X, PLOTARRY(I + 4 + 1).Y
DRWLINE 1, 10, PLOTARRY(I).X, PLOTARRY(I).Y, PLOTARRY(I + 4).X, PLOTARRY(I + 4).Y
NEXT I
DRWLINE 1, 10, PLOTARRY(3).X, PLOTARRY(3).Y, PLOTARRY(7).X, PLOTARRY(7).Y
DRWLINE 1, 10, PLOTARRY(0).X, PLOTARRY(0).Y, PLOTARRY(3).X, PLOTARRY(3).Y
DRWLINE 1, 10, PLOTARRY(4).X, PLOTARRY(4).Y, PLOTARRY(7).X, PLOTARRY(7).Y
DRWLINE 1, 10, PLOTARRY(3).X, PLOTARRY(3).Y, PLOTARRY(8).X, PLOTARRY(8).Y
DRWLINE 1, 10, PLOTARRY(8).X, PLOTARRY(8).Y, PLOTARRY(2).X, PLOTARRY(2).Y
DRWLINE 1, 10, PLOTARRY(7).X, PLOTARRY(7).Y, PLOTARRY(9).X, PLOTARRY(9).Y
DRWLINE 1, 10, PLOTARRY(9).X, PLOTARRY(9).Y, PLOTARRY(6).X, PLOTARRY(6).Y
DRWLINE 1, 10, PLOTARRY(8).X, PLOTARRY(8).Y, PLOTARRY(9).X, PLOTARRY(9).Y
'*************************************************************************
'* SAVE THE OLD POINTS
'*************************************************************************
BYTECOPY PLOTARRY(0).X, OPLOTARRY(0).X, 56
END SUB
SUB SHOWPCX (RET$, FILENAME$)
DEFINT A-Z
REM $DYNAMIC
'*************************************************************************
'* THIS ROUTINE IS CALLED BY DOPCX
'*************************************************************************
TITLE$ = "DEMO 8: PCX functions"
'*************************************************************************
'* SHOW PCX GET INFO
'*************************************************************************
FILLSCREEN 0
DRWSTRING 1, 7, 0, TITLE$, 10, 0
A$ = "PCXGETINFO(FileName$,PCXXSize,PCXYSize,NumColors,Palette$)"
DRWSTRING 1, 7, 0, A$, 10, 16
PCXFILENAME$ = FILENAME$
OK = PCXGETINFO(PCXFILENAME$, XSIZE, YSIZE, NUMCOL, PCXPAL)
MIN& = (255 ^ 2) * 3
MAX& = 0
IF OK = 1 THEN
'*********************************************************************
'* WE NEED TO CHECK THE PCX COLOR PALETTE ENTRIES TO SEE IF ANY COLORS
'* ARE GREATER THE SIX BITS IN LENGTH AS THE VGA COLOR PALETTE
'* REGISTERS ARE ONLY SIX BITS WIDE. WE ALSO LOOK FOR THE BRIGHTEST
'* AND DARKEST COLORS TO USE AS OUR TEXT AND BACKGROUND COLORS
'*********************************************************************
FIXIT = 0
FOR A = 1 TO NUMCOL * 3 STEP 3
R = ASC(MID$(PCXPAL, A, 1))
G = ASC(MID$(PCXPAL, A + 1, 1))
B = ASC(MID$(PCXPAL, A + 2, 1))
IF R > 63 THEN
FIXIT = 1
END IF
IF G > 63 THEN
FIXIT = 1
END IF
IF B > 63 THEN
FIXIT = 1
END IF
TEST& = R ^ 2 + G ^ 2 + B ^ 2
IF TEST& < MIN& THEN
'* FIND THE DARKEST COLOR FOR THE BACKGROUND
MIN& = TEST&
MINCOLOR = A / 3
END IF
IF TEST& > MAX& THEN
'* FIND THE BRIGHTEST COLOR FOR THE TEXT
MAX& = TEST&
MAXCOLOR = A / 3
END IF
NEXT A
'*********************************************************************
'* IF THE PCX USES 8 BIT COLOR THEN WE SHIFT EACH COLOR ENTRY RIGHT
'* BY 2 BITS (THIS REDUCES IT TO 6 BITS OF COLOR)
'*********************************************************************
IF FIXIT = 1 THEN
FOR A = 1 TO NUMCOL * 3
C = ASC(MID$(PCXPAL, A, 1))
MID$(PCXPAL, A, 1) = CHR$(C \ 4)
NEXT A
END IF
'*********************************************************************
'* IF THE PCX HAS A PALETTE OF 128 COLORS OR LESS THEN WE CAN USE
'* OUR OWN COLORS FOR THE TEXT AND BACKGROUND
'*********************************************************************
IF NUMCOL < 128 THEN
MID$(PCXPAL, 763, 1) = CHR$(0) '* THIS IS THE COLOR BLACK
MID$(PCXPAL, 764, 1) = CHR$(0)
MID$(PCXPAL, 765, 1) = CHR$(0)
MINCOLOR = 254
MID$(PCXPAL, 766, 1) = CHR$(32) '* THIS IS THE COLOR MED WHITE
MID$(PCXPAL, 767, 1) = CHR$(32)
MID$(PCXPAL, 768, 1) = CHR$(32)
MAXCOLOR = 255
END IF
A$ = "'" + PCXFILENAME$ + "' is identified as a v3.0 PCX file."
DRWSTRING 1, 15, 0, A$, 10, 64
A$ = "Dimensions are:" + STR$(XSIZE) + " pixels wide and" + STR$(YSIZE) + " pixels high"
DRWSTRING 1, 15, 0, A$, 10, 80
A$ = "Number of colors:" + STR$(NUMCOL)
DRWSTRING 1, 15, 0, A$, 10, 96
GETKEY RET$
IF (RET$ = "S") OR (RET$ = "Q") THEN
FILLSCREEN 0
SETVIEW 0, 0, GETMAXX, GETMAXY
EXIT SUB
END IF
'*********************************************************************
'* SHOW PCX GET PUT
'*********************************************************************
PALSET PCXPAL, 0, 255
OVERSCANSET MINCOLOR
FILLSCREEN MINCOLOR
DRWSTRING 1, MAXCOLOR, MINCOLOR, TITLE$, 10, 0
A$ = "PCXPUT(Mode,X,Y,FileName$)"
DRWSTRING 1, MAXCOLOR, MINCOLOR, A$, 10, 16
SETVIEW 0, 32, GETMAXX, GETMAXY
Xloc = (GETMAXX \ 2) - (XSIZE \ 2)
Yloc = ((GETMAXY - 32) \ 2) - (YSIZE \ 2) + 32
OK = PCXPUT(1, Xloc, Yloc, PCXFILENAME$)
IF OK <> 1 THEN
'*********************************************************************
'* OOPSTHIS FILE HAS SOME PROBLEM
'********************************************************************
SOUND 100, 5
A$ = "The file '" + PCXFILENAME$ + "' "
B$ = ""
SELECT CASE OK
CASE IS = 0
A$ = A$ + "does not exist in the specified directory"
B$ = " or there is some disk I/O problem."
CASE IS = -1
A$ = A$ + "is not a v 3.0 PCX file."
CASE IS = -2
A$ = A$ + "is not run length encoded."
CASE IS = -3
A$ = A$ + "has some general error."
END SELECT
DRWSTRING 1, MINCOLOR, MAXCOLOR, A$, 10, 64
DRWSTRING 1, MINCOLOR, MAXCOLOR, B$, 10, 80
END IF
ELSE
'*********************************************************************
'* OOPSTHIS FILE HAS SOME PROBLEM
'*********************************************************************
SOUND 100, 5
A$ = "The file '" + PCXFILENAME$ + "' "
B$ = ""
SELECT CASE OK
CASE IS = 0
A$ = A$ + "does not exist in the specified directory"
B$ = " or there is some disk I/O problem."
CASE IS = -1
A$ = A$ + "is not a v 3.0 PCX file."
CASE IS = -2
A$ = A$ + "is not run length encoded."
CASE IS = -3
A$ = A$ + "has some general error."
END SELECT
DRWSTRING 1, 15, 0, A$, 10, 64
DRWSTRING 1, 15, 0, B$, 10, 80
END IF
GETKEY RET$
PALSET ORGPAL, 0, 255
OVERSCANSET 0
FILLSCREEN 0
SETVIEW 0, 0, GETMAXX, GETMAXY
END SUB
SUB SHOWSTAR
DEFINT A-Z
REM $DYNAMIC
SHARED OPLOTARRY() AS P2DType
SHARED PLOTARRY() AS P2DType
'*************************************************************************
'* THIS ROUTINE IS CALLED BY DO2D
'*************************************************************************
'*************************************************************************
'* ERASE THE OLD STAR
'*************************************************************************
FOR I = 0 TO 7
DRWLINE 1, 0, OPLOTARRY(I).X, OPLOTARRY(I).Y, OPLOTARRY(I + 1).X, OPLOTARRY(I + 1).Y
NEXT I
'*************************************************************************
'* DRAW THE NEW STAR
'*************************************************************************
FOR I = 0 TO 7
DRWLINE 1, 10, PLOTARRY(I).X, PLOTARRY(I).Y, PLOTARRY(I + 1).X, PLOTARRY(I + 1).Y
NEXT I
'*************************************************************************
'* SAVE THE OLD POINTS
'*************************************************************************
BYTECOPY PLOTARRY(0).X, OPLOTARRY(0).X, 36
END SUB
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -