home *** CD-ROM | disk | FTP | other *** search
/ FreeWare Collection 3 / FreeSoftwareCollection3pd199x-jp.img / fb386 / 32k2pxx / 32k2pxx.bas next >
BASIC Source File  |  1980-01-02  |  22KB  |  674 lines
  1. 1000 '
  2. 1010 '     ＊＊＊  安易３万色画像コンバートプログラム　v1.2 ＊＊＊
  3. 1020 '        　　　   （tif→pXXファイル）
  4. 1030 '
  5. 1040 '                      By  Pumpkin
  6. 1050 '
  7. 1060 '
  8. 1070 CLS:SCREEN @1:WINDOW(0,0)-(511,255):VIEW(0,0)-(511,255)
  9. 1080 PRINT "＊＊＊  安易３万色画像コンバートプログラム　v1.2  ＊＊＊"
  10. 1090 CLEAR ,,,&HC0000,8192:DEFINT A-Z:RANDOMIZE TIME
  11. 1100 DIM BUF(512*1024/2-1)
  12. 1110 LOADM"32k2pxx.rex",0
  13. 1120 CAL0&=13:CAL1&=15:CAL2&=17:CAL3&=19:CAL4&=24
  14. 1130 CAL5&=29:CAL6&=34
  15. 1140 '
  16. 1150 PRINT 
  17. 1160 PRINT "1)32K色→256色 その１ FAST"
  18. 1170 PRINT "2)32K色→256色 その２ SLOW"
  19. 1180 PRINT "3)32K色→256色パレット固定（カラー）"
  20. 1190 PRINT "4)32K色→モノクロ256階調"
  21. 1200 PRINT "5)32K色→モノクロ16階調(疑似32階調)"
  22. 1210 PRINT "6)32K色→モノクロ16階調(疑似48階調)"
  23. 1220 PRINT "7)32K色→８色パレット固定（カラー）"
  24. 1230 PRINT "8)32K色→モノクロ単色"
  25. 1240 A$=INPUT$(1):IF A$>"8" OR A$<"1" THEN *BYE
  26. 1250 '
  27. 1260 LINE INPUT "入力ファイル名 =",FIN$ :IF LEN(FIN$ )<5 THEN *BYE
  28. 1270 LINE INPUT "出力ファイル名 =",FOUT$:IF LEN(FOUT$)<5 THEN *BYE
  29. 1280 LINE INPUT"センタリング処理をする(y/n)",KY$
  30. 1290 IF KY$="Y" OR KY$="y" THEN C_F=-1 ELSE C_F=0
  31. 1300 IF A$<"3" THEN X_F=-1:GOTO 1340
  32. 1310 LINE INPUT"２倍拡大表示をする(y/n)",KY$
  33. 1320 IF KY$="Y" OR KY$="y" THEN X_F=0 ELSE X_F=-1
  34. 1330 '
  35. 1340 IF A$="1" THEN O_F=2:GOSUB 1430:A_F=1:GOSUB *CLCV:GOTO *BYE
  36. 1350 IF A$="2" THEN O_F=2:GOSUB 1430:A_F=2:GOSUB *CLCV:GOTO *BYE
  37. 1360 IF A$="3" THEN O_F=1:GOSUB 1430:GOSUB *CL256  :GOTO *BYE
  38. 1370 IF A$="4" THEN O_F=2:GOSUB 1430:GOSUB *MN256  :GOTO *BYE
  39. 1380 IF A$="5" THEN O_F=2:GOSUB 1430:GOSUB *MN16_32:GOTO *BYE
  40. 1390 IF A$="6" THEN O_F=2:GOSUB 1430:GOSUB *MN16_48:GOTO *BYE
  41. 1400 IF A$="7" THEN O_F=1:GOSUB 1430:GOSUB *CL8    :GOTO *BYE
  42. 1410 IF A$="8" THEN O_F=3:GOSUB 1430:GOSUB *MN1    :GOTO *BYE
  43. 1420 '
  44. 1430 IF RIGHT$(FOUT$,4)<>".tif" AND RIGHT$(FOUT$,4)<>".TIF" THEN O_F = 4
  45. 1440 RETURN
  46. 1450 '
  47. 1460 *BYE
  48. 1470 END
  49. 1480 '
  50. 1490 '
  51. 1500 '＊＊＊　２５６色化
  52. 1510 '
  53. 1520 *CLCV
  54. 1530 '
  55. 1540 DIM PAL0(32767),PAL1(255),PAL2(255),PAL3(255),PAL4&(255),COUNT&(32767)
  56. 1550 '
  57. 1560 'PAL0   .. 3万色コード→256コードの表
  58. 1570 'PAL1   .. 256コード→3万色コードの表
  59. 1580 'PAL2   .. 各色グループに属する色の数
  60. 1590 'PAL3   .. 各色グループに属するドットの数
  61. 1600 'COUNT& .. 色数勘定用のワーク
  62. 1610 '
  63. 1620 LINE INPUT"色の間引き処理をする(y/n)",KY$
  64. 1630 IF KY$="Y" OR KY$="y" THEN M_F=2 ELSE M_F=1
  65. 1640 LINE INPUT"簡易ディザ表示をする(y/n)",KY$
  66. 1650 IF KY$="Y" OR KY$="y" THEN D_F=0 ELSE D_F=-1
  67. 1660 SCREEN @1
  68. 1670 '
  69. 1680 TIME$="00:00:00":GOSUB *FILE_READ
  70. 1690 '
  71. 1700 'ヒストグラム作成
  72. 1710 '
  73. 1720 CALLM CAL0&,X_WIDTH*Y_WIDTH,VARPTR(BUF(0)),VARPTR(COUNT&(0))
  74. 1730 '
  75. 1740 'FOR Y=0 TO Y_WIDTH-1                             'cal0の内容
  76. 1750 ' FOR X=0 TO X_WIDTH-1
  77. 1760 '  COL=BUF(X_WIDTH*Y+X):COUNT&(COL)=COUNT&(COL)+1
  78. 1770 ' NEXT
  79. 1780 'NEXT
  80. 1790 '
  81. 1800 '
  82. 1810 NUM_COL=0
  83. 1820 FOR I&=0 TO 32767
  84. 1830  IF COUNT&(I&)<>0 THEN NUM_COL=NUM_COL+1
  85. 1840 NEXT
  86. 1850 PRINT "総色数        =";NUM_COL
  87. 1860 '
  88. 1870 IF M_F=1 THEN 2100
  89. 1880 '
  90. 1890 '
  91. 1900 '間引き
  92. 1910 '
  93. 1920 FOR I&=0 TO 32767
  94. 1930  FLG=0
  95. 1940  IF I&>0     THEN IF COUNT&(I&-1)<>0    THEN FLG=1
  96. 1950  IF I&<32767 THEN IF COUNT&(I&+1)<>0    THEN FLG=FLG+1
  97. 1960  IF I&>31    THEN IF COUNT&(I&-32)<>0   THEN FLG=FLG+1
  98. 1970  IF I&<32736 THEN IF COUNT&(I&+32)<>0   THEN FLG=FLG+1
  99. 1980  IF I&>1023  THEN IF COUNT&(I&-1024)<>0 THEN FLG=FLG+1
  100. 1990  IF I&<31744 THEN IF COUNT&(I&+1024)<>0 THEN FLG=FLG+1
  101. 2000  IF FLG=6 THEN COUNT&(I&)=0
  102. 2010 NEXT
  103. 2020 '
  104. 2030 NUM_COL=0
  105. 2040 FOR I&=0 TO 32767
  106. 2050  IF COUNT&(I&)<>0 THEN NUM_COL=NUM_COL+1
  107. 2060 NEXT
  108. 2070 PRINT "間引き後色数  =";NUM_COL
  109. 2080 '
  110. 2090 '
  111. 2100 '各色グループに含まれる色数を調べる
  112. 2110 '
  113. 2120 ERASE PAL2:DIM PAL2(255) '配列クリア
  114. 2130 FOR I&=0 TO 32767
  115. 2140   IF COUNT&(I&)=0 THEN 2190
  116. 2150   'G=I&\1024:R=(I& AND &H3E0)/32:B=I& AND 31
  117. 2160   CALLM CAL5&,I&,VARPTR(G),VARPTR(R),VARPTR(B)
  118. 2170   COL=(G\4)*32+(R\4)*4+(B\8)
  119. 2180   PAL2(COL)=PAL2(COL)+1
  120. 2190 NEXT
  121. 2200 '
  122. 2210 IF A_F=1 THEN 2380
  123. 2220 '
  124. 2230 '
  125. 2240 '各色グループに含まれるドット数を調べる
  126. 2250 '
  127. 2260 ERASE PAL4&:DIM PAL4&(255) '配列クリア
  128. 2270 FOR I&=0 TO X_WIDTH*Y_WIDTH-1
  129. 2280   COL=BUF(I&):IF COUNT&(COL)=0 THEN 2320
  130. 2290   'G=COL\1024:R=(COL AND &H3E0)/32:B=COL AND 31
  131. 2300   CALLM CAL5&,COL,VARPTR(G),VARPTR(R),VARPTR(B)
  132. 2310   COL=(G\4)*32+(R\4)*4+(B\8):PAL4&(COL)=PAL4&(COL)+1
  133. 2320 NEXT
  134. 2330 '
  135. 2340 'パレットの割当て数の算出
  136. 2350 '
  137. 2360 IF A_F=2 THEN 2500
  138. 2370 '
  139. 2380 PNUM=255
  140. 2390 PTOT=0
  141. 2400 FOR I=0 TO 255
  142. 2410  IF PAL2(I)=0 THEN 2440
  143. 2420  PAL3(I)=INT(PAL2(I)/NUM_COL*PNUM):IF PAL3(I)=0 THEN PAL3(I)=1
  144. 2430  PTOT=PTOT+PAL3(I)
  145. 2440 NEXT
  146. 2450 IF PTOT>250 THEN PNUM=PNUM-1:GOTO 2390
  147. 2460 IF NOT(PTOT>240 AND PTOT=<250) THEN PNUM=PNUM+1:GOTO 2390
  148. 2470 '
  149. 2480 GOTO 2660 
  150. 2490 '
  151. 2500 FOR I=0 TO 255
  152. 2510  PAL4&(I)=PAL2(I)*PAL4&(I):TOT&=TOT&+PAL4&(I)
  153. 2520 NEXT
  154. 2530 PNUM=255
  155. 2540 PTOT=0
  156. 2550 FOR I=0 TO 255
  157. 2560  IF PAL4&(I)=0 THEN 2590
  158. 2570  PAL3(I)=INT(PAL4&(I)/TOT&*PNUM):IF PAL3(I)=0 THEN PAL3(I)=1
  159. 2580  PTOT=PTOT+PAL3(I)
  160. 2590 NEXT
  161. 2600 IF PTOT>250 THEN PNUM=PNUM-1:GOTO 2540
  162. 2610 IF NOT(PTOT>240 AND PTOT=<250) THEN PNUM=PNUM+1:GOTO 2540
  163. 2620 '
  164. 2630 '
  165. 2640 'ＴｏｗｎｓＰａｉｎｔ対策
  166. 2650 '
  167. 2660 PAL1(0)=0:PAL1(255)=&H7FFF:PAL1(182)=&H6318
  168. 2670 '
  169. 2680 'パレット設定
  170. 2690 '
  171. 2700 FOR I&=0 TO 32767:PAL0(I&)=-1:NEXT
  172. 2710 '
  173. 2720 PNUM=1
  174. 2730 FOR I=0 TO 255
  175. 2740  IF PAL3(I)=0 THEN 2900
  176. 2750  COL=(I\32)*4*1024+(I AND &H1C)*32+(I AND 3)*8
  177. 2760  FOR J=1 TO PAL3(I) 'そのグループ内の上位色を調べる
  178. 2770   IF PNUM=>254 THEN 2890
  179. 2780   PMAX&=0
  180. 2790   FOR G=0 TO 3
  181. 2800    FOR R=0 TO 3
  182. 2810     FOR B=0 TO 7
  183. 2820      COL2=COL+G*1024+R*32+B
  184. 2830      IF PMAX&<COUNT&(COL2) THEN PMAX&=COUNT&(COL2):PCNT=COL2
  185. 2840     NEXT
  186. 2850    NEXT
  187. 2860   NEXT
  188. 2870   PAL1(PNUM)=PCNT:PAL0(PCNT)=PNUM:COUNT&(PCNT)=0
  189. 2880   PNUM=PNUM+1:IF PNUM=182 THEN PNUM=183
  190. 2890  NEXT
  191. 2900 NEXT
  192. 2910 '
  193. 2920 '
  194. 2930 '表示
  195. 2940 '
  196. 2950 SCREEN@ 2:PALETTE
  197. 2960 '
  198. 2970 FOR I=0 TO 255:PAL2(I)=PAL1(I):NEXT
  199. 2980 FOR Y=0 TO Y_WIDTH-1
  200. 2990  FOR X=0 TO X_WIDTH-1
  201. 3000   COL=BUF(Y*X_WIDTH+X)
  202. 3010   CALLM CAL5&,COL,VARPTR(G),VARPTR(R),VARPTR(B)
  203. 3020   COL=PAL0(COL):IF COL<>-1 THEN 3110
  204. 3030   COL=CALLM(CAL3&,G,R,B,VARPTR(PAL1(0))) '似ている色を探す
  205. 3040   IF D_F THEN 3110
  206. 3050   PAL2(COL)=0                      'その次に似ている色を探す
  207. 3060   COL2=CALLM(CAL3&,G,R,B,VARPTR(PAL2(0))):PAL2(COL)=PAL1(COL)
  208. 3070   CALLM CAL5&,PAL1(COL),VARPTR(G1),VARPTR(R1),VARPTR(B1)
  209. 3080   CALLM CAL5&,PAL1(COL2),VARPTR(G2),VARPTR(R2),VARPTR(B2)
  210. 3090   IF ABS(G1-G)+ABS(R1-R)+ABS(B1-B)<ABS((G1+G2)/2-G)+ABS((R1+R2)/2-R)+ABS((B1+B2)/2-B) THEN 3110
  211. 3100   IF RND>.5! THEN COL=COL2
  212. 3110   PSET(X+OX,Y+OY),%COL
  213. 3120  NEXT
  214. 3130 NEXT
  215. 3140 CLOSE
  216. 3150 '
  217. 3160 ' MAKE HEADER
  218. 3170 BIT=8:GOSUB *MAKE_BUF:RESTORE *HEAD25:CNT=0:GOSUB *READ_DATA
  219. 3180 ' PALETTE
  220. 3190 FOR I=0 TO 255
  221. 3200  G=(PAL1(I) AND &H7C00)/1024
  222. 3210  R=(PAL1(I) AND &H3E0)/32
  223. 3220  B=(PAL1(I) AND 31)
  224. 3230  PALETTE I,[G*8,R*8,B*8]
  225. 3240  IF R<>0 THEN BF&=(R*8+7)*256 ELSE BF&=0
  226. 3250  IF BF&>32767 THEN BF&=BF&-65536
  227. 3260  BUF(CNT)=BF&:CNT=CNT+1
  228. 3270  IF G<>0 THEN BF&=(G*8+7)*256 ELSE BF&=0
  229. 3280  IF BF&>32767 THEN BF&=BF&-65536
  230. 3290  BUF(CNT)=BF&:CNT=CNT+1
  231. 3300  IF B<>0 THEN BF&=(B*8+7)*256 ELSE BF&=0
  232. 3310  IF BF&>32767 THEN BF&=BF&-65536
  233. 3320  BUF(CNT)=BF&:CNT=CNT+1
  234. 3330 NEXT
  235. 3340 '
  236. 3350 GOSUB *DATA_SAVE
  237. 3360 SYMBOL(0,0),"所要時間:"+TIME$,1,1,7,,,8
  238. 3370 RETURN
  239. 3380 '
  240. 3390 '
  241. 3400 '＊＊＊　モノクロ256階調
  242. 3410 '
  243. 3420 *MN256
  244. 3430 TIME$="00:00:00":GOSUB *FILE_READ
  245. 3440 '
  246. 3450 SCREEN @2:PALETTE
  247. 3460 '
  248. 3470 IF NOT(X_FLG) THEN 3590
  249. 3480 '
  250. 3490 FOR Y=0 TO Y_WIDTH-1
  251. 3500  FOR X=0 TO X_WIDTH-1
  252. 3510   COL=BUF(X_WIDTH*Y+X)
  253. 3520   G=(COL\1024)*8:R=(COL AND &H3E0)/32*8:B=(COL AND 31)*8
  254. 3530   L=INT((G*6+R*3+B)/10)
  255. 3540   IF L=182 AND O_F=4 THEN L=183 'TownsPaint対策
  256. 3550   PSET(X+OX,Y+OY),%L
  257. 3560  NEXT
  258. 3570 NEXT
  259. 3580 GOTO 3810
  260. 3590 '
  261. 3600 FOR Y=0 TO Y_WIDTH-2 STEP 2
  262. 3610  FOR X=0 TO X_WIDTH-2 STEP 2
  263. 3620   COL=BUF(X_WIDTH/2*INT(Y/2)+INT(X/2))
  264. 3630   G=(COL\1024)*8:R=(COL AND &H3E0)/32*8:B=(COL AND 31)*8
  265. 3640   L=INT((G*6+R*3+B)/10)
  266. 3650   IF X=X_WIDTH-2 OR Y=Y_WIDTH-2 THEN 3760
  267. 3660   FOR DY=0 TO 1
  268. 3670    FOR DX=0 TO 1
  269. 3680     COL=BUF(X_WIDTH/2*(INT(Y/2)+DY)+INT(X/2)+DX)
  270. 3690     G=(COL\1024)*8:R=(COL AND &H3E0)/32*8:B=(COL AND 31)*8
  271. 3700     L2=INT((G*6+R*3+B)/10):L2=(L+L2)/2
  272. 3710     IF L2=182 AND O_F=4 THEN L2=183 'TownsPaint対策
  273. 3720     PSET(X+OX+DX,Y+OY+DY),%L2
  274. 3730    NEXT
  275. 3740   NEXT
  276. 3750   GOTO 3770
  277. 3760   LINE(X+OX,Y+OY)-(X+OX+1,Y+OY+1),PSET,%L,BF
  278. 3770  NEXT
  279. 3780 NEXT
  280. 3790 '
  281. 3800 ' MAKE HEADER
  282. 3810 BIT=8:GOSUB *MAKE_BUF:RESTORE *HEAD25:CNT=0:GOSUB *READ_DATA
  283. 3820 ' PALETTE
  284. 3830 FOR I=0 TO 255
  285. 3840  PALETTE I,[I,I,I]
  286. 3850  BF&=I*256:IF BF&>32767 THEN BF&=BF&-65536
  287. 3860  BUF(CNT)=BF&:BUF(CNT+1)=BUF(CNT):BUF(CNT+2)=BUF(CNT):CNT=CNT+3
  288. 3870 NEXT
  289. 3880 '
  290. 3890 GOSUB *DATA_SAVE
  291. 3900 SYMBOL(0,0),"所要時間:"+TIME$,1,1,7,,,8
  292. 3910 RETURN
  293. 3920 '
  294. 3930 '
  295. 3940 '＊＊＊　モノクロ16階調
  296. 3950 '
  297. 3960 *MN16_32
  298. 3970 S_F=32:GOTO *MN16
  299. 3980 *MN16_48
  300. 3990 S_F=48:GOTO *MN16
  301. 4000 *MN16
  302. 4010 TIME$="00:00:00":GOSUB *FILE_READ
  303. 4020 '
  304. 4030 SCREEN@ 0:FOR I=0 TO 15:PALETTE I,[I*16,I*16,I*16]:NEXT
  305. 4040 '
  306. 4050 FOR Y=0 TO Y_WIDTH-1
  307. 4060  FOR X=0 TO X_WIDTH-1
  308. 4070   IF X_F THEN COL=BUF(X_WIDTH*Y+X) ELSE COL=BUF(X_WIDTH/2*INT(Y/2)+INT(X/2))
  309. 4080   G=(COL\1024)*8:R=(COL AND &H3E0)/32*8:B=(COL AND 31)*8
  310. 4090 '
  311. 4100    IF S_F<>32 THEN 4150
  312. 4110    L=INT((G*6+G*3+B)/160*2)
  313. 4120    IF (L MOD 2)=0 THEN L=L/2:GOTO 4200 
  314. 4130    IF (L MOD 2)=1 THEN L=INT(L/2)+ABS(RND>.5!):GOTO 4200
  315. 4140 '
  316. 4150    L=INT((G*6+G*3+B)/160*3)
  317. 4160    IF (L MOD 3)=0 THEN L=L/3:GOTO 4200 
  318. 4170    IF (L MOD 3)=1 THEN L=INT(L/3)+ABS(RND>.66!):GOTO 4200
  319. 4180    IF (L MOD 3)=2 THEN L=INT(L/3)+ABS(RND>.33!):GOTO 4200
  320. 4190 '
  321. 4200   IF L<0  THEN L=0
  322. 4210   IF L>15 THEN L=15
  323. 4220   PSET(X+OX,Y+OY),%L
  324. 4230  NEXT
  325. 4240 NEXT
  326. 4250 CLOSE
  327. 4260 '
  328. 4270 ' MAKE HEADER
  329. 4280 BIT=4:GOSUB *MAKE_BUF:RESTORE *HEAD16:CNT=0:GOSUB *READ_DATA
  330. 4290 ' PALETTE
  331. 4300 BUF(CNT)=0:BUF(CNT+1)=0:BUF(CNT+2)=0:CNT=CNT+3
  332. 4310 FOR I=1 TO 15
  333. 4320  BF&=(I*16+15)*256:IF BF&>32767 THEN BF&=BF&-65536
  334. 4330  BUF(CNT)=BF&:BUF(CNT+1)=BUF(CNT):BUF(CNT+2)=BUF(CNT):CNT=CNT+3
  335. 4340 NEXT
  336. 4350 '
  337. 4360 GOSUB *DATA_SAVE
  338. 4370 SYMBOL(0,0),"所要時間:"+TIME$,1,1,7,,,8
  339. 4380 RETURN
  340. 4390 '
  341. 4400 '
  342. 4410 '
  343. 4420 '＊＊＊　２５６色固定カラー
  344. 4430 '
  345. 4440 *CL256
  346. 4450 DIM BG&(639,1),BR&(639,1),BB&(639,1),SKR(6),SKG(6),SKB(6)
  347. 4460 '
  348. 4470 FOR I=1 TO 7:SKR(I-1)=INT(256*31*I/7):SKG(I-1)=SKR(I-1):NEXT
  349. 4480 FOR I=1 TO 3:SKB(I-1)=INT(256*31*I/3):NEXT
  350. 4490 '
  351. 4500 TIME$="00:00:00":GOSUB *FILE_READ
  352. 4510 '
  353. 4520 SCREEN@ 2:PALETTE
  354. 4530 '
  355. 4540 FOR Y=0 TO Y_WIDTH-1
  356. 4550  LC=(Y AND 1):LB=(Y+1) AND 1
  357. 4560  CG&=0:CB&=0:CR&=0
  358. 4570  FOR X=0 TO X_WIDTH-1
  359. 4580   BG&(X,LB)=0:BR&(X,LB)=0:BB&(X,LB)=0
  360. 4590  NEXT
  361. 4600  FOR X=0 TO X_WIDTH-1
  362. 4610   IF X_F THEN COL=BUF(X_WIDTH*Y+X) ELSE COL=BUF(X_WIDTH/2*INT(Y/2)+INT(X/2))
  363. 4620   CALLM CAL5&,COL,VARPTR(G),VARPTR(R),VARPTR(B)
  364. 4630   CG&=CG&+G*256+BG&(X,LC)
  365. 4640   CR&=CR&+R*256+BR&(X,LC)
  366. 4650   CB&=CB&+B*256+BB&(X,LC)
  367. 4660   DG=0:DB=0:DR=0
  368. 4670   FOR I=6 TO 0 STEP -1
  369. 4680    IF CG& >= SKG(I) THEN DG=I+1:CG&=CG&-SKG(I):I=-1
  370. 4690   NEXT
  371. 4700   FOR I=6 TO 0 STEP -1
  372. 4710    IF CR& >= SKR(I) THEN DR=I+1:CR&=CR&-SKR(I):I=-1
  373. 4720   NEXT
  374. 4730   FOR I=2 TO 0 STEP -1
  375. 4740    IF CB& >= SKB(I) THEN DB=I+1:CB&=CB&-SKB(I):I=-1
  376. 4750   NEXT
  377. 4760   L=INT(DG)*32+INT(DR)*4+DB
  378. 4770   IF L=182 AND O_F=4 THEN L=181 'TownsPaint対策
  379. 4780   PSET(X+OX,Y+OY),%L
  380. 4790   CALLM CAL6&,VARPTR(BG&(X,LB)),CG&,-3
  381. 4800   CALLM CAL6&,VARPTR(BR&(X,LB)),CR&,-3
  382. 4810   CALLM CAL6&,VARPTR(BB&(X,LB)),CB&,-3
  383. 4820   IF X>0 THEN EX=X-1 ELSE EX=X
  384. 4830   CALLM CAL6&,VARPTR(BG&(EX,LB)),CG&,-2
  385. 4840   CALLM CAL6&,VARPTR(BR&(EX,LB)),CR&,-2
  386. 4850   CALLM CAL6&,VARPTR(BB&(EX,LB)),CB&,-2
  387. 4860   IF X<X_WIDTH-1 THEN EX=X+1 ELSE EX=X
  388. 4870   CALLM CAL6&,VARPTR(BG&(EX,LB)),CG&,-3
  389. 4880   CALLM CAL6&,VARPTR(BR&(EX,LB)),CR&,-3
  390. 4890   CALLM CAL6&,VARPTR(BB&(EX,LB)),CB&,-3
  391. 4900   CG&=CG&/2:CR&=CR&/2:CB&=CB&/2
  392. 4910  NEXT
  393. 4920 NEXT
  394. 4930 CLOSE
  395. 4940 '
  396. 4950 ' MAKE HEADER
  397. 4960 BIT=8:GOSUB *MAKE_BUF:RESTORE *HEAD25:CNT=0:GOSUB *READ_DATA
  398. 4970 ' PALETTE
  399. 4980 BUF(CNT)=0:BUF(CNT+1)=0:BUF(CNT+2)=0:CNT=CNT+3
  400. 4990 FOR I=1 TO 15
  401. 5000  BF&=(I*16+15)*256:IF BF&>32767 THEN BF&=BF&-65536
  402. 5010  BUF(CNT)=BF&:BUF(CNT+1)=BUF(CNT):BUF(CNT+2)=BUF(CNT):CNT=CNT+3
  403. 5020 NEXT
  404. 5030 '
  405. 5040 GOSUB *DATA_SAVE
  406. 5050 SYMBOL(0,0),"所要時間:"+TIME$,1,1,7,,,8
  407. 5060 RETURN
  408. 5070 '
  409. 5080 '
  410. 5090 '
  411. 5100 '＊＊＊　８色固定カラー
  412. 5110 '
  413. 5120 *CL8
  414. 5130 DIM BG&(639,1),BR&(639,1),BB&(639,1)
  415. 5140 TIME$="00:00:00":GOSUB *FILE_READ
  416. 5150 '
  417. 5160 SCREEN@ 0:PALETTE
  418. 5170 '
  419. 5180 FOR Y=0 TO Y_WIDTH-1
  420. 5190  LC=(Y AND 1):LB=(Y+1) AND 1
  421. 5200  CG&=0:CB&=0:CR&=0
  422. 5210  FOR X=0 TO X_WIDTH-1
  423. 5220   BG&(X,LB)=0:BR&(X,LB)=0:BB&(X,LB)=0
  424. 5230  NEXT
  425. 5240  FOR X=0 TO X_WIDTH-1
  426. 5250   IF X_F THEN COL=BUF(X_WIDTH*Y+X) ELSE COL=BUF(X_WIDTH/2*INT(Y/2)+INT(X/2))
  427. 5260   CALLM CAL5&,COL,VARPTR(G),VARPTR(R),VARPTR(B)
  428. 5270   CG&=CG&+G*256+BG&(X,LC)
  429. 5280   CR&=CR&+R*256+BR&(X,LC)
  430. 5290   CB&=CB&+B*256+BB&(X,LC)
  431. 5300   CL=8
  432. 5310   IF CG&>=&H1F00 THEN CL=CL+4:CG&=CG&-&H1F00
  433. 5320   IF CR&>=&H1F00 THEN CL=CL+2:CR&=CR&-&H1F00
  434. 5330   IF CB&>=&H1F00 THEN CL=CL+1:CB&=CB&-&H1F00
  435. 5340   IF CL<>8 THEN PSET(X+OX,Y+OY),%CL
  436. 5350   CALLM CAL6&,VARPTR(BG&(X,LB)),CG&,-3
  437. 5360   CALLM CAL6&,VARPTR(BR&(X,LB)),CR&,-3
  438. 5370   CALLM CAL6&,VARPTR(BB&(X,LB)),CB&,-3
  439. 5380   IF X>0 THEN EX=X-1 ELSE EX=0
  440. 5390   CALLM CAL6&,VARPTR(BG&(EX,LB)),CG&,-2
  441. 5400   CALLM CAL6&,VARPTR(BR&(EX,LB)),CR&,-2
  442. 5410   CALLM CAL6&,VARPTR(BB&(EX,LB)),CB&,-2
  443. 5420   IF X<X_WIDTH-1 THEN EX=X+1 ELSE EX=X
  444. 5430   CALLM CAL6&,VARPTR(BG&(EX,LB)),CG&,-3
  445. 5440   CALLM CAL6&,VARPTR(BR&(EX,LB)),CR&,-3
  446. 5450   CALLM CAL6&,VARPTR(BB&(EX,LB)),CB&,-3
  447. 5460   CG&=CG&/2:CR&=CR&/2:CB&=CB&/2
  448. 5470  NEXT
  449. 5480 NEXT
  450. 5490 CLOSE
  451. 5500 '
  452. 5510 ' MAKE HEADER
  453. 5520 BIT=4:GOSUB *MAKE_BUF:RESTORE *HEAD16:CNT=0:GOSUB *READ_DATA
  454. 5530 ' PALETTE
  455. 5540 BUF(CNT)=0:BUF(CNT+1)=0:BUF(CNT+2)=0:CNT=CNT+3
  456. 5550 FOR I=1 TO 15
  457. 5560  BF&=(I*16+15)*256:IF BF&>32767 THEN BF&=BF&-65536
  458. 5570  BUF(CNT)=BF&:BUF(CNT+1)=BUF(CNT):BUF(CNT+2)=BUF(CNT):CNT=CNT+3
  459. 5580 NEXT
  460. 5590 '
  461. 5600 GOSUB *DATA_SAVE
  462. 5610 SYMBOL(0,0),"所要時間:"+TIME$,1,1,7,,,8
  463. 5620 RETURN
  464. 5630 '
  465. 5640 '
  466. 5650 '
  467. 5660 '＊＊＊　モノクロ単色
  468. 5670 '
  469. 5680 *MN1
  470. 5690 DIM BG&(639,1)
  471. 5700 '
  472. 5710 TIME$="00:00:00":GOSUB *FILE_READ
  473. 5720 '
  474. 5730 SCREEN@ 0:PALETTE
  475. 5740 '
  476. 5750 FOR Y=0 TO Y_WIDTH-1
  477. 5760  LC=(Y AND 1):LB=(Y+1) AND 1
  478. 5770  CG&=0
  479. 5780  FOR X=0 TO X_WIDTH-1
  480. 5790   BG&(X,LB)=0
  481. 5800  NEXT
  482. 5810  FOR X=0 TO X_WIDTH-1
  483. 5820   IF X_F THEN COL=BUF(X_WIDTH*Y+X) ELSE COL=BUF(X_WIDTH/2*INT(Y/2)+INT(X/2))
  484. 5830   CALLM CAL5&,COL,VARPTR(G),VARPTR(R),VARPTR(B)
  485. 5840   COL=INT(((G*6+R*3+B)/10)*256)
  486. 5850   CG&=CG&+COL+BG&(X,LC)
  487. 5860   IF CG&>=&H1F00 THEN CG&=CG&-&H1F00:PSET(X+OX,Y+OY),%15
  488. 5870   CALLM CAL6&,VARPTR(BG&(X,LB)),CG&,-3
  489. 5880   IF X>0 THEN EX=X-1 ELSE EX=X
  490. 5890   CALLM CAL6&,VARPTR(BG&(EX,LB)),CG&,-2
  491. 5900   IF X<X_WIDTH-1 THEN EX=X+1 ELSE EX=X
  492. 5910   CALLM CAL6&,VARPTR(BG&(EX,LB)),CG&,-3
  493. 5920   CG&=INT(CG&/2)
  494. 5930  NEXT
  495. 5940 NEXT
  496. 5950 CLOSE
  497. 5960 '
  498. 5970 IF O_F=4 THEN 6030
  499. 5980 ' MAKE TIF HEADER
  500. 5990 BIT=1:GOSUB *MAKE_BUF:RESTORE *HEADTIF:CNT=0:GOSUB *READ_DATA
  501. 6000 CNT=248:GOSUB *READ_DATA
  502. 6010 GOTO 6110
  503. 6020 ' MAKE HEADER
  504. 6030 BIT=4:GOSUB *MAKE_BUF:RESTORE *HEAD16:CNT=0:GOSUB *READ_DATA
  505. 6040 ' PALETTE
  506. 6050 BUF(CNT)=0:BUF(CNT+1)=0:BUF(CNT+2)=0:CNT=CNT+3
  507. 6060 FOR I=1 TO 15
  508. 6070  BF&=(I*16+15)*256:IF BF&>32767 THEN BF&=BF&-65536
  509. 6080  BUF(CNT)=BF&:BUF(CNT+1)=BUF(CNT):BUF(CNT+2)=BUF(CNT):CNT=CNT+3
  510. 6090 NEXT
  511. 6100 '
  512. 6110 GOSUB *DATA_SAVE
  513. 6120 SYMBOL(0,0),"所要時間:"+TIME$,1,1,7,,,8
  514. 6130 RETURN
  515. 6140 '
  516. 6150 '
  517. 6160 '＊＊＊　サブルーチン　＊＊＊
  518. 6170 '
  519. 6180 *FILE_READ
  520. 6190 GOSUB *FILE_OPEN
  521. 6200 IF X_WIDTH>512 OR Y_WIDTH>256 THEN GOSUB *FILE_GET:GOTO 6250
  522. 6210 CLOSE:LOAD@ FIN$:GET@A(0,0)-(X_WIDTH-1,Y_WIDTH-1),BUF
  523. 6220 '
  524. 6230 IF NOT(X_F) THEN X_WIDTH=X_WIDTH*2:Y_WIDTH=Y_WIDTH*2
  525. 6240 IF C_F THEN OX=(640-X_WIDTH)/2:OY=(480-Y_WIDTH)/2 ELSE OX=0:OY=0
  526. 6250 RETURN
  527. 6260 '
  528. 6270 '
  529. 6280 *FILE_OPEN
  530. 6290 OPEN "I",#1,FIN$
  531. 6300 ID$=INPUT$(3,1):DMY$=INPUT$(1,1)
  532. 6310 IF ID$="II*" THEN BYTE_ORDER=1:GOTO 6350
  533. 6320 IF ID$="MM*" THEN BYTE_ORDER=0:GOTO 6350
  534. 6330 PRINT "TIFFファイルではありません":END
  535. 6340 '
  536. 6350 GOSUB *GETLONG:IFD_OFST=VALUE&
  537. 6360 '
  538. 6370 CLOSE:OPEN "I",#1,FIN$:FOR I=1 TO IFD_OFST:DMY$=INPUT$(1,1):NEXT
  539. 6380 GOSUB *GETWORD:NUM_IFD=VALUE&:PRINT :PRINT "Reading TAG = ";
  540. 6390 FOR I=1 TO NUM_IFD
  541. 6400  GOSUB *GETTAG:PRINT HEX$(TAG);" ";
  542. 6410  IF TAG=&H100 THEN X_WIDTH=DT&
  543. 6420  IF TAG=&H101 THEN Y_WIDTH=DT&
  544. 6430  IF TAG=&H102 THEN COL=DT&
  545. 6440  IF TAG=&H103 THEN ASSUKU=DT&
  546. 6450  IF TAG=&H111 THEN OFFSET=DT&
  547. 6460  IF TAG=&H117 THEN DATA_SIZE&=DT&
  548. 6470  IF TAG=&H140 THEN PAL_OFFSET=DT&
  549. 6480 NEXT
  550. 6490 PRINT :CLOSE
  551. 6500 IF ASSUKU<>1 THEN PRINT "非圧縮ファイルしか扱えません":END
  552. 6510 IF COL<>16 THEN PRINT "３万色ファイルではありません":END
  553. 6520 '
  554. 6530 OPEN "I",#1,FIN$
  555. 6540 FOR I=1 TO OFFSET/128:A$=INPUT$(128,1):NEXT
  556. 6550 '
  557. 6560 IF NOT(X_F) AND (X_WIDTH>320 OR Y_WIDTH>240) THEN X_F=-1:                      PRINT "元画像が320×240ドットより大きいので拡大処理はできません"
  558. 6570 RETURN
  559. 6580 '
  560. 6590 *GETTAG
  561. 6600 GOSUB *GETWORD:TAG=VALUE&
  562. 6610 GOSUB *GETWORD:TYPE=VALUE&
  563. 6620 GOSUB *GETLONG
  564. 6630 GOSUB *GETLONG:DT&=VALUE&
  565. 6640 RETURN
  566. 6650 '
  567. 6660 *FILE_GET
  568. 6670 FOR I&=0 TO X_WIDTH*Y_WIDTH-1
  569. 6680  GOSUB *GETWORD:DT&=VALUE&
  570. 6690  IF DT&>32767 THEN DT&=DT&-65536
  571. 6700  BUF(I&)=DT&
  572. 6710 NEXT
  573. 6720 CLOSE:RETURN
  574. 6730 '
  575. 6740 *GETWORD
  576. 6750 IF BYTE_ORDER=1 THEN VALUE&=ASC(INPUT$(1,1))+ASC(INPUT$(1,1))*256
  577. 6760 IF BYTE_ORDER=0 THEN VALUE&=ASC(INPUT$(1,1))*256+ASC(INPUT$(1,1))
  578. 6770 RETURN
  579. 6780 '
  580. 6790 *GETLONG
  581. 6800 IF BYTE_ORDER=1 THEN VALUE&=ASC(INPUT$(1,1))+ASC(INPUT$(1,1))*256+ASC(INPUT$(1,1))*65536+ASC(INPUT$(1,1))*16777216
  582. 6810 IF BYTE_ORDER=0 THEN VALUE&=ASC(INPUT$(1,1))*16777216+ASC(INPUT$(1,1))*65536+ASC(INPUT$(1,1))*256+ASC(INPUT$(1,1))
  583. 6820 RETURN
  584. 6830 '
  585. 6840 *MAKE_BUF
  586. 6850 ERASE BUF
  587. 6860 IF C_F THEN 6930
  588. 6870 IF BIT=1 THEN BUFSIZE&=INT((INT((X_WIDTH+7)/8)*Y_WIDTH+1)/2)
  589. 6880 IF BIT=4 THEN BUFSIZE&=INT((INT((X_WIDTH+7)/8)*Y_WIDTH*4+1)/2)
  590. 6890 IF BIT=8 THEN BUFSIZE&=INT((X_WIDTH*Y_WIDTH+1)/2)
  591. 6900 DIM BUF(BUFSIZE&+787)
  592. 6910 IF BIT=1 THEN DIM BUF2(BUFSIZE&)
  593. 6920 RETURN
  594. 6930 IF BIT=1 THEN BUFSIZE&=19200
  595. 6940 IF BIT=4 THEN BUFSIZE&=76800
  596. 6950 IF BIT=8 THEN BUFSIZE&=153600
  597. 6960 DIM BUF(BUFSIZE&+787)
  598. 6970 IF BIT=1 THEN DIM BUF2(BUFSIZE&)
  599. 6980 RETURN
  600. 6990 '
  601. 7000 *DATA_SAVE
  602. 7010 BUF(CNT)=0:CNT=CNT+1 '背景番号
  603. 7020 IF C_F THEN X_WIDTH=640:Y_WIDTH=480
  604. 7030 ON O_F GOTO 7060,7080,7100,7230
  605. 7040 RETURN
  606. 7050 'パレット無TIF
  607. 7060 SAVE@ FOUT$,(0,0)-(X_WIDTH-1,Y_WIDTH-1):RETURN
  608. 7070 'パレット有TIF
  609. 7080 SAVE@ FOUT$,(0,0)-(X_WIDTH-1,Y_WIDTH-1),1:RETURN
  610. 7090 '単色TIF
  611. 7100 BUF(15)=X_WIDTH:BUF(21)=Y_WIDTH
  612. 7110 GET@(0,0)-(X_WIDTH-1,Y_WIDTH-1),BUF2,0
  613. 7120 FOR I=0 TO BUFSIZE&:BUF(256+I)=BUF2(I):NEXT
  614. 7130 PTH$="":NM$="":I=LEN(FOUT$):D$=RIGHT$(FOUT$,1)
  615. 7140 WHILE I<>0 AND D$<>"\" AND D$<>":"
  616. 7150  D$=MID$(FOUT$,I,1)
  617. 7160  NM$=D$+NM$:I=I-1
  618. 7170 WEND
  619. 7180 PTH$=LEFT$(FOUT$,I)
  620. 7190 SAVE@ PTH$+"_tmp.snc",BUF:NAME PTH$+"_tmp.snc" AS NM$
  621. 7200 RETURN
  622. 7210 '
  623. 7220 'Pxx
  624. 7230 BF&=X_WIDTH*Y_WIDTH  '背景サイズ
  625. 7240 IF (BF& AND 65536)>32767 THEN BUF(CNT)=(BF& AND 65536)-65536                ELSE BUF(CNT)=(BF& AND 65536)
  626. 7250 CNT=CNT+1:BUF(CNT)=(BF& AND &HFFF0000)/65536:CNT=CNT+1
  627. 7260 BUF(CNT)=0:BUF(CNT+1)=0:CNT=CNT+2 '左上座標 (原点固定)
  628. 7270 BUF(CNT)=X_WIDTH-1:BUF(CNT+1)=Y_WIDTH-1:CNT=CNT+2 ' 右下座標
  629. 7280 GET@A(0,0)-(X_WIDTH-1,Y_WIDTH-1),BUF,CNT
  630. 7290 SAVE@ FOUT$,BUF
  631. 7300 RETURN
  632. 7310 '
  633. 7320 *READ_DATA
  634. 7330 READ D1$,D2$
  635. 7340 WHILE D1$<>"*"
  636. 7350  BF&=VAL("&H"+D2$)*256+VAL("&H"+D1$)
  637. 7360  IF BF&>32767 THEN BUF(CNT)=BF&-65536 ELSE BUF(CNT)=BF&
  638. 7370  CNT=CNT+1:READ D1$,D2$
  639. 7380 WEND
  640. 7390 RETURN
  641. 7400 '
  642. 7410 ' p16 header
  643. 7420 *HEAD16
  644. 7430 DATA 59,55,4B,49,FF,FF,FF,FF,FF,FF,FF,FF,FF,FF,FF,FF
  645. 7440 DATA 01,00,03,00,00,00,00,00,*,*
  646. 7450 ' p25 header
  647. 7460 *HEAD25
  648. 7470 DATA 59,55,4B,49,FF,FF,FF,FF,FF,FF,FF,FF,FF,FF,FF,FF
  649. 7480 DATA 01,00,0C,00,00,00,00,00,*,*
  650. 7490 '
  651. 7500 ' tiff mono header
  652. 7510 *HEADTIF
  653. 7520 DATA 49,49,2A,00,08,00,00,00,0F,00
  654. 7530 '    tag    type   length       value/offset
  655. 7540 DATA FF,00, 03,00, 01,00,00,00, 01,00,00,00
  656. 7550 DATA 00,01, 03,00, 01,00,00,00, ff,ff,00,00 '  横ドット
  657. 7560 DATA 01,01, 03,00, 01,00,00,00, ff,ff,00,00 '  縦ドット
  658. 7570 DATA 02,01, 03,00, 01,00,00,00, 01,00,00,00  ' 1ビット/ピクセル
  659. 7580 DATA 03,01, 03,00, 01,00,00,00, 01,00,00,00  ' 圧縮なし
  660. 7590 DATA 06,01, 03,00, 01,00,00,00, 00,00,00,00  ' 2値イメージ
  661. 7600 DATA 0A,01, 03,00, 01,00,00,00, 01,00,00,00
  662. 7610 DATA 11,01, 04,00, 01,00,00,00, 00,02,00,00 ' 画像データオフセット
  663. 7620 DATA 12,01, 03,00, 01,00,00,00, 01,00,00,00
  664. 7630 DATA 15,01, 03,00, 01,00,00,00, 01,00,00,00
  665. 7640 DATA 18,01, 03,00, 01,00,00,00, 00,00,00,00
  666. 7650 DATA 19,01, 03,00, 01,00,00,00, 01,00,00,00
  667. 7660 DATA 1A,01, 05,00, 01,00,00,00, F0,01,00,00
  668. 7670 DATA 1B,01, 05,00, 01,00,00,00, F8,01,00,00
  669. 7680 DATA 1C,01, 03,00, 01,00,00,00, 01,00,00,00
  670. 7690 DATA *,* '～01EF   padding NULL
  671. 7700 DATA 4B,00,00,00, 01,00,00,00 '  1F0 横解像度 75/1
  672. 7710 DATA 4B,00,00,00, 01,00,00,00 '  1F8 縦解像度 75/1
  673. 7720 DATA *,*
  674.