FM Towns: Free Software Collection 3/FREEWARE.BIN/towns_os/pmgf/src/pmgfsave.bas

BASIC Source File | 1980-01-02 | 23KB | 325 lines

10 '*****************************************************************           *                                                               *
20 '*              PMGf File Saver BASIC Version 1.25               *          '* Copyright (C)1990- By Studio Pineapple Marmalade & MiwaSuguru *
30 '*                                                               *          '*                         All Programmed 1991.01.01 みわ すぐる *          '*****************************************************************
40 CLEAR ,,1024,1000000,4096:LOADM ".\COMPRESS.REX",0:LOADM ".\trans.rex",2048:DEFINT A-Z:RESTORE 50:DIM TAIL$(4),PAL&(255),BUF%(511,7),G%(511),GM%(2000),GP%(153599):DEF FNB!(M$)=CVL(RIGHT$(M$,1)+MID$(M$,3,1)+MID$(M$,2,1)+LEFT$(M$,1))
45 DEF FNF$(F)=RIGHT$("  "+STR$(F),3):DEF FNG$(G)=RIGHT$("  "+STR$(G),4)
50 MGC=15:CPMC=0:ID$="H:":OD$="H:":I$="\GDATA.P16":O$="\GDATA":HEAD$="PMGf":VERN=1:PALM=1:MASKF=1:BACKF=1:MASK=129:LPF=0:PPX0=0:PPY0=0:PPX1=319:PPY1=239:INIT=0
60 PPF=PPF AND 1:GOSUB *PARAMGET:PALM=1:CLS:PCF=0
70 F_F$=ID$+I$:GOSUB  *FILESIZE_ONLY:IF FSI&=0 THEN 60 ELSE SFS&=FSI&
75 LPF=1:IF O$="!!" THEN O$=LEFT$(I$,INSTR(I$,".")-1)
80 ON ERROR GOTO *L_ERR:OPEN "I",#1,ID$+I$:DUM$=INPUT$(4,1):IF DUM$="YUKI" THEN *PXX ELSE MASK=1:DUM$=INPUT$(26,1):A!=FNB!(INPUT$(4,1)):X=A!:DUM$=INPUT$(8,1):A!=FNB!(INPUT$(4,1)):Y=A!:DUM$=INPUT$(8,1):A!=FNB!(INPUT$(4,1)):BIT=A!:IF CPMC<>0 THEN BIT=1
90 CLOSE #1:PPF=0:IF A!<>4 AND A!<>8 THEN PALM=0:SCM=1:GOTO 130
100 IF A!=4 THEN DL=15:SCM=0 ELSE DL=255:SCM=2
110 ON ERROR GOTO *ERROR:OPEN "I",#2,ID$+LEFT$(I$,INSTR(I$,".")-1)+".plt":ON ERROR GOTO 0
120 A!=CVL(INPUT$(4,2)):CLOSE #2:IF HEX$(A!)="F0000000" THEN GOSUB *PAL_INI ELSE GOSUB *PAL_LOAD
130 SCREEN@ 0:PALETTE:IF BIT=1 THEN SCM=0:DL=1:PALM=0
140 GOSUB *SCREEN_MODE:CLS:LOAD@ ID$+I$:GOSUB *PALETTE_CHANGE:GOSUB *O_OPEN:IF ERF=1 THEN *ERRIVENT
145 GOSUB *MAIN:CLOSE:GOTO *ENDIVENT
150 *O_OPEN:ERF=0:ON ERROR GOTO *O_ERR:OPEN "O",#1,OD$+O$+".PGF":ON ERROR GOTO 0:IF PPM<>0 AND ((NOBJ=1 OR (MASKF AND 128)=0) OR PPF=0) THEN GOSUB *GETPP
160 BITL=LLN\8+SGN(LLN MOD 8):PRINT #1,HEAD$+CHR$(VERN)+MKI$(X)+MKI$(Y)+CHR$(BIT,PALM,MASK,0,0,BITL,0);:IF PALM<>0 THEN GOSUB *PAL_PUT:RETURN ELSE RETURN
170 *MAIN:BITL=LLN\8+SGN(LLN MOD 8):X1=0:X2=X1+X-1:Y1=0:Y2=Y1+Y-1
175 IF PPF>1 THEN ROLL -(PPY0),-(PPX0)
177 FS&=0:YP=Y1-1:A=0:AP=0:IF BIT=1 THEN FOR C=Y1 TO Y2:GET@ (X1,C)-(X2,C),G%,%MGC:GOTO 200
180 FOR C=Y1 TO Y2
190  GET@A (X1,C)-(X2,C),G%
200  A&=CALLM(0,AP,LLN,VARPTR(G%(0)),VARPTR(BUF%(0,0)),VARPTR(GM%(0)),VARPTR(GP%(0)),BITL,A)
210   FS&=FS&+A&:IF SCM<>2 OR C>25 THEN LOCATE 58,0:PRINT USING "Y ### 圧縮率 ###.#%";C;FS&/((C-YP)*LLN)*100
220   A=A+1:IF A>7 THEN A=0
230   AP=AP+1:IF AP=9 THEN AP=8
240  AD&=VARPTR(GM%(0))
250  FOR B=0 TO A&-1
260   PRINT #1,CHR$(PEEK(AD&+B));
270  NEXT
280 NEXT
290 RETURN
300 *PAL_INI:PALM=0:PCF=0:IF DL=255 THEN 320
310 RESTORE 330:FOR A=0 TO 15:READ PAL&(A):NEXT:FOR A=16 TO 255:PAL&(A)=0:NEXT:A&=16:RETURN
320 A=0:FOR G=0 TO 7:FOR R=0 TO 7:FOR B=0 TO 3:PAL&(A)=(G*32+31*SGN(G))*65536+(R*32+31*SGN(R))*256+(B*64+63*SGN(B)):A=A+1:NEXT:NEXT:NEXT:A&=256:RETURN
330 DATA 0,128,32768,32896,8388608,8388736,8421376,8421504,4210752,255,65280,65535,16711680,16711935,16776960,16777215
340 *PAL_LOAD:PALM=1:IF DL=255 THEN 360
350 OPEN "I",#1,ID$+LEFT$(I$,INSTR(I$,".")-1)+".plt":FOR A=0 TO 15:PAL&(A)=CVL(INPUT$(4,1)):NEXT:CLOSE #1:RETURN
360 LOAD@ ID$+LEFT$(I$,INSTR(I$,".")-1)+".plt",PAL&:RETURN
370 *ERROR:GOSUB *PAL_INI:ON ERROR GOTO 0:RESUME 130
380 *L_ERR:M$="指定のファイルは見つかりませんでした。":RESUME *ERRIVENT
390 *O_ERR:GOSUB *PINI:M$="同じファイル名が既に存在しています｡更新しますか?(Y･左クリック/N･右クリック)":IF SCM=2 THEN GET@A (0,0)-(639,7),BUF%:GET@A(0,8)-(639,15),GP%:SYMBOL (0,0),M$,1,1,7 ELSE PRINT M$;
400  ON ERROR GOTO 0:GOSUB *INKEYMOS:GOSUB *PCHG:IF YN=0 THEN CLOSE #1:KILL OD$+O$+".PGF" ELSE M$="画像の出力を中止しました｡":RESUME *RETURN
410 IF SCM=2 THEN PUT@A (0,0)-(639,7),BUF%:PUT@A(0,8)-(639,15),GP%:RESUME ELSE CLS 4:RESUME
415 *RETURN:ERF=1:RETURN
420 *SCREEN_MODE:SCREEN@ SCM:IF SCM=1 THEN SCREEN@ 1,1,(0,0):PMAX=511:PMAY=255:WINDOW (0,0)-(511,255):VIEW (0,0)-(511,255) ELSE PMAX=1023:PMAY=511:WINDOW (0,0)-(1023,511):VIEW (0,0)-(1023,511)
430 IF SCM<>1 THEN 435
431 IF PPX0>511 THEN PPX0=0
432 IF PPY0>255 THEN PPY0=0
433 IF PPX1>511 THEN PPX1=319
434 IF PPY1>255 THEN PPY1=239
435 *CALC_LLN:IF BIT=1 THEN LLN=(X+7)\8:RETURN
440 IF BIT=4 THEN LLN=((X+7)\8)*4:RETURN
450 IF BIT=8 THEN LLN=X:RETURN
460 IF BIT=16 THEN LLN=X*2:RETURN
470 *PALETTE_CHANGE:IF PALM=0 THEN PCF=0:RETURN
480 FOR A=0 TO DL:PALETTE A,[(PAL&(A) AND 16711680)\65536,(PAL&(A) AND 65280)\256,PAL&(A) AND 255]:NEXT:PCF=1:RETURN
490 *PAL_PUT:IF SCM=2 THEN 510
500 FOR A=0 TO 15:PRINT #1,MKI$(((PAL&(A) AND &HF00000)\65536)*16+((PAL&(A) AND &HF000)\256)+(PAL&(A) AND &HF0)\16);:NEXT:LLP=LLP+32:RETURN
510 FOR A=0 TO 255:PRINT #1,RIGHT$(MKL$(PAL&(A)),3);:NEXT:LLP=LLP+768:RETURN
520 *PXX:CLOSE:BOJ=0:MOF=0:PPF=1
530 F_F$=ID$+I$:GOSUB *FILESIZE:LOAD@ ID$+I$,FB%:FP&=0
540 NOBJ=FB%(8):BSCM=FB%(9):GOSUB *PAL_GET:BOJ&=0
550 GOSUB *GET_HEAD:BX0=X0:BY0=Y0:X=X1-X0+1:Y=Y1-Y0+1:BDL&=IDL&:BOJ&=FP&:FP&=FP&+BDL&:GOSUB *CALC_LLN
560  IF NOBJ<>1 THEN GOSUB *GET_HEAD:OX0=X0:OY0=Y0:OX=X1-X0+1:OY=Y1-Y0+1
570  GOSUB *PUT_HEAD:IF ERF=1 THEN *ERRIVENT ELSE IF (MASK AND 128)=0 THEN *BACKGROUND
580 *OBJECT:CALLM 2048,VARPTR(FB%(0))+FP&+IDL&,VARPTR(GP%(0)),MDL&
590  CLS:PUT@ (0,0)-(OX-1,OY-1),GP%,PSET,%MGC:SWAP X,OX:SWAP Y,OY:SWAP LLN,MLLN:BBIT=BIT:BIT=1:GOSUB *MAIN
600  CALLM 2048,VARPTR(FB%(0))+FP&,VARPTR(GP%(0)),IDL&:MONB&=FS&
610  CLS:PUT@A (0,0)-(X-1,Y-1),GP%:SWAP BBIT,BIT:LLN=OLLN:GOSUB *MAIN
620  FP&=FP&+IDL&+MDL&:MONB&=MONB&+FS&:IF (MASK AND 1)=0 THEN ERASE FB%:CLOSE:GOTO 670
630 *BACKGROUND
640  CALLM 2048,VARPTR(FB%(0))+BOJ&,VARPTR(GP%(0)),BDL&
650  IF (MASK AND 128)=128 THEN SWAP X,OX:SWAP Y,OY:SWAP LLN,MLLN
660  IF PPF<2 THEN GOSUB *SCREEN_MODE:PUT@A (0,0)-(X-1,Y-1),GP%
665  GOSUB *MAIN:ERASE FB%:CLOSE:IF (MASK AND 128)=0 THEN GOTO *ENDIVENT
670  OPEN "R",#1,OD$+"(1)"+O$+".PGF":LLEN$=MKL$(MONB&):FIELD #1, 1 AS A$
680  FOR B=1 TO 4:LSET A$=MID$(LLEN$,B,1):PUT #1,LLP+B:NEXT:CLOSE:GOTO *ENDIVENT
690 *GET_HEAD:OID=PEEK(VARPTR(FB%(0))+FP&,2):IDL&=PEEK(VARPTR(FB%(0))+FP&+2,4):IF OID=1 THEN MDL&=PEEK(VARPTR(FB%(0))+FP&+6,4):FP&=FP&+4
700 X0=PEEK(VARPTR(FB%(0))+FP&+6,2):Y0=PEEK(VARPTR(FB%(0))+FP&+8,2):X1=PEEK(VARPTR(FB%(0))+FP&+10,2):Y1=PEEK(VARPTR(FB%(0))+FP&+12,2)
710 FP&=FP&+14:RETURN
720 *PAL_GET:SCM=SGN(BSCM-10)+1:IF SCM=0 THEN BIT=4:DL=15 ELSE IF SCM=1 THEN BIT=16:PALM=0 ELSE BIT=8:DL=255
730 GOSUB *SCREEN_MODE:IF SCM=1 THEN FP&=448+24:RETURN
740 FOR A=0 TO DL:PAL&(A)=((FB%(13+A*3) AND &HFF00)*256) OR (FB%(12+A*3) AND &HFF00) OR ((FB%(14+A*3) AND &HFF00)\256):NEXT
750 GOSUB *PALETTE_CHANGE:FP&=24+(DL+1)*6:RETURN
760 *FILESIZE
770  F_1 =INSTR (F_F$,":")
780  F_D$=LEFT$ (F_F$,F_1)
790  F_F$=RIGHT$(F_F$,LEN(F_F$)-LEN(F_D$))
800  OPEN "R",#3,F_D$+"(1)"+F_F$
810  F_SI&=LOF(3)
820  CLOSE #3
830 DIM FB%(CLNG(F_SI&/2+.5!)-2)
840 RETURN
850 *PUT_HEAD
860 IF NOBJ=1 THEN NMASK=1 ELSE NMASK=129
870 MASK=MASK AND NMASK
880 LLP=16:GOSUB *O_OPEN:IF ERF=1 THEN RETURN
890 IF (MASK AND 128)=0 THEN RETURN ELSE MLLN=(OX+7)\8
900 IF BIT=4 THEN OLLN=((OX+7)\8)*4
910 IF BIT=8 THEN OLLN=OX
920 IF BIT=16 THEN OLLN=OX*2
930 PRINT #1,MKL$(0);MKI$(OX0-BX0);MKI$(OY0-BY0);MKI$(OX);MKI$(OY);CHR$(MLLN\8+SGN(MLLN MOD 8),OLLN\8+SGN(OLLN MOD 8),0,0);
940 RETURN
1000 *FILESIZE_ONLY
1010  ON ERROR GOTO 1100
1020  F_1 =INSTR (F_F$,":")
1030  F_D$=LEFT$ (F_F$,F_1)
1040  F_F$=RIGHT$(F_F$,LEN(F_F$)-LEN(F_D$))
1050  OPEN "R",#3,F_D$+"(1)"+F_F$
1060  FSI&=LOF(3)
1070  CLOSE #3
1080  ON ERROR GOTO 0
1090 RETURN
1100 CLOSE #3:IF ERR=5 THEN KILL F_D$+F_F$
1110 FSI&=0:ON ERROR GOTO 0:M$="指定のファイルは見つかりませんでした。":RESUME 1090
5000 *GETPP
5010 IF PPF=1 THEN GOSUB *SCREEN_MODE:GOSUB *OFF_CALC:PUT@A (0,0)-(X-1,Y-1),FB%,,,,,FBOFF&
5020 MOUSE 0:MOUSE 1,,,1:FCX=PPX0:FCY=PPY0:PPX=PPX1-PPX0+1:PPY=PPY1-PPY0+1:SAF=1:DI=4:GOSUB *FILE:PPX0=FCX:PPY0=FCY:PPX1=FCX+PPX-1:PPY1=FCY+PPY-1:MOUSE 5:IF PCF=0 THEN *PCHG
5030 X=PPX:Y=PPY:GOSUB *CALC_LLN:PPF=PPF+2:RETURN
5500 *OFF_CALC
5510 ON SCM+1 GOTO 5520,5530,5540:RETURN
5520 FBOFF&=19+48:RETURN
5530 FBOFF&=19+224:RETURN
5540 FBOFF&=19+768:RETURN
6000 *FILE
6010 GOSUB *FBOX_CHK:GOSUB 6350:GOSUB 6400:MOUSE 4,0,0,PMAX,PMAY:IF SAF=1 THEN GOSUB 6240
6020 IF MOUSE(2,1) THEN WHILE MOUSE(6,1)=0:WEND:GOTO 6170
6030 IF MOUSE(2,0) THEN A=MOUSE(6,0) ELSE 6020
6040 MMX=MOUSE(0):MMY=MOUSE(1):IF MMX<311 AND MMY>=MCY AND MMY<=MCY+15 THEN 6250
6050 IF SAF=0 THEN 6190 ELSE GOSUB 6240:CMD=0:IF NOT(MMX>FCX-DI AND MMX<FCX+PPX+DI AND MMY<FCY+PPY+DI AND MMY>FCY-DI) THEN 6190
6060 IF ABS(MMX-FCX)<DI THEN CMD=1 ELSE IF ABS(MMX-(FCX+PPX-1))<DI THEN CMD=2
6070 IF ABS(MMY-FCY)<DI THEN CMD=CMD+4 ELSE IF ABS(MMY-(FCY+PPY-1))<DI THEN CMD=CMD+8
6080 IF CMD=0 THEN GOSUB 6320:WHILE MOUSE(6,0)=0:FCX=MOUSE(0)-LNX:FCY=MOUSE(1)-LNY:GOSUB 6240:GOSUB 6390:GOSUB 6240:WEND:GOSUB 6240:SAF=1:MOUSE 4,0,0,PMAX,PMAY:GOTO 6020
6090 LNX=MMX:LNY=MMY:CPX=MMX:CPY=MMY:MMX=FCX+PPX-1:MMY=FCY+PPY-1:IF CMD AND 1 THEN LNX=0:CPX=MMX:MMX=FCX:FCX=CPX ELSE IF CMD AND 2 THEN LNX=FCX:CPX=PMAX
6100 IF CMD AND 4 THEN LNY=0:CPY=MMY:MMY=FCY:FCY=CPY ELSE IF CMD AND 8 THEN LNY=FCY:CPY=PMAY
6110 IF CPX>PMAX THEN CPX=PMAX
6120 IF CPY>PMAY THEN CPY=PMAY
6130 MOUSE 4,LNX,LNY,CPX,CPY:MOUSE 1,MMX,MMY,1:WHILE MOUSE(6,0)=0:ON CMD GOSUB 6140,6140,6450,6160,6150,6150,6450,6160,6150,6150:GOSUB 6230:GOSUB 6380:GOSUB 6230:WEND:GOSUB 6230:MOUSE 4,0,0,PMAX,PMAY:GOTO 6200
6140 MMX=MOUSE(0):PPX=ABS(MMX-FCX)+1:RETURN
6150 GOSUB 6140
6160 MMY=MOUSE(1):PPY=ABS(MMY-FCY)+1:RETURN
6170 IF SAF=1 THEN GOSUB 6240
6180 GOSUB 6370:MMM=1-MMM:GOSUB 6350:GOSUB 6400:IF SAF=1 THEN GOSUB 6240:GOTO 6020 ELSE 6020
6190 FCX=MMX:FCY=MMY:GOSUB 6310:GOSUB 6230
6200 SAF=1:IF MMX<FCX THEN SWAP MMX,FCX
6210 IF MMY<FCY THEN SWAP MMY,FCY
6220 GOSUB 6390:GOTO 6020
6230 LINE (FCX,FCY)-(MMX,MMY),XOR,7,B:RETURN
6240 LINE (FCX,FCY)-(FCX+PPX-1,FCY+PPY-1),XOR,7,B:RETURN
6250 IF MMX<48 THEN GOSUB 6410:GOSUB 6500:GOTO 6020
6260 IF MMX<112 THEN GOSUB 6300:GOSUB 6410:GOSUB 6370:RETURN          '呼出し元へリターン
6270 IF MMX<280 THEN GOSUB 6380:GOSUB 6410:GOSUB 6390:GOTO 6020
6280 IF MMX>287 THEN GOSUB 6410:GOTO 6170
6290 GOSUB 6410:GOTO 6020
6300 IF SAF=1 THEN GOSUB 6240:RETURN ELSE RETURN
6310 WHILE MOUSE(6,0)=0:MMX=MOUSE(0):MMY=MOUSE(1):PPX=ABS(MMX-FCX)+1:PPY=ABS(MMY-FCY)+1:GOSUB 6230:GOSUB 6380:GOSUB 6230:WEND:RETURN
6320 LNX=PMAX-(FCX+PPX-1)+MMX:IF LNX>PMAX THEN LNX=PMAX
6330 LNY=PMAY-(FCY+PPY-1)+MMY:IF LNY>PMAY THEN LNY=PMAY
6340 MOUSE 4,MMX-FCX,MMY-FCY,LNX,LNY:LNX=MMX-FCX:LNY=MMY-FCY:RETURN
6350 IF MMM=0 THEN MCY=0 ELSE MCY=228
6360 M$=" PAL. 圧縮開始"
6365 IF SCM=2 THEN GET@A (0,MCY)-(310,MCY+15),BUF%:LINE (0,MCY)-(310,MCY+15),PSET,4,BF:SYMBOL (0,MCY),M$,1,1,0:SYMBOL (288,MCY),"◆",1,1,0:RETURN ELSE LOCATE 0,MCY\19:COLOR 4,1,,5:PRINT M$;:LOCATE 36,MCY\19:PRINT "◆";:COLOR 7,0,,0:RETURN
6370 IF SCM=2 THEN PUT@A (0,MCY)-(310,MCY+15),BUF%,PSET:RETURN ELSE CLS 4:RETURN
6380 M$="セーブ領域 ("+FNG$(PPX)+","+FNF$(PPY)+")":IF SCM=2 THEN LINE (112,MCY)-(279,MCY+15),PSET,4,BF:SYMBOL (112,MCY),M$,1,1,0:RETURN ELSE LOCATE 14,MCY\19:COLOR 4,1,,5:PRINT M$;:COLOR 7,0,,0:RETURN
6390 IF SCM=2 THEN LINE (112,MCY)-(279,MCY+15),PSET,4,BF
6400 M$="("+FNG$(FCX)+","+FNF$(FCY)+")-("+FNG$(FCX+PPX-1)+","+FNF$(FCY+PPY-1)+")":IF SCM=2 THEN SYMBOL (112,MCY),M$,1,1,0:RETURN ELSE LOCATE 14,MCY\19:COLOR 4,1,,5:PRINT M$;:COLOR 7,0,,0:RETURN
6410 WHILE MOUSE(6,0)=0:WEND:RETURN
6420 SYMBOL (IMX,IMY),IS$,1,1,C:RETURN
6430 *FBOX_CHK:IF FCX+PPX-1>PMAX THEN FCX=0:PPX=8
6440 IF FCY+PPY-1>PMAY THEN FCY=0:PPY=8
6450 RETURN
6500 ON PCF+1 GOSUB *PCHG,*PINI:RETURN
6510 *PINI:IF SCM<>1 THEN PALETTE@
6520 PCF=0:RETURN
6550 *PCHG:IF SCM<>1 THEN GOSUB *PALETTE_CHANGE
6560 RETURN
19000 MGC=15:CPMC=0:ID$="h:":OD$="h:":I$="\GDATA.P16":O$="\GDATA"
19010 PALM=1:MASK=129:GOTO *PARAMGET
19500 IF ERR=63 THEN RESUME 20040
19510 PRINT "環境ファイルに異常があります｡";:CLOSE:MGC=15:CPMC=0:ID$="H:":OD$="H:":I$="\GDATA.P16":O$="\GDATA":PALM=1:MASKF=1:BACKF=1:PPX0=0:PPY0=0:PPX1=319:PPY1=239:WAIT 50:RESUME 20040
20000 *PARAMGET
20010 SCREEN@ 0:TAIL$(0)=".TIF":TAIL$(1)=".P16":TAIL$(2)=".P32":TAIL$(3)=".P25":IF LPF<>0 THEN 20040
20020 ON ERROR GOTO 19500:OPEN "I",#1,".\pmgfsave.env":MGC=CVI(INPUT$(2,1)):CPMC=ASC(INPUT$(1,1)):PPM=ASC(INPUT$(1,1)):MASKF=ASC(INPUT$(1,1)):BACKF=ASC(INPUT$(1,1))
20030 PPX0=CVI(INPUT$(2,1)):PPY0=CVI(INPUT$(2,1)):PPX1=CVI(INPUT$(2,1)):PPY1=CVI(INPUT$(2,1))
20035 DUM=ASC(INPUT$(1,1)):ID$=INPUT$(DUM,1):DUM=ASC(INPUT$(1,1)):OD$=INPUT$(DUM,1):DUM=ASC(INPUT$(1,1)):I$=INPUT$(DUM,1):DUM=ASC(INPUT$(1,1)):O$=INPUT$(DUM,1):CLOSE
20040 ON ERROR GOTO 0:IF ASC(I$)<32 THEN I$="\*.TIF"
20045 F$=LEFT$(I$,INSTR(I$,".")-1):T$=RIGHT$(I$,LEN(I$)-INSTR(I$,".")+1):MOUSE 0:MOUSE 1,320,240,1
20050 GOSUB *MENU_DRAW
20060 WHILE K$<>"":K$=INKEY$:WEND:WHILE MOUSE(2,0)=0 AND K$="":K$=INKEY$:WEND:IF K$="" THEN WHILE MOUSE(6,0)=0:WEND:MX=MOUSE(0):MY=MOUSE(1) ELSE IF INSTR(CHR$(13)+CHR$(24),K$)=0 THEN 20060 ELSE IF CHR$(13)=K$ THEN *PARAMSET ELSE RETURN *ENDIVENT
20070 IF MX>74 AND MY>55 AND MX<268 AND MY<74 THEN CPMC=1-SGN(CPMC):GOSUB *MONOMODE:GOTO 20060
20080 IF MX>74 AND MY>93 AND MX<268 AND MY<112 THEN MASKF=1-SGN(MASKF):GOSUB *MASKMODE:GOTO 20060
20085 IF MX>74 AND MY>131 AND MX<268 AND MY<150 THEN PPM=1-SGN(PPM):GOSUB *PPMODE:GOTO 20060
20090 IF MX>314 AND MY>93 AND MX<508 AND MY<112 THEN BACKF=1-SGN(BACKF):GOSUB *BACKMODE:GOTO 20060
20100 IF MX>314 AND MY>55 AND MX<602 AND MY<74 THEN IF CPMC=0 THEN 20060 ELSE GOSUB *MONOCIN:GOSUB *MONOMODE:GOTO 20060
20110 IF NOT(MX>188 AND MY>169 AND MX<390 AND MY<188) THEN 20160
20120 IF MX<248 THEN T$=TAIL$(0):GOSUB *INTAIL:GOTO 20060
20130 IF MX<296 THEN T$=TAIL$(1):GOSUB *INTAIL:GOTO 20060
20140 IF MX<344 THEN T$=TAIL$(2):GOSUB *INTAIL:GOTO 20060
20150 IF MX>343 THEN T$=TAIL$(3):GOSUB *INTAIL:GOTO 20060
20160 IF MX>0 AND MY>188 AND MX<154 AND MY<207 THEN GOSUB *DRIVE_SEL:ID$=D$:GOSUB *INDRIVE:GOTO 20060
20170 IF MX>0 AND MY>264 AND MX<154 AND MY<283 THEN GOSUB *DRIVE_SEL:OD$=D$:GOSUB *OUTDRIVE:GOTO 20060
20180 IF MY>226 AND MY<264 THEN FILE$=F$:FIY=12:GOSUB *FILEIN:F$=FILE$:GOSUB *INFILEVIEW:GOSUB *OUTFILEVIEW:GOTO 20060
20190 IF MY>302 AND MY<340 THEN FILE$=O$:FIY=16:GOSUB *FILEIN:O$=FILE$:IF O$="!!" THEN O$=F$:GOSUB *OUTFILEVIEW:GOTO 20060 ELSE GOSUB *OUTFILEVIEW:GOTO 20060
20200 IF MX>478 AND MY>454 AND MX<537 AND MY<474 THEN RETURN *ENDIVENT
20210 IF MX>550 AND MY>454 AND MX<609 AND MY<474 THEN *PARAMSET
20220 IF MX>6 AND MY>454 AND MX<65 AND MY<474 THEN GOSUB *FILESVIEW:GOTO 20060
21990 BEEP:GOTO 20060
25000 *PARAMSET
25010 IF MASKF=1 AND BACKF=1 THEN MASK=129:GOTO 25040
25020 IF MASKF=1 AND BACKF=0 THEN MASK=128:GOTO 25040
25030 MASK=0
25040 I$=F$+T$:MOUSE 5:RETURN
27000 *MONOCIN
27010 TMGC&=MGC:WHILE K$<>"":WEND:MOUSE 1,,,0
27020 LOCATE 69,3:PRINT USING "#####";TMGC&
27030 K$="":WHILE K$="":LINE (540,55)-(602,74),XOR,7,B:LINE (540,55)-(602,74),XOR,7,B:K$=INKEY$:WEND
27040 IF INSTR("1234567890"+CHR$(8)+CHR$(12)+CHR$(13),K$)=0 THEN IF K$=CHR$(29) THEN K$=CHR$(8) ELSE IF K$<" " THEN K$=CHR$(12) ELSE BEEP:GOTO 27030
27050 IF INSTR("1234567890",K$)<>0 THEN PTV=VAL(K$):TMGC&=TMGC&*10+PTV:IF TMGC&>32767 THEN BEEP:TMGC&=TMGC& \ 10:GOTO 27030 ELSE 27020
27060 IF K$=CHR$(8) THEN TMGC&=TMGC& \ 10:GOTO 27020
27070 IF K$=CHR$(12) THEN TMGC&=0:GOTO 27020
27080 IF K$=CHR$(13) THEN MGC=TMGC&:MOUSE 1,,,1:RETURN
27090 GOTO 27030
28000 *FILEIN
28010 LOCATE 0,FIY:PRINT LEFT$(FILE$+SPACE$(159),159);
28020 I$="":WHILE I$<>CHR$(13):STL=LEN(FILE$):MMX=STL MOD 80:MMY=(STL \ 80)+FIY:I$="":WHILE I$="":LOCATE MMX,MMY:PRINT "#";:LOCATE MMX,MMY:PRINT " ";:I$=INKEY$:WEND
28030 I=ASC(I$):IF I=8 OR I=29 THEN STL=STL-1:IF STL<0 THEN STL=0
28040 IF I>96 AND I<&H123 THEN I=I-32:I$=CHR$(I)
28060 IF INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ\0123456789$&#%'@^{}`!_*",I$)<>0 THEN FILE$=FILE$+I$:STL=STL+1
28070 FILE$=LEFT$(FILE$,STL):LOCATE 0,FIY:PRINT LEFT$(FILE$+SPACE$(159),159);
28080 WEND:LOCATE 0,FIY:PRINT SPACE$(159);:RETURN
29000 *DRIVE_SEL
29010 COLOR 7,,,4:LOCATE 0,20:PRINT "ドライブ名を左クリックで指定してください｡"+CHR$(13,10)+"  Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ Ｉ Ｊ Ｋ Ｌ Ｍ Ｎ Ｏ Ｐ Ｑ Ｒ Ｓ Ｔ Ｕ Ｖ Ｗ Ｘ Ｙ Ｚ ";:COLOR 7,,,4
29020 WHILE MOUSE(2,0)=0:WEND:WHILE MOUSE(6,0)=0:WEND:MX=MOUSE(0):MY=MOUSE(1):IF MY<399 OR MY>417 THEN BEEP:GOTO 29020
29030 IF MX<8 THEN D$="A:":GOTO 29060
29040 IF MX>631 THEN D$="Z:":GOTO 29060
29050 D$=CHR$(65+((MX-8) \ 24))+":"
29060 LOCATE 0,20:PRINT SPACE$(160);:RETURN
30000 *MONOMODE:COLOR 7,,,4:LOCATE 10,3:PRINT "モノクロモード   ";:IF CPMC=0 THEN PRINT "ＯＦＦ"; ELSE PRINT "ＯＮ　";
30010 LOCATE 40,3:IF CPMC=0 THEN COLOR 1 ELSE COLOR 7
30020 PRINT USING "モノクロセーブカラーコード   #####";MGC;:COLOR 7:RETURN
30030 *MASKMODE:LOCATE 10,5:PRINT "マスク画像       ";:IF MASKF=0 THEN PRINT "ＯＦＦ"; ELSE PRINT "ＯＮ　";
30040 RETURN
30050 *BACKMODE:LOCATE 40,5:PRINT "背景画像         ";:IF BACKF=0 THEN PRINT "ＯＦＦ"; ELSE PRINT "ＯＮ　";
30060 RETURN
30070 *PPMODE:LOCATE 10,7  :PRINT "セーブ範囲指定   ";:IF PPM=0 THEN PRINT "ＯＦＦ"; ELSE PRINT "ＯＮ　";
30080 LOCATE 40,7:IF PPM=0 THEN PRINT "読み込み画像範囲全体   "; ELSE PRINT "セーブ時指定範囲       ";
30085 COLOR 7:RETURN
30090 *INDRIVE:COLOR 7,,,4:LOCATE 0,10:PRINT "入力ドライブ    "+ID$;:RETURN
30100 *OUTDRIVE:COLOR 7,,,4:LOCATE 0,14:PRINT "出力ドライブ    "+OD$:RETURN
30110 *INTAIL:COLOR 7,,,4:LOCATE 0,9:PRINT "入力画像ファイル拡張子   ";
30120 FOR A=0 TO 4:IF T$=TAIL$(A) THEN COLOR 7 ELSE COLOR 2
30130 PRINT " "+TAIL$(A)+" ";:NEXT:COLOR 7
30140 GOSUB *INFILEVIEW:RETURN
30150 *INFILEVIEW:COLOR 7,,,4:LOCATE 0,12:PRINT LEFT$(F$+T$+SPACE$(160),159);
30160 RETURN
30170 *OUTFILEVIEW:COLOR 7,,,4:LOCATE 0,16:IF O$=F$ THEN PRINT LEFT$("!!"+SPACE$(160),159); ELSE PRINT LEFT$(O$+".PGF"+SPACE$(160),159);
30180 RETURN
35000 *MENU_DRAW
35010 CLS:COLOR 7,,,4
35020 GOSUB *MONOMODE:GOSUB *PPMODE:GOSUB *BACKMODE:GOSUB *MASKMODE:GOSUB *INDRIVE:GOSUB *OUTDRIVE:GOSUB *INTAIL:GOSUB *INFILEVIEW:GOSUB *OUTFILEVIEW
35030 LOCATE 0,11:PRINT "入力画像ファイル名";:LOCATE 0,15:PRINT "出力PMGfファイル名";
35040 LINE (0,0)-(639,479),PSET,%4,BF,CHR$(&H40,&H40,&H40,&H40,4,4,4,4)
35050 LINE (74,55)-(204,74),PSET,%4,BF,%1:LINE (204,55)-(268,74),PSET,%4,BF,0:LINE (314,55)-(540,74),PSET,%4,BF,%1:LINE (540,55)-(602,74),PSET,%4,BF,0:LINE (269,65)-(313,65),PSET,%4
35060 LINE (74,93)-(204,112),PSET,%4,BF,%1:LINE (204,93)-(268,112),PSET,%4,BF,0:LINE (314,93)-(444,112),PSET,%4,BF,%1:LINE (444,93)-(508,112),PSET,%4,BF,0:LINE (74,131)-(204,150),PSET,%4,BF,%1:LINE (204,131)-(268,150),PSET,%4,BF,0
35070 LINE (269,141)-(313,141),PSET,%4:LINE (314,131)-(540,150),PSET,%4,BF,0
35080 LINE (0,169)-(188,188),PSET,%4,BF,%1:LINE (188,169)-(390,188),PSET,%4,BF,0
35090 LINE (0,188)-(108,207),PSET,%4,BF,%1:LINE (108,188)-(154,207),PSET,%4,BF,0
35100 LINE (0,207)-(154,226),PSET,%4,BF,%1:LINE (0,226)-(639,264),PSET,%4,BF,0
35110 LINE (0,264)-(108,283),PSET,%4,BF,%1:LINE (108,264)-(154,283),PSET,%4,BF,0
35120 LINE (0,283)-(154,302),PSET,%4,BF,%1:LINE (0,302)-(639,340),PSET,%4,BF,0
35130 LOCATE 22,1:PRINT "“ＰＭＧｆ画像圧縮ユーティリティー”";:LINE (176,17)-(463,38),PSET,%4,BF,0
35140 LOCATE 1,24:PRINT " FILES ";:LINE (6,454)-(65,474),PSET,%4,BF,0:LOCATE 60,24:PRINT " 終 了    実 行 ";:LINE (478,454)-(537,474),PSET,%4,BF,0:LINE (550,454)-(609,474),PSET,%4,BF,0:RETURN
35150 *FILESVIEW
35160 CLS:CONSOLE 0,23:LOCATE 0,24:PRINT RIGHT$(SPACE$(70)+ID$+F$+T$,70)+" [戻 る] ";:LINE (0,455)-(639,455),PSET,7:GOSUB *GETPATH
35170 ON ERROR GOTO 35270:FFF=1
35180 LOCATE 0,0:FILES ID$+F$+T$:M$=""::FOR A=7 TO 14:P$=CHR$(SCREEN(A,TMY)):M$=M$+P$:NEXT
35185 IF M$="ファイル" THEN CLS 1:LOCATE 0,0:FFF=0:PRINT "指定されたファイルは見つかりませんでした｡"
35190 WHILE MOUSE(2,0)=0:WEND:WHILE MOUSE(6,0)=0:WEND:MX=MOUSE(0):MY=MOUSE(1)
35200 IF MY>456 THEN IF MX>560 AND MX<616 THEN *FILESRET ELSE BEEP:GOTO 35190
35210 IF FFF=0 THEN BEEP:GOTO 35190 ELSE TMY=MY \ 19:M$="":FOR A=0 TO 7:P$=CHR$(SCREEN(A,TMY)):IF ASC(P$)>32 THEN M$=M$+P$
35220 NEXT:M2$=".":FOR A=9 TO 11:P$=CHR$(SCREEN(A,TMY)):IF P$<>" " THEN M2$=M2$+P$
35230 NEXT:IF M$<>"" THEN F$=PATH$+M$
35240 IF M2$<>"." THEN T$=M2$
35250 *FILESRET
35260 CONSOLE 0,24:GOSUB *MENU_DRAW:RETURN
35270 FFF=0:PRINT "指定されたファイルは見つかりませんでした｡":RESUME 35190
35271 *GETPATH
35273 PP=0:FOR A=1 TO LEN(F$):IF "\"=MID$(F$,A,1) THEN PP=A
35275 NEXT:PATH$=LEFT$(F$,PP):RETURN
35280 *PARAMSAVE
35290 ON ERROR GOTO 35320:OPEN "O",#1,".\pmgfsave.env":PRINT #1,MKI$(MGC)+CHR$(CPMC,PPM,MASKF,BACKF);
35295 PRINT #1,MKI$(PPX0)+MKI$(PPY0)+MKI$(PPX1)+MKI$(PPY1);
35300 PRINT #1,CHR$(LEN(ID$))+ID$;:PRINT #1,CHR$(LEN(OD$))+OD$;:PRINT #1,CHR$(LEN(I$))+I$;:PRINT #1,CHR$(LEN(O$))+O$;:CLOSE
35310 RETURN
35320 IF ERR=64 THEN KILL ".\pmgfsave.env":RESUME
35330 IF ERR=73 THEN RESUME 35310
35340 CLS:LOCATE 0,5:PRINT "環境情報保存中に異常が起きました｡環境情報は削除されます｡":RESUME 35340
35350 ON ERROR GOTO 35360:KILL ".\pmgfsave.env":ON ERROR GOTO 0:GOTO 35310
35360 ON ERROR GOTO 0:RESUME 35310
35370 *INKEYMOS
35380 MOUSE 0:WHILE K$<>"":K$=INKEY$:WEND
35390 K$=INKEY$:IF K$<>"" THEN IF INSTR("YyNn"+CHR$(24)+CHR$(13),K$)<>0 THEN 35420 ELSE BEEP:GOTO 35390
35400 IF MOUSE(2,0) THEN YN=0:WHILE MOUSE(6,0)=0:WEND:GOTO 35430
35410 IF MOUSE(2,1) THEN YN=1:WHILE MOUSE(6,1)=0:WEND:GOTO 35430 ELSE 35390
35420 IF INSTR("Yy"+CHR$(13),K$)=0 THEN YN=1 ELSE YN=0
35430 MOUSE 5:RETURN
35440 *ERRIVENT
35450 SCREEN@ 0:CLS:PRINT M$
35460 GOTO *ENDIVENT_IN
35470 *ENDIVENT
35480 SCREEN@ 0:CLS:PALETTE@
35490 F_F$=OD$+O$+".PGF":GOSUB  *FILESIZE_ONLY:IF SFS&=0 THEN *ENDIVENT_IN
35500 LOCATE 4,2:PRINT USING "元データ ######## Bytes／圧縮ファイル ######## Bytes／圧縮率 ###.##";SFS&;FSI&;((FSI&/SFS&)*100);
35510 *ENDIVENT_IN
35520 MOUSE 0:LOCATE 30,5:PRINT "画像圧縮を終了しました｡":PRINT :PRINT "           続けて圧縮を行う時は[実 行]キー(左クリックも可)を押してください｡":PRINT "           終了する場合はそれ以外のキー(右クリックも可)を押してください｡"
35530 WHILE K$<>"":K$=INKEY$:WEND:WHILE MOUSE(2,0)=0 AND MOUSE(2,1)=0 AND K$="":K$=INKEY$
35540 WEND:IF K$=CHR$(13) THEN 60 ELSE IF K$<>"" THEN 35570
35550 IF MOUSE(6,0)<>0 THEN 60
35560 IF MOUSE(6,1)=0 THEN 35550
35570 CLS:LOCATE 30,5:PRINT "プログラムを終了します｡"
35580 GOSUB *PARAMSAVE:WAIT 30:END