| 10 '***********************************
20 ' ELEKTRONIKERS F R E U N D 30 ' 40 ' (c)1991 Christian Leubner 45 ' & CPC International 50 '*********************************** 60 DIM zahl(20),s$(20) 70 DIM r(100),anz(100) 80 MODE 2 90 CALL &BC02:PEN 1:PAPER 0 100 INK 1,26:BORDER 0:INK 0,0 110 WINDOW 2,79,6,24 120 x1=1:y1=5:x2=80:y2=25 130 GOSUB 3910 140 WINDOW #2,2,79,2,3 150 x1=1:y1=1:x2=80:y2=4 160 GOSUB 3910 170 CLS 180 CLS#2 190 PRINT#2,SPC(28)"- Elektronikers Freund -" 200 PRINT#2,SPC(22)"written by Christian Leubner in 1991" 210 i$=CHR$(24) 220 LOCATE 34,2:PRINT i$" Hauptmenue "i$ 230 LOCATE 24,5:PRINT i$"[1]"i$" Farbringe in Zahl umrechnen" 240 LOCATE 24,7:PRINT i$"[2]"i$" Zahl in Farbringe umrechnen" 250 LOCATE 24,9:PRINT i$"[3]"i$" Ersatzwiderstand heraussuchen" 260 LOCATE 30,12:PRINT i$" Bitte waehlen : "i$; 270 a$=INKEY$:IF a$="" THEN 270 280 a=VAL(a$) 290 IF a<1 OR a>3 THEN 270 300 PRINT a 310 ON a GOSUB 360,930,1450 320 GOTO 170 330 '***** 340 'Umrechnung: Farbringe in Zahlen 350 '***** 360 CLS 370 WINDOW #3,67,77,8,21 380 x1=66:y1=7:x2=78:y2=22 390 GOSUB 3910 400 LOCATE 1,1:PRINT"Bitte geben Sie die Farbringe von links nach rechts ein:" 410 FOR z=1 TO 4 420 IF z=4 AND eing=1 THEN 490 430 GOSUB 620 440 IF zahl=-1 THEN r=-1:RETURN 450 farbe(z)=zahl 460 LOCATE 1,3+z 470 IF z=4 THEN PRINT 480 PRINT " "i$"Farbring";z;":"i$" ";s$ 490 NEXT z 500 r=10*farbe(1) 510 r=r+farbe(2) 520 IF farbe(3)<1 AND farbe(3)>0 THEN 550 530 r=r*(10^farbe(3)) 540 GOTO 560 550 r=r*farbe(3) 560 IF eing=1 THEN RETURN 570 LOCATE 1,12 580 PRINT"Der Widerstand betraegt"r;CHR$(191) 590 PRINT" mit einer Toleranz von"farbe(4)"%" 600 PRINT:PRINT"-Taste-":CALL &BB06 610 RETURN 620 RESTORE 870 630 IF z=3 THEN high=12 ELSE high=10 640 IF z=4 THEN RESTORE 890:high=4 650 GOSUB 680 660 RETURN 670 '**** 680 'Auswahlfenster: Farben 690 '**** 700 CLS#3 710 FOR i=1 TO high 720 READ s$(i),zahl(i) 730 PRINT#3,s$(i):NEXT 740 high=high+1 750 s$(high)="ABBRUCH":zahl(high)=-1 760 PRINT#3,s$(high) 770 wahly=1:wahlyy=wahly 780 LOCATE#3,11,wahlyy:PRINT#3," ":LOCATE#3,11,wahly:PRINT#3,"<" 790 wahlyy=wahly 800 a$=INKEY$:IF a$="" THEN 800 810 IF a$=CHR$(240) THEN wahly=wahly-1 820 IF a$=CHR$(241) THEN wahly=wahly+1 830 IF a$=CHR$(13) THEN s$=s$(wahly):zahl=zahl(wahly):RETURN 840 IF wahly<1 THEN wahly=1 850 IF wahly>high THEN wahly=high 860 GOTO 780 870 DATA schwarz,0,braun,1,rot,2,orange,3,gelb,4,gruen,5,blau,6 880 DATA violett,7,grau,8,weiss,9,gold,0.1,silber,0.01 890 DATA braun,1,rot,2,gold,5,silber,10 900 '***** 910 'Umrechnung: Zahl in Farbringe 920 '***** 930 CLS 940 INPUT"Gesuchter Widerstand: ",a$ 950 IF a$="" THEN RETURN 960 farbe(3)=LEN(a$)-2 970 IF INSTR(1,a$,".")>0 THEN 1100 980 farbe(1)=VAL(LEFT$(a$,1)) 990 farbe(2)=VAL(MID$(a$,2,1)) 1000 RESTORE 870 1010 FOR i=0 TO 11 1020 READ s$(i),zahl(i) 1030 NEXT 1040 FOR i=1 TO 3 1050 LOCATE 1,4+i:PRINT"Farbring"i": "s$(farbe(i)) 1060 NEXT i 1070 PRINT:PRINT"Moechten Sie eine Farbdarstellung ? [ /n]" 1080 a$=UPPER$(INKEY$):IF a$="" THEN 1080 ELSE IF a$="N" THEN RETURN ELSE 1180 1090 GOTO 1180 1100 zahl=VAL(a$) 1110 IF LEN(a$)=3 THEN farbe(3)=10:zahl=zahl*10 1120 IF LEN(a$)=4 THEN farbe(3)=11:zahl=zahl*100 1130 a$=RIGHT$(STR$(zahl),LEN(STR$(zahl))-1) 1140 GOTO 980 1150 '**** 1160 'Farbdarstellung des Widerstandes 1170 '**** 1180 MODE 1 1190 INK 0,10:BORDER 10 1200 a$=CHR$(206) 1210 PRINT TAB(5);STRING$(31,a$) 1220 PRINT TAB(4);STRING$(33,a$) 1230 PRINT TAB(4);STRING$(33,a$) 1240 PRINT TAB(3);STRING$(35,a$) 1250 PRINT STRING$(39,a$) 1260 PRINT TAB(3);STRING$(35,a$) 1270 PRINT TAB(4);STRING$(33,a$) 1280 PRINT TAB(4);STRING$(33,a$) 1290 PRINT TAB(5);STRING$(31,a$) 1300 RESTORE 1410 1310 FOR i=0 TO 11:READ zahl(i):NEXT 1320 FOR i=1 TO 3 1330 FOR j=1 TO 9 1340 IF farbe(i)>9 THEN a$=CHR$(207) ELSE a$=CHR$(143) 1350 LOCATE i*10,j:INK i,zahl(farbe(i)):PEN i:PRINT STRING$(3,a$) 1360 NEXT j 1370 LOCATE i*10,j+2:PRINT s$(farbe(i)) 1380 NEXT i 1390 CALL &BB06 1400 RUN 1410 DATA 0,3,6,15,24,9,1,5,13,26,24,26 1420 '***** 1430 'Untermenue: Ersatzwiderstand heraussuchen 1440 '***** 1450 anzahl=1 1460 CLS 1470 LOCATE 34,2:PRINT i$" Untermenue "i$ 1480 LOCATE 24,5:PRINT i$"[1]"i$" Ersatzwiderstand suchen" 1490 LOCATE 24,7:PRINT i$"[2]"i$" Widerstaende eingeben" 1500 LOCATE 24,9:PRINT i$"[3]"i$" Widerstaende abspeichern" 1510 LOCATE 24,11:PRINT i$"[4]"i$" Widerstaende einladen" 1520 LOCATE 24,13:PRINT i$"[5]"i$" Bestand listen/korrigieren" 1530 LOCATE 24,15:PRINT i$"[6]"i$" zurueck zum Hauptmenue" 1540 LOCATE 30,18:PRINT i$" Bitte waehlen : "i$; 1550 a$=INKEY$:IF a$="" THEN 1550 1560 a=VAL(a$):IF a<1 OR a>6 THEN 1550 1570 PRINT a 1580 IF a=6 THEN RETURN 1590 ON a GOTO 1630,2100,2740,2930,3090 1600 '**** 1610 'Untermenue: Ersatzwiderstand suchen 1620 '**** 1630 FOR i=1 TO 6:dif(i)=999999:NEXT 1640 CLS 1650 PRINT i$" Bestmoeglichen Ersatzwiderstand suchen "i$ 1660 PRINT:INPUT"Welchen Widerstand moechten Sie erreichen: ",rs 1670 IF rs=0 THEN 1460 1680 FOR i=1 TO anzahl-1 1690 IF anz(i)<2 THEN x=i+1 ELSE x=i 1700 FOR j=x TO anzahl-1 1710 ra=r(i)+r(j):a$="seriell" 1720 GOSUB 1830 1730 ra=(1/r(i))+(1/r(j)):ra=ROUND(1/ra):a$="parallel" 1740 GOSUB 1830 1750 NEXT j 1760 NEXT i 1770 LOCATE 1,12 1780 PRINT" Die beste Kombination, die ich anbieten kann, ist:" 1790 PRINT r(r1(1))CHR$(191)" und"r(r2(1))CHR$(191)" "s$(1)" zu schalten." 1800 proz=ROUND((dif(1)*100)/rs) 1810 PRINT" Die Abweichung vom gewuenschten Widerstand betraegt"proz"%" 1820 PRINT:PRINT"-Taste-":CALL &BB06:GOTO 1460 1830 '*** 1840 'Top Five ausgeben 1850 '*** 1860 top(6)=ra:s$(6)=a$:r1(6)=i:r2(6)=j:dif(6)=ABS(ra-rs) 1870 first=0 1880 flag=0 1890 FOR k=1 TO 5 1900 IF dif(k)>dif(k+1) THEN GOSUB 2000 1910 NEXT k 1920 IF flag=1 THEN first=1:GOTO 1880 1930 IF first=0 THEN RETURN 1940 FOR k=1 TO 5 1950 proz=ROUND((dif(k)*100)/rs) 1960 LOCATE 1,k+4 1970 PRINT"-"k"- R"top(k)CHR$(191)" (Abw.:"dif(k)" --"proz"%) / aus"r(r1(k))CHR$(191)" &"r(r2(k))CHR$(191)" "s$(k);STRING$(15,32) 1980 NEXT 1990 RETURN 2000 help=top(k):top(k)=top(k+1):top(k+1)=help 2010 help$=s$(k):s$(k)=s$(k+1):s$(k+1)=help$ 2020 help=r1(k):r1(k)=r1(k+1):r1(k+1)=help 2030 help=r2(k):r2(k)=r2(k+1):r2(k+1)=help 2040 help=dif(k):dif(k)=dif(k+1):dif(k+1)=help 2050 flag=1 2060 RETURN 2070 '**** 2080 'Untermenue: Widerstaende eingeben 2090 '**** 2100 CLS 2110 WINDOW #5,4,32,12,12 2120 x1=3:y1=11:x2=33:y2=13 2130 GOSUB 3880 2140 LOCATE 2,3:PRINT"Wie moechten Sie Ihre Widerstaende eingeben ?" 2150 '*** 2160 'Auswahlfenster: Art der Eingabe waehlen 2170 '*** 2180 x=1 2190 CLS#5:IF x=1 THEN 2200 ELSE IF x=2 THEN 2220 2200 PRINT#5," "I$" als Zahl "i$" als Farbringe" 2210 GOTO 2230 2220 PRINT#5," als Zahl "i$" als Farbringe "i$ 2230 a$=INKEY$:IF a$="" THEN 2230 2240 IF a$=CHR$(243) OR a$=CHR$(242) THEN 2270 2250 IF a$=CHR$(13) THEN GOTO 2280 2260 GOTO 2230 2270 x=(x XOR 3):GOTO 2190 2280 IF x=1 THEN 2320 ELSE 2430 2290 '*** 2300 'Eingabeart 1: als Zahlen 2310 '*** 2320 CLS 2330 PRINT i$" Eingabe der Widerstaende als Zahlen "i$ 2340 PRINT 2350 INPUT"Widerstand: ",r(anzahl) 2360 IF r(anzahl)=0 THEN 2520 2370 GOSUB 2540 2380 anzahl=anzahl+1 2390 GOTO 2320 2400 '*** 2410 'Eingabeart 2: als Farbringe 2420 '*** 2430 CLS:eing=1:GOSUB 360:eing=0 2440 IF r=-1 THEN 2520 2450 r(anzahl)=r 2460 CLS 2470 PRINT i$"Eingabe der Widerstaende mit Hilfe der Farbringe"i$ 2480 PRINT:PRINT"Der eingegebene Widerstand betraegt"r;CHR$(191) 2490 GOSUB 2540 2500 anzahl=anzahl+1 2510 GOTO 2430 2520 PRINT:PRINT"Moechten Sie die eingegebenen Widerstaende abspeichern ? [j/n]" 2530 a$=UPPER$(INKEY$):IF a$="J" THEN 2740 ELSE IF a$="N" THEN 1460 ELSE 2530 2540 WINDOW #4,4,27,12,13 2550 x1=3:y1=11:x2=28:y2=14 2560 GOSUB 3880 2570 CLS#4 2580 PRINT#4,"Wieviele Widerstaende ?" 2590 x=1 2600 IF x=1 THEN 2610 ELSE 2630 2610 LOCATE#4,1,2:PRINT#4," "i$" einen "i$" mehrere " 2620 GOTO 2640 2630 LOCATE#4,1,2:PRINT#4," einen "I$" mehrere "i$" " 2640 a$=INKEY$ 2650 IF a$=CHR$(242) OR a$=CHR$(243) THEN 2680 2660 IF a$=CHR$(13) THEN 2690 2670 GOTO 2640 2680 x=(x XOR 3):GOTO 2600 2690 IF x=1 THEN anz(anzahl)=1 ELSE anz(anzahl)=2 2700 RETURN 2710 '**** 2720 'Untermenue: Widerstaende abspeichern 2730 '**** 2740 CLS 2750 IF anzahl=0 THEN PRINT i$" Keine Widerstaende eingegeben "i$:CALL &BB06:GOTO 1460 2760 PRINT i$"Eingegebene Widerstaende abspeichern"i$ 2770 PRINT:PRINT"Mit [Return] wird der Name >R-DATA.DAT< gewaehlt." 2780 PRINT"Mit [.] und [Return] koennen Sie abbrechen." 2790 PRINT:INPUT"Dateiname: ",a$ 2800 IF a$="." THEN 1460 2810 IF a$="" THEN a$="r-data.dat" 2820 OPENOUT a$ 2830 WRITE#9,anzahl 2840 FOR i=1 TO anzahl 2850 WRITE#9,r(i),anz(i) 2860 NEXT:CLOSEOUT 2870 PRINT:PRINT i$" Widerstaende abgespeichert ! "i$ 2880 CALL &BB06 2890 GOTO 1460 2900 '*** 2910 'Untermenue: Widerstaende einladen 2920 '*** 2930 CLS 2940 PRINT i$" Widerstaende einladen "i$ 2950 PRINT:PRINT"Mit [Return] wird der Name >R-DATA.DAT< gewaehlt." 2960 PRINT"Mit [.] und [Return] koennen Sie abbrechen." 2970 PRINT:INPUT"Dateiname: ",a$ 2980 IF a$="." THEN 1460 2990 IF a$="" THEN a$="r-data.dat" 3000 OPENIN a$ 3010 INPUT#9,anzahl 3020 FOR i=1 TO anzahl 3030 INPUT#9,r(i),anz(i) 3040 NEXT:CLOSEIN 3050 GOTO 1460 3060 '**** 3070 'Untermenue: Widerstaende auflisten/korrigieren 3080 '**** 3090 CLS 3100 PRINT i$" Widerstaende auflisten/korrigieren "i$ 3110 PRINT:PRINT i$" [Return] "i$" zum Bestand korrigieren." 3120 PRINT i$" [Space] "i$" um weiterzulisten" 3130 PRINT i$" [S] "i$" um die Widerstaende nach ihrem Wert zu sortieren" 3140 PRINT i$" [.] "i$" um abzubrechen" 3150 WINDOW #3,4,44,23,13 3160 x1=3:y1=12:x2=45:y2=24 3170 GOSUB 3880 3180 akty=1 3190 CLS#3 3200 aktend=akty+9 3210 IF aktend>=anzahl THEN aktend=anzahl-1 3220 IF anzahl=1 THEN CLS:PRINT i$" Keine Widerstaende (mehr) vorhanden ! "i$:CALL &BB06:GOTO 1460 3230 FOR i=akty TO aktend 3240 IF anz(i)=1 THEN a$="einer" ELSE a$="mehrere" 3250 PRINT#3,"R"r(i);CHR$(191)," - Bestand: "a$ 3260 NEXT i 3270 '*** 3280 'Auswahlfenster: Liste der Widerstaende 3290 '*** 3300 y=1:oldy=y 3310 LOCATE#3,39,oldy:PRINT#3," ":LOCATE#3,39,y:PRINT#3,"<" 3320 oldy=y 3330 a$=INKEY$:IF a$="" THEN 3330 3340 IF a$=CHR$(240) THEN y=y-1:GOTO 3410 3350 IF a$=CHR$(241) THEN y=y+1:GOTO 3410 3360 IF a$=" " THEN 3450 3370 IF a$=CHR$(13) THEN 3510 3380 IF a$="." THEN 1460 3390 IF a$="s" OR a$="S" THEN GOTO 3790 3400 GOTO 3330 3410 IF y<1 THEN y=1 3420 IF y>10 THEN y=10 3430 IF y+akty>anzahl THEN y=anzahl-akty 3440 GOTO 3310 3450 IF akty+10>anzahl THEN akty=1:GOTO 3190 3460 akty=akty+10 3470 GOTO 3190 3480 '*** 3490 'Auswahlfenster: Bestimmung der vorhandenen Stueckzahl 3500 '*** 3510 WINDOW #4,47,77,15,15 3520 x1=46:y1=14:x2=78:y2=16 3530 GOSUB 3880 3540 PRINT#4,"Anzahl :" 3550 ON x GOTO 3560,3570,3580 3560 LOCATE#4,1,2:PRINT#4," "i$" einer "i$" mehrere keiner ":GOTO 3590 3570 LOCATE#4,1,2:PRINT#4," einer "i$" mehrere "i$" keiner ":GOTO 3590 3580 LOCATE#4,1,2:PRINT#4," einer mehrere "i$" keiner "i$" " 3590 a$=INKEY$:IF a$="" THEN 3590 3600 IF a$=CHR$(242) THEN x=x-1:GOTO 3640 3610 IF a$=CHR$(243) THEN x=x+1:GOTO 3640 3620 IF a$=CHR$(13) THEN 3670 3630 GOTO 3590 3640 IF x<1 THEN x=1 3650 IF x>3 THEN x=3 3660 GOTO 3550 3670 IF x=1 THEN anz(akty+y-1)=1 3680 IF x=2 THEN anz(akty+y-1)=2 3690 IF x=3 THEN 3700 ELSE 3190 3700 beg=akty+y-1:ende=anzahl-1 3710 FOR i=beg TO ende 3720 r(i)=r(i+1):anz(i)=anz(i+1) 3730 NEXT:r(anzahl-1)=0:anz(anzahl-1)=0 3740 anzahl=anzahl-1 3750 GOTO 3190 3760 '*** 3770 'Untermenue Listen/Korrigieren: Widerstaende nach Wert sortieren 3780 '*** 3790 flag=0 3800 FOR i=1 TO anzahl-2 3810 IF r(i)>r(i+1) THEN GOSUB 3840 3820 NEXT 3830 IF flag=1 THEN 3790 ELSE 3180 3840 help=r(i):r(i)=r(i+1):r(i+1)=help 3850 help=anz(i):anz(i)=anz(i+1):anz(i+1)=help 3860 flag=1 3870 RETURN 3880 '**** 3890 'Windowumrahmung zeichnen 3900 '**** 3910 a1=8*x1-2:b1=400-(16*y1-10) 3920 a2=8*x2-6:b2=400-(16*y2-4) 3930 MOVE a1,b1:DRAW a2,b1:DRAW a2,b2:DRAW a1,b2:DRAW a1,b1 3940 a1=a1-4:a2=a2+4 3950 b1=b1-8:b2=b2+8 3960 MOVE a1,b1:DRAW a2,b1:DRAW a2,b2:DRAW a1,b2:DRAW a1,b1 3970 RETURN |