BCODE3.BAS

1 ' BASICODE 3 routines voor IBM / GW BASIC(A).
2 ' (C) Copyright B. Niewold 1984,85 (BC2 routines)
3 ' (C) Copyright J. Goudsmit 1987 (BC3 aanvullingen)                             '
4 ' De BC3 routines mogen vrij gekopieerd worden, mits voor niet-commerciele      ' doeleinden.                                                                   '
5 ' Voor Basicode 3 heeft U BASICA versie 2.0 of hoger nodig, evenals de bij-     ' behorende DOS-versie. Dit i.v.m. enkele BASICA opdrachten die pas vanaf
6 ' versie 2.0 geimplementeerd zijn. Disk BASIC is niet bruikbaar, omdat daar     ' enkele grafische en andere routines niet inzitten.
7 ' Voor mooie grafieken hebt U een Color/Graphics adapter of een Hercules        ' Monochrome Graphics kaart nodig.
8 ' Vanwege de ingewikkelde procedure, en omdat het oplossend vermogen daartoe      meestal toch niet toereikend is, is er geen routine geimplementeerd voor        lijnen op het monochrome beeldscherm. Punten mogen wel, evenals tekst.
10 GOTO 1000
11 'In regel 20 worden de variabelen geinitialiseerd voor resp.:                    voor- en achtergrondkleur, border-kleur, accent-voor- en -achtergrondkleuren    breedte, mode (zie 23-), palletkleur en grafische kleur
20 OFG=2:OBG=1:OBD=1:OAF=14:OAB=4:OWD=40:OGS=2:OPL=0:OGK=2                         'Deze regel naar smaak aanpassen. Tip: gebruik ENVIRON$ om deze waarden in te    lezen.
21 VE=23:HO=OWD-1:IN$="":IN=0:SR$="":CT=0:CN=0:OGF=1 'ogf= flag voor grafmode
22 KEY OFF:FOR O=1 TO 10:KEY O,"":KEY(O) OFF:NEXT:GOSUB 100
23 ON OGS+1 GOTO 24,25,26,27
24 HG=80:VG=24:GOTO 28 'Geen grafische mogelijkheid: gebruik maken van tekst-scherm.
25 HG=320:VG=192:GOTO 28 'Gebruik maken van SCREEN 1 en COLOR BACKG,PALET
26 HG=640:VG=192:GOTO 28 'SCREEN 2 en voorgrondkleur BACKG. Merk op dat het aspect in deze mode flink afwijkt van de 3/4 die door BC3 is aangeraden.
27 HG=720:VG=348 'SCREEN 2 wordt gebruikt, maar er wordt rekening gehouden met de 720x348 resolutie van het Hercules scherm.
28 ON ERROR GOTO 850
29 KEY 15,CHR$(4)+CHR$(&H46):ON KEY(15) GOSUB 281:KEY(15) OFF
30 DIM OFO(3):FOR O=0 TO 3:OFO(O)=0:NEXT:GOTO 1010
100 CLS:IF OGF THEN OUT &H3D9,0:SCREEN 0,1,0,0:WIDTH OWD:COLOR OFG,OBG,OBD:OGF=0:LOCATE ,,0:CLS
105 RETURN
110 OVE%=INT(VE):OHO%=INT(HO)
111 IF OVE%>23 THEN OVE%=23
112 IF OVE%<0 THEN OVE%=0
113 IF OHO%>OWD-1 THEN OHO%=OWD-1
114 IF OHO%<0 THEN OHO%=0
115 LOCATE OVE%+1,OHO%+1
116 RETURN
120 HO=POS(0)-1:VE=CSRLIN-1:RETURN
150 COLOR OAF,OAB:OA$=LEFT$("   "+SR$+"   ",80-POS(0)):PRINT OA$;:COLOR OFG,OBG:RETURN
200 IN$=INKEY$
201 IN=0:IF IN$="" THEN RETURN
202 IF LEN(IN$)=2 THEN IF MID$(IN$,2,1)=CHR$(3) THEN IN$=CHR$(0):RETURN ELSE IN=ASC(RIGHT$(IN$,1)) ELSE IN=ASC(IN$):GOTO 205
203 IF IN<>72 THEN IF IN<>75 THEN IF IN<>77 THEN IF IN<>80 THEN IN=0:IN$="":RETURN ELSE IN=30 ELSE IN=29 ELSE IN=28 ELSE IN=31
204 RETURN ' Merk op dat afdrukken van codes 28-31 WEL werkt op de IBM
205 IF IN=13 OR (IN>=32 AND IN<96) THEN RETURN
206 IF IN>96 THEN IN=IN-32
207 IF IN=8 THEN IN=127
208 RETURN
210 IN$="":WHILE IN$="":GOSUB 200:WEND:RETURN
220 IN=0:IF HO>23 OR HO<0 OR VE>OWD-1 OR VE<0 THEN RETURN
221 OIN$=IN$:IN$=CHR$(SCREEN(VE+1,HO+1)):GOSUB 201:IF IN<32 OR IN>96 THEN IN=32
222 IN$=OIN$:RETURN
250 BEEP:RETURN
260 RV=RND:RETURN
270 FR=FRE(""):RETURN
280 IF FR=1 THEN KEY(15) ON ELSE KEY(15) OFF
281 RETURN 'Ook gebruikt voor ON KEY(15) GOSUB
300 SR$=STR$(SR):WHILE LEFT$(SR$,1)=" ":SR$=MID$(SR$,2):WEND
301 RETURN
310 OCT%=INT(ABS(CT)):IF OCT%>255 THEN OCT%=255
311 OCN%=INT(CN)
312 OSR=INT(SR*10^OCN%+.5)/10^OCN%:SR$=STR$(OSR):OSG$="":IF LEFT$(SR$,1)="-" THEN OSG$="-"
313 SR$=MID$(SR$,2):OE%=INSTR(SR$,"E")+INSTR(SR$,"D")
314 IF OE%<>0 THEN OX%=VAL(MID$(SR$,OE%+1,3)):SR$=LEFT$(SR$,OE%-1) ELSE OX%=0
315 OPT%=INSTR(SR$,"."):IF OPT%=0 THEN OPT%=LEN(SR$)+1:SR$=SR$+"."
316 SR$=LEFT$(SR$,OPT%-1)+MID$(SR$,OPT%+1):OPT%=OPT%+OX%
317 IF OPT%<=0 THEN SR$=STRING$(1-OPT%,"0")+SR$:OPT%=2
318 IF OPT%>LEN(SR$)+1 THEN SR$=SR$+STRING$(OPT%-LEN(SR$)-1)
319 OV$=LEFT$(SR$,OPT%-1):OA$=MID$(SR$,OPT%):IF OV$="" THEN OV$="0"
320 OV$=OSG$+OV$:IF LEN(OV$)>OCT% THEN 329
321 OA$=LEFT$(OA$+STRING$(OCN%,"0"),OCN%):SR$=OV$:IF OA$<>"" THEN SR$=SR$+"."+OA$
322 IF LEN(SR$)<OCT% THEN SR$=SPACE$(OCT%-LEN(SR$))+SR$
323 IF LEN(SR$)=OCT% THEN RETURN
329 SR$=STRING$(OCT%,"*"):RETURN
330 FOR O=1 TO LEN(SR$):OO=ASC(MID$(SR$,O,1)):IF OO<96 THEN 332 ELSE OO=(OO AND &H5F)
331 MID$(SR$,O,1)=CHR$(OO)
332 NEXT O:RETURN
350 LPRINT SR$;:RETURN
360 LPRINT:RETURN
400 PLAY"MFML":IF SV<=0 THEN SOUND 32767,SD*1.82:RETURN 'Alleen volumes >0 spelen
401 OSD=SD:IF OSD<1 THEN OSD=1
402 ONM=1:WHILE OSD>64:OSD=OSD/2:ONM=ONM*2:WEND:PLAY"T38L"+STR$(INT(64/OSD+.5)) 'Door die 38 ipv 37.5 en die INT gaat de werkelijke tijd al snel afwijken.
403 ONO=SP-35:IF ONO<1 THEN ONO=1 ELSE IF ONO>84 THEN ONO=84
404 FOR O=1 TO ONM:PLAY"N"+STR$(ONO):NEXT:RETURN
450 OT=TIMER
452 IN$=INKEY$:IF IN$="" AND TIMER-OT<SD/10 THEN 452
454 SD=SD-(TIMER-OT)*10
455 GOTO 201
500 IF NF<=1 THEN OM$="BASICODE files nog niet geimplementeerd":GOSUB 940:RETURN
501 IF OFO(NF\2)<>0 THEN CLOSE(NF\2)
502 ON ERROR GOTO 539:IF NF MOD 2 THEN OPEN NF$ FOR OUTPUT AS NF\2 ELSE OPEN NF$ FOR INPUT AS NF\2
503 OFO(NF\2)=1+(NF MOD 2)
504 ON ERROR GOTO 850:RETURN
539 OM$="Fout no."+STR$(ERR)+"bij openen van file.":GOSUB 940:RESUME 504
540 IN$="":IN=0:IF OFO(NF\2)<>1 THEN IN=-1:RETURN
541 IF EOF(NF\2) THEN IN=1:RETURN
542 ON ERROR GOTO 559:INPUT#NF\2,IN$
543 ON ERROR GOTO 850:IF EOF(NF\2) AND IN=0 THEN IN=1
544 RETURN
559 IN=-1:RESUME NEXT
560 IN=0:IF OFO(NF\2)<>2 THEN IN=-1:RETURN
561 ON ERROR GOTO 559:WRITE#NF\2,SR$
562 ON ERROR GOTO 850:RETURN
580 IF OFO(NF\2)=0 THEN RETURN ELSE CLOSE(NF\2):OFO(NF\2)=0:RETURN
600 CLS:OGCH=1:OGCV=1:OUT &H3D9,0:ON OGS+1 GOTO 601,602,603,604
601 COLOR OGK,OBG,OBG:LOCATE ,,0:RETURN
602 SCREEN 1:COLOR OBG,OPL:OGF=1:RETURN
603 SCREEN 2:OUT &H3D9,OGK:OGF=1:RETURN
604 SCREEN 2:OGF=1:RETURN
620 OCN=1-ABS(SGN(CN)):OHO=ABS(HO-INT(HO))*HG:IF OHO>HG THEN OHO=HG ELSE IF OHO<0 THEN OHO=0
621 OVE=ABS(VE-INT(VE))*VG:IF OVE>VG THEN OVE=VG ELSE IF OVE<0 THEN OVE=0
622 OGCH=OHO+1:OGCV=OVE+1:ON OGS+1 GOTO 623,624,624,625
623 LOCATE OVE+1,OHO+1:PRINT CHR$(32+187*OCN);:RETURN
624 PSET(OHO+1,OVE+1),-(OGS=2)-(OGS=1)*OGK*OCN:RETURN
625 PSET(OHO,OVE),OCN:RETURN
630 IF OGS=0 THEN OM$="Monochroom lijnstukken kan nog niet":GOSUB 940:RETURN
631 OCN=1-ABS(SGN(CN)):OHO=ABS(HO-INT(HO))*HG:IF OHO>HG THEN OHO=HG ELSE IF OHO<0 THEN OHO=0
632 OVE=ABS(VE-INT(VE))*VG:IF OVE>VG THEN OVE=VG ELSE IF OVE<0 THEN OVE=0
633 ON GS GOTO 635,635,636
635 LINE(OGCH,OGCV)-(OHO+1,OVE+1),-(OGS=2)-(OGS=1)*OGK*OCN:GOTO 637
636 LINE(OGCH-1,OGCV-1)-(OHO,OVE),OCN
637 OGCH=OHO+1:OGCV=OVE+1:RETURN
650 IF OGS<>1 THEN OA=80 ELSE OA=40
651 OCN=1-ABS(SGN(CN)):OHO=ABS(HO-INT(HO))*(OA-1):IF OHO>=OA THEN OHO=OA-1 ELSE IF OHO<0 THEN OHO=0
652 OVE=ABS(VE-INT(VE))*24:IF OVE>23 THEN OVE=23 ELSE IF OVE<0 THEN OVE=0
653 LOCATE INT(OVE+1),(OHO+1):DEF SEG:POKE &HFE,OCN*(OGK-1)+1:PRINT SR$;:OGCH=OHO/(OWD-1)*HG:OGCV=OVE/24*VG:RETURN
850 O=2:GOSUB 941
852 ON ERR    GOSUB 902,901,903,904,905,905,904,912,905,912
854 IF ERR>10 THEN ON ERR-10 GOSUB 905,912,905,912,912,912,912,912,912,912
856 IF ERR>20 THEN ON ERR-20 GOSUB 912,912,912,906,906,902,906,912,912,912
858 IF ERR>49 THEN ON ERR-49 GOSUB 912,912,907,907,907,907,912,906,907,912,912
860 IF ERR>60 THEN ON ERR-60 GOSUB 907,907,907,911,912,912,907,906,912,908
862 IF ERR>70 THEN ON ERR-70 GOSUB 909,910,912,912,907,911
900 GOSUB 942:ON O+1 GOTO 936,937,938,939
901 PRINT"Syntaxfout in"ERL;:RETURN
902 PRINT"FOR/NEXT lus fout no"ERR"in"ERL;:RETURN
903 PRINT"GOSUB/RETURN fout no"ERR"in"ERL;:RETURN
904 PRINT"Data/geheugen op ("ERR") in"ERL;:RETURN
905 PRINT"Foute waarde (fout no"ERR") in"ERL;:RETURN
906 PRINT"Device I/O fout no"ERR"in"ERL;:O=1:RETURN
907 PRINT"File I/O fout no"ERR"in"ERL;:O=1:RETURN
908 PRINT"Disk beschermd.";:O=0:RETURN
909 PRINT"Steek diskette in.";:O=0:RETURN
910 PRINT"Foute diskette.";:O=0:RETURN
911 PRINT"Filenaam fout ("ERR").";:O=1:RETURN
912 PRINT"Fout nr";ERR;"in regel";ERL;"Zie Quick Ref.";:O=2:RETURN
913 O$=INPUT$(1):LOCATE 25,1:PRINT SPC(39);
936 RESUME 'Retry
937 RESUME NEXT 'Ignore error
938 ON ERROR GOTO 0:RESUME 'Retry error - geeft BASIC melding
939 RESUME 950 'Abort - zonder boodschap
940 GOSUB 941:PRINT OM$;:GOTO 942
941 OH1=HO:OV1=VE:GOSUB 120:LOCATE 25,1:RETURN
942 O$=INPUT$(1):LOCATE ,1:PRINT SPACE$(OWD-1);:GOSUB 110:HO=OH1:VE=OV1:RETURN
950 SCREEN 0,0,0:WIDTH 80:CLOSE:COLOR 7,0,0:CLS:KEY(15) OFF:ON ERROR GOTO 0:END