home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 9
/
MEDIASHARE_09.ISO
/
tsr
/
fonttsr.zip
/
FONTTSR.BAS
< prev
next >
Wrap
BASIC Source File
|
1993-01-12
|
11KB
|
332 lines
$compile EXE
$Lib All Off
$optimize size
Defint a-z
DECLARE SUB LoadFontFile(String, Integer, Integer, Integer)
%FLAGS = 0 : %AX = 1 : %BX = 2 : %CX = 3 : %DX = 4 : %SI = 5
%DI = 6 : %BP = 7 : %DS = 8 : %ES = 9
' These are the fonts for the screen
DIM Font$(30)
Font$(1) = "JULIE"
Font$(2) = "JULIE2"
Font$(3) = "POOTER"
Font$(4) = "POOTER2"
Font$(5) = "AMB"
Font$(6) = "KING"
Font$(7) = "ANTIQUE"
Font$(8) = "BIG"
Font$(9) = "BLOCK"
Font$(10) = "BOLD"
Font$(11) = "BROADWAY"
Font$(12) = "COMPUTER"
Font$(13) = "DECO"
Font$(14) = "FUTURE"
Font$(15) = "HEARST"
Font$(16) = "LCD"
Font$(17) = "MEDIEVAL"
Font$(18) = "MODERN"
Font$(19) = "MODERN-R"
Font$(20) = "ROMAN"
Font$(21) = "ROMAN-1"
Font$(22) = "SCRAWL-1"
Font$(23) = "SCRAWL-2"
Font$(24) = "SWISS-1"
Font$(25) = "SWISS-2"
Font$(26) = "SWISS-3"
Font$(27) = "THICK"
Font$(28)=""
x& = SETMEM(-700000) ' release unused memory
x& = SETMEM(32000)
POPUP KEY CHR$(12,33,247) ' CTRL-ALT F is the hot key
POPUP MULTIPLEX &HC000, 253 ' reg AX and DX get this pattern as an ID
REG 1, &HC000 : REG 4, 253 ' set pattern to check for already installed
CALL INTERRUPT &H2F ' do the multiplex interrrupt
IF REG(1)<>&HC000 AND REG(4)<>253 THEN
PRINT "Font TSR is already loaded."
END 'we were already installed
END IF
SwapFile$ = LEFT$(CURDIR$,2)+"\FONTTSR.SWP"
FontDir$ = CURDIR$+"\"
PRINT "Font List available as CTRL-ALT-F"
REG 1, &HC001 : REG 4, 252 ' Alter AX,DX to show we were here
DO
POPUP SLEEP USING EMS, SwapFile$ ' before going to sleep
TEMP$ = SAVESCREEN$:X%=CSRLIN:Y%=POS(0)
NumberChars% = 255 'How many characters
CharWidth% = 16 'Which dot pattern
FirstChar% = 0 'Where in the ascii table to put
SELECT CASE FILEBOX$(Font$())
CASE "JULIE"
FontFile$ = FontDir$ + "JULIE.BIN"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "JULIE2"
FontFile$ = FontDir$ +"JULIE2.BIN"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "POOTER"
FontFile$ = FontDir$ +"POOTER.BIN"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "POOTER2"
FontFile$ = FontDir$ +"POOTER2.BIN"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "AMB"
FontFile$ = FontDir$ +"AMB.BIN"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "KING"
FontFile$ = FontDir$ +"KING.BIN"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "ANTIQUE"
FontFile$ = FontDir$ +"ANTIQUE.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "BIG"
FontFile$ = FontDir$ +"BIG.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "BLOCK"
FontFile$ = FontDir$ +"BLOCK.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "BOLD"
FontFile$ = FontDir$ +"BOLD.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "BROADWAY"
FontFile$ = FontDir$ +"BROADWAY.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "COMPUTER"
FontFile$ = FontDir$ +"COMPUTER.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "DECO"
FontFile$ = FontDir$ +"DECO.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "FUTURE"
FontFile$ = FontDir$ +"FUTURE.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "HEARST"
FontFile$ = FontDir$ +"HEARST.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "LCD"
FontFile$ = FontDir$ +"LCD.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "MEDIEVAL"
FontFile$ = FontDir$ +"MEDIEVAL.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "MODERN"
FontFile$ = FontDir$ +"MODERN.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "MODERN-R"
FontFile$ = FontDir$ +"MODERN-R.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "ROMAN"
FontFile$ = FontDir$ +"ROMAN.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "ROMAN-1"
FontFile$ = FontDir$ +"ROMAN-1.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "SCRAWL-1"
FontFile$ = FontDir$ +"SCRAWL-1.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "SCRAWL-2"
FontFile$ = FontDir$ +"SCRAWL-2.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "SWISS-1"
FontFile$ = FontDir$ +"SWISS-1.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "SWISS-2"
FontFile$ = FontDir$ +"SWISS-2.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "SWISS-3"
FontFile$ = FontDir$ +"SWISS-3.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE "THICK"
FontFile$ = FontDir$ +"THICK.F16"
Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
CASE ELSE
SCREEN 1
SCREEN 0
END SELECT
' Restore the screen and cursor position
RESTORESCREEN TEMP$:LOCATE X%, Y%, 1 ' make sure cursor is visible
LOOP
' Thaddy De Konings' Font file subroutine.
Sub LoadFontFile(FontFile$,CharWidth%,FirstChar%, NumberChars%) shared
FontFile% = FREEFILE
OPEN FontFile$ FOR BINARY AS #FontFile%
GET$ #FontFile%,lof(FontFile%) , a$ ' do it
CLOSE #FontFile%
Reg %CX, NumberChars% ' # of characters in the font
Reg %DX, FirstChar% ' DX = where to begin loading.
Reg %BX, CharWidth% * 256 ' BH = # of bytes in each
Reg %ES, StrSEG(a$) ' Segment if using QBX/BC7 FAR strings
Reg %BP, Strptr(a$) ' The address of our string
Reg %AX, &H1100 ' Use Function 11h, Service 0 (Load)
call Interrupt &H10 ' Invoke BIOS service 10h
Reg %AX, &H1103 ' Use Function 11h, Service 3 (Set)
Reg %BX, 0 ' BL = Which block to load (parallels
call Interrupt &H10 ' Invoke BIOS service 10h
end sub
SUB SingleBox (Wa%, Wb%, Wc%, Wd%)
LOCATE Wa%, Wb%: PRINT CHR$(213) + STRING$((Wd% - Wb%) - 1, 205) + CHR$(184)
LOCATE Wc%, Wb%: PRINT CHR$(212) + STRING$((Wd% - Wb%) - 1, 205) + CHR$(190)
FOR zxy% = 1 TO Wc% - Wa% - 1
LOCATE Wa% + zxy%, Wb%
PRINT CHR$(179) + SPACE$((Wd% - Wb%) - 1) + CHR$(179)
NEXT zxy%
END SUB
FUNCTION FileBox$( ListArray$() )
O$=SAVESCREEN$
' The last element of the list in the array has to be blank.
' calculate how wide to make the window
Yy%=0
DO
INCR Yy%
IF LEN(ListArray$(Yy%)) > MaxLen% THEN MaxLen%=LEN(ListArray$(Yy%))
IF LEN(ListArray$(Yy%)) = 0 THEN ListLen%=Yy%: EXIT LOOP
LOOP
WinTop%=5:WinLeft%=38-(MaxLen%\2):WinRight%=43+(MaxLen%\2)
WinBot% = (WinTop% + Yy%)-1:If WinBot% > 20 THEN WinBot% = 20
COLOR 0,7
Call SingleBox(WinTop%, WinLeft%, WinBot%, WinRight%)
TopLine% = 0 ' the first element to appear inside the box
PickLine% = 1 ' the offset box line you are pointing at
DO ' Main loop start
For Yy% = WinTop% + 1 TO WinBot%-1
Locate Yy%, WinLeft%+1
IF Yy% = WinTop% + PickLine% THEN COLOR 7,0 ELSE COLOR 0,7
PRINT " " + ListArray$(Yy%-WinTop%+TopLine%) + SPACE$(MaxLen%-LEN(ListArray$(Yy%-WinTop%+TopLine%))+2)
Next Yy%
DO:A$=INKEY$:LOOP WHILE A$=""
Pick:
SELECT CASE A$
CASE CHR$(0,&H48) 'up arrow
DECR PickLine%
CASE CHR$(0,&H50) 'dn arrow
INCR PickLine%
CASE CHR$(0,&H4B) 'rt arrow
CASE CHR$(0,&H4D) 'lf arrow
CASE CHR$(0,&H47) 'home
PickLine%=1
CASE CHR$(0,&H4F) 'end
PickLine%=WinBot%-WinTop%-1
CASE CHR$(0,&H49) 'page up
if PickLine%=1 then_
TopLine%=TopLine%-(WinBot%-winTop%)+2 else_
PickLine%=1
CASE CHR$(0,&H51) 'page dn
If PickLine%=WinBot%-WinTop%-1 THEN_
TopLine%=TopLine%+(WinBot%-WinTop%)-2 else_
PickLine%=WinBot%-WinTop%-1
CASE CHR$(0,82) ' insert
CASE CHR$(0,119) 'ctrl home
CASE CHR$(0,117) 'ctrl end
CASE CHR$(0,132) 'ctrl pgup
CASE CHR$(0,118) 'ctrl pgdn
CASE CHR$(27) ' Escape ESC
CASE ELSE
END SELECT
if A$=CHR$(27) then FileBox$="":RESTORESCREEN O$:EXIT FUNCTION
if A$=CHR$(13) then FileBox$=ListArray$(TopLine%+PickLine%):RESTORESCREEN O$:EXIT FUNCTION
if PickLine%<1 then PickLine%=1:DECR TopLine%
if topLine%<0 then TopLine%=0:PickLine%=1:sound 1500,.1
if PickLine%=>WinBot%-WinTop% then PickLine%=WinBot%-WinTop%-1:INCR TopLine%
if TopLine% > ListLen% - (Winbot%-WinTop%) then TopLine%=ListLen%-(Winbot%-WinTop%):PickLine%=WinBot%-WinTop%-1:sound 500,.1
LOOP
END FUNCTION
SUB SoundEffect (ef$)
ef$ = UCASE$(ef$)
SELECT CASE ef$
CASE "CAPTURE ON"
FOR x = 1 TO 3: FOR Y = 500 TO 5500 STEP 500: SOUND Y, .2: NEXT Y: NEXT x
CASE "CAPTURE OFF"
FOR x = 1 TO 3: FOR Y = 5500 TO 500 STEP -500: SOUND Y, .2: NEXT Y: NEXT x
CASE "PRINTER ON"
SOUND 50, 4
SOUND 1000, 1: SOUND 2000, 1: SOUND 3000, 1
CASE "PRINTER OFF"
SOUND 50, 4
SOUND 3000, 1: SOUND 2000, 1: SOUND 1000, 1
CASE "C"
FOR Y% = 100 TO 1000 STEP 50: SOUND Y%, .2: SOUND 500, .1: NEXT Y%
CASE "W"
FOR Y% = 2500 TO 3000 STEP 50: SOUND Y%, .1: NEXT Y%
SOUND 5000, .5: SOUND 100, .5: SOUND 50, .1
CASE "FWEEP"
FOR Y% = 500 TO 1500 STEP 200: SOUND Y%, .1: NEXT Y%
CASE "FWOP"
FOR Y% = 1500 TO 100 STEP -400: SOUND Y%, .1: NEXT Y%
CASE "OPEN"
FOR Y% = 100 TO 1600 STEP 200: SOUND INT(RND(1) * 500) + Y%, RND(1) + .1: SOUND Y%, .3: NEXT Y%
FOR Y% = 1100 TO 100 STEP -200: SOUND Y%, .5: NEXT Y%
CASE ELSE
SOUND 1000, 1: SOUND 2000, 1: SOUND 3000, 1
END SELECT
END SUB
FUNCTION SaveScreen$
CALL SoundEffect("FWEEP")
REG 1, 15*256
CALL INTERRUPT &H10
IF Reg(1) - (Reg(1)\256) * 256 = 7 THEN Address=&HB000 else Address=&HB800
DEF SEG = ADDRESS
SaveScreen$=PEEK$(0,4000)
DEF SEG
END FUNCTION
SUB RestoreScreen(S$)
CALL SoundEffect("FWOP")
REG 1, 15*256
CALL INTERRUPT &H10
IF Reg(1) - (Reg(1)\256) * 256 = 7 THEN Address=&HB000 else Address=&HB800
DEF SEG = Address
POKE$ 0, S$
DEF SEG
END SUB