'===========================================================================
' Subject: COLLECTION OF FN FUNCTIONS         Date: 09-05-99 (21:34)       
'  Author: Antoni Gual                        Code: QB, PDS                
'  Origin: agual@eic.ictnet.es              Packet: MISC.ABC
'===========================================================================
'I think FN functions can be useful to reduce the View Sub's list of a big program
'These functions are not popular, I made a search in the ABC files and found
'no more than 40 programs using them. About a half used only the same single
'function that calculates an integer random number. Probably it hapens because
'MS labeled these functions as "obsolete", not to be suported in further
'versions. In fact They switched so fast to windows that no one cares about
'the "unportability" of FN functions.
'
'Facts:
'They must be declared in the main part of the module, before they are used
'Can't be shared with other modules
'Variables used are shared with te main part of the module.
'Variables can be made local by declaring them as STATIC
'Paremeters are received by value
'Can't receive user defined vars or arrays as parameters
'As Procedure functions, they can only return simple values
'Don't appear in View sub's listing
'QB has a bug: String paremeters passed to a FN are not deleted
'when exiting function so if they are big, tou must assign them to ""
'before exiting.

'Two sintaxes:
'   single line      DEF FNname%(x,y)=x+y*2

'   multiple line    DEF FNname%(x,y)
'                        FNname% = 2
'                        IF x > 0 THEN EXIT DEF
'                        FNname% = x + y * 2
'                    END DEF

'Here is a small library of functions. Almost any small procedure not to
'be shared between modules can be made a FN function.

DEFINT A-Z

'$INCLUDE: 'qb.bi'
DIM SHARED regs AS RegTypeX

'----------------------file attributes

DEF fnAtr2Str$ (a$)      'converts file attr byte to a char
	fnAtr2Str$ = STRING$(8, "-")
	a1 = ASC(a$)
	IF a1 AND 1 THEN MID$(fnAtr2Str$, 1, 1) = "R" 'readonly
	IF a1 AND 2 THEN MID$(fnAtr2Str$, 2, 1) = "H" 'hidden
	IF a1 AND 4 THEN MID$(fnAtr2Str$, 3, 1) = "S" 'system
	IF a1 AND 8 THEN MID$(fnAtr2Str$, 4, 1) = "V" 'volume label
	IF a1 AND 16 THEN MID$(fnAtr2Str$, 5, 1) = "D"'directory
	IF a1 AND 32 THEN MID$(fnAtr2Str$, 6, 1) = "A"'archive
	IF a1 AND 64 THEN MID$(fnAtr2Str$, 7, 1) = "7"'long filename?
	IF a1 AND 128 THEN MID$(fnAtr2Str$, 8, 1) = "8"
END DEF


'----------------------time function substitute

DEF fngettime&  'stores 18'2ths of second since midnight to a long
	regs.AX = 0
	CALL INTERRUPT(&H1A, regs, regs)
	fngettime& = CVL(MKI$(regs.DX) + MKI$(regs.CX))
END DEF


'-----------------------math

CONST PI180# = 3.14159226# / 180
DEF FnRad# (x#) = x# * PI180#     'degrees to rad


DEF fndeg# (x#) = x# / PI180#     'rad to degrees

DEF fnmax% (x, y) 'max
fnmax% = x
IF y > x THEN fnmax% = y
END DEF

DEF fnmin% (x, y)  'min
fnmin% = x
IF y < x THEN fnmin% = y
END DEF

DEF FNR (a) = INT(RND * a)     'random integer 0<=x <a (the best seller)        


'------------------------screen attributes and formats

DEF fnattr (fore, back)         'pack color to an attribute byte
	fnattr = 16 * back + fore
END DEF
								'pack color and char to an integer
DEF FnPackCharAttr (char$, fore, back)
	FnPackCharAttr = ASC(char$) + (fore + (back * 16) * 256)
END DEF



DEF FNLONG2STR$ (x&, L%) 'LONG to  right justif string, with 1000's separators
y& = x&: i = L%: FNLONG2STR$ = SPACE$(L%)
	DO
	IF (L% - i) MOD 4 = 3 THEN MID$(FNLONG2STR$, i, 1) = "+": i = i - 1
	MID$(FNLONG2STR$, i, 1) = (y& MOD 10) + 48: y& = y& \ 10: i = i - 1
	LOOP UNTIL y& = 0 OR i = 0
	IF y& THEN FNLONG2STR$ = STRING$(L%, 35)
END DEF


'-------------------------keyboard

DEF fnlastkey%   'clears kbd buffer and returns last key pressed
	DO
	SWAP b$, a$: a$ = INKEY$
	LOOP WHILE LEN(a$)
	IF LEN(b$) = 0 THEN EXIT DEF
	IF ASC(b$) = 0 THEN fnlastkey% = -ASC(RIGHT$(b$, 1)) ELSE fnlastkey% = ASC(b$)
END DEF

DEF fngetkey%    'gets 1st key pressed
	a$ = INKEY$
	IF LEN(a$) = 0 THEN EXIT DEF
	IF ASC(a$) = 0 THEN fngetkey% = -ASC(RIGHT$(a$, 1)) ELSE fngetkey% = ASC(a$)
END DEF


DEF fnclrbuff%    'clear kbd buffer
	DO: a$ = INKEY$: LOOP UNTIL NOT LEN(a$)
END DEF

'----------------------------strings

DEF fnstrtrim$ (x!) = LTRIM$(STR$(x!)) 'convert num to string, without leading space


DEF FNTRIM$ (x$) = LTRIM$(RTRIM$(x$))  'trim both sides



DEF fnbINSTR% (from, a$, c$)           'reverse INSTR (search single char)
	IF from > LEN(a$) THEN EXIT DEF
	IF from = 0 THEN from = LEN(a$)
	IF LEN(c$) = 0 THEN EXIT DEF
	IF LEN(a$) = 0 THEN EXIT DEF
	DEF SEG = VARSEG(a$)
	car = ASC(c$)
	t1 = SADD(a$)
	t2 = t1 + from
	fnbINSTR% = 0
	DO WHILE t2 >= t1
		IF PEEK(t2) = car THEN fnbINSTR% = t2 - t1 + 1: EXIT DO
		t2 = t2 - 1
	LOOP
	DEF SEG
	a$ = ""
END DEF

DEF fncentr$ (a$, b$)                  'centers string b$ in a$
	Temp = (LEN(a$) - LEN(b$)) \ 2
	MID$(a$, Temp) = b$
	fncentr$ = a$
END DEF

DEF fnAsciiz2Str$ (txt$)               'C type string to basic
	fnAsciiz2Str$ = LEFT$(txt$, INSTR(txt$, CHR$(0)) - 1)
END DEF

DEF fnstr2Asciiz$ (txt$)               'C type string to basic
	fnstr2Asciiz$ = txt$ + CHR$(0)
END DEF

'--------------------- unsigned int's

DEF fnuint2Lng& (x) 'converts an unsigned integer (2 bytes) to a LONG
	fnuint2Lng& = x
	IF x < 0 THEN fnuint2Lng& = x + 65536
END DEF

DEF fnlng2uint% (x&) 'convert a long to an unsigned int
	fnlng2uint% = CVI(LEFT$(MKL$(x&), 2))
END DEF


DEF FNWoRD (x, y)       'forms word from 2 bytes
   Temp$ = MKL$(x * 256& + y)
   FNWoRD = CVI(LEFT$(Temp$, 2))
END DEF

'Subject: BIOS MEMORY USAGE SUMMARY          Date: 10-20-97 (10:34)
'  Author: William A. Deer                    Code: QB, QBasic, PDS    

' Get the Base Addresses of each Com Port 1-4
DEF FnCom1Address$ :    DEF SEG = &H40: FnCom1Address$ = HEX$(PEEK(&H1)) + (HEX$(PEEK(&H0))): END DEF
DEF FnCom2Address$ :    DEF SEG = &H40: FnCom2Address$ = HEX$(PEEK(&H2)) + (HEX$(PEEK(&H3))): END DEF
DEF FnCom3Address$ :    DEF SEG = &H40: FnCom3Address$ = HEX$(PEEK(&H4)) + (HEX$(PEEK(&H5))): END DEF
DEF FnCom4Address$ :    DEF SEG = &H40: FnCom4Address$ = HEX$(PEEK(&H6)) + (HEX$(PEEK(&H7))): END DEF

' Get the Base Addresses of each LPTn Port 1-4
DEF FnLPT1Address$ :    DEF SEG = &H40: FnLPT1Address$ = HEX$(PEEK(&H8)) + (HEX$(PEEK(&H9))): END DEF
DEF FnLPT2Address$ :    DEF SEG = &H40: FnLPT2Address$ = HEX$(PEEK(&HA)) + (HEX$(PEEK(&HB))): END DEF
DEF FnLPT3Address$ :    DEF SEG = &H40: FnLPT3Address$ = HEX$(PEEK(&HC)) + (HEX$(PEEK(&HD))): END DEF
DEF FnLPT4Address$ :    DEF SEG = &H40: FnLPT4Address$ = HEX$(PEEK(&HE)) + (HEX$(PEEK(&HF))): END DEF

' Keyboard Rountine
DEF FnCapsLockStatus% : DEF SEG = &H40: FnCapsLockStatus% = ((PEEK(&H17) AND &H40) / &H40): END DEF
DEF FnNumbLockStatus% : DEF SEG = &H40: FnNumbLockStatus% = ((PEEK(&H17) AND &H20) / &H20): END DEF
DEF FnScrlLockStatus% : DEF SEG = &H40: FnScrlLockStatus% = ((PEEK(&H17) AND &H10) / &H10): END DEF
DEF FnInsertMode% :     DEF SEG = &H40: FnInsertMode% = ((PEEK(&H17) AND &H80) / &H80): END DEF
DEF FnR.AltKeyStatus% : DEF SEG = &H40: FnR.AltKeyStatus% = ((PEEK(&H17) AND &H8) / &H8): END DEF
DEF FnRCtrlKeyStatus% : DEF SEG = &H40: FnRCtrlKeyStatus% = ((PEEK(&H17) AND &H4) / &H4): END DEF
DEF FnRShftKeyStatus% : DEF SEG = &H40: FnRShftKeyStatus% = ((PEEK(&H17) AND &H1) / &H1): END DEF
DEF FnLShftKeyStatus% : DEF SEG = &H40: FnLShftKeyStatus% = ((PEEK(&H17) AND &H2) / &H2): END DEF
DEF FnL.AltKeyStatus% : DEF SEG = &H40: FnL.AltKeyStatus% = ((PEEK(&H18) AND &H2) / &H2): END DEF
DEF FnLCtrlKeyStatus% : DEF SEG = &H40: FnLCtrlKeyStatus% = ((PEEK(&H18) AND &H1) / &H1): END DEF

' Installed Hardware
DEF FnFloppyNo% :       DEF SEG = &H40: FnFloppyNo% = 1 + (PEEK(&H10) AND &H1) + (PEEK(&H10) AND &H2): END DEF
DEF FnPrnAdaptors% :    DEF SEG = &H40: FnPrnAdaptors% = ((PEEK(&H11) AND &H80) / &H40) + ((PEEK(&H11) AND &H40) / &H40): END DEF
DEF FnInternalModem% :  DEF SEG = &H40: FnInternalModem% = ((PEEK(&H11) AND &H20) / &H20): END DEF
DEF FnComPorts% :       DEF SEG = &H40: FnComPorts% = ((PEEK(&H11) AND &H8) / &H2) + ((PEEK(&H11) AND &H4) / &H2) + ((PEEK(&H11) AND &H2) / &H2): END DEF
DEF FnTotalMemory$ :    DEF SEG = &H40: FnTotalMemory$ = HEX$(PEEK(&H14)) + (HEX$(PEEK(&H13))): END DEF

'----------------------------Found in Ethan Winer's book

DEF FNPeekWord& (a&)       'peek a word
  FNPeekWord& = PEEK(a&) + 256& * PEEK(a& + 1)
END DEF

DEF FnRound# (Value#, Digits%) 'round a value to Digits
	 Mult% = 10 ^ Digits%
	 FnRound# = FIX((Mult% * Value#) + (SGN(Value#)) * .5#) / Mult%
END DEF

DEF FnGetDrive%   'gets default drive
	regs.ax = &H1900
	CALL INTERRUPT(&H21, regs, regs)
	FnGetDrive% = (regs.ax AND &HFF) + 65
END DEF

DEF fnDriveValid% (TestDrive$) 'is a drive name valid?
  STATIC Current                'local to this function
  Current = FnGetDrive%         'save the current drive
  fnDriveValid% = 0             'assume not valid
  SHELL "Testdrive$" + ":"
  IF ASC(UCASE$(TestDrive$)) = FnGetDrive% THEN
	fnDriveValid% = -1         'they match so it's valid
  END IF
  SHELL "Current$" + ":"   'either way restore it
END DEF


'calculate  position of a record
DEF FNSeekLoc& (RecNumber, RecLen) = ((RecNumber - 1) * CLNG(RecLen)) + 1


DEF FnGetDir$ (Drive$)          'returns default dir of a drive
  STATIC Temp$, Drive, Zero     'local variables
  IF LEN(Drive$) THEN           'did they pass a drive?
		Drive = ASC(UCASE$(Drive$)) - 64
  ELSE
		Drive = 0
  END IF
  Temp$ = SPACE$(65)            'DOS stores the name here
  regs.ax = &H4700         'get directory service
  regs.dx = Drive          'the drive goes in DL
  regs.si = SADD(Temp$)    'show DOS where Temp$ is
  regs.ds = -1             'use this with QuickBASIC
  CALL INTERRUPT(&H21, regs, regs)'call DOS
  IF regs.flags AND 1 THEN 'must be an invalid drive
	  FnGetDir$ = ""
  ELSE
	  Zero = INSTR(Temp$, CHR$(0))    'find the zero byte
	  FnGetDir$ = "\" + LEFT$(Temp$, Zero)
  END IF
END DEF


TYPE DTA                        'used by find first/next
  Reserved  AS STRING * 21      'reserved for use by DOS
  Attribute AS STRING * 1       'the file's attribute
  FileTime  AS STRING * 2       'the file's time
  FileDate  AS STRING * 2       'the file's date
  FileSize  AS LONG             'the file's size
  FileName  AS STRING * 13      'the file's name
END TYPE

DIM SHARED DTAData AS DTA       'shared so LoadNames can

DEF FnFileExist% (Spec$)         'file Spec$ exists?
  FnFileExist% = -1              'assume the file exists
  regs.dx = VARPTR(DTAData) 'set a new DOS DTA
  regs.ds = VARSEG(DTAData)
  regs.ax = &H1A00
  CALL INTERRUPTX(&H21, regs, regs)
  Spec$ = Spec$ + CHR$(0)      'DOS needs an ASCIIZ string
  regs.ax = &H4E00        'find file name service
  regs.cx = 39            'attribute for any file
  regs.dx = SADD(Spec$)   'show where the spec is
  regs.ds = VARSEG(Spec$)
  CALL INTERRUPTX(&H21, regs, regs)
  IF regs.flags AND 1 THEN FnFileExist% = 0
END DEF

DEF FnFileCount% (Spec$, Attribute)
  STATIC Count                   'make this private
  regs.dx = VARPTR(DTAData) 'set new DTA address
  regs.ds = -1              'the DTA is in DGROUP
  regs.ax = &H1A00          'specify service 1Ah
  CALL INTERRUPTX(&H21, regs, regs)
  Count = 0                      'clear the counter
  Spec$ = Spec$ + CHR$(0)        'make an ASCIIZ string
  IF Attribute AND 16 THEN       'find directory names?
	 DirFlag = -1                 'yes
  ELSE
	 DirFlag = 0                  'no
  END IF
  regs.dx = SADD(Spec$)     'the file spec address
  regs.ds = -1              'this is for QuickBASIC
  regs.cx = Attribute       'assign the attribute
  regs.ax = &H4E00          'find first matching name
  DO
	 CALL INTERRUPTX(&H21, regs, regs)
	 IF regs.flags AND 1 THEN EXIT DO   'no more
	 IF DirFlag THEN
		 IF ASC(DTAData.Attribute) AND 16 THEN
			  IF LEFT$(DTAData.FileName, 1) <> "." THEN
				 Count = Count + 1      'increment the counter
			  END IF
		 END IF
	 ELSE
		 Count = Count + 1          'they want regular files
	 END IF
	 regs.ax = &H4F00        'find next name
  LOOP
  FnFileCount% = Count           'assign the function
END DEF

'----- This function loads a group of file names to an array
DEF FNLoadNames%

  STATIC Count
  '---- define a new Data Transfer Area for DOS
  regs.dx = VARPTR(DTAData)
  regs.ds = VARSEG(DTAData)
  regs.ax = &H1A00
  CALL INTERRUPTX(&H21, regs, regs)
  Count = 0                  'zero the file counter
  Spec$ = Spec$ + Zero$      'DOS needs an ASCIIZ string
  regs.dx = SADD(Spec$) 'show where the spec is
  regs.ds = VARSEG(Spec$)
  regs.cx = 39          'the attribute for any file
  regs.ax = &H4E00      'find file name service
  '---- Read the file names that match the search specification.  The Flags
  '     regs indicates when no more matching files are found.  Copy
  '     each file name to the string array.  Service &H4F is used to
  '     continue the search started with service &H4E using the same file
  '     specification.
  DO
	CALL INTERRUPTX(&H21, regs, regs)
	IF regs.flags AND 1 THEN EXIT DO
	Count = Count + 1
	Array$(Count) = DTAData.FileName
	regs.ax = &H4F00
  LOOP WHILE Count < MaxFiles%
  FNLoadNames% = Count       'return the number of files
END DEF