jargon

mishap22 font routines.bas

Aug 20th, 2020
4,100
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. #lang "qb"
  2. Option GoSub
  3.  
  4. 'MISHAP22 Engine: font routines (ps5)
  5. 'MISER'S HOUSE ANTHOLOGY PROJECT - MISHAP22 ENGINE - MISHAP22.BAS
  6.  
  7. CONST H = "0123456789ABCDEF"
  8. CONST PI = 3.141592654#
  9.  
  10. DECLARE SUB LOADFONT (BYVAL INDEX AS INTEGER, BYVAL HEXDAT AS STRING)
  11. DECLARE SUB DRAWFONT (BYVAL TXTDAT AS STRING)
  12. DECLARE FUNCTION HEXTOLONG(BYVAL HEXDAT AS STRING) AS LONG
  13. DECLARE FUNCTION GLYPHADDR(BYVAL INDEX AS LONG) AS LONG
  14. DECLARE FUNCTION HEX2BYTE(BYVAL VALUE AS STRING) AS LONG
  15. DIM SHARED FONT(0 TO GLYPHADDR(256)-1) AS INTEGER
  16. DECLARE FUNCTION INPUTFONT (BYVAL TXTDAT AS STRING) AS STRING
  17.  
  18. FUNCTION INPUTFONT (BYVAL TXTDAT AS STRING) AS STRING
  19.     DIM X AS INTEGER
  20.     DIM Y AS INTEGER
  21.     DIM C AS STRING
  22.     DIM CI AS STRING
  23.     DIM T AS INTEGER
  24.     X = POS(0)
  25.     Y = CSRLN
  26.     C = INKEY$
  27.     CI = ""
  28.     PRINT
  29.     X = POS(0)
  30.     Y = CSRLIN - 1
  31.     DO
  32.         GAMEHUD
  33.         LOCATE Y, X
  34.         T = INT(TIMER * 4!) AND 1
  35.         LOCATE Y, X
  36.         DRAWFONT (CI + MID$(CHR$(254) + CHR$(255), T + 1, 1))
  37.         C = INKEY$'
  38.         IF C = CHR$(8) AND LEN(CI) > 0 THEN
  39.             LOCATE Y, X + LEN(CI)
  40.             LINE ((POS(0) - 1) * 8, (CSRLIN - 1) * 8)-(POS(0) * 8 - 1, CSRLIN * 8 - 1), 0, BF
  41.             CI = LEFT$(CI, LEN(CI) - 1)
  42.         ELSEIF C = CHR$(13) THEN
  43.             LOCATE Y, X + LEN(CI)
  44.             LINE ((POS(0) - 1) * 8, (CSRLIN - 1) * 8)-(POS(0) * 8 - 1, CSRLIN * 8 - 1), 0, BF
  45.             INPUTFONT = CI
  46.             EXIT DO
  47.         ELSE
  48.             IF LEN(C) = 1 AND LEN(CI) < 38 THEN
  49.                 IF ASC(C) >= 32 AND ASC(C) <= 127 THEN
  50.                     CI = CI + C
  51.                 END IF
  52.             END IF
  53.         END IF
  54.     LOOP
  55.     PRINT
  56. END FUNCTION
  57.  
  58. FUNCTION HEX2BYTE(BYVAL VALUE AS STRING) AS LONG
  59.     HEX2BYTE = (((INSTR(1, UCASE$(H), LEFT$(VALUE, 1)) - 1) AND 15) * 16) OR ((INSTR(1, UCASE$(H), MID$(VALUE, 2, 1)) - 1) AND 15)
  60. END FUNCTION
  61.  
  62. FUNCTION HEXTOLONG(BYVAL HEXDAT AS STRING) AS LONG
  63.     DIM P AS LONG
  64.     P = ((INSTR(1, UCASE$(H), UCASE$(MID$(HEXDAT, Y * 2 + 1, 1))) - 1) AND 15) * 16
  65.     P = P OR (INSTR(1, UCASE$(H), UCASE$(MID$(HEXDAT, Y * 2 + 2, 1))) - 1) AND 15
  66.     HEXTOLONG=P
  67. END FUNCTION
  68. FUNCTION GLYPHADDR(BYVAL INDEX AS LONG) AS LONG
  69.     GLYPHADDR=40*INDEX
  70. END FUNCTION
  71. SUB LOADFONT (BYVAL INDEX AS INTEGER, BYVAL HEXDAT AS STRING)
  72.     'DIM H AS STRING
  73.     'H = "0123456789ABCDEF"
  74.     IF INDEX < 0 OR INDEX > 255 THEN
  75.         EXIT SUB
  76.     END IF
  77.     CLS
  78.     PALETTE 15, 0
  79.     DIM X AS INTEGER
  80.     DIM Y AS INTEGER
  81.     DIM LINESTYLE AS INTEGER
  82.     FOR Y = 0 TO 7
  83.         LINESTYLE=HEXTOLONG(HEXDAT)
  84.         LINE (0, Y)-(15, Y), 8, , P
  85.     NEXT
  86.     GET (8, 0)-(15, 7), FONT%(GLYPHADDR(INDEX))
  87.     LINE (8, 0)-(15, 7), 0, BF
  88.     FOR Y = 0 TO 7
  89.         LINESTYLE=HEXTOLONG(HEXDAT)
  90.         LINE (0, Y)-(15, Y), 7, , LINESTYLE
  91.     NEXT
  92.     PUT (8, 0), FONT(GLYPHADDR(INDEX)), OR
  93.     GET (8, 0)-(15, 7), FONT(GLYPHADDR(INDEX))
  94.     PALETTE 15, (63 * 65536) OR (63 * 256) OR 63
  95. END SUB
  96.  
  97. SUB DRAWFONT (BYVAL TXTDAT AS STRING)
  98.     DIM X AS INTEGER
  99.     DIM Y AS INTEGER
  100.     DIM BUF AS STRING
  101.     DIM LP AS LONG
  102.     DIM RP AS LONG
  103.     X = POS(0)
  104.     Y = CSRLIN
  105.     IF LEN(TXTDAT) = 0 THEN
  106.         PRINT
  107.         EXIT SUB
  108.     END IF
  109.     BUF = TXTDAT + SPACE$(1)
  110.     DO
  111.         IF LEN(BUF) = 0 THEN EXIT DO
  112.         RP = 1
  113.         WHILE RP < 42 AND RP > 0
  114.             LP = RP
  115.             RP = INSTR(LP + 1, BUF, SPACE$(1))
  116.         WEND
  117.         FOR RP = 1 TO LP - 1
  118.             X = POS(0)
  119.             Y = CSRLIN
  120.             IF X < 40 THEN
  121.                 LOCATE CSRLIN, POS(0) + 1
  122.             ELSEIF Y < 25 THEN
  123.                 LOCATE CSRLIN + 1, 1
  124.             ELSE
  125.                 LOCATE 25, 1
  126.             END IF
  127.             IF ASC(MID$(BUF, RP, 1)) <> 32 THEN
  128.                 PUT ((X - 1) * 8, (Y - 1) * 8), FONT(ASC(MID$(BUF, RP, 1)) * 40), PSET
  129.             ELSE
  130.                 LINE ((X - 1) * 8, (Y - 1) * 8)-(X * 8 - 1, Y * 8 - 1), 0, BF
  131.             END IF
  132.         NEXT
  133.         X = POS(0)
  134.         Y = CSRLIN
  135.         IF Y < 25 THEN
  136.             LOCATE CSRLIN, 1
  137.         ELSE
  138.             LOCATE 25, 1
  139.         END IF
  140.         PRINT
  141.         BUF = RIGHT$(BUF, LEN(BUF) - LP)
  142.     LOOP
  143. END SUB
  144.  
RAW Paste Data

Adblocker detected! Please consider disabling it...

We've detected AdBlock Plus or some other adblocking software preventing Pastebin.com from fully loading.

We don't have any obnoxious sound, or popup ads, we actively block these annoying types of ads!

Please add Pastebin.com to your ad blocker whitelist or disable your adblocking software.

×