Commit aaa9534e authored by TheOuterLinux's avatar TheOuterLinux

...

parent 459e3ae2
DEFINT A-Z
DECLARE FUNCTION ReadFileStructure% ()
DECLARE FUNCTION RightJust$ (Value$, FieldWidth%)
DECLARE FUNCTION ZeroJust$ (Number AS INTEGER)
DECLARE FUNCTION ReadDbfHdr% ()
DECLARE SUB DspDbfInfo ()
DECLARE SUB DspFileStructure ()
DECLARE SUB Pause ()
DECLARE SUB PrintDbfRecord (fv$(), RecNum%)
DECLARE SUB PrintReport ()
DECLARE SUB ReadDbfRecord (fv$())
'=================================================
'= PROGRAM: PRINTDBF.BAS =
'= PURPOSE: Print listings of dBASE III+/IV =
'= DBF files =
'=================================================
'-------------------------------------------------
' Initialize variables and create types -
'-------------------------------------------------
CONST True = -1, False = 0
TYPE HeaderInfoType
VersionNumber AS INTEGER
LastUpdate AS STRING * 8
NumberRecords AS LONG
HeaderLength AS INTEGER
RecordLength AS INTEGER
NumberFields AS INTEGER
FileSize AS LONG
END TYPE
TYPE FieldInfoType
FdName AS STRING * 11
FdType AS STRING * 1
FdLength AS INTEGER
FdDec AS INTEGER
END TYPE
DIM SHARED Hdr AS HeaderInfoType
DIM SHARED FileName$
FileName$ = "PLANETS.DBF"
'-------------------------------------------------
' Main processing loop -
'-------------------------------------------------
OPEN FileName$ FOR BINARY AS #1
CLS
ActionHdr = ReadDbfHdr
SELECT CASE ActionHdr
CASE 1
BEEP
PRINT "Not a dBASE III+ or IV file"
CASE ELSE
DspDbfInfo
Pause
DIM SHARED FLDS(Hdr.NumberFields)_
AS FieldInfoType
ActionFile = ReadFileStructure
SELECT CASE ActionFile
CASE True
CLS
DspFileStructure
Pause
IF ActionHdr <> 2 THEN
CLS
PrintReport
Pause
ELSE
CLS
PRINT "No records to print"
END IF
CASE False
BEEP
PRINT "Field information error"
END SELECT
END SELECT
CLOSE #1
END
SUB DspDbfInfo
'-------------------------------------------------
'Display dBASE file header information -
'-------------------------------------------------
PRINT USING "dBASE Version : #";_
Hdr.VersionNumber
PRINT "Database in use : "; FileName$
PRINT USING "Number of data records: ########";_
Hdr.NumberRecords
PRINT "Date of last update : "; Hdr.LastUpdate
PRINT USING "Header length : ####";_
Hdr.HeaderLength
PRINT USING "Record length : ####";_
Hdr.RecordLength
PRINT USING "Number of fields : ###";_
Hdr.NumberFields
PRINT USING "File size : ########";_
Hdr.FileSize
END SUB
SUB DspFileStructure
'-------------------------------------------------
'Purpose: Display the structure of the dBASE file-
' Name, Field Type, Length and number -
' of decimals if a number -
'-------------------------------------------------
FieldTitleS$ =_
"Field Field Name Type Width Dec"
FieldString1$ = " ### \ \ "
FieldString2$ = "\ \ ### ##"
PRINT : PRINT FieldTitleS$
FOR I = 1 TO Hdr.NumberFields
PRINT USING FieldString1$; I; FLDS(I).FdName;
SELECT CASE FLDS(I).FdType
CASE "C": ty$ = "Character"
CASE "L": ty$ = "Logical"
CASE "N": ty$ = "Number"
CASE "F": ty$ = "Floating Pt"
CASE "D": ty$ = "Date"
CASE "M": ty$ = "Memo"
CASE ELSE: ty$ = "Unknown"
END SELECT
PRINT USING FieldString2$; ty$;_
FLDS(I).FdLength; FLDS(I).FdDec
NEXT I
PRINT " ** Total **"; TAB(33);
PRINT USING "####"; Hdr.RecordLength
END SUB
SUB Pause
PRINT
PRINT "Press any key to continue"
WHILE INKEY$ = "": WEND
END SUB
SUB PrintDbfRecord (fv$(), RecNum)
'-------------------------------------------------
'Purpose: Print the record to the screen. Left -
' justify character, date and logical -
' fields. Right justify numeric fields -
' and ignore memo fields -
'Input : Field values store in character array, -
' current record number -
'-------------------------------------------------
' Print rec # & delete status
ColumnSpace = 4 'Room between columns
PRINT USING "####### !"; RecNum; fv$(0);
ColumnLocation = 10 'Set current location
FOR I = 1 TO Hdr.NumberFields
IF FLDS(I).FdType <> "M" THEN
PRINT TAB(ColumnLocation);
IF FLDS(I).FdType = "N" OR _
FLDS(I).FdType = "F" THEN
PRINT RightJust$(fv$(I), FLDS(I).FdLength);
ELSE
PRINT fv$(I);
END IF
' Set next print location
ColumnLocation = ColumnLocation +_
FLDS(I).FdLength + ColumnSpace
END IF
NEXT I
PRINT
END SUB
SUB PrintReport
'-------------------------------------------------
'Purpose: Main printing routine -
'Calls : ReadDbfRecord -
' PrintDbfRecord -
'-------------------------------------------------
DIM FieldValues$(Hdr.NumberFields)
PRINT : PRINT
PRINT "Report on the "; FileName$; " file"
PRINT
FOR I = 1 TO Hdr.NumberRecords
CALL ReadDbfRecord(FieldValues$())
CALL PrintDbfRecord(FieldValues$(), I)
NEXT I
END SUB
FUNCTION ReadDbfHdr
'-------------------------------------------------
'Purpose: Read the dBASE file header information -
' and store in the header record -
'-------------------------------------------------
HdrStr$ = SPACE$(32)
GET #1, , HdrStr$ 'Read dBASE Header
Hdr.VersionNumber = ASC(LEFT$(HdrStr$, 1)) AND (7)
UpdYY$ = ZeroJust$(ASC(MID$(HdrStr$, 2, 1)))
UpdMM$ = ZeroJust$(ASC(MID$(HdrStr$, 3, 1)))
UpdDD$ = ZeroJust$(ASC(MID$(HdrStr$, 4, 1)))
Hdr.LastUpdate = UpdMM$+"/"+UpdDD$+"/"+UpdYY$
Hdr.NumberRecords = CVL(MID$(HdrStr$, 5, 4))
Hdr.HeaderLength = CVI(MID$(HdrStr$, 9, 2))
Hdr.RecordLength = CVI(MID$(HdrStr$, 11, 2))
Hdr.NumberFields = (Hdr.HeaderLength - 33) / 32
Hdr.FileSize = Hdr.HeaderLength + Hdr.RecordLength_
* Hdr.NumberRecords + 1
IF Hdr.VersionNumber <> 3 THEN
ReadDbfHdr = 1 'Not a dBASE file
EXIT FUNCTION
END IF
IF Hdr.NumberRecords = 0 THEN
ReadDbfHdr = 2 'No records
EXIT FUNCTION
END IF
ReadDbfHdr = 0 'No errors
END FUNCTION
SUB ReadDbfRecord (fv$())
'-------------------------------------------------
'Purpose: Read a dBASE record, format date and -
' logical fields for output -
'Input : Array of Field values -
'-------------------------------------------------
F$ = SPACE$(Hdr.RecordLength)
GET #1, , F$ 'Read the record
fv$(0) = LEFT$(F$, 1) 'Read deleted record mark
FPOS = 2
FOR I = 1 TO Hdr.NumberFields
fv$(I) = MID$(F$, FPOS, FLDS(I).FdLength)
SELECT CASE FLDS(I).FdType 'Adjust field types
CASE "D" 'Modify date format
y$ = LEFT$(fv$(I), 4)
M$ = MID$(fv$(I), 5, 2)
d$ = RIGHT$(fv$(I), 2)
fv$(I) = M$ + "/" + d$ + "/" + y$
CASE "L" 'Standardize T or F
SELECT CASE UCASE$(fv$(I))
CASE "Y", "T": fv$(I) = ".T."
CASE "N", "F": fv$(I) = ".F."
CASE ELSE: fv$(I) = ".?."
END SELECT
CASE ELSE
END SELECT
FPOS = FPOS + FLDS(I).FdLength 'Set next fld
' PRINT fv$(I)
NEXT I
END SUB
FUNCTION ReadFileStructure
'-------------------------------------------------
'Purpose: Read the file structure store in the -
' dBASE file header. -
'-------------------------------------------------
FOR I = 1 TO Hdr.NumberFields
Fld$ = SPACE$(32)
GET #1, , Fld$ 'Get field info string
FLDS(I).FdName = LEFT$(Fld$, 11)
FLDS(I).FdType = MID$(Fld$, 12, 1)
FLDS(I).FdLength = ASC(MID$(Fld$, 17, 1))
FLDS(I).FdDec = ASC(MID$(Fld$, 18, 1))
NEXT I
HeaderTerminator$ = INPUT$(1, #1) 'Last hdr byte
IF ASC(HeaderTerminator$) <> 13 THEN
ReadFileStructure = False 'Bad Dbf header
END IF
ReadFileStructure = True
END FUNCTION
FUNCTION RightJust$ (Value$, FieldWidth)
'-------------------------------------------------
'Purpose: Right justify a string by padding it -
' with spaces on the left -
'Input : The character value to justify, the -
' width of the field to fit -
'Output : A right justified string to print -
'-------------------------------------------------
RightJust$ = RIGHT$(STRING$(FieldWidth, " ") +_
Value$, FieldWidth)
END FUNCTION
DEFSNG A-Z
FUNCTION ZeroJust$ (Number AS INTEGER)
'-------------------------------------------------
'Purpose: Add a leading zero to numbers less -
' than 10 so they take as much room as -
' numbers 10 and larger -
'Input : The number to standardize -
'Output : The adjusted number -
'-------------------------------------------------
N$ = STR$(Number)
LengthN = LEN(N$) - 1'Subtract 1 for leading space
N$ = RIGHT$("0" + RIGHT$(N$, LengthN), 2)
ZeroJust$ = N$
END FUNCTION
'
'DEGIF6.BAS - No frills GIF decoder for the VGA's 320x200x256 mode.
'By Rich Geldreich 1993 (Public domain, use as you wish.)
'This version should properly decode all LZW encoded images in
'GIF image files. I've finally added GIF89a and local colormap
'support, so it more closely follows the GIF specification. It
'still doesn't support the entire GIF89a specification, but it'll
'show most GIF files fine.
'The GIF decoding speed of this program isn't great, but I'd say
'for an all QB/PDS decoder it's not bad!
'Note: This program does not stop decoding the GIF image after the
'rest of the scanlines become invisible! This happens with images
'larger than the 320x200 screen. So if the program seems to be
'just sitting there, accessing your hard disk, don't worry...
'It'll beep when it's done.
DEFINT A-Z
'Prefix() and Suffix() hold the LZW phrase dictionary.
'OutStack() is used as a decoding stack.
'ShiftOut() as a power of two table used to quickly retrieve the LZW
'multibit codes.
DIM Prefix(4095), Suffix(4095), OutStack(4095), ShiftOut(8)
'The following line is for the QB environment(slow).
DIM YBase AS LONG, Powersof2(11) AS LONG, WorkCode AS LONG
'For a little more speed, unremark the next line and remark the one
'above, before you compile... You'll get an overflow error if the
'following line is used in the QB environment, so change it back.
'DIM YBase AS INTEGER, Powersof2(11) AS INTEGER, WorkCode AS INTEGER
'Precalculate power of two tables for fast shifts.
FOR A = 0 TO 8: ShiftOut(8 - A) = 2 ^ A: NEXT
FOR A = 0 TO 11: Powersof2(A) = 2 ^ A: NEXT
'Get GIF filename.
A$ = COMMAND$: IF A$ = "" THEN INPUT "GIF file"; A$: IF A$ = "" THEN END
'Add GIF extension if the given filename doesn't have one.
FOR A = LEN(A$) TO 1 STEP -1
SELECT CASE MID$(A$, A, 1)
CASE "\", ":": EXIT FOR
CASE ".": Extension = -1: EXIT FOR
END SELECT
NEXT
IF Extension = 0 THEN A$ = A$ + ".GIF"
'Open file for input so QB stops with an error if it doesn't exist.
OPEN A$ FOR INPUT AS #1: CLOSE #1
OPEN A$ FOR BINARY AS #1
'Check to see if GIF file. Ignore GIF version number.
A$ = " ": GET #1, , A$
IF LEFT$(A$, 3) <> "GIF" THEN PRINT "Not a GIF file.": END
'Get logical screen's X and Y resolution.
GET #1, , TotalX: GET #1, , TotalY: GOSUB GetByte
'Calculate number of colors and find out if a global palette exists.
NumColors = 2 ^ ((A AND 7) + 1): NoPalette = (A AND 128) = 0
'Retrieve background color.
GOSUB GetByte: Background = A
'Get aspect ratio and ignore it.
GOSUB GetByte
'Retrieve global palette if it exists.
IF NoPalette = 0 THEN P$ = SPACE$(NumColors * 3): GET #1, , P$
DO 'Image decode loop
'Skip by any GIF extensions.
'(With a few modifications this code could also fetch comments.)
DO
'Skip by any zeros at end of image (why must I do this? the
'GIF spec never mentioned it)
DO
IF EOF(1) THEN GOTO AllDone 'if at end of file, exit
GOSUB GetByte
LOOP WHILE A = 0 'loop while byte fetched is zero
SELECT CASE A
CASE 44 'We've found an image descriptor!
EXIT DO
CASE 59 'GIF trailer, stop decoding.
GOTO AllDone
CASE IS <> 33
PRINT "Unknown GIF extension type.": END
END SELECT
'Skip by blocked extension data.
GOSUB GetByte
DO: GOSUB GetByte: A$ = SPACE$(A): GET #1, , A$: LOOP UNTIL A = 0
LOOP
'Get image's start coordinates and size.
GET #1, , XStart: GET #1, , YStart: GET #1, , XLength: GET #1, , YLength
XEnd = XStart + XLength: YEnd = YStart + YLength
'Check for local colormap, and fetch it if it exists.
GOSUB GetByte
IF (A AND 128) THEN
NoPalette = 0
NumColors = 2 ^ ((A AND 7) + 1)
P$ = SPACE$(NumColors * 3): GET #1, , P$
END IF
'Check for interlaced image.
Interlaced = (A AND 64) > 0: PassNumber = 0: PassStep = 8
'Get LZW starting code size.
GOSUB GetByte
'Calculate clear code, end of stream code, and first free LZW code.
ClearCode = 2 ^ A
EOSCode = ClearCode + 1
FirstCode = ClearCode + 2: NextCode = FirstCode
StartCodeSize = A + 1: CodeSize = StartCodeSize
'Find maximum code for the current code size.
StartMaxCode = 2 ^ (A + 1) - 1: MaxCode = StartMaxCode
BitsIn = 0: BlockSize = 0: BlockPointer = 1
X = XStart: y = YStart: YBase = y * 320&
'Set screen 13 in not set yet.
IF FirstTime = 0 THEN
'Go to VGA mode 13 (320x200x256).
SCREEN 13: DEF SEG = &HA000
END IF
'Set palette, if there was one.
IF NoPalette = 0 THEN
'Use OUTs for speed.
OUT &H3C8, 0
FOR A = 1 TO NumColors * 3: OUT &H3C9, ASC(MID$(P$, A, 1)) \ 4: NEXT
'Save palette of image to disk.
'OPEN "pal." FOR BINARY AS #2: PUT #2, , P$: CLOSE #2
END IF
IF FirstTime = 0 THEN
'Clear entire screen to background color. This isn't
'done until the image's palette is set, to avoid flicker
'on some GIFs.
LINE (0, 0)-(319, 199), Background, BF
FirstTime = -1
END IF
'Decode LZW data stream to screen.
DO
'Retrieve one LZW code.
GOSUB GetCode
'Is it an end of stream code?
IF Code <> EOSCode THEN
'Is it a clear code? (The clear code resets the sliding
'dictionary - it *should* be the first LZW code present in
'the data stream.)
IF Code = ClearCode THEN
NextCode = FirstCode
CodeSize = StartCodeSize
MaxCode = StartMaxCode
DO: GOSUB GetCode: LOOP WHILE Code = ClearCode
IF Code = EOSCode THEN GOTO ImageDone
LastCode = Code: LastPixel = Code
IF X < 320 AND y < 200 THEN POKE X + YBase, LastPixel
X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
ELSE
CurCode = Code: StackPointer = 0
'Have we entered this code into the dictionary yet?
IF Code >= NextCode THEN
IF Code > NextCode THEN GOTO AllDone 'Bad GIF if this happens.
'mimick last code if we haven't entered the requested
'code into the dictionary yet
CurCode = LastCode
OutStack(StackPointer) = LastPixel
StackPointer = StackPointer + 1
END IF
'Recursively get each character of the string.
'Since we get the characters in reverse, "push" them
'onto a stack so we can "pop" them off later.
'Hint: There is another, much faster way to accomplish
'this that doesn't involve a decoding stack at all...
DO WHILE CurCode >= FirstCode
OutStack(StackPointer) = Suffix(CurCode)
StackPointer = StackPointer + 1
CurCode = Prefix(CurCode)
LOOP
LastPixel = CurCode
IF X < 320 AND y < 200 THEN POKE X + YBase, LastPixel
X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
'"Pop" each character onto the display.
FOR A = StackPointer - 1 TO 0 STEP -1
IF X < 320 AND y < 200 THEN POKE X + YBase, OutStack(A)
X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
NEXT
'Can we put this new string into our dictionary? (Some GIF
'encoders will wait a bit when the dictionary is full
'before sending a clear code- this increases compression
'because the dictionary's contents are thrown away less
'often.)
IF NextCode < 4096 THEN
'Store new string in the dictionary for later use.
Prefix(NextCode) = LastCode
Suffix(NextCode) = LastPixel
NextCode = NextCode + 1
'Time to increase the LZW code size?
IF (NextCode > MaxCode) AND (CodeSize < 12) THEN
CodeSize = CodeSize + 1
MaxCode = MaxCode * 2 + 1
END IF
END IF
LastCode = Code
END IF
END IF
LOOP UNTIL Code = EOSCode
ImageDone:
LOOP
AllDone:
'Save image and palette to BSAVE file.
'DEF SEG = &HA000
'OUT &H3C7, 0
'FOR a = 0 TO 767
' POKE a + 64000, INP(&H3C9)
'NEXT
'BSAVE "pic.bas", 0, 64768
'Load images saved with the above code with this:
'DEF SEG= &HA000
'BLOAD "Pic.Bas"
'OUT &H3C8, 0
'FOR a = 0 To 767
' OUT &H3C9, Peek(a+ 64000)
'NEXT
BEEP: DO: LOOP WHILE INKEY$ <> "": DO: LOOP UNTIL INKEY$ <> ""
END
'Slowly reads one byte from the GIF file...
GetByte: A$ = " ": GET #1, , A$: A = ASC(A$): RETURN
'Moves down one scanline. If the GIF is interlaced, then the number
'of scanlines skipped is based on the current pass.
NextScanLine:
IF Interlaced THEN
y = y + PassStep
IF y >= YEnd THEN
PassNumber = PassNumber + 1
SELECT CASE PassNumber
CASE 1: y = 4: PassStep = 8
CASE 2: y = 2: PassStep = 4
CASE 3: y = 1: PassStep = 2
END SELECT
END IF
ELSE
y = y + 1
END IF
X = XStart: YBase = y * 320&
RETURN
'Reads a multibit code from the data stream.
GetCode:
WorkCode = LastChar \ ShiftOut(BitsIn)
'Loop while more bits are needed.
DO WHILE CodeSize > BitsIn
'Reads a byte from the LZW data stream. Since the data stream is
'blocked, a check is performed for the end of the current block
'before each byte is fetched.
IF BlockPointer > BlockSize THEN
'Retrieve block's length
GOSUB GetByte: BlockSize = A
A$ = SPACE$(BlockSize): GET #1, , A$
BlockPointer = 1
END IF
'Yuck, ASC() and MID$() aren't that fast.
LastChar = ASC(MID$(A$, BlockPointer, 1))
BlockPointer = BlockPointer + 1
'Append 8 more bits to the input buffer
WorkCode = WorkCode OR LastChar * Powersof2(BitsIn)
BitsIn = BitsIn + 8
LOOP
'Take away x number of bits.
BitsIn = BitsIn - CodeSize
'Return code to caller.
Code = WorkCode AND MaxCode
RETURN
How To Trap CRTL-BREAK And CRTL-ALT-DEL?
This is done using the ON KEY x GOSUB statement, like this:
KEY 15, CHR$(&H04;) + CHR$(70) 'CTRL-BREAK
KEY 16, CHR$(&H04;) + CHR$(&H08;) + CHR$(83) 'CTRL-ALT-DEL
ON KEY (15) GOSUB 100
ON KEY (16) GOSUB 200
DO
...
LOOP
100 PRINT "CTRL-BREAK pressed."
RETURN
200 PRINT "CTRL-ALT-DEL pressed."
RETURN
This, however, may not work on all systems.
This tip was contributed by Jim Oliver.
Another way of disabling CTRL-BREAK is as follows:
' DISABLE CTRL-BREAK:
dim brk$(3)
' First save the current vectors:
def seg=0: for i=108 to 111: brk$(i-108)=str$(peek(i)): next
' Then poke new interrupt vectors:
poke 108,83: poke 109,255: poke 110,0: poke 111,240: def seg
' RESTORE CTRL-BREAK:
def seg=0: for i=108 to 111: poke i,val(brk$(i-108)): next: def seg
Do make sure you reenable CTRL-BREAK before exiting your program, or it will stay disabled.
This tip came from Foon.
' Program FM-LAB.BAS
' Wouter Bergmann Tiest
' 17th December 1995
' This program lets you experiment with four parameters of FM music:
' attack rate, decay rate, sustain level and release time.
DECLARE SUB DrawBars ()
DECLARE SUB InitFM ()
DECLARE SUB DrawScreen ()
DECLARE SUB SetReg (Reg%, Value%)
DECLARE FUNCTION SetValues% ()
DECLARE SUB PlayNote ()
CONST BaseAddr = &H220 'Change if your sound card uses another base address
CONST RegAddr = BaseAddr + 8, DataAddr = BaseAddr + 9
CONST Escape = 27, Enter = 13, left = 75, right = 77, up = 72, down = 80
DEFINT A-Z
DIM SHARED Params(1 TO 4) 'Hold values for parameters
COMMON SHARED CurrParam 'Holds number of current parameter
InitFM
CurrParam = 1 'Set initial values
Params(1) = 14
Params(2) = 4
Params(3) = 9
Params(4) = 13
DrawScreen
DO
LOOP UNTIL SetValues = Escape
CLS
END
SUB DrawBars
LOCATE 8, 1
PRINT " Attack Decay Sustain Release";
FOR i = 15 TO 0 STEP -1
PRINT
FOR j = 1 TO 4
LOCATE , 10 * j - 3
IF Params(j) >= i THEN PRINT "��"; ELSE PRINT "��"; 'Draw bars
NEXT j
NEXT i
COLOR 1, 7 'Reverse video
LOCATE 8, CurrParam * 10 - 5
SELECT CASE CurrParam
CASE 1
PRINT "Attack"
CASE 2
PRINT "Decay"
CASE 3
PRINT "Sustain"
CASE 4
PRINT "Release"
END SELECT
COLOR 7, 1 'Normal colours
END SUB
SUB DrawScreen
COLOR 7, 1
CLS
PRINT " ."
PRINT " . ."
PRINT " . ."
PRINT " . . . . . . ."
PRINT " . ."
PRINT " . ."
PRINT " . ."
LOCATE 9, 10