10
20
30
40 :
50 DIM mcode% &200:load%=&FFFF0961
60 osword=&FFF1:oswrch=&FFFE:vduout=&FFBC
70 vduQ=&26A:vduN=&322:dest=&27C:wrchv=&20E
80 :
90 FOR P=0 TO 1
100 P%=load%:O%=mcode%
110 [OPT P*3+4
120 .go%
130 PHP:SEI
140 LDX wrchv+0:LDY wrchv+1
150 CPX #newwrch AND 255:BNE setup
160 CPY #newwrch DIV 256:BEQ done
170 .setup
180 STX oldwrchv+0:STY oldwrchv+1
190 LDX #newwrch AND 255
200 LDY #newwrch DIV 256
210 STX wrchv+0:STY wrchv+1
220 .done
230 PLP:RTS
240 :
250 .newwrch
260 PHA:LDA vduQ:BEQ newwrch1 :\ No queue, is it a char?
270 CMP #&FF:BNE oldwrch1 :\ Not last param
280 LDA block:EOR #22:BEQ newwrch2 :\ Pending MODE
290 CMP #18 EOR 22:BNE oldwrch1 :\ Pending not GCOL
300 LDA vduN :\ Get GCOL command
310 LSR A:EOR #&46:BNE oldwrch1 :\ Not GCOL -ASC"s" or "t"
320 PLA:PHA:PHP:DEC vduQ
330 JSR oldwrch:LDA #0:STA vduQ :\ Allow SPOOL/Serial/etc
340 PLP:PLA:BEQ newwrch3 :\ Set flag to zero
350 BCS newwrch3:ORA flag :\ GCOL 140, add to flag
360 .newwrch3 :\ GCOL 141, set flag
370 STA flag:RTS :\ Set flag from GCOL
380 .newwrch2
390 STA flag:BEQ oldwrch1 :\ Reset flag on MODE
400 .newwrch1
410 LDA flag:CMP #&01 :\ CC=flag is zero
420 PLA:STA block :\ Store character
430 BCC oldwrch :\ Flag is zero, ignore
440 CMP #32:BCS output:PHA :\ Not control code
450 .oldwrch1
460 PLA
470 .oldwrch
480 JMP (oldwrchv)
490 :
500 .output
510 PHA:TXA:PHA:TYA:PHA :\ Save everything
520 :
530 LDA dest:PHA
540 ORA #&02:STA dest
550 LDA block:TAX:JSR oldwrch :\ Allow Print/SPOOL/Serial/etc
560 PLA:STA dest
570 :
580 CPX #127:BNE output2 :\ Not delete
590 BIT flag:BPL output1
600 TXA:JSR vduout :\ Wide, do twice
610 .output1
620 LDA #127:JSR vduout
630 JMP exit
640 :
650 .output2
660 LDX #block AND 255
670 LDY #block DIV 256
680 LDA #10:JSR osword :\ Read definition
690 \
700 \ Effect bitmap
710 \ 0 1 underline
720 \ 1 2 bold
730 \ 2 4 italics
740 \ 3 8 thin
750 \ 4 16 superscript
760 \ 5 32 subscript
770 \ 6 64 inverse
780 \ 7 128 wide
790 \
800 LDA flag:PHP:LSR A:PHP :\ Save Wide,Underline flags
810 LSR A:BCC TestItalic :\ Skip if not bold
820 PHA:LDX #8
830 .BoldLp
840 LDA block,X:ASL A:ORA block,X
850 STA block,X:DEX:BNE BoldLp :\ Thicken character
860 PLA
870 :
880 .TestItalic
890 LSR A:BCC TestThin :\ Skip if not italic
900 LDX #2
910 .ItalicLp
920 LSR block+1,X:ASL block+6,X
930 DEX:BPL ItalicLp :\ Slant character
940 :
950 .TestThin
960 LSR A:BCC TestSuper :\ Skip if not thin
970 PHA:LDX #8
980 .ThinLp
990 LDA block,X:ASL A:AND block,X
1000 STA block,X:DEX:BNE ThinLp :\ Thinen character
1010 PLA
1020 :
1030 .TestSuper
1040 AND #3:BEQ TestUnder :\ Not Sup/Sub
1050 PHA:LDX #&FB
1060 .SuperLp1
1070 LDA block-&FB+3,X :\ Shrink character
1080 STA block-&FB+2,X
1090 INX:BNE SuperLp1
1100 LDY block+5:STA block+5
1110 LDA block
1120 CMP #ASC"f":BCC TestSuper1
1130 STY block+4 :\ Adjust lower case
1140 .TestSuper1
1150 TXA:LDX #2 :\ Clear bottom of char
1160 .SuperLp2
1170 STA block+6,X:DEX:BPL SuperLp2
1180 PLA:CMP #2:BCC TestUnder :\ Not subscript
1190 LDX #5
1200 .SubLp
1210 LDA block,X:STA block+3,X :\ Move to bottom
1220 LDA #0:STA block,X
1230 DEX:BNE SubLp
1240 :
1250 .TestUnder
1260 PLP:BCC TestInverse :\ Skip if not underlined
1270 LDA #255:STA block+8 :\ Add an underline
1280 :
1290 .TestInverse
1300 BIT flag:BVC TestWide :\ Not inverse
1310 LDX #8
1320 .InvLp
1330 LDA block,X:EOR #255
1340 STA block,X:DEX:BNE InvLp :\ Invert character
1350 :
1360 .TestWide
1370 LDY #11 :\ Print one bitmap
1380 PLP:BPL OutputChar :\ Not wide
1390 LDX #8
1400 .WideLp
1410 LDA block,X:LDY #4
1420 .WideLp1
1430 LSR A:PHP:ROR block+11,X :\ Right half
1440 PLP:ROR block+11,X
1450 DEY:BNE WideLp1
1460 LDY #4
1470 .WideLp2
1480 LSR A:PHP:ROR block,X :\ Left half
1490 PLP:ROR block,X
1500 DEY:BNE WideLp2
1510 DEX:BNE WideLp
1520 LDY #22 :\ Print two bitmaps
1530 :
1540 .OutputChar
1550 LDX #255:STX block
1560 .OutputLp
1570 INX:TXA:PHA:TYA:PHA
1580 LDA block-1,X:JSR vduout :\ Send to VDU only
1590 PLA:TAY:PLA:TAX
1600 DEY:BNE OutputLp
1610 :
1620 .exit
1630 PLA:TAY:PLA:TAX:PLA:RTS
1640 :
1650 .flag
1660 EQUB 0 :\ Font style flag
1670 EQUB 23 :\ Start of VDU sequence
1680 .block
1690 EQUB 255:EQUS "12345678":EQUB 255
1700 EQUB 23
1710 EQUB 255:EQUS "JGHv1.00":EQUB 255
1720 .oldwrchv
1730 ]:NEXT
1740 A$="SAVE FONTFX "+STR$~mcode%+" "+STR$~O%+" "+STR$~(go%OR-65536)+" "+STR$~load%
1750 PRINTA$;:OSCLI A$:PRINT