home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
PC Plus SuperCD 1
/
SuperCD_1.iso
/
pcplus
/
wilf
/
piecrust.bas
< prev
next >
Wrap
BASIC Source File
|
1996-10-14
|
20KB
|
914 lines
DEFINT A-Z
DECLARE SUB ziDragging ()
' Return if mouse active and still dragging, or else exhausted
DECLARE SUB ziDrawBank (FromButton, ToButton)
' Draw a bank of buttons (using Bank array)
DECLARE SUB ziExhaust ()
' Return when no keystrokes and no mouse buttons
DECLARE SUB ziLoadFont (Font$)
' Load a specified font
DECLARE SUB ziLocateMCursor (XCoord, YCoord)
' Locate mouse cursor to a named point
DECLARE SUB ziMouseOnButton (FromButton, ToButton)
' Sets FoundButton
DECLARE SUB ziPublish (PrintString$, Size, Italic)
' Print a string
' Size = magnitude (per 8 pixels)
' Italic = +1 to make italic
' = +2 to make overprint (no background)
DECLARE SUB ziRadio (Button, FromButton, ToButton)
' Set one button in a Bank, resetting the rest
DECLARE SUB ziReadField (Min, Max, Permitted$)
' Read a field at the current TCursor location
' Permitted$ contains:
' * - any characters
' . - allow one full-stop (as decimal)
' A - auto-enter (when filled)
' C - capitalise letters
' E - ESC allowed to finish (skip) field
' J - justify (especially for numeric)
' N - numerics
' P - password-type display
' S - space
' X - alphabetic
' Y - Y or N (upper or lower)
DECLARE SUB ziSetMCursorVis (Status)
' Set visibility of mouse cursor
' Status = 0 for OFF
' 1 for ON
' 2 for ENQUIRE (set MCursorVis)
' 10 for TEMPORARILY OFF
' 11 for RESTORED (set MCursorVis)
DECLARE SUB ziWander (Timeout!)
' Timeout = in seconds (0 = none)
' Response = 0 = (0:00) timed out
' n = (0:n) displacement into Allowed$
' key &h01xx &h02xx &h04xx &h08xx &h10xx &h20xx &h40xx
' plain CTRL shift Mouse Fn CTRL-Fn shift-Fn
' Enter 0 * * - double - - -
' (left) 1 * * - left F1 ^F1 +F1
' (right) 2 * * - right F2 ^F2 +F2
' (up) 3 * - - both F3 ^F3 +F3
' (down) 4 * - - leftdrag F4 ^F4 +F4
' Backspace 5 * * - rightdrag F5 ^F5 +F5
' Home 6 * * - bothdrag F6 ^F6 +F6
' End 7 * * - - F7 ^F7 +F7
' PgUP 8 * * - - F8 ^F8 +F8
' PgDN 9 * * - - F9 ^F9 +F9
' Tab 10 * - * - F10 ^F10 +F10
' Escape 11 * - - - F11 ^F11 +F11
' 12 - - - - F12 ^F12 +F12
' Allowed$ = other allowed strokes
' (Note: DClick is a flag permitting Double-clicks of mouse - slower!)
DEFINT A-Z
DECLARE SUB zsAlignGCursor ()
' Align graphic cursor to same as text cursor
' - sets Row, Col, GXloc, GYloc
DECLARE SUB zsAlignTCursor ()
' Align text cursor to same as graphic cursor
' - sets Row, Col, GXloc, GYloc
DECLARE SUB zsLocateGCursor (XCoord, YCoord)
' Locate graphic cursor to a named point
DECLARE SUB zsPastel (XCoord, YCoord, Wide, Deep, colour1, colour2)
' Colour the defined oblong with a pastel mix of two colours
' Deep = 0 or 1 - square
' = n - Y-pixel depth
DECLARE SUB zsSetScrnMode (Mode, HiRows, HiCols)
' Mode = 9 or 12
' HiRows = 1 to make high number of rows
' HiCols = 1 to make high number of cols (80)
' Set SCREEN parameters and blank the screen
' - sets ScrnMode, Xmax, Ymax, Rows, Cols, XYRatio!
' - uses FG and optionally BG (colours)
DECLARE SUB zsSubstitute (XCoord, YCoord, Wide, Deep, colour1, colour2)
' Substitute one colour with another within the defined oblong
' Deep = 0 or 1 - square
' = n - Y-pixel depth
DECLARE SUB zzBasicInt (IntType)
' Execute interrupt (params in REGS.AX etc)
DECLARE SUB zzInPath (Field$)
' Return full path to a file (in same string)
'================================================
'/ UK copyright (c) 1995 by Future Publishing
'/
'/
'/
'/
'================================================
TYPE REGISTERS
AX AS INTEGER
BX AS INTEGER
CX AS INTEGER
DX AS INTEGER
DS AS INTEGER
SI AS INTEGER
ES AS INTEGER
DI AS INTEGER
FL AS INTEGER
END TYPE
TYPE Buttons
Xloc AS INTEGER
Yloc AS INTEGER
Wide AS INTEGER
Deep AS INTEGER
' 0 = checkbutton
' 1 = square sculptured
' n = Y-pixels deep
State AS INTEGER
' 0 = off
' 1 = on
Active AS INTEGER
' 0 = inactive
' 1 = active
END TYPE
CONST Pi! = 3.14159
CONST Ex! = 2.71828
CONST DegToRad! = .0174533
CONST RadToDeg! = 57.2958
CONST ziNoShift = &H1
CONST ziCTRL = &H2
CONST ziShift = &H4
CONST ziMouse = &H8
CONST ziFn = &H10
CONST ziCTRLFn = &H20
CONST ziShiftFn = &H40
CONST ziL = 1
CONST ziR = 2
CONST ziUp = 3
CONST ziDn = 4
CONST ziBS = 5
CONST ziHome = 6
CONST ziEnd = 7
CONST ziPgUp = 8
CONST ziPgDn = 9
CONST ziTab = 10
CONST ziEsc = 11
CONST ziDbl = 0
CONST ziBoth = 3
CONST ziLDrag = 4
CONST ziRDrag = 5
CONST ziBothDrag = 6
DIM SHARED REGS AS REGISTERS
DIM SHARED Bank(20) AS Buttons
DIM SHARED Bad, Module$
DIM SHARED Mouse, MCursorVis, MXloc, MYloc
DIM SHARED DClick
DIM SHARED ScrnMode, BG, FG, TCursor
DIM SHARED Xmax, Ymax, GXloc, GYloc, XYratio!
DIM SHARED Rows, Cols, Row, Col
DIM SHARED Allowed$, Field$
DIM SHARED FoundButton
DIM SHARED Font(255, 7)
DIM SHARED Response, HResponse, LResponse
'++++++++++++++++++++++++
RANDOMIZE TIMER
ON ERROR GOTO RESUMENEXT
RESUMENEXT:
IF ERR = 255 THEN
CLS
BEEP
PRINT "Cannot find module "; Module$
SLEEP
SYSTEM
END IF
IF ERR THEN
Bad = ERR
RESUME NEXT
END IF
'++++++++++++++++++++++++
' Test for presence of a mouse
Mouse = 0
REGS.AX = 0
CALL zzBasicInt(&H33)
IF REGS.AX THEN
Mouse = 1
CALL ziSetMCursorVis(0)
END IF
'++++++++++++++++++++++++
' Load the ASCII font
CALL ziLoadFont("Ascii8x8")
'/==================================/'
'/ End of Standard Piecrust code /'
'/==================================/'
'++++++++++++++++++++++++
SUB ziDragging
IF Mouse AND MCursorVis THEN
SELECT CASE Response
CASE 2052 TO 2054
REGS.AX = 3
CALL zzBasicInt(&H33)
IF REGS.BX = Response - 2051 THEN
EXIT SUB
END IF
END SELECT
END IF
CALL ziExhaust
END SUB
'++++++++++++++++++++++++
SUB ziDrawBank (FromButton, ToButton)
CALL ziSetMCursorVis(10)
FOR i = FromButton TO ToButton
IF Bank(i).Active THEN
IF Bank(i).State THEN
colour1 = 8
ELSE
colour1 = 15
END IF
colour2 = colour1 XOR 7
XCoord = Bank(i).Xloc
YCoord = Bank(i).Yloc
XWidth = Bank(i).Wide
YDepth = Bank(i).Deep
X2Coord = XCoord + XWidth
IF YDepth THEN
IF YDepth = 1 THEN
Y2Coord = YCoord + XWidth / XYratio!
ELSE
Y2Coord = YCoord + YDepth
END IF
LINE (XCoord, YCoord)-(X2Coord - 1, YCoord), colour1
LINE (XCoord, YCoord)-(XCoord, Y2Coord - 1), colour1
LINE (XCoord + 1, Y2Coord)-(X2Coord, Y2Coord), colour2
LINE (X2Coord, YCoord)-(X2Coord, Y2Coord), colour2
ELSE
a = XWidth \ 2
b = a / XYratio!
c = XCoord + a
d = YCoord + b
LINE (XCoord, YCoord)-(c + a, d + b), 7, BF
CIRCLE (c, d), a, 8
CIRCLE (c, d), a - 1, 8
PAINT (c, d), 7, 7
IF Bank(i).State THEN
CIRCLE (c, d), XWidth \ 3, 8
PAINT (c, d), 8, 8
END IF
END IF
END IF
NEXT
CALL ziSetMCursorVis(11)
END SUB
'++++++++++++++++++++++++
SUB ziExhaust
DO
x$ = INKEY$
LOOP WHILE LEN(x$)
IF Mouse AND MCursorVis THEN
DO
REGS.AX = 3
CALL zzBasicInt(&H33)
LOOP WHILE (REGS.BX AND 3)
END IF
Response = 0
END SUB
'++++++++++++++++++++++++
SUB ziLoadFont (Font$)
DEF SEG = VARSEG(Font(0, 0))
Module$ = Font$ + ".OVL"
CALL zzInPath(Module$)
IF Module$ = "" THEN
Module$ = Font$ + ".OVL"
ERROR 255
ELSE
BLOAD Module$, VARPTR(Font(0, 0))
END IF
DEF SEG
END SUB
'++++++++++++++++++++++++
SUB ziLocateMCursor (XCoord, YCoord)
IF Mouse THEN
MXloc = XCoord
MYloc = YCoord
REGS.AX = 4
REGS.CX = XCoord
REGS.DX = YCoord
CALL zzBasicInt(&H33)
CALL ziSetMCursorVis(1)
END IF
END SUB
'++++++++++++++++++++++++
SUB ziMouseOnButton (FromButton, ToButton)
FoundButton = 0
FOR i = FromButton TO ToButton
IF Bank(i).Active THEN
IF Bank(i).Deep < 2 THEN
j = Bank(i).Wide / XYratio!
ELSE
j = Bank(i).Deep
END IF
IF MXloc > Bank(i).Xloc THEN
IF MXloc < Bank(i).Xloc + Bank(i).Wide THEN
IF MYloc > Bank(i).Yloc THEN
IF MYloc < Bank(i).Yloc + j THEN
FoundButton = i
EXIT SUB
END IF
END IF
END IF
END IF
ELSE
EXIT SUB
END IF
NEXT
END SUB
'++++++++++++++++++++++++
SUB ziPublish (PrintString$, Size, Italic)
CALL ziSetMCursorVis(10)
xx = POINT(0)
yy = POINT(1)
IF Size THEN
Scale = Size
ELSE
Scale = 1
END IF
LenString = LEN(PrintString$)
ExpScale = 8 * Scale
limxx = xx + ExpScale * LenString - 1
limyy = yy + ExpScale - 1
IF Italic AND 1 THEN
limxx = limxx + 4 * Scale
END IF
IF Italic AND 2 THEN
ELSE
LINE (xx, yy)-(limxx, limyy), BG, BF
END IF
FOR a = 0 TO LenString - 1
x = ASC(MID$(PrintString$, a + 1, 1))
b = xx + ExpScale * a
FOR y = 0 TO 7
c = Font(x, y)
d = y * Scale
e = yy + d
IF Italic AND 1 THEN
f = b + 4 * Scale - (d + Scale - 1) \ 2 - 1
ELSE
f = b
END IF
g = 128
DO
IF c AND g THEN
FOR h = 0 TO Scale - 1
FOR i = 0 TO Scale - 1
PSET (f + h, e + i), FG
NEXT
NEXT
END IF
f = f + Scale
g = g \ 2
LOOP UNTIL g = 0
NEXT
NEXT
CALL zsLocateGCursor(limxx + 1, yy)
CALL ziSetMCursorVis(11)
END SUB
'++++++++++++++++++++++++
SUB ziRadio (Button, FromButton, ToButton)
IF Button >= FromButton THEN
IF Button <= ToButton THEN
FOR a = FromButton TO ToButton
Bank(a).State = 0
NEXT
END IF
END IF
Bank(Button).State = 1
CALL ziDrawBank(FromButton, ToButton)
END SUB
'++++++++++++++++++++++++
SUB ziReadField (Min, Max, Permitted$)
CALL ziSetMCursorVis(10)
atRow = CSRLIN
atCol = POS(x)
Field$ = ""
PRINT CHR$(219); SPACE$(Max);
Rules$ = UCASE$(Permitted$)
Brake = 1
WHILE Brake
x$ = ""
WHILE LEN(x$) = 0
x$ = INKEY$
WEND
IF INSTR(Rules$, "C") THEN x$ = UCASE$(x$)
oldLen = LEN(Field$)
Good = 0
IF INSTR(Rules$, ".") THEN
IF x$ = "." THEN
IF INSTR(Field$, ".") = 0 THEN
Good = 1
END IF
END IF
END IF
IF INSTR(Rules$, "N") THEN
IF INSTR("0123456789", x$) THEN
Good = 1
END IF
END IF
IF INSTR(Rules$, "S") THEN
IF x$ = " " THEN
Good = 1
END IF
END IF
IF INSTR(Rules$, "X") THEN
IF INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ", UCASE$(x$)) THEN
Good = 1
END IF
END IF
IF INSTR(Rules$, "Y") THEN
IF INSTR("YyNy", x$) THEN
Good = 1
END IF
END IF
IF Good THEN
Field$ = Field$ + x$
IF INSTR(Field$, ".") THEN
NewMax = Max + 1
ELSE
NewMax = Max
END IF
Field$ = MID$(Field$, 1, NewMax)
END IF
' handle Bkspace
IF ASC(x$) = 8 AND LEN(Field$) THEN
Field$ = MID$(Field$, 1, LEN(Field$) - 1)
END IF
Signif$ = Field$ + "X"
WHILE INSTR(" 0", MID$(Signif$, 1, 1))
Signif$ = MID$(Signif$, 2)
WEND
IF INSTR(Signif$, ".") THEN
SignifLen = LEN(Signif$) - 2
ELSE
SignifLen = LEN(Signif$) - 1
END IF
' handle Enter
IF ASC(x$) = 13 AND SignifLen >= Min THEN
oldLen = LEN(Field$) + 1
Brake = 0
END IF
' handle Esc
IF ASC(x$) = 27 THEN
LOCATE atRow, atCol
PRINT CHR$(219); SPACE$(Max);
Field$ = ""
IF INSTR(Rules$, "E") THEN
RETURN
END IF
END IF
' reprint if change, or beep if no change
IF oldLen = LEN(Field$) THEN
BEEP
ELSE
LOCATE atRow, atCol
IF INSTR(Rules$, "P") THEN
PRINT STRING$(LEN(Field$), 254); CHR$(219); " ";
ELSE
PRINT Field$; CHR$(219); " ";
END IF
END IF
' check for auto-Enter
IF INSTR(Rules$, "A") THEN
IF SignifLen = Max THEN
Brake = 0
END IF
END IF
WEND
' justify if required
IF INSTR(Rules$, "J") THEN
WHILE MID$(Field$, 1, 1) = "0"
Field$ = MID$(Field$, 2)
WEND
Field$ = RIGHT$(SPACE$(NewMax) + Field$, NewMax)
END IF
' reprint, deleting the cursor
LOCATE atRow, atCol
IF INSTR(Rules$, "P") THEN
PRINT STRING$(LEN(Field$), 254); " ";
ELSE
PRINT Field$; " ";
END IF
CALL ziSetMCursorVis(11)
END SUB
'++++++++++++++++++++++++
SUB ziSetMCursorVis (Status) STATIC
IF Mouse THEN
SELECT CASE Status
CASE 0
IF MCursorVis THEN
REGS.AX = 2
CALL zzBasicInt(&H33)
END IF
CASE 1
REGS.AX = 1
CALL zzBasicInt(&H33)
CASE 10
REGS.AX = &H2A
CALL zzBasicInt(&H33)
IF REGS.AX = 0 THEN
TempFlag = 1
REGS.AX = 2
CALL zzBasicInt(&H33)
ELSE
TempFlag = 0
END IF
CASE 11
IF TempFlag THEN
REGS.AX = 1
CALL zzBasicInt(&H33)
END IF
END SELECT
REGS.AX = &H2A
CALL zzBasicInt(&H33)
IF REGS.AX = 0 THEN
MCursorVis = 1
ELSE
MCursorVis = 0
END IF
END IF
END SUB
'++++++++++++++++++++++++
SUB ziWander (Timeout!)
IF Timeout! = 0 THEN
WatchFor! = TIMER + 3600
ELSE
WatchFor! = TIMER + Timeout!
END IF
Response = 0
DO
x$ = INKEY$
IF LEN(x$) THEN
SELECT CASE LEN(x$)
CASE 1
a = INSTR(Allowed$, x$)
IF a THEN
Response = a
EXIT DO
END IF
SELECT CASE ASC(x$)
CASE 8: Response = 261
CASE 9: Response = 266
CASE 10: Response = 512
CASE 13: Response = 256
CASE 27: Response = 267
CASE 127: Response = 517
END SELECT
IF Response THEN
EXIT DO
END IF
CASE 2
Rightmost = ASC(RIGHT$(x$, 1))
SELECT CASE Rightmost
CASE 15: Response = 1019
CASE 59 TO 68
Response = 4038
CASE 72: Response = 187
CASE 71 TO 73
Response = 191
CASE 75: Response = 182
CASE 77: Response = 181
CASE 80: Response = 180
CASE 79 TO 81
Response = 184
CASE 84 TO 93
Response = 16301
CASE 94 TO 103
Response = 8099
CASE 115 TO 116
Response = 398
CASE 117: Response = 402
CASE 118: Response = 403
CASE 119: Response = 399
CASE 127: Response = 390
CASE 132: Response = 388
CASE 133 TO 134
Response = 3974
CASE 135 TO 136
Response = 16260
CASE 137 TO 138
Response = 8066
END SELECT
IF Response THEN
Response = Response + Rightmost
EXIT DO
END IF
END SELECT
END IF
IF Mouse AND MCursorVis THEN
REGS.AX = 3
CALL zzBasicInt(&H33)
SELECT CASE REGS.BX
CASE 1 TO 3
Response = 2048 + REGS.BX
nowtime! = TIMER
DO
REGS.AX = 3
CALL zzBasicInt(&H33)
IF REGS.BX = 0 THEN EXIT DO
LOOP UNTIL TIMER - nowtime! > .3
IF REGS.BX = Response - 2048 THEN
Response = Response + 3
ELSE
IF REGS.BX = 0 AND Response = 2049 AND DClick THEN
nowtime! = TIMER
DO
REGS.AX = 3
CALL zzBasicInt(&H33)
IF REGS.BX = 1 THEN EXIT DO
LOOP UNTIL TIMER - nowtime! > .3
IF REGS.BX = 1 THEN
Response = 2048
CALL ziExhaust
END IF
END IF
IF REGS.BX = 3 THEN
Response = 2051
END IF
END IF
END SELECT
IF Response THEN
MXloc = REGS.CX
MYloc = REGS.DX
EXIT DO
END IF
END IF
LOOP UNTIL WatchFor! < TIMER
HResponse = Response \ 256
LResponse = Response MOD 256
END SUB
'++++++++++++++++++++++++
SUB zsAlignGCursor
Row = CSRLIN
Col = POS(0)
GXloc = (Col - 1) * ((Xmax + 1) \ Cols)
GYloc = (Row - 1) * (((Ymax \ Rows) * Rows + 1) \ Rows)
CALL zsLocateGCursor(GXloc, GYloc)
END SUB
'++++++++++++++++++++++++
SUB zsAlignTCursor
GXloc = POINT(0)
GYloc = POINT(1)
a = (Xmax + 1) / Cols
b = (Ymax + 1) / Rows
Col = (GXloc + a - 1) \ a + 1
Row = (GYloc + b - 1) \ b + 1
LOCATE Row, Col
CALL zsAlignGCursor
END SUB
'++++++++++++++++++++++++
SUB zsLocateGCursor (XCoord, YCoord)
GXloc = XCoord
GYloc = YCoord
PSET (GXloc, GYloc), POINT(GXloc, GYloc)
END SUB
'++++++++++++++++++++++++
SUB zsPastel (XCoord, YCoord, Wide, Deep, colour1, colour2)
CALL ziSetMCursorVis(10)
IF Deep < 2 THEN
a = Wide / XYratio!
ELSE
a = Deep
END IF
LINE (XCoord, YCoord)-(XCoord + Wide - 1, YCoord + a - 1), colour1, BF
FOR b = XCoord TO XCoord + Wide - 1 STEP 2
LINE (b, YCoord)-(b, YCoord + a - 1), colour2, , &H5555
NEXT
FOR b = XCoord + 1 TO XCoord + Wide - 1 STEP 2
LINE (b, YCoord)-(b, YCoord + a - 1), colour2, , &HAAAA
NEXT
CALL ziSetMCursorVis(11)
END SUB
'++++++++++++++++++++++++
SUB zsSetScrnMode (Mode, HiRows, HiCols)
CALL ziSetMCursorVis(10)
ScrnMode = Mode
IF Mode = 9 THEN
SCREEN 9
IF HiRows THEN
Rows = 43
ELSE
Rows = 25
END IF
Xmax = 639
Ymax = 349
END IF
IF Mode = 12 THEN
SCREEN 12
IF HiRows THEN
Rows = 60
ELSE
Rows = 30
END IF
Xmax = 639
Ymax = 479
END IF
IF HiCols THEN
Cols = 80
ELSE
Cols = 40
END IF
WIDTH Cols, Rows
CLS
IF Mode = 9 THEN
COLOR FG, BG
ELSE
COLOR FG
END IF
LINE (0, 0)-(Xmax, Ymax), BG, BF
LOCATE 1, 1, 0
PSET (0, 0), BG
XYratio! = .75 * (Xmax + 1) / (Ymax + 1)
CALL ziSetMCursorVis(11)
END SUB
'++++++++++++++++++++++++
SUB zsSubstitute (XCoord, YCoord, Wide, Deep, colour1, colour2)
CALL ziSetMCursorVis(10)
IF Deep < 2 THEN
a = Wide / XYratio!
ELSE
a = Deep
END IF
FOR b = XCoord TO XCoord + Wide - 1
FOR c = YCoord TO YCoord + a - 1
IF POINT(b, c) = colour1 THEN
PSET (b, c), colour2
END IF
NEXT
NEXT
CALL ziSetMCursorVis(11)
END SUB
'++++++++++++++++++++++++
SUB zzBasicInt (IntType) STATIC
DIM ASM(54)
DEF SEG = VARSEG(ASM(0))
IF ASM(1) = 0 THEN
Module$ = "BASICINT.OVL"
CALL zzInPath(Module$)
IF Module$ = "" THEN
Module$ = "BASICINT.OVL"
ERROR 255
ELSE
BLOAD Module$, VARPTR(ASM(0))
END IF
END IF
CALL ABSOLUTE(REGS, IntType, VARPTR(ASM(0)))
DEF SEG
END SUB
'++++++++++++++++++++++++
SUB zzInPath (Field$)
x$ = ".;" + ENVIRON$("PATH")
IF RIGHT$(x$, 1) <> ";" THEN x$ = x$ + ";"
i = 1
DO
j = INSTR(i, x$, ";")
IF j THEN
y$ = UCASE$(MID$(x$, i, j - i))
i = j + 1
IF RIGHT$(y$, 1) <> "\" THEN y$ = y$ + "\"
f$ = y$ + Field$
Bad = 0
OPEN "I", 1, f$
IF Bad = 0 THEN
CLOSE 1
EXIT DO
END IF
f$ = ""
END IF
LOOP WHILE j
Bad = 0
Field$ = f$
END SUB