Created
February 23, 2014 18:16
-
-
Save binzume/9175060 to your computer and use it in GitHub Desktop.
プログラミング始めたころに書いたコードが出てきたので晒す
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
10 WIDTH 80,25:CONSOLE 0,25,0,1:COLOR 7,0,,,2:SCREEN 3,0,0,1:CLS 3 | |
20 DIM R(15),G(15),B(15),C(255):ON HELP GOSUB *HLP.:HELP ON | |
30 RESTORE *CDATA.:FOR I=0 TO 15:READ R(I),G(I),B(I):NEXT:GOSUB *COL. | |
40 *MAIN'------------------------- MAIN ----------------------------- | |
50 MS$(0)="PROGRAMED K.KAWAHIRA" | |
60 MS$(1)="画像データをロード" | |
70 MS$(2)="画像データをセーブ" | |
80 MS$(3)="画面のクリア" | |
90 MS$(4)="RDS" | |
100 MS$(5)="終了" | |
110 MS=5:GOSUB *MENU:IF M=5 THEN PRINT"終了しました。":SCREEN ,0:END | |
120 ON M GOSUB *LO.,*SA.,*CLS.,*RDS:GOTO *MAIN | |
130 *LO.'------------------------- LOAD ----------------------------- | |
140 MS$(0)="入力 ファイル":GOSUB *TYP. | |
150 GOSUB *FINP.:PRINT FI$;"の画像データをロードします。" | |
160 ON M GOSUB *BMLO.,*BELO.,*STLO.,*PCLO.,*COLO.:GOSUB *COL. | |
170 CLS:IF INP(225)<>127 THEN 170 ELSE RETURN | |
180 *SA.'------------------------- SAVE ----------------------------- | |
190 CLS:MS$(0)="出力 ファイル":GOSUB *TYP. | |
200 GOSUB *FINP.:PRINT FI$;"に画像データをセーブします。" | |
210 ON M GOSUB *BMSA.,*BESA.,*STSA.,*PCSA.,*COSA.:RETURN | |
220 *CLS.'------------------------- RDS ----------------------------- | |
230 SCREEN 3,0,0,1:CLS 3:RETURN | |
240 *RDS'------------------------- RDS ----------------------------- | |
250 RDS=3:RANDOMIZE VAL(MID$(TIME$,1,2)+MID$(TIME$,7,2)) | |
260 SCREEN ,,1,33:I=1:CLS 3 | |
270 I=I+1:Y=INT(RND*400):EX=INT(RND*640):X=EX:C=INT(RND(1)*16) | |
280 SCREEN ,,1:PSET(X,Y),C | |
290 SCREEN ,,0:H=POINT(X+50,Y)-7:X=X+100-H*RDS | |
300 IF INP(225)=127 THEN 360 | |
310 IF X<640 THEN 280 ELSE X=EX:GOTO 330 | |
320 SCREEN ,,1:PSET(X,Y),C | |
330 SCREEN ,,0:H=POINT(X-50,Y)-7:X=X-100+H*RDS | |
340 IF INP(225)=127 THEN 360 | |
350 IF X>0 THEN 320 ELSE IF I<50000! THEN 270 | |
360 SCREEN ,,1,33:RETURN | |
370 *CDATA.'----------------------------------- | |
380 DATA 0,0,0, 0,0,15, 15,0,0, 15,0,15 | |
390 DATA 0,15,0, 0,15,15, 15,15,0, 15,15,15 | |
400 DATA 4,4,4, 0,0,8, 8,0,0, 8,0,8 | |
410 DATA 0,8,0, 0,8,8, 8,8,0, 8,8,8 | |
420 *TYP.'--------------------------------------------- | |
430 K$(1)=".BMP":K$(2)=".B1 ":K$(3)=".ST4":K$(4)=".PCK":K$(5)=".COL" | |
440 MS$(1)=" ビットマップ(.BMP)":MS$(2)=" ベタ (.B1 )" | |
450 MS$(3)=" ST4 (.ST4)":MS$(4)=" PCK (.PCK)" | |
460 MS$(5)=" カラー (.COL)":MS=5:GOSUB *MENU | |
470 K$=K$(M):RETURN | |
480 *MENU'--------------------------------------------------- | |
490 M=1:CLS:COLOR 7:LOCATE 8,0:PRINT MS$(0) | |
500 IF INKEY$<>"" THEN 500 | |
510 FOR I=1 TO MS:LOCATE 10,I+1:IF I=M THEN COLOR 4 ELSE COLOR 7 | |
520 PRINT MS$(I):NEXT | |
530 IK$=INKEY$:IF IK$="" THEN 530 | |
540 IF IK$=CHR$(13) THEN 580 | |
550 IF IK$=CHR$(30) AND M>1 THEN M=M-1:GOTO 510 | |
560 IF IK$=CHR$(31) AND M<MS THEN M=M+1:GOTO 510 | |
570 GOTO 530 | |
580 COLOR 7:IF INP(225)=127 THEN 580 ELSE CLS:RETURN | |
590 *HANI.'------------------------------------------------------------ | |
600 X1=0:Y1=0:X2=639:Y2=399:MS=2:MS$(0)="保存の方法" | |
610 MS$(1)="全体":MS$(2)="部分":GOSUB *MENU | |
620 IF M=1 THEN 795 ELSE CLS:PRINT"(X1,Y1)-(X2,Y2)":XX=0:YY=0:SCREEN ,0 | |
630 GOSUB *INK.:IF RR THEN 680 | |
640 PSET(XX,YY),15-POINT(XX,YY) | |
650 FOR W=1 TO 5000:NEXT:J=0:GOSUB *INK. | |
660 PSET(XX,YY),15-POINT(XX,YY) | |
670 XX=XX+X:YY=YY+Y:IF RR THEN 680 ELSE 640 | |
680 X1=XX:Y1=YY:FOR W=1 TO 3000:NEXT:IF INKEY$<>"" THEN 680 | |
690 FOR I=0 TO 1 | |
700 FOR X=X1 TO XX STEP 2 | |
710 PSET(X,Y1),15-POINT(X,Y1):PSET(X,YY),15-POINT(X,YY):NEXT | |
720 FOR Y=Y1 TO YY STEP 2 | |
730 PSET(X1,Y),15-POINT(X1,Y):PSET(XX,Y),15-POINT(XX,Y):NEXT | |
740 J=-I:GOSUB *INK.:NEXT | |
750 XX=XX+X:YY=YY+Y:IF RR THEN 790 | |
760 IF XX<X1 THEN XX=X1 | |
770 IF YY<Y1 THEN YY=Y1 | |
780 GOTO 690 | |
790 X2=XX:Y2=YY:GOSUB *HLP.:GOSUB *HLP. | |
795 RETURN | |
800 *INK.:X=0:Y=0:F=1:RR=0:FR=J | |
810 IF (INP(&HE9) OR &HBF)=&HBF THEN RR=-1:FR=-1 | |
820 IF (INP(&HE8) OR &HBF)=&HBF THEN F= 8 :FR=-1 | |
830 IF (INP(&HE8) OR &HFB)=&HFB AND XX+F<640 THEN X= F :FR=-1 | |
840 IF (INP(&HE8) OR &HFD)=&HFD AND YY-F>-1 THEN Y=-F :FR=-1 | |
850 IF (INP(&HEA) OR &HFB)=&HFB AND XX-F>-1 THEN X=-F :FR=-1 | |
860 IF (INP(&HEA) OR &HFD)=&HFD AND YY+F<400 THEN Y= F :FR=-1 | |
870 IF FR=0 THEN 800 ELSE RETURN | |
880 *FINP.'------------------------------------------------------------ | |
890 INPUT"ディレクトリ名を入力して下さい";DI$:IF DI$="" THEN 910 | |
900 IF RIGHT$(DI$,1)<>"\" THEN DI$=DI$+"\" | |
910 FILES DI$+"*"+K$ | |
920 INPUT"ファイル名を入力して下さい";FI$:IF FI$="" THEN 910 | |
930 P=INSTR(FI$,"."):IF P>0 THEN FI$=MID$(FI$,1,P-1) | |
940 FI$=DI$+MID$(FI$,1,8):RETURN | |
950 *COSA.'-------------------------------------------------------------- | |
960 OPEN FI$+".COL" FOR OUTPUT AS #1:PRINT#1,"R G B" | |
970 FOR I=0 TO 15:WRITE#1,R(I),G(I),B(I):NEXT:CLOSE:RETURN | |
980 *COLO.'-------------------------------------------------------------- | |
990 OPEN FI$+".COL" FOR INPUT AS #1:INPUT#1,I$ | |
1000 FOR I=0 TO 15:INPUT#1,R(I),G(I),B(I):NEXT:CLOSE:RETURN | |
1010 *COL.'-------------------------------------------------------------- | |
1020 FOR Q=0 TO 15:COLOR=(Q,G(Q)*256+R(Q)*16+B(Q)):NEXT:RETURN | |
1030 *NCOL.:STOP'--------------------------------------------------------- | |
1040 FOR Q=0 TO 15:COLOR=(Q,0):NEXT:RETURN | |
1050 *BELO.'------------------------------------------------------------ | |
1060 DEF SEG=&HA800:BLOAD FI$+".B1 ",0 | |
1070 DEF SEG=&HB000:BLOAD FI$+".R1 ",0 | |
1080 DEF SEG=&HB800:BLOAD FI$+".G1 ",0 | |
1090 DEF SEG=&HE000:BLOAD FI$+".E1 ",0 :RETURN | |
1100 *BESA.'------------------------------------------------------------ | |
1110 DEF SEG=&HA800:BSAVE FI$+".B1 ",0,&H8000 | |
1120 DEF SEG=&HB000:BSAVE FI$+".R1 ",0,&H8000 | |
1130 DEF SEG=&HB800:BSAVE FI$+".G1 ",0,&H8000 | |
1140 DEF SEG=&HE000:BSAVE FI$+".E1 ",0,&H8000 :RETURN | |
1150 *BMLO.'------------------------------------------------------------ | |
1160 OPEN FI$+".BMP" FOR INPUT AS #1:B$=INPUT$(54,#1) | |
1170 IF MID$(B$,1,2)<>"BM" THEN BEEP:GOTO 1290 | |
1180 X=ASC(MID$(B$,19,1))+ASC(MID$(B$,20,1))*256 | |
1190 Y=ASC(MID$(B$,23,1))+ASC(MID$(B$,24,1))*256 | |
1200 IF ASC(MID$(B$,11,1))=54 THEN PRINT"256 => 16":BEEP:GOTO 1350 | |
1210 IF ASC(MID$(B$,11,1))=62 THEN GOTO 1300 | |
1220 C=INT((X+7)/8)*4:F=INT(C/201):P=F*200+200-C | |
1230 C$=INPUT$(64,#1):FOR I=0 TO 15:B(I)=INT(ASC(MID$(C$,1+I*4,1))/16) | |
1240 G(I)=INT(ASC(MID$(C$,2+I*4,1))/16):R(I)=INT(ASC(MID$(C$,3+I*4,1))/16) | |
1250 NEXT:GOSUB *COL. | |
1260 FOR J=1 TO Y:FOR I=0 TO F:A$=INPUT$(200+(I=F)*P,#1) | |
1270 FOR G=0 TO LEN(A$)-1:H=ASC(MID$(A$,G+1,1)):K=INT(H/16):L=H-K*16 | |
1280 PSET((I*200+G)*2,Y-J),K:PSET((I*200+G)*2+1,Y-J),L:NEXT:NEXT:NEXT | |
1290 CLOSE:CLS:RETURN | |
1300 C$=INPUT$(8,#1):FOR I=0 TO 1:B(I)=INT(ASC(MID$(C$,1+I*4,1))/16) | |
1310 G(I)=INT(ASC(MID$(C$,2+I*4,1))/16):R(I)=INT(ASC(MID$(C$,3+I*4,1))/16) | |
1320 NEXT:GOSUB *COL.:DEF SEG=&HA800:D=INT((X+7)/8):C=INT((D+15)/16)*16 | |
1330 FOR J=1 TO Y:A$=INPUT$(C,#1):FOR G=0 TO D-1 | |
1340 POKE((Y-J)*80+G),ASC(MID$(A$,G+1,1)):NEXT:NEXT:CLOSE:GOTO 1290 | |
1350 FOR C1=0 TO 15:C$=INPUT$(64,#1):FOR C2=0 TO 15:LC=1025 | |
1360 B=INT(ASC(MID$(C$,1+C2*4,1))/16):G=INT(ASC(MID$(C$,2+C2*4,1))/16) | |
1370 R=INT(ASC(MID$(C$,3+C2*4,1))/16):COLOR=(0,G*255+R*15+B) | |
1375 OO=0:IF R>G AND R=>B THEN OO=1 ELSE IF G>B AND G=>B THEN OO=2 | |
1380 FOR C3=0 TO 15:S=ABS(B-B(C3))+ABS(G-G(C3))+ABS(R-R(C3)):O=0 | |
1384 IF (R=G AND G=B) OR (R(C3)=G(C3) AND G(C3)=B(C3)) THEN 1390 | |
1385 IF R(C3)>G(C3) AND R(C3)=>B(C3) THEN O=1 | |
1386 IF G(C3)>B(C3) AND G(C3)=>B(C3) THEN O=2 | |
1388 IF O=OO THEN S=S-10 | |
1390 IF S<LC THEN C(C1*15+C2)=C3:LC=S | |
1400 NEXT:NEXT:NEXT | |
1410 C=INT((X+3)/4)*4:F=INT(C/251):P=F*250+250-C | |
1420 FOR J=1 TO Y:FOR I=0 TO F:A$=INPUT$(250+(I=F)*P,#1) | |
1430 FOR G=0 TO LEN(A$)-1:PSET(I*250+G,Y-J),C(ASC(MID$(A$,G+1,1))) | |
1440 NEXT:NEXT:NEXT | |
1450 CLOSE:CLS:RETURN | |
1460 *BMSA.'------------------------------------------------------------ | |
1470 GOSUB *HANI. | |
1480 OPEN FI$+".BMP" FOR OUTPUT AS #1:XX=X2-X1:YY=Y2-Y1:B$="424D" | |
1490 O=INT((XX*YY/2+118)/256) | |
1500 O$=RIGHT$("000000"+HEX$(O)+HEX$((XX*YY/2+118)-O*256),6) | |
1510 B$=B$+MID$(O$,5,2)+MID$(O$,3,2)+MID$(O$,1,2) | |
1520 B$=B$+"00000000007600000028000000" | |
1530 N$=RIGHT$("0000"+HEX$(XX+1),4) | |
1540 B$=B$+MID$(N$,3,2)+MID$(N$,1,2)+"0000" | |
1550 N$=RIGHT$("0000"+HEX$(YY+1),4) | |
1560 B$=B$+MID$(N$,3,2)+MID$(N$,1,2)+"00000100040000000000" | |
1570 O=INT((XX*YY/2)/256) | |
1580 O$=RIGHT$("000000"+HEX$(O)+HEX$((XX*YY/2)-O*256),6) | |
1590 B$=B$+MID$(O$,5,2)+MID$(O$,3,2)+MID$(O$,1,2)+"00" | |
1600 K$="":FOR I=1 TO 54:K$=K$+CHR$(VAL("&H"+MID$(B$,I*2-1,2))):NEXT | |
1610 PRINT#1,K$;:K$="":FOR I=0 TO 15 | |
1620 K$=K$+CHR$(B(I)*17)+CHR$(G(I)*17)+CHR$(R(I)*17)+CHR$(0):NEXT | |
1630 PRINT#1,K$;:K$="" | |
1640 D=4-(XX/2-INT(XX/8)*4):C=XX/2-D*(D<>4):F=INT(C/200):P=F*200+200-C | |
1650 FOR J=0 TO YY:FOR I=0 TO F:FOR G=1 TO 200+(I=F)*P | |
1660 K=POINT(X1+(I*200+G-1)*2,Y2-J)*16+POINT(X1+(I*200+G-1)*2+1,Y2-J) | |
1670 K$=K$+CHR$(K):NEXT:PRINT#1,K$;:K$="":NEXT:PSET(2,Y2-J),15-POINT(2,Y2-J) | |
1680 NEXT:FOR I=Y1 TO Y2:PSET(2,I),15-POINT(2,I):NEXT:CLOSE:RETURN | |
1690 *STLO.'------------------------------------------------------------ | |
1700 OPEN FI$+".ST4" FOR INPUT AS #1 | |
1710 FOR L=0 TO 3:FOR K=0 TO 2:DEF SEG=&HA800+&H1F4*L+&H800*K | |
1720 FOR J=0 TO 99:I$=INPUT$(80,#1):FOR I=0 TO 79 | |
1730 POKE J*80+I,ASC(MID$(I$,I+1,1)):NEXT:NEXT:NEXT:NEXT | |
1740 CLOSE:RETURN | |
1750 *STSA.'------------------------------------------------------------ | |
1760 OPEN FI$+".ST4" FOR OUTPUT AS #1 | |
1770 FOR L=0 TO 3:FOR K=0 TO 2:DEF SEG=&HA800+&H1F4*L+&H800*K | |
1780 FOR J=0 TO 99:I$="":FOR I=0 TO 79:I$=I$+CHR$(PEEK(J*80+I)) | |
1790 NEXT:PRINT#1,I$;:NEXT:NEXT:NEXT | |
1800 CLOSE:RETURN | |
1810 *PCLO.'------------------------------------------------------------ | |
1820 OPEN FI$+".PCK" FOR INPUT AS #1:B$=INPUT$(4,#1) | |
1830 X=ASC(MID$(B$,2,1))*255+ASC(MID$(B$,1,1)):C=INT(X/8)-(INT(X/8)<>X/8) | |
1840 Y=ASC(MID$(B$,4,1))*255+ASC(MID$(B$,3,1)) | |
1850 FOR J=0 TO Y-1:FOR K=0 TO 2:DEF SEG=&HA800+&H800*K | |
1860 I$=INPUT$(C,#1):FOR I=0 TO C-1 | |
1870 POKE J*80+I,ASC(MID$(I$,I+1,1)):NEXT:NEXT:NEXT | |
1880 CLOSE:RETURN | |
1890 *PCSA.'------------------------------------------------------------ | |
1900 GOSUB *HANI.:X1=INT((X1+1)/8)*8:X2=INT((X2+1)/8)*8:X=X2-X1:Y=Y2-Y1 | |
1910 OPEN FI$+".PCK" FOR OUTPUT AS #1 | |
1920 X$=RIGHT$("0000"+HEX$(X),4):Y$=RIGHT$("0000"+HEX$(Y),4) | |
1930 B$=CHR$(VAL("&H"+MID$(X$,3,2)))+CHR$(VAL("&H"+MID$(X$,1,2))) | |
1940 B$=B$+CHR$(VAL("&H"+MID$(Y$,3,2)))+CHR$(VAL("&H"+MID$(Y$,1,2))) | |
1950 C=INT(X/8)-(INT(X/8)<>X/8):PRINT#1,B$; | |
1960 FOR J=0 TO Y-1:FOR K=0 TO 2:DEF SEG=&HA800+&H800*K | |
1970 I$="":FOR I=0 TO C-1:I$=I$+CHR$(PEEK((Y1+J)*80+I+X1/8)) | |
1980 NEXT:PRINT#1,I$;:NEXT:NEXT | |
1990 CLOSE:RETURN | |
2000 *HLP.'------------------------------------------------------------ | |
2010 BEEP 1:IF QQ THEN SCREEN ,0:QQ=0 ELSE SCREEN ,2:QQ=-1 | |
2020 BEEP 1:BEEP 0:RETURN |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
RDSの計算式はベーマガに乗っていたコードのコピーの可能性が高いです