Skip to content

Instantly share code, notes, and snippets.

@binzume
Created February 23, 2014 18:16
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save binzume/9175060 to your computer and use it in GitHub Desktop.
Save binzume/9175060 to your computer and use it in GitHub Desktop.
プログラミング始めたころに書いたコードが出てきたので晒す
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
@binzume
Copy link
Author

binzume commented Feb 23, 2014

RDSの計算式はベーマガに乗っていたコードのコピーの可能性が高いです

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment