十進 BASIC で、JPG ファイルを作る。

 投稿者：SECOND  投稿日：2009年10月13日(火)22時43分48秒
  !十進 BASIC で、JPG ファイルを作る。
!
!先に投稿した、デコーダーと対を成すものですが、此方はベースラインのみです。
!DCT 変換、ハフマンコード化 …JPG ファイルまでを、見えるプログラムで、実行。

!ハフマン・コードについては、標準テーブルを使わず、
!ランレングス・頻度の測定と、ハフマン・ツリーの作成を行い、それによる
!専用ハフマン・テーブルで、コード化します。（本来のハフマン・コード。）

DEBUG ON
!------------------
!JPG.BAS  09.10.13
!------------------
!テキスト・ウィンドウの、左上位置(x0,y0)と、幅(xw,yw)。
CALL SetWindowPos( WinHandle("TEXT" ),0, 15,172,500,520, 0)

SUB SetWindowPos( handle,C2, x0,y0,xw,yw, nFLG) !nFLG: 0=x0y0xwyw 1=x0y0 2=xwyw
   ASSIGN "user32.dll","SetWindowPos"
END SUB
!----------------------------------------------------------
LET FL$="baseline.jpg" ! 削除すると、ダイアログ・ボックス入力。
SET ECHO "OFF"
ASK DIRECTORY s$
IF FL$>"" THEN PRINT "カレント DIR："& s$ ELSE file getname FL$, "jpg"
PRINT "出力ファイル："& FL$
IF FL$>"" THEN PRINT "上書き。又は作成されます。…"& "Ok？[Enter]"
IF FL$>"" THEN CHARACTER INPUT k$
IF FL$="" OR k$<>CHR$(13) THEN
   PRINT "中止"
   STOP
END IF

OPTION ARITHMETIC NATIVE
OPTION BASE 0
OPTION CHARACTER byte
SET TEXT background "OPAQUE"
ASK BITMAP SIZE bmx,bmy
SET WINDOW 0,bmx, bmy,0
!
DIM D8(1000,1000)   !sample picture
DIM D2(1000,1000,2) !Y=D2(,,0)  Cb=D2(,,1)  Cr=D2(,,2)
DIM MH(2),MV(2)     !MCU.Ybr.H()V()
DIM HDC(2),HAC(2)   !hT.table selection
DIM QS(2),CoID(255) !qT.table selection
!
DIM U(63),V(63)         !zigzag
DIM DQ(7,7,3)           !DQT
DIM DH(16,7),DV(255,7)  !DHT
DIM B(255+1,7),L(255,7) !huffman.code & length ( MAKE_H2 )
DIM B2(2)               !Ybr D.C.成分 starting
DIM T(7,7),X(7),XO(7)   !DDCT8X8
!
!---encorder
DIM SV(255,3)            !ZFRE0     頻度SV( 座標)
DIM S_(255,3)            !MAKE_DHT  頻度SV( 座標)--> 頻度S_( 降順No.) 座標DV( 降順No.)
DIM F_(255),Tr(16,255,3) !TREE3
!---lister
LET crlf$=CHR$(13)& CHR$(10)
DIM W_$(7)
LET W_$(0)="Y.DC"
LET W_$(1)="Y.AC"
LET W_$(2)="C.DC"
LET W_$(3)="C.AC"
!
SET VIEWPORT 0,0.4,0.6,1
CALL sample(DX$,DY$)     !サンプル画像。
LET DX=VAL(DX$)
LET DY=VAL(DY$)
MAT D8=ZER(DX-1,DY-1)
SET VIEWPORT 0, 1, 0, 1
SET WINDOW 0,bmx, bmy,0
SET COLOR MODE "NATIVE"
ASK PIXEL ARRAY (0,0) D8
! MAT PLOT CELLS,IN 250,250; 450,450: D8 ! check
!
LET CMO=2   !CMO=0(mono.) CMO=2(color)
LET SD=1    !encoder 量子化テーブル調整 1/SD
CALL DQTINI !DQ(,,0)~DQ(,,1)~{zigzag U()V()},MH(),MV()
LET DU =CEIL(DX/(8*MH(0)))*8*MH(0)  !Uwidth= (8X8)*2 bound by MCU size
LET DV_=CEIL(DY/(8*MV(0)))*8*MV(0)  !Vwidth= (8X8)*1
MAT D2=ZER(DU-1,DV_-1,2) !Y=D2(,,0)  Cb=D2(,,1)  Cr=D2(,,2)
!
CALL YbrRGB  ! Ybr D2()<--RGB D8()
LET MHT=1    ! flag. uncondition making huff.table
CALL DDCT8X8 ! D2() -->DCT -->Quantization
CALL ZZRL0   ! encoder
!---
PRINT "-------------------------"
PRINT "Encoder huffman Code"
FOR J=0 TO CMO+1
   CALL list_HT(W_$(J),J) ! value Sort !H2.LST
NEXT J
beep
PRINT "終了"

!---------
SUB YbrRGB
!--------- JPG 色空間 -------------------------
! | Y |   | 0.2990   +0.5870   +0.1140  | | R |
! |B-Y| = |-0.1687   -0.3313   +0.5000  | | G |
! |R-Y|   | 0.5000   -0.4187   -0.0813  | | B |
!
! | R |   | 1         0        +1.40200 | | Y |
! | G | = | 1        -0.34414  -0.71414 | |B-Y|
! | B |   | 1        +1.77200   0       | |R-Y|
!----------------------------------------------
   FOR V0=0 TO DY-1
      FOR U0=0 TO DX-1
         LET w1=   MOD(D8(U0,V0),256)      !R
         LET w2=MOD(IP(D8(U0,V0)/256),256) !G
         LET w3=    IP(D8(U0,V0)/65536)    !B
         LET D2(U0,V0,0)= 0.2990*w1+0.5870*w2+0.1140*w3 !Y
         LET D2(U0,V0,1)=-0.1687*w1-0.3313*w2+0.5000*w3 !Cb
         LET D2(U0,V0,2)= 0.5000*w1-0.4187*w2-0.0813*w3 !Cr
      NEXT U0
   NEXT V0
END SUB

!-----------
SUB DQTINI
   RESTORE
   !---DQT quantization
   FOR j=0 TO 1
      FOR V_=0 TO 7
         FOR U_=0 TO 7
            READ W
            LET DQ(U_,V_,j)=CEIL(W/SD) ! inhibit 0
         NEXT U_
      NEXT V_
   NEXT j
   !---zigzag-U()V()
   FOR V_=0 TO 7
      FOR U_=0 TO 7
         READ i
         LET U(i)=U_
         LET V(i)=V_
      NEXT U_
   NEXT V_
   !---HT selection
   MAT READ HDC !Y Cb Cr
   MAT READ HAC !Y Cb Cr
   !---QT selection
   MAT READ QS  !Y Cb Cr
   !---MCU size
   MAT MH=CON   !Y Cb Cr =1
   MAT MV=CON   !Y Cb Cr =1
   IF 0< CMO THEN
      LET MH(0)=2 !Y
      LET MV(0)=2 !Y
   END IF
END SUB

!---quantization table
!輝度( SMPTE 370M ).Y
!*DQTY
DATA 32, 16, 17, 18, 18, 19, 42, 44
DATA 16, 17, 18, 18, 19, 38, 43, 45
DATA 17, 18, 19, 19, 40, 41, 45, 48
DATA 18, 18, 19, 40, 41, 42, 46, 49
DATA 18, 19, 40, 41, 42, 43, 48,101
DATA 19, 38, 41, 42, 43, 44, 98,104
DATA 42, 43, 45, 46, 48, 98,109,116
DATA 44, 45, 48, 49,101,104,116,123

!---quantization table
!色差( SMPTE 370M ).Cb Cr
!*DQTC
DATA 32, 16, 17, 25, 26, 26, 42, 44
DATA 16, 17, 25, 25, 26, 38, 43, 91
DATA 17, 25, 26, 27, 40, 41, 91, 96
DATA 25, 25, 27, 40, 41, 84, 93,197
DATA 26, 26, 40, 41, 84, 86,191,203
DATA 26, 38, 41, 84, 86,177,197,209
DATA 42, 43, 91, 93,191,197,219,232
DATA 44, 91, 96,197,203,209,232,246

!---Zigzag table
DATA  0, 1, 5, 6,14,15,27,28
DATA  2, 4, 7,13,16,26,29,42
DATA  3, 8,12,17,25,30,41,43
DATA  9,11,18,24,31,40,44,53
DATA 10,19,23,32,39,45,52,54
DATA 20,22,33,38,46,51,55,60
DATA 21,34,37,47,50,56,59,61
DATA 35,36,48,49,57,58,62,63

!---HT selection
DATA 0,2,2 !DC. Y Cb Cr
DATA 1,3,3 !AC. Y Cb Cr

!---QT selection
DATA 0,1,1 ! Y Cb Cr

!==========================================
! analizing frequency SV(nnnn,ssss) for DHT
SUB ZFRE0
   MAT SV=ZER
   LET B2(0)=0 !  Y.DC( start prediction)
   LET B2(1)=0 ! Cb.DC
   LET B2(2)=0 ! Cr.DC
   !---
   FOR V09=0 TO DV_-1 STEP 8*MV(0)
      FOR U09=0 TO DU-1 STEP 8*MH(0)
      !---MCU
         FOR P=0 TO CMO ! ( 0=Y 1=Cb 2=Cr)
            FOR V0=V09 TO V09+8*MV(P)-1 STEP 8
               FOR U0=U09 TO U09+8*MH(P)-1 STEP 8
                  CALL F_BLK0
               NEXT U0
            NEXT V0
         NEXT P
         !---
      NEXT U09
   NEXT V09
   !---
   CALL MAKE_DHT !DH( ,J) DV( ,J) <--S_( ,J)
END SUB

!Page-2 へ続く 		 

つづき２

 投稿者：SECOND  投稿日：2009年10月13日(火)22時42分38秒
  !Page-2 の始め

! haffman Transform. main
SUB ZZRL0
!   ---pass-1 analize frequency SV(nnnn,ssss) -->DV( ,J) DH( ,J)
   IF 0< MHT OR DH(0,0)=0 THEN CALL ZFRE0
   !---pass-2
   CALL MAKE_H2 ! huffman code=B(V,J) len.=L(V,J) <-- DH( ,J) DV( ,J)
   !---
   LET byt=0 !!!
   CALL WOPEN
   CALL W_BIN31
   !---
   LET Hw=0 !bits stream buffer
   LET BC=0 !bits in Hw
   !---
   LET B2(0)=0 !  Y.DC( start prediction)
   LET B2(1)=0 ! Cb.DC
   LET B2(2)=0 ! Cr.DC
   !---
   FOR V09=0 TO DV_-1 STEP 8*MV(0)
      FOR U09=0 TO DU-1 STEP 8*MH(0)
      !---MCU
         FOR P=0 TO CMO    !( 0=Y 1=Cb 2=Cr)
            FOR V0=V09 TO V09+8*MV(P)-1 STEP 8
               FOR U0=U09 TO U09+8*MH(P)-1 STEP 8
                  CALL W_BLK0
               NEXT U0
            NEXT V0
         NEXT P
         !---
      NEXT U09
   NEXT V09
   CALL W_FLUSH
   !---EOI
   CALL WRT_H("FFD9")
   CLOSE #1
   PRINT "byte size:";byt
END SUB

!------
SUB F_BLK0
   LET J=2*SGN(P) ! ( 0=Y 1=Cb 2=Cr)
   !---D.C.part
   LET W=D2(U0+U(0),V0+V(0),P)
   LET SY=W-B2(P)
   LET B2(P)=W ! previous of D.C.difference
   IF SY<>0 THEN LET SS=LEN(BSTR$(ABS( SY),2)) ELSE LET SS=0 ! bit_length
   LET SV(SS,J)=SV(SS,J)+1
   !---A.C.parts
   FOR AE=63 TO 0 STEP -1
      IF 0<>D2(U0+U(AE),V0+V(AE),P) THEN EXIT FOR
   NEXT AE
   !---
   LET Z=0 !zero run counter
   FOR A_=1 TO AE
      LET SY=D2(U0+U(A_),V0+V(A_),P)
      IF SY=0 AND Z< 15 THEN
         LET Z=Z+1
      ELSE
         IF SY<>0 THEN LET SS=LEN(BSTR$(ABS(SY),2)) ELSE LET SS=0 ! bit_length
         LET W=Z*16+SS
         LET Z=0
         LET SV(W,J+1)=SV(W,J+1)+1
      END IF
   NEXT A_
   IF A_< 64 THEN LET SV(0,J+1)=SV(0,J+1)+1 !End Of Block
END SUB

SUB W_BLK0
   LET J=2*SGN(P) ! ( 0=Y 1=Cb 2=Cr)
   !---D.C.part absolute SY bits length
   LET W=D2(U0+U(0),V0+V(0),P)
   LET SY=W-B2(P)
   LET B2(P)=W ! previous of D.C.difference
   IF SY<>0 THEN LET SS=LEN(BSTR$(ABS( SY),2)) ELSE LET SS=0 ! bit_length
   LET L_=L(SS,J)
   LET Ww=B(SS,J)
   CALL W_HUFF
   !---D.C.extent
   IF SS<>0 THEN
      IF SY< 0 THEN LET SY=SY+2^SS-1 !add maxim. in same bit_length.
      LET L_=SS
      LET Ww=SY*2^(16-L_)
      CALL W_HUFF
   END IF
   !---A.C.parts
   FOR AE=63 TO 0 STEP -1
      IF 0<>D2(U0+U(AE),V0+V(AE),P) THEN EXIT FOR
   NEXT AE
   !---
   LET Z=0 !zero run counter
   FOR A_=1 TO AE
      LET SY=D2(U0+U(A_),V0+V(A_),P)
      IF SY=0 AND Z< 15 THEN
         LET Z=Z+1
      ELSE
         IF SY<>0 THEN LET SS=LEN(BSTR$(ABS(SY),2)) ELSE LET SS=0 ! bit_length
         LET W=Z*16+SS
         LET Z=0
         LET L_=L(W,J+1)
         LET Ww=B(W,J+1)
         CALL W_HUFF
         !---A.C.extent
         IF SS<>0 THEN
            IF SY< 0 THEN LET SY=SY+2^SS-1 !add maxim. in same bit_length.
            LET L_=SS
            LET Ww=SY*2^(16-L_)
            CALL W_HUFF
         END IF
      END IF
   NEXT A_
   IF A_< 64 THEN
      LET L_=L(0,J+1)
      LET Ww=B(0,J+1)
      CALL W_HUFF !End Of Block
   END IF
END SUB

!-----
!Ww：b15 ~0 左詰め 入力 bit_stream.  L_：bit長
SUB W_HUFF
   LET Hw=Hw+Ww*2^(-BC-8)
   LET BC=BC+L_
   DO WHILE 8<=BC
      CALL WRT_D( IP(Hw))
      IF IP(Hw)=255 THEN CALL WRT_D( 0)
      LET Hw=FP(Hw)*256
      LET BC=BC-8
   LOOP
END SUB

!flush bit buffer with byte_bound( fill"1"in blank)
SUB W_FLUSH
   IF BC<>0 THEN
      LET w=Hw +2^(8-BC)-1
      CALL WRT_D( w)
      IF w=255 THEN CALL WRT_D( 0)
   END IF
END SUB

!=====================
!pre hafman Transform.
!sort frequency S_() of nnnnssss( zero_run_length data)
!make DH() DV()

SUB MAKE_DHT
   MAT DH=ZER
   !---debug monitor
   PRINT "-----------------------------------------"
   FOR J=0 TO CMO+1  ! CMO =0=mono =2=color
      PRINT "Zero_Run_Length 頻度表　(→)画素bit幅0~15、(↓)直前０数0~15"
      PRINT W_$(J)
      CALL msg00( SV, 0,255,J, 5) ! SV( 0~255, J)
      PRINT "total=";Tx
   NEXT J
   PRINT
   !---
   FOR P=0 TO CMO+1 ! P(0~1=Y.DC~AC  2~3=C.DC~AC), CMO( 0=mono 2=color)
   !--- make S_(,)DV(,)<-- SV(,)
      LET SE=-1
      FOR i=0 TO 255
         IF SV(i,P)<>0 THEN
            LET SE=SE+1
            LET S_(SE,P)=SV(i,P)
            LET DV(SE,P)=i
         END IF
      NEXT i
      PRINT "===================================="
      PRINT W_$(P)
      PRINT "Zero Run Length 頻度表を詰めたもの"
      CALL msg00( S_, 0,SE,P, 5)  ! S_(0~SE, P)
      PRINT "表座標(0~F=直前０数：0~F=画素bit長)"
      CALL msg0x( DV, 0,SE,P, 5)  ! DV(0~SE, P)
      !---
      CALL Qsort(0,SE)
      CALL TREE3
      !---
      PRINT
      PRINT " Encoder DHT table"
      PRINT " (→)コード長1~16の、各個数"
      CALL msg0x( DH, 1,16  ,P, 3) ! DH(1~16, P)
      PRINT " 頻度順の、表座標(0~F=直前０数：0~F=画素bit長)"
      CALL msg0x( DV, 0,Tx-1,P, 3) ! DV(0~Tx-1, P)
      PRINT
   NEXT P
END SUB

SUB msg00( M(,), S,E,J, w)
   LET Tx=0
   LET w$=""
   FOR i=S TO E
      LET Tx=Tx+M(i,J)
      LET w$=w$& USING$( REPEAT$("#",w),M(i,J))
      IF MOD(i-S,16)=15 THEN LET w$=w$& crlf$
   NEXT i
   IF MOD(i-S,16)=0 THEN PRINT w$; ELSE PRINT w$
END SUB

SUB msg0x( M(,), S,E,J, w)
   LET Tx=0
   LET w$=""
   FOR i=S TO E
      LET Tx=Tx+M(i,J)
      LET w$=w$& REPEAT$(" ",w-2)& RIGHT$("0"& BSTR$(M(i,J),16),2)
      IF MOD(i-S,16)=15 THEN LET w$=w$& crlf$
   NEXT i
   IF MOD(i-S,16)=0 THEN PRINT w$; ELSE PRINT w$
END SUB

!Page-3 へ続く 		 

つづき３

 投稿者：SECOND  投稿日：2009年10月13日(火)22時41分20秒
  !Page-3 の始め

!-------------------
! make huffman tree
SUB TREE3
   MAT Tr=ZER
   FOR i=0 TO SE
      LET F_(i)=S_(i,P)
   NEXT i
   !---minimum2
   DO
      LET w=1e8
      FOR i=0 TO SE
         IF F_(i)< w THEN
            LET w=F_(i)
            LET Ad1=i ! minimum1
         END IF
      NEXT i
      LET w=1e8
      FOR i=0 TO SE
         IF F_(i)< w AND i<>Ad1 THEN
            LET w=F_(i)
            LET Ad2=i ! minimum2
         END IF
      NEXT i
      IF w=1e8 THEN EXIT DO
      IF Ad1>Ad2 THEN swap Ad1,Ad2
      !---
      LET F_(Ad1)=F_(Ad1)+F_(Ad2)
      LET F_(Ad2)=1e9
      !---
      FOR Le1=16 TO 1 STEP -1
         IF Tr(Le1,Ad1,1)>0 OR Tr(Le1,Ad1,3)>0 THEN EXIT FOR
      NEXT Le1
      FOR Le2=16 TO 1 STEP -1
         IF Tr(Le2,Ad2,1)>0 OR Tr(Le2,Ad2,3)>0 THEN EXIT FOR
      NEXT Le2
      LET Le0=MAX( Le1,Le2 )+1
      !---
      LET Tr(Le0,Ad1,0)=Le1
      LET Tr(Le0,Ad1,1)=Ad1
      LET Tr(Le0,Ad1,2)=Le2
      LET Tr(Le0,Ad1,3)=Ad2
   LOOP
   !---make DH()
   LET DH(0,P)=SE+1
   LET k=0
   CALL bitl(Le0,Ad1)
   FOR Ad=0 TO SE
      LET DH(Tr(0,Ad,1),P)=DH(Tr(0,Ad,1),P)+1
   NEXT Ad
END SUB

SUB bitl(Le,Ad)
   IF 0< Le THEN
      LET k=k+1
      CALL bitl( Tr(Le,Ad,0), Tr(Le,Ad,1) )
      CALL bitl( Tr(Le,Ad,2), Tr(Le,Ad,3) )
      LET k=k-1
   ELSE
      LET Tr(Le,Ad,1)=k
   END IF
END SUB

!-------------------
! Quick Sort S_()
SUB Qsort(L,R) ! 降順にセット。
   local i,j
   LET i=L
   LET j=R
   LET Tx=S_(IP((L+R)/2),P)
   DO
      DO WHILE S_(i,P) >Tx ! 降順＞、昇順＜
         LET i=i+1
      LOOP
      DO WHILE Tx >S_(j,P) ! 降順＞、昇順＜
         LET j=j-1
      LOOP
      IF j< i THEN EXIT DO ! 等号付 j<=i は、暴走。
      SWAP S_(i,P),S_(j,P)
      SWAP DV(i,P),DV(j,P)
      LET i=i+1
      LET j=j-1
   LOOP UNTIL j< i  ! 等号付 j<=i は、低速。
   IF L< j THEN CALL Qsort(L,j)
   IF i< R THEN CALL Qsort(i,R)
END SUB

!===================================
! make encorder table B()L()<-- DH()
SUB MAKE_H2
   MAT L=ZER
   FOR J=0 TO CMO+1
      LET I=0        ! コード生成 順番(短い順)
      LET Hx=0
      LET Tx=BVAL("8000",16)
      FOR L_=1 TO 16
         FOR N=1 TO DH(L_,J)
            LET V_=DV(I,J)   ! 座標DV(頻度降順)
            LET L(V_,J)=L_
            LET B(V_,J)=Hx   ! コード(座標V_)
            LET I=I+1
            LET Hx=Hx+Tx
         NEXT N
         LET Tx=Tx/2
      NEXT L_
      LET B(256,J)=1
   NEXT J
END SUB

!==============================
!Fast Discrete Cosin Transform.( M=8x8, DCT-2 )
SUB DDCT8X8
   FOR P=0 TO CMO ! (0=Y,1=Cb,2=Cr)
      FOR V0=0 TO DV_-1 STEP 8*MV(0)/MV(P)
         FOR U0=0 TO DU-1 STEP 8*MH(0)/MH(P)
            FOR Y_=0 TO 7
               LET w=Y_*MV(0) !sampling pt.Y
               FOR X_=0 TO 7  !level shift, sampling CbCr from MCU
                  IF P=0 THEN LET X(X_)=D2(U0+X_,V0+Y_,P)-128 ELSE LET X(X_)=D2(U0+X_*MH(0),V0+w,P)
               NEXT X_
               CALL WANG
               FOR U_=0 TO 7
                  LET T(U_,Y_)=X(U_)
               NEXT U_
            NEXT Y_
            FOR U_=0 TO 7
               FOR Y_=0 TO 7
                  LET X(Y_)=T(U_,Y_)
               NEXT Y_
               CALL WANG
               FOR V_=0 TO 7
                  LET D2(U0+U_,V0+V_,P)=ROUND( X(V_)/DQ(U_,V_,QS(P)) ) ! Quantization
               NEXT V_
            NEXT U_
         NEXT U0
      NEXT V0
   NEXT P
END SUB

!=============================
!Fast Discrete Cosin Transform
!Wang.( M=8, DCT-2 )
SUB WANG
   LET XO(0)=X(0)+X(7)
   LET XO(1)=X(1)+X(6)
   LET XO(2)=X(2)+X(5)
   LET XO(3)=X(3)+X(4)
   LET XO(4)=X(3)-X(4)
   LET XO(5)=X(2)-X(5)
   LET XO(6)=X(1)-X(6)
   LET XO(7)=X(0)-X(7)
   !
   LET X(0)=XO(0)+XO(3)
   LET X(1)=XO(1)+XO(2)
   LET X(2)=XO(1)-XO(2)
   LET X(3)=XO(0)-XO(3)
   LET X(4)=XO(7)*SQR(2)
   LET X(5)=XO(6)-XO(5)
   LET X(6)=XO(6)+XO(5)
   LET X(7)=XO(4)*SQR(2)
   !
   LET XO(0)=(COS(PI/4)*X(0)+COS(PI/4)*X(1))
   LET XO(1)=(COS(PI/4)*X(0)-COS(PI/4)*X(1)) !fin 0(0),1(4)
   LET XO(2)=(COS(PI/8)*X(3)+SIN(PI/8)*X(2))
   LET XO(3)=(COS(PI*3/8)*X(3)-SIN(PI*3/8)*X(2)) !fin 2(2),3(6)
   LET XO(4)=X(4)
   LET XO(5)=X(6)
   LET XO(6)=X(5)
   LET XO(7)=X(7)
   !
   LET X(4)=XO(4)+XO(5)
   LET X(5)=XO(4)-XO(5)
   LET X(6)=-XO(6)+XO(7)
   LET X(7)=XO(6)+XO(7)
   !
   LET XO(4)=(COS(PI/16)*X(4)+SIN(PI/16)*X(7))
   LET XO(5)=(COS(PI*5/16)*X(5)+SIN(PI*5/16)*X(6))
   LET XO(6)=(SIN(PI*5/16)*X(5)-COS(PI*5/16)*X(6))
   LET XO(7)=(SIN(PI/16)*X(4)-COS(PI/16)*X(7))
   !
   LET X(0)=SQR(2/8)*XO(0)
   LET X(4)=SQR(2/8)*XO(1)
   LET X(2)=SQR(2/8)*XO(2)
   LET X(6)=SQR(2/8)*XO(3)
   LET X(1)=SQR(1/8)*XO(4)
   LET X(5)=SQR(1/8)*XO(5)
   LET X(3)=SQR(1/8)*XO(6)
   LET X(7)=SQR(1/8)*XO(7)
END SUB

!Page-4 へ続く 		 

つづき４

 投稿者：SECOND  投稿日：2009年10月13日(火)22時40分4秒
  !Page-4 の始め

!========================
SUB W_BIN31
!---SOI
   CALL WRT_H("FFD8")
   !---APP0
   CALL WRT_H("FFE0")
   CALL WRT_W( 2+14)  !size
   CALL WRT_M("JFIF"& CHR$(0))
   CALL WRT_H("0101") !ver 1.1
   CALL WRT_D(1)      !0=none 1=dpi 2=dpcm
   CALL WRT_W(72)     !Xd 72 アスペクト比　IE6(no) imaging(ok)
   CALL WRT_W(72)     !Yd 72 アスペクト比
   CALL WRT_D(0)      !Xt 0
   CALL WRT_D(0)      !Yt 0
   !---DQT.Y.C
   CALL WRT_H("FFDB")
   LET W=2           !start size
   FOR J=0 TO CMO/2  !CMO=0(mono.) CMO=2(color)
      LET W=W+1+64   !+ID +QT
   NEXT J
   CALL WRT_W( W)    !size
   FOR J=0 TO CMO/2  ! CMO=0(mono.) CMO=2(color)
      CALL WRT_D(J)  !J= (0)Y.DQ (1)C.DQ
      FOR I=0 TO 63
         CALL WRT_D( DQ(U(i),V(i),J) )
      NEXT I
   NEXT J
   !---SOF0
   CALL WRT_H("FFC0")
   IF CMO=0 THEN CALL WRT_W( 11) ELSE CALL WRT_W( 17) !size
   CALL WRT_D( 8)  !8bit at RGB
   CALL WRT_W( DY) !V.pixels
   CALL WRT_W( DX) !H.pixels
   IF CMO=0 THEN
      CALL WRT_H("01")     !1 items
      CALL WRT_H("011100") !Y MCU(H:V) DQT
   ELSE
      CALL WRT_H("03")     !3 items
      CALL WRT_H("01"& STR$(MH(0))& STR$(MV(0))& "0"& STR$(QS(0))) !Y  MCU(H:V) DQT
      CALL WRT_H("02"& STR$(MH(1))& STR$(MV(1))& "0"& STR$(QS(1))) !Cb - -
      CALL WRT_H("03"& STR$(MH(2))& STR$(MV(2))& "0"& STR$(QS(2))) !Cr - -
   END IF
   !---DHT
   CALL WRT_H("FFC4")
   LET W=2                 !start size
   FOR J=0 TO CMO+1        !CMO=0(mono.) CMO=2(color)
      LET W=W+1+16+DH(0,J) !+ID +HT +VT
   NEXT J
   CALL WRT_W( W)          !size
   FOR J=0 TO CMO+1                     !CMO=0(mono.) CMO=2(color)
      CALL WRT_D( 16*MOD(J,2)+IP(J/2) ) !   00h=YDC 10h=YAC 01h=CDC 11h=CAC
      FOR I=1 TO 16                     !(J) 0 =YDC  1 =YAC  2 =CDC  3 =CAC
         CALL WRT_D( DH(I,J))
      NEXT I
      FOR I=0 TO DH(0,J)-1
         CALL WRT_D( DV(I,J))
      NEXT I
   NEXT J
   !---SOS
   CALL WRT_H("FFDA")
   IF CMO=0 THEN
      CALL WRT_W(8)      !size
      CALL WRT_D(1)      !1 items
      CALL WRT_H("0100") !No.  Y.HDC/HAC
   ELSE
      CALL WRT_W(12)     !size
      CALL WRT_D( 3)     !3 items
      CALL WRT_H("0100") !No.  Y.HDC/HAC
      CALL WRT_H("0211") !No. Cb.HDC/HAC
      CALL WRT_H("0311") !No. Cr.HDC/HAC
   END IF
   CALL WRT_H("003F00") !band 0~63, AhAl=00
END SUB

!----------------
!open write binary
SUB WOPEN
   OPEN #1:NAME FL$
   ERASE #1
END SUB

!sequential write byte
SUB WRT_D( D)
   PRINT #1 :CHR$(D);
   LET byt=byt+1 !!!
END SUB

!sequential write word
SUB WRT_W( w)
   PRINT #1 :CHR$(IP(w/256));CHR$(MOD(w,256));
   LET byt=byt+2 !!!
END SUB

!sequential write binary massage W$
SUB WRT_M( w$)
   FOR w=1 TO LEN(w$)
      PRINT #1 :MID$(w$,w,1);
   NEXT w
   LET byt=byt+w-1 !!!
END SUB

!sequential write binary hex.massage w$
SUB WRT_H( w$)
   FOR w=1 TO LEN(w$) STEP 2
      PRINT #1 :CHR$(BVAL(MID$(w$,w,2),16));
   NEXT w
   LET byt=byt+LEN(w$)/2 !!!
END SUB

!=====================
! print huffman_table
SUB list_HT( m$,J)
   PRINT m$;" 頻度 座標 bit コード(";
   IF MOD(B(256,J),2)=1 THEN PRINT "座標順)" ELSE PRINT "生成順、頻度降順)"
   LET sum=0
   FOR i=0 TO 255
      IF L(i,J)<>0 THEN
         IF MOD(B(256,J),2)=1 THEN ! 1=Sort_value. Encorder
            LET V_=i
            LET w$="     "& RIGHT$("   "& STR$(SV(i,J)),4)& "  " ! times
            LET sum=sum+L(i,J)*SV(i,J)
         ELSE                      ! 0=Sort_length. Decorder
            LET V_=DV(i,J)
            LET w$="     "& RIGHT$("   "& STR$(S_(i,J)),4)& "  " ! times
            LET sum=sum+L(i,J)*S_(i,J)
         END IF
         LET w$=w$& RIGHT$("0"& BSTR$(V_,16),2)& "  " ! value
         LET w$=w$& RIGHT$(" "& STR$(L(i,J)),2)& "  " ! length
         !--- huffman code
         LET H_=B(i,J) ! code
         LET L_=L(i,J) ! length
         !--- bit_pattern
         LET w$=w$& left$(right$("0000000"& BSTR$(H_,2),16),L_)
         PRINT w$
      END IF
   NEXT i
   PRINT " 合計( 頻度 * bit)=";sum
END SUB

END

EXTERNAL SUB sample(DX$,DY$)
! マンデルブロー（Complex\mandelbm.bas の着色改変）
OPTION ARITHMETIC COMPLEX
SET COLOR MODE "REGULAR"
SET POINT STYLE 1
FOR n=1 TO 51
   SET COLOR MIX(    n) 0   ,0     ,n/51   !BLACK < < BLUE
   SET COLOR MIX( 51+n) 0   ,n/51  ,1      !BLUE  < < CYAN
   SET COLOR MIX(102+n) 0   ,1     ,1-n/51 !CYAN  < < GREEN
   SET COLOR MIX(153+n) n/51,1     ,0      !GREEN < < YELLOW
   SET COLOR MIX(204+n) 1   ,1-n/51,n/51   !YELLOW< < MAGENTA
NEXT n
LET XL=-2
LET XR=.8
LET w1=XR-XL
LET w2=w1/2
SET WINDOW XL, XR,-w2,w2
ASK PIXEL SIZE(XL,-w2; XR,w2) px,py
!
FOR x=XL TO XR+1e-6 STEP w1/(px-1)
   FOR y=-w2-.49*w1/(py-1) TO w2 STEP w1/(py-1) !故意に(x,0)を描点の間に挟む。
      LET z=0
      FOR n=1 TO 255
         LET z=z^2+COMPLEX(x,y)
         IF 2< ABS(z) THEN
            IF n< 64 THEN SET POINT COLOR n*4 ELSE SET POINT COLOR 253
            PLOT POINTS :x,y !上下の対象プロットをしない。
            EXIT FOR
         END IF
      NEXT n
   NEXT y
NEXT x
LET DX$=STR$(px)
LET DY$=STR$(py)
END SUB
 		 

Re: 十進 BASIC で、JPG ファイルを作る。

 投稿者：島村1243  投稿日：2009年10月14日(水)17時39分17秒
  > No.646[元記事へ]

SECONDさんへのお返事です。

> !十進 BASIC で、JPG ファイルを作る。

プログラムをBASIC-7.3.5でRUNすると、タイトルバーに

「IF FL$>"" THEN CHARACTER INPUT k$」

と記載された何も無い細長のダイアログが表示され、又、出力用テキストウインドウに

カレント DIR：C:\Program Files\Decimal BASIC\BASICw32
出力ファイル：baseline.jpg
上書き。又は作成されます。…Ok？[Enter]

と出ますが、jpeg化したいファイルの指定は、どの様にするのでしょうか？ 		 

戻る