Skip to content

Instantly share code, notes, and snippets.

@binzume binzume/BMPLOAD.BAS
Created Feb 23, 2014

Embed
What would you like to do?
プログラミング始めたころに書いたコードが出てきたので晒す
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

This comment has been minimized.

Copy link
Owner Author

commented Feb 23, 2014

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.