GIF アニメ－ション を作る。

 投稿者：SECOND  投稿日：2009年 7月16日(木)03時59分38秒
  ! GIF Animation を作る。
!-------

OPTION CHARACTER BYTE
SET ECHO "OFF"

LET ofile$="DecAnima.GIF" ! 削除すると、ダイアログ・ボックス入力。
ASK DIRECTORY s$
IF ofile$>"" THEN PRINT "カレント DIR："& s$ ELSE file getname ofile$, "gif"
PRINT "出力ファイル："& ofile$
IF ofile$>"" THEN PRINT "上書き。又は作成されます。…"& "Ok？[Enter]"
IF ofile$>"" THEN CHARACTER INPUT k$
IF ofile$="" OR k$<>CHR$(13) THEN
   PRINT "中止"
   STOP
END IF

!-------
!LZW圧縮アルゴリズム特許、国内では2004年6月20日に失効 …
!　…GIF画像ファイルを表示・生成するソフトの開発が自由に…なる。

!-----------
! 射影変換 ( SAMPLE\TRANSFO9.BAS から、拝借）
DIM T(4,4),m(501,501)
MAT T=IDN

PICTURE House
   SET AREA COLOR 15
   PLOT AREA:    0, 1;   0,  0;   2,  0;   2,  1 !壁
   SET AREA COLOR 2
   PLOT AREA:  -0.6,1;  2.6, 1;   2,  2;   0,  2 !屋根
   SET AREA COLOR 10
   PLOT AREA:  0.1, 0; 0.1,0.8; 0.5,0.8; 0.5,  0 !ドア
   SET AREA COLOR 5
   PLOT AREA: 1.4,0.4; 1.9,0.4; 1.9,0.8; 1.4,0.8 !窓
   SET AREA COLOR 12
   PLOT AREA:  1.7, 2; 1.7,2.3; 1.5,2.3; 1.5,  2 !煙突
END PICTURE

SET WINDOW -5,5,-5,5
ASK PIXEL SIZE (-1.1,4.3 ; 4.6,-.5) Xw,Yw
MAT m=ZER(Xw,Yw)
!screen& picture.xw =Xw
!screen& picture.yw =Yw
LET obits0=4 !（ 2= 2色~4色, 3= 8色, 4=16色, … 8=256色)
!
CALL gif_header
CALL applica_blk(0) !repeat number, 0=end less
!
LET N000=2^obits0 !encoder colors max.  …予約登録番号最大値+1
LET t_max= 2000   ! 表示のthead より大きい程度に、小さいと辞書クリアー頻度増。
DIM dic_0(0 TO t_max, 0 TO N000-1), dic_1(0 TO t_max, 0 TO N000-1) !逆引き辞書
!
FOR i9=-PI TO 0*PI+.01 STEP PI/2
   LET a=(1+COS(i9))/2
   LET T(1,4)= .1*a
   LET T(2,4)=-.1*a
   SET DRAW mode hidden
   CLEAR
   DRAW axes
   SET AREA COLOR 6 !透過色に使用
   PLOT AREA: -1.1,-.5; 4.6,-.5; 4.6,4.3; -1.1,4.3
   DRAW House WITH T*ROTATE(-PI/20*a)*SCALE(1.72)
   ASK PIXEL ARRAY (-1.1,4.3) m
   SET DRAW mode explicit
   !----
   READ dly
   DATA 140,20,100
   !CALL img_ctl_blk( dly,BVAL("00001000",2), 6) !透過させない、全表示
   CALL img_ctl_blk( dly,BVAL("00001001",2), 6) !表示時間(x10ms),iflg,透過色
   CALL picture_blk
   CALL picture_data
   !----
NEXT i9
CALL gif_terminater

!---------
!画像配列 m(1~Xw,1~Yw) !! 注意 x,y の順 mat read m(y,x)
SUB inppix             !! ask pixel array(x0,y0) m(x,y)
   LET lx=lx+1
   IF Xw< lx THEN
      LET lx=1
      LET ly=ly+1
   END IF
   IF ly<=Yw THEN LET bx=m(lx,ly) ! data on bx
END SUB

SUB picture_data
   PRINT #1: CHR$(obits0); !最小データービット長 …予約登録番号の最大ビット長
   LET blkfull=255         !block size max.(~~255)
   LET bitfull=12          !  LZW bits max.(~~ 12)
   CALL LZW_encoder
   CALL outcode       !flush registered dic.number on ax
   LET ax=N000+1      !code end
   CALL outcode
   CALL out_flush
   PRINT #1: CHR$(0); !block size 0 (end)
END SUB

SUB LZW_encoder
   LET lx=1 -1 !画像配列 m(1~Xw,1~Yw)
   LET ly=1
   CALL inppix             !data on bx
   LET pdata$=""           !clear output bytes buffer
   LET oacc$=""            !clear output bits buffer
   LET owidth=obits0+1     !starting bit width
   DO
      LET ax=N000          !reset code
      CALL outcode
      MAT dic_0=ZER        !clear dic.number
      MAT dic_1=ZER        !clear dic.chain
      LET thead=1          !reset make_table pointer
      LET dicnum=N000+2    !reset dictionary new number
      LET owidth=obits0+1  !starting bit width
      DO
         LET di=0                  !top table
         LET dic_0(di,bx)=bx
         DO
            LET ax=dic_0(di,bx)    !---latch last chained register
            IF dic_1(di,bx)>0 THEN LET di=dic_1(di,bx) ELSE CALL make_table
            CALL inppix            ! next bx
            IF Yw< ly THEN EXIT SUB
         LOOP UNTIL dic_0(di,bx)=0 !---until no register
         LET dic_0(di,bx)=dicnum   ! new register, bx=tail
         CALL outcode              !write last register
         LET owidth=LEN( BSTR$(dicnum,2) ) ! remake owidth
         LET dicnum=dicnum+1
      LOOP UNTIL dicnum>2^bitfull-1 OR thead>t_max !bits full or dic.full
   LOOP
END SUB

SUB make_table
   LET dic_1(di,bx)=thead !chained table pointer
   LET di=thead           !new table head
   LET thead=thead+1
END SUB

SUB outcode
   LET oacc$=right$("00000000000"& BSTR$(ax,2),owidth)& oacc$
   DO WHILE LEN(oacc$)>=8
      LET pdata$=pdata$& CHR$(BVAL(right$(oacc$,8),2))
      LET oacc$=oacc$(1:LEN(oacc$)-8)
      IF LEN(pdata$)=blkfull THEN CALL bw_sub
   LOOP
END SUB

SUB bw_sub
   PRINT #1: CHR$(LEN(pdata$)); pdata$;
   LET pdata$=""
   PRINT "thead=";thead;" dicnum=";dicnum  !--monitor
END SUB

SUB out_flush
   IF oacc$<>"" THEN LET pdata$=pdata$& CHR$(BVAL(oacc$,2) )
   LET oacc$=""
   IF pdata$>"" THEN CALL bw_sub
   PRINT "------"  !--monitor
END SUB

!=============
SUB gif_header
   PRINT "処理中"
   OPEN #1: NAME ofile$
   ERASE #1
   PRINT #1: "GIF89a";
   CALL prt_2dw( Xw,Yw )
   ! ---sflg---
   !  1: common-palet-ON
   !xxx: colors_bits/pixel 2^(xxxb+1)
   !  0: sort-OFF
   !xxx: colors_bits/common-palet 2^(xxxb+1)
   LET sflg=BVAL("10000000",2)+(obits0-1)*16+(obits0-1)
   PRINT #1: CHR$(sflg);
   PRINT #1: CHR$(0); ! back ground color
   PRINT #1: CHR$(0); ! アスペクト比 if n=0 then 1:1 else H:V=(n+15):64
   ! common_palette
   FOR i=0 TO 2^obits0-1
      ASK COLOR MIX(i) r,g,b
      PRINT #1: CHR$(r*255);CHR$(g*255);CHR$(b*255); ! R G B
   NEXT i
END SUB

SUB applica_blk(rp)
   CALL prt_BVAL16("21,FF") ! アプリケーション・ブロック
   PRINT #1: CHR$(11);            !block size
   PRINT #1: "NETSCAPE2.0";       !アプリケーション名(8) バージョン(3)
   PRINT #1: CHR$(3);             !block size
   PRINT #1: CHR$(1);             !constant 1
   PRINT #1: CHR$(MOD(rp,256));CHR$(IP(rp/256)); !repeat number  0=endless
   PRINT #1: CHR$(0);             !block size 0 (end)
END SUB

SUB img_ctl_blk( Dtm,iflg,tco )
   CALL prt_BVAL16("21,F9") ! イメージコントロール・ブロック
   PRINT #1: CHR$(4);       !block size
   ! ---iflg---
   !000:blank
   !010: 000=none( OR )
   !     001= OR( same as 000)
   !     010=remove all before( paint screen-BG before)
   !     011=remove last picture before
   !  0:user click-OFF
   !  0:透過GIFの透明色のスイッチ 1=ON 0=OFF
   PRINT #1: CHR$(iflg);
   PRINT #1: CHR$(MOD(Dtm,256));CHR$(IP(Dtm/256)); !表示時間(x10ms)
   PRINT #1: CHR$(tco);  !透過GIFの透明色
   PRINT #1: CHR$(0);    !block size 0 (end)
END SUB

SUB picture_blk
   CALL prt_BVAL16("2C") ! 画像・ブロック
   CALL prt_2dw( 0,0 )   !picture.x0=0,y0=0
   CALL prt_2dw( Xw,Yw ) !picture.xw,yw =screen.xw,yw
   ! ---pflg---
   !  0:private-palet-OFF
   !  0:interrace-OFF
   !  0:sort-OFF
   ! 00:blank
   !xxx:private-palette-bits 2^(xxxb+1)
   LET pflg=BVAL("00000000",2)
   PRINT #1: CHR$(pflg);
END SUB

SUB gif_terminater
   PRINT #1: CHR$(BVAL("3B",16));
   CLOSE #1
   PRINT "終了"
END SUB

!-----------
SUB prt_2dw( dw1,dw2 )
   PRINT #1: CHR$(MOD(dw1,256));CHR$(IP(dw1/256));
   PRINT #1: CHR$(MOD(dw2,256));CHR$(IP(dw2/256));
END SUB

SUB prt_BVAL16(h$)
   FOR i=1 TO LEN(h$) STEP 3
      PRINT #1: CHR$(BVAL(h$(i:i+1),16));
   NEXT i
END SUB

END 		 

LZW エンコーダーと、デコーダー

 投稿者：SECOND  投稿日：2009年 7月21日(火)18時32分53秒
  > No.458[元記事へ]

! LZW エンコーダーと、デコーダー
!-----------
OPTION CHARACTER byte
DIM m(501,501)
LET obits0=2             !（ 2= 2色~4色, 3= 8色, 4=16色, … 8=256色)
LET N000=2^obits0        ! 色数（予約の登録番号最大+1）
!
LET t_max= 1000  !＝使われた色数ｘ辞書への登録文字の長さ。(不詳)【逆引き辞書】
!                !　小さいと辞書クリアー頻度増し、圧縮出力サイズは、悪化するが、
!                !　その分、復元側も、辞書のメモリー消費は、減る。
DIM dic_0(0 TO t_max, 0 TO N000-1), dic_1(0 TO t_max, 0 TO N000-1) !encoder 辞書
!
LET blkfull=255          ! block size max.(~~255)
LET bitfull=12           ! LZW bits max.(~~ 12)
DIM dic$(0 TO 2^bitfull) ! decoder 辞書、収納は、新規の登録番号最大まで。
!
!------------------- テスト原画の作成 -----------------------------------
LET Xw=4
LET Yw=3
MAT m=ZER(Yw,Xw)
MAT READ m
!MAT m=BVAL("03",16)*CON(Yw,Xw)
!     ４色(2bits) 横:４ 縦:３ の、テスト・パターン
DATA  0,1,2,3
DATA  0,1,2,3
DATA  0,1,2,3
!
PRINT "******************* 原画パターン"; Xw;"x";Yw
FOR j=1 TO Yw
   LET ww$=""
   FOR i=1 TO Xw
      LET ww$=ww$& right$("0"& BSTR$(m(j,i),16),2)& " "
   NEXT i
   PRINT ww$
NEXT j
!
CALL picture_data !　上記パターンを 実際に、Encode する。原画→ LZW$
CALL decomp_data  !　上のEncode 出力を 実際に、Decode する。LZW$→ 原画

!------------------------------------------------------------------------
!上のパターンの例
! 02              !　最小データービット長　… 予約登録番号(0~n-1) のビット長
! 05              !　block size（バイト）
! 44 34 86 3A 05  !…LZW compression bit stream
! 00              !　block end 0
!
!復元側 LZW_decoder 入力は、下の様に並べて、左 ← 右 へ向かって読み取る。
!開始は、辞書 初期化コード(n+0) のビット長で、始める為に、１ビット長い=3

!0~n-1= (0,1,2,3)：予約登録番号　←最小データービット長=2 の意味。
!　n+0= 4        ：入力開始ビット長を、初期値=3 に戻す。辞書のクリア
!　n+1= 5        ：処理の終了
!　n+2= 6        ：辞書、スタートの新規登録番号
!(登録番号) から辞書を読んだ時は、次の番号、
!(登録番号+1) の先頭１data も後に付加する。
!                                 <--------
!                     05       3A       86       34       44
!               00000101 00111010 10000110 00110100 01000100
!         0000 0101 0011 1010 1000 0110 0011 010 001 000 100
!LZW12V           5    3    A    8    6    3   2   1   0   4
!登録番号              D    C    B    A    9   8   7   6
!--------------------------------------------------------------
!復元data      (n+1)   3    0    2    0    3   2   1   0  (n+0)
!           code end        1    3    1                  reset
!                           2
!------------------------------------------------------------------------
! LZW12Vコードの桁幅は、直前の登録番号と同じ幅で連動、12bitまで増大する。
!------------------------------------------------------------------------
!原始  |        |Encorder|        |GIF    |Decorder
!データ|バッファ|辞書内容|登録番号|LZW12V |辞書内容 …復元データでもある
!                         110b     100b    …初期化コード4(n)
!0      0
!1      01       01       110b     000b    0
!2      12       12       111b     001b    1
!3      23       23       1000b    010b    2
!0      30       30       1001b    0011b   3
!1      01
!2      012      012      1010b    0110b   01
!3      23
!0      230      230      1011b    1000b   23
!1      01
!2      012
!3      0123     0123     1100b    1010b   012
!       3                 1101b    0011b   3
!                                  0101b   …終了コード5(n+1)
!最小データービット長の範囲は２～８で、１は無く２色４色の区別無し。
!LZW_encoder は 最小データービット長の値だけが 支配的で、２色でも、
!LZW コードは、２ビット１画素(0,1,2,3) で処理、(,,2,3) は、空席。


!------------------- 原画から、画像データ LZW$ の作成。------------------
!画像配列 m(1~Yw,1~Xw) !! 注意 x,y の順 mat read m(y,x)
SUB inppix             !! ask pixel array(x0,y0) m(x,y)
   LET lx=lx+1
   IF Xw< lx THEN
      LET lx=1
      LET ly=ly+1
   END IF
   IF ly<=Yw THEN LET bx=m(ly,lx) ! data on bx
END SUB

SUB picture_data
   PRINT "******************* 圧縮( LZW エンコード )"
   LET LZW$=CHR$(obits0)
   CALL prthex(CHR$(obits0),"最小データービット長") !予約登録番号最大のビット長
   !---
   CALL LZW_encoder
   CALL outcode            !flush last chained dic.number on ax
   LET ax=N000+1
   CALL outcode            !code end
   CALL out_flush
   !---
   LET LZW$=LZW$& CHR$(0)  !block end
   CALL prthex(CHR$(0),"block size") !モニター
END SUB

SUB LZW_encoder
   LET lx=1 -1 !画像配列 start pointer
   LET ly=1
   CALL inppix             !data on bx
   LET pdata$=""           !clear output byte buffer
   LET oacc$=""            !clear output bit buffer
   LET owidth=obits0+1     !starting bit width
   DO
      LET ax=N000          !reset code
      CALL outcode
      MAT dic_0=ZER        !clear dic.number
      MAT dic_1=ZER        !clear dic.chain
      LET thead=1          !reset make_table pointer
      LET dicnum=N000+2    !reset new dic.number
      LET owidth=obits0+1  !starting bit width
      DO
         LET di=0                  !top table
         LET dic_0(di,bx)=bx       !bx as reserved dic.number
         DO
            LET ax=dic_0(di,bx)    !---latch last chained dic.number
            IF dic_1(di,bx)>0 THEN LET di=dic_1(di,bx) ELSE CALL make_table
            CALL inppix            ! next bx
            IF Yw< ly THEN EXIT SUB
         LOOP UNTIL dic_0(di,bx)=0 !---until no dic.number
         LET dic_0(di,bx)=dicnum   ! new dic.number, bx as tail& next top
         CALL outcode              ! write ax, last chained dic.number
         LET owidth=LEN( BSTR$(dicnum,2) ) ! remake owidth
         LET dicnum=dicnum+1
      LOOP UNTIL dicnum>2^bitfull-1 OR thead>t_max !bits full or dic.full
   LOOP
END SUB

SUB make_table
   LET dic_1(di,bx)=thead !chained table pointer
   LET di=thead           !new table head
   LET thead=thead+1
END SUB

SUB outcode
   LET oacc$=right$("00000000000"& BSTR$(ax,2),owidth)& oacc$
   DO WHILE LEN(oacc$)>=8
      LET pdata$=pdata$& CHR$(BVAL(right$(oacc$,8),2))
      LET oacc$=oacc$(1:LEN(oacc$)-8)
      IF blkfull=LEN(pdata$) THEN CALL bw_sub
   LOOP
END SUB

SUB bw_sub
   LET LZW$=LZW$& CHR$(LEN(pdata$))& pdata$
   CALL prthex( CHR$(LEN(pdata$)),"block size")      !モニター
   CALL prthex( pdata$,"LZW compression bit stream") !モニター
   LET pdata$=""
END SUB

SUB out_flush
   IF oacc$<>"" THEN LET pdata$=pdata$& CHR$(BVAL(oacc$,2) )
   LET oacc$=""
   IF pdata$>"" THEN CALL bw_sub
END SUB

!---------------- モニター共通パーツ
SUB prthex(d$,w$)
   LET ww$=""
   FOR ii=1 TO LEN(d$)
      LET ww$=ww$& right$("0"& BSTR$(ORD(d$(ii:ii)),16),2)& " "
   NEXT ii
   IF w$>"" THEN LET ww$=ww$& "; "& w$
   PRINT ww$
END SUB


!------------------- 画像データ LZW$ から、原画へ戻す。------------------
SUB decomp_data
   PRINT "******************* 復元( LZW デコード )"
   LET obits0=ORD(LZW$(1:1))
   CALL prthex(CHR$(obits0),"最小データービット長") !モニター
   LET N000=2^obits0
   LET li=2                               !start input pointer
   LET blkend=0                           !clear input block pointer
   LET iacc$=""                           !clear input bit buffer
   LET pdata$=""                          !clear output byte buffer
   CALL LZW_decoder
   FOR i=1 TO LEN(pdata$) STEP Xw
      CALL prthex(pdata$(i:i+Xw-1),"")    !モニター
   NEXT i
   !--- check block_end
   CALL prthex( LZW$(li:li),"block size") !モニター
END SUB

SUB LZW_decoder
   DO
      LET dicnum=N000+2-1                   !start dic.number-1
      DO
         LET iwidth=LEN( BSTR$(dicnum,2) )  !remake iwidth
         IF  bitfull< iwidth THEN LET iwidth=bitfull !to handle BAD encode
         LET dicnum=dicnum+1
         CALL inpcode                       !data on bx
         IF bx=-1 OR bx=N000+1 THEN
            EXIT SUB
         ELSEIF bx=N000 THEN
            EXIT DO
         ELSE
            IF bx< N000 THEN
               LET dic$(dicnum)=CHR$(bx)
            ELSE
               LET dic$(dicnum)=dic$(bx)
               LET dic$(dicnum)=dic$(dicnum)& dic$(bx+1)(1:1)
            END IF
            LET pdata$=pdata$& dic$(dicnum)
         END IF
      LOOP
   LOOP
END SUB

SUB inpcode
   LET bx=-1
   DO WHILE LEN(iacc$)< iwidth
      IF blkend<=li THEN
         LET blksize=ORD(LZW$(li:li))
         CALL prthex(CHR$(blksize),"block size") !モニター
         IF blksize=0 THEN EXIT SUB
         LET li=li+1
         LET blkend=li+blksize
      END IF
      LET iacc$=right$("0000000"& BSTR$(ORD(LZW$(li:li)),2),8)& iacc$
      LET li=li+1
   LOOP
   LET bx=BVAL(right$(iacc$,iwidth),2)
   LET iacc$=iacc$(1:LEN(iacc$)-iwidth)
END SUB

END
 		 

戻る