home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / tsr / fonttsr.zip / FONTTSR.BAS < prev    next >
BASIC Source File  |  1993-01-12  |  11KB  |  332 lines
  1. $compile EXE
  2. $Lib All Off
  3. $optimize size
  4. Defint a-z
  5. DECLARE SUB LoadFontFile(String, Integer, Integer, Integer)
  6.  
  7. %FLAGS = 0 : %AX    = 1 : %BX    = 2 : %CX    = 3 : %DX    = 4 : %SI    = 5
  8. %DI    = 6 : %BP    = 7 : %DS    = 8 : %ES    = 9
  9.  
  10. ' These are the fonts for the screen
  11. DIM Font$(30)
  12. Font$(1) = "JULIE"
  13. Font$(2) = "JULIE2"
  14. Font$(3) = "POOTER"
  15. Font$(4) = "POOTER2"
  16. Font$(5) = "AMB"
  17. Font$(6) = "KING"
  18. Font$(7) = "ANTIQUE"
  19. Font$(8) = "BIG"
  20. Font$(9) = "BLOCK"
  21. Font$(10) = "BOLD"
  22. Font$(11) = "BROADWAY"
  23. Font$(12) = "COMPUTER"
  24. Font$(13) = "DECO"
  25. Font$(14) = "FUTURE"
  26. Font$(15) = "HEARST"
  27. Font$(16) = "LCD"
  28. Font$(17) = "MEDIEVAL"
  29. Font$(18) = "MODERN"
  30. Font$(19) = "MODERN-R"
  31. Font$(20) = "ROMAN"
  32. Font$(21) = "ROMAN-1"
  33. Font$(22) = "SCRAWL-1"
  34. Font$(23) = "SCRAWL-2"
  35. Font$(24) = "SWISS-1"
  36. Font$(25) = "SWISS-2"
  37. Font$(26) = "SWISS-3"
  38. Font$(27) = "THICK"
  39.  
  40. Font$(28)=""
  41.  
  42.  
  43. x& = SETMEM(-700000)          ' release unused memory
  44. x& = SETMEM(32000)
  45.  
  46. POPUP KEY CHR$(12,33,247)      ' CTRL-ALT F is the hot key
  47.  
  48. POPUP MULTIPLEX &HC000, 253   ' reg AX and DX get this pattern as an ID
  49. REG 1, &HC000 : REG 4, 253    ' set pattern to check for already installed
  50. CALL INTERRUPT &H2F           ' do the multiplex interrrupt
  51. IF REG(1)<>&HC000 AND REG(4)<>253 THEN
  52.         PRINT "Font TSR is already loaded."
  53.         END 'we were already installed
  54. END IF
  55.  
  56. SwapFile$ = LEFT$(CURDIR$,2)+"\FONTTSR.SWP"
  57. FontDir$ = CURDIR$+"\"
  58. PRINT "Font List available as CTRL-ALT-F"
  59. REG 1, &HC001 : REG 4, 252  ' Alter AX,DX to show we were here
  60. DO
  61. POPUP SLEEP USING EMS, SwapFile$       ' before going to sleep
  62.  
  63. TEMP$ = SAVESCREEN$:X%=CSRLIN:Y%=POS(0)
  64.  
  65.      NumberChars% = 255          'How many characters
  66.      CharWidth%   = 16           'Which dot pattern
  67.      FirstChar%   = 0            'Where in the ascii table to put
  68.  
  69.         SELECT CASE FILEBOX$(Font$())
  70.         CASE "JULIE"
  71.     FontFile$ = FontDir$ + "JULIE.BIN"
  72.     Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  73.         CASE "JULIE2"
  74.     FontFile$ = FontDir$ +"JULIE2.BIN"
  75.     Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  76.         CASE "POOTER"
  77.     FontFile$ = FontDir$ +"POOTER.BIN"
  78.     Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  79.         CASE "POOTER2"
  80.     FontFile$ = FontDir$ +"POOTER2.BIN"
  81.     Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  82.         CASE "AMB"
  83.     FontFile$ = FontDir$ +"AMB.BIN"
  84.     Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  85.         CASE "KING"
  86.     FontFile$ = FontDir$ +"KING.BIN"
  87.     Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  88.                 CASE "ANTIQUE"
  89.         FontFile$ = FontDir$ +"ANTIQUE.F16"
  90.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  91.                 CASE "BIG"
  92.         FontFile$ = FontDir$ +"BIG.F16"
  93.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  94.                 CASE "BLOCK"
  95.         FontFile$ = FontDir$ +"BLOCK.F16"
  96.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  97.                 CASE "BOLD"
  98.         FontFile$ = FontDir$ +"BOLD.F16"
  99.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  100.                 CASE "BROADWAY"
  101.         FontFile$ = FontDir$ +"BROADWAY.F16"
  102.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  103.                 CASE "COMPUTER"
  104.         FontFile$ = FontDir$ +"COMPUTER.F16"
  105.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  106.                 CASE "DECO"
  107.         FontFile$ = FontDir$ +"DECO.F16"
  108.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  109.                 CASE "FUTURE"
  110.         FontFile$ = FontDir$ +"FUTURE.F16"
  111.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  112.                 CASE "HEARST"
  113.         FontFile$ = FontDir$ +"HEARST.F16"
  114.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  115.                 CASE "LCD"
  116.         FontFile$ = FontDir$ +"LCD.F16"
  117.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  118.                 CASE "MEDIEVAL"
  119.         FontFile$ = FontDir$ +"MEDIEVAL.F16"
  120.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  121.                 CASE "MODERN"
  122.     FontFile$ = FontDir$ +"MODERN.F16"
  123.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  124.                 CASE "MODERN-R"
  125.         FontFile$ = FontDir$ +"MODERN-R.F16"
  126.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  127.                 CASE "ROMAN"
  128.         FontFile$ = FontDir$ +"ROMAN.F16"
  129.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  130.                 CASE "ROMAN-1"
  131.         FontFile$ = FontDir$ +"ROMAN-1.F16"
  132.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  133.                 CASE "SCRAWL-1"
  134.         FontFile$ = FontDir$ +"SCRAWL-1.F16"
  135.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  136.                 CASE "SCRAWL-2"
  137.         FontFile$ = FontDir$ +"SCRAWL-2.F16"
  138.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  139.                 CASE "SWISS-1"
  140.         FontFile$ = FontDir$ +"SWISS-1.F16"
  141.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  142.                 CASE "SWISS-2"
  143.         FontFile$ = FontDir$ +"SWISS-2.F16"
  144.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  145.                 CASE "SWISS-3"
  146.         FontFile$ = FontDir$ +"SWISS-3.F16"
  147.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  148.                 CASE "THICK"
  149.         FontFile$ = FontDir$ +"THICK.F16"
  150.         Call LoadFontFile (FontFile$, CharWidth%, FirstChar%, NumberChars%)
  151.  
  152.  
  153.                 CASE ELSE
  154.         SCREEN 1
  155.         SCREEN 0
  156.     END SELECT
  157.  
  158. ' Restore the screen and cursor position
  159.  
  160. RESTORESCREEN TEMP$:LOCATE X%, Y%, 1  ' make sure cursor is visible
  161.  
  162. LOOP
  163.  
  164.  
  165. ' Thaddy De Konings' Font file subroutine.
  166. Sub LoadFontFile(FontFile$,CharWidth%,FirstChar%, NumberChars%) shared
  167.          FontFile% = FREEFILE
  168.             OPEN FontFile$ FOR BINARY AS #FontFile%
  169.             GET$ #FontFile%,lof(FontFile%) , a$           ' do it
  170.          CLOSE #FontFile%
  171.               Reg %CX, NumberChars%      ' # of characters in the font
  172.               Reg %DX, FirstChar%        ' DX = where to begin loading.
  173.               Reg %BX, CharWidth% * 256  ' BH = # of bytes in each
  174.               Reg %ES, StrSEG(a$)        ' Segment if using QBX/BC7 FAR strings
  175.               Reg %BP, Strptr(a$)        ' The address of our string
  176.               Reg %AX, &H1100            ' Use Function 11h, Service 0 (Load)
  177.  
  178.             call  Interrupt &H10  ' Invoke BIOS service 10h
  179.  
  180.               Reg %AX, &H1103        ' Use Function 11h, Service 3 (Set)
  181.               Reg %BX, 0             ' BL = Which block to load (parallels
  182.  
  183.             call Interrupt &H10  ' Invoke BIOS service 10h
  184. end sub
  185.  
  186. SUB SingleBox (Wa%, Wb%, Wc%, Wd%)
  187.          LOCATE Wa%, Wb%: PRINT CHR$(213) + STRING$((Wd% - Wb%) - 1, 205) + CHR$(184)
  188.    LOCATE Wc%, Wb%: PRINT CHR$(212) + STRING$((Wd% - Wb%) - 1, 205) + CHR$(190)
  189.  
  190.    FOR zxy% = 1 TO Wc% - Wa% - 1
  191.       LOCATE Wa% + zxy%, Wb%
  192.       PRINT CHR$(179) + SPACE$((Wd% - Wb%) - 1) + CHR$(179)
  193.    NEXT zxy%
  194.  
  195. END SUB
  196.  
  197.  
  198.  
  199.  
  200. FUNCTION FileBox$( ListArray$() )
  201. O$=SAVESCREEN$
  202. ' The last element of the list in the array has to be blank.
  203. ' calculate how wide to make the window
  204. Yy%=0
  205. DO
  206.         INCR Yy%
  207.         IF LEN(ListArray$(Yy%)) > MaxLen% THEN MaxLen%=LEN(ListArray$(Yy%))
  208.         IF LEN(ListArray$(Yy%)) = 0 THEN ListLen%=Yy%: EXIT LOOP
  209. LOOP
  210.  
  211. WinTop%=5:WinLeft%=38-(MaxLen%\2):WinRight%=43+(MaxLen%\2)
  212. WinBot% = (WinTop% + Yy%)-1:If WinBot% > 20 THEN WinBot% = 20
  213. COLOR 0,7
  214. Call SingleBox(WinTop%, WinLeft%, WinBot%, WinRight%)
  215.  
  216. TopLine% = 0           ' the first element to appear inside the box
  217. PickLine% = 1          ' the offset box line you are pointing at
  218.  
  219. DO                     ' Main loop start
  220.  
  221. For Yy% = WinTop% + 1 TO WinBot%-1
  222.         Locate Yy%, WinLeft%+1
  223.         IF Yy% = WinTop% + PickLine% THEN COLOR 7,0 ELSE COLOR 0,7
  224.     PRINT " " + ListArray$(Yy%-WinTop%+TopLine%) + SPACE$(MaxLen%-LEN(ListArray$(Yy%-WinTop%+TopLine%))+2)
  225. Next Yy%
  226.  
  227.  
  228. DO:A$=INKEY$:LOOP WHILE A$=""
  229.  
  230. Pick:
  231.  
  232. SELECT CASE A$
  233.         CASE CHR$(0,&H48) 'up arrow
  234.                 DECR PickLine%
  235.         CASE CHR$(0,&H50) 'dn arrow
  236.                 INCR PickLine%
  237.         CASE CHR$(0,&H4B) 'rt arrow
  238.         CASE CHR$(0,&H4D) 'lf arrow
  239.         CASE CHR$(0,&H47) 'home
  240.                 PickLine%=1
  241.         CASE CHR$(0,&H4F) 'end
  242.                 PickLine%=WinBot%-WinTop%-1
  243.         CASE CHR$(0,&H49) 'page up
  244.                 if PickLine%=1 then_
  245.                  TopLine%=TopLine%-(WinBot%-winTop%)+2 else_
  246.                   PickLine%=1
  247.         CASE CHR$(0,&H51) 'page dn
  248.                 If PickLine%=WinBot%-WinTop%-1 THEN_
  249.                  TopLine%=TopLine%+(WinBot%-WinTop%)-2 else_
  250.                   PickLine%=WinBot%-WinTop%-1
  251.         CASE CHR$(0,82)   ' insert
  252.         CASE CHR$(0,119)  'ctrl home
  253.         CASE CHR$(0,117)  'ctrl end
  254.         CASE CHR$(0,132)  'ctrl pgup
  255.         CASE CHR$(0,118)  'ctrl pgdn
  256.                         CASE CHR$(27)  ' Escape ESC
  257.  
  258.         CASE ELSE
  259.  
  260.         END SELECT
  261.  
  262. if A$=CHR$(27) then FileBox$="":RESTORESCREEN O$:EXIT FUNCTION
  263. if A$=CHR$(13) then FileBox$=ListArray$(TopLine%+PickLine%):RESTORESCREEN O$:EXIT FUNCTION
  264.  
  265.  
  266.  
  267. if PickLine%<1 then PickLine%=1:DECR TopLine%
  268. if topLine%<0 then TopLine%=0:PickLine%=1:sound 1500,.1
  269.  
  270. if PickLine%=>WinBot%-WinTop% then PickLine%=WinBot%-WinTop%-1:INCR TopLine%
  271. if TopLine% > ListLen% - (Winbot%-WinTop%) then TopLine%=ListLen%-(Winbot%-WinTop%):PickLine%=WinBot%-WinTop%-1:sound 500,.1
  272.  
  273. LOOP
  274.  
  275. END FUNCTION
  276.  
  277. SUB SoundEffect (ef$)
  278.    ef$ = UCASE$(ef$)
  279.    SELECT CASE ef$
  280.    CASE "CAPTURE ON"
  281.       FOR x = 1 TO 3: FOR Y = 500 TO 5500 STEP 500: SOUND Y, .2: NEXT Y: NEXT x
  282.    CASE "CAPTURE OFF"
  283.       FOR x = 1 TO 3: FOR Y = 5500 TO 500 STEP -500: SOUND Y, .2: NEXT Y: NEXT x
  284.    CASE "PRINTER ON"
  285.       SOUND 50, 4
  286.       SOUND 1000, 1: SOUND 2000, 1: SOUND 3000, 1
  287.    CASE "PRINTER OFF"
  288.       SOUND 50, 4
  289.       SOUND 3000, 1: SOUND 2000, 1: SOUND 1000, 1
  290.    CASE "C"
  291.       FOR Y% = 100 TO 1000 STEP 50: SOUND Y%, .2: SOUND 500, .1: NEXT Y%
  292.    CASE "W"
  293.       FOR Y% = 2500 TO 3000 STEP 50: SOUND Y%, .1: NEXT Y%
  294.       SOUND 5000, .5: SOUND 100, .5: SOUND 50, .1
  295.    CASE "FWEEP"
  296.       FOR Y% = 500 TO 1500 STEP 200: SOUND Y%, .1: NEXT Y%
  297.    CASE "FWOP"
  298.       FOR Y% = 1500 TO 100 STEP -400: SOUND Y%, .1: NEXT Y%
  299.    CASE "OPEN"
  300.       FOR Y% = 100 TO 1600 STEP 200: SOUND INT(RND(1) * 500) + Y%, RND(1) + .1: SOUND Y%, .3: NEXT Y%
  301.       FOR Y% = 1100 TO 100 STEP -200: SOUND Y%, .5: NEXT Y%
  302.  
  303.  
  304.  
  305.    CASE ELSE
  306.       SOUND 1000, 1: SOUND 2000, 1: SOUND 3000, 1
  307.    END SELECT
  308. END SUB
  309.  
  310.  
  311. FUNCTION SaveScreen$
  312. CALL SoundEffect("FWEEP")
  313. REG 1, 15*256
  314. CALL INTERRUPT &H10
  315. IF Reg(1) - (Reg(1)\256) * 256 = 7 THEN Address=&HB000 else Address=&HB800
  316. DEF SEG = ADDRESS
  317. SaveScreen$=PEEK$(0,4000)
  318. DEF SEG
  319. END FUNCTION
  320.  
  321. SUB RestoreScreen(S$)
  322. CALL SoundEffect("FWOP")
  323. REG 1, 15*256
  324. CALL INTERRUPT &H10
  325. IF Reg(1) - (Reg(1)\256) * 256 = 7 THEN Address=&HB000 else Address=&HB800
  326. DEF SEG = Address
  327. POKE$ 0, S$
  328. DEF SEG
  329. END SUB
  330.  
  331.  
  332.