アーティクル

#11 Article 69 Posted at 1987/01/30 11:53:17 by W.M. (MAP009) [PRG.PACK]
Subject: SHINOBU_PACK.PAS
program shinobu_pack; (* SHINOBU ｻﾝ ﾉ ﾎｳｼｷ ﾉ ﾖﾙ､ pack ｺﾏﾝﾄﾞ ﾃﾞｽ *)

const XMAX=639;
      YMAX=399;
      GRAPHIC_MAX=31999; (* (XMAX+1)*(YMAX+1)/8-1=31999 *)
      UPPER4BIT=0;
      LOWER4BIT=1;

type screen=array[0..GRAPHIC_MAX] of byte;

var readbyte_pointer:integer;
    readbyte_position:integer;
    flag_end_of_data:boolean;

    bitbuffer:byte;
    bitbuffer_count:integer;
    bitmaskdata:array[0..7] of byte;

    graphic_buffer:screen;

    f:file of byte;

{$i getplain.pas } (* ｸﾞﾗﾌｨｸ data ｦ ｶﾞﾒﾝ ｶﾗ ﾖﾐﾀﾞｽ procedure ｶﾞ ﾊｲｯﾃｲﾏｽ *)

(* subroutines : file ｶｷｺﾐ ｶﾝｹｲ *)

procedure writedata_init;
  var i:integer;
  begin
    bitbuffer:=0;
    bitbuffer_count:=0;

    bitmaskdata[0]:=1;
    for i:=1 to 7 do
      bitmaskdata[i]:=bitmaskdata[i-1]*2;
  end;

procedure writeonebit(b:byte);
  begin
    if b=0 then
      bitbuffer:=bitbuffer*2
    else
      bitbuffer:=bitbuffer*2+1;

    bitbuffer_count:=bitbuffer_count+1;

    if bitbuffer_count=8 then
      begin
        write(f,bitbuffer);
        bitbuffer:=0;
        bitbuffer_count:=0;
      end;
  end;

procedure writebit(b:byte; bitlen:integer);
  var i:integer;
  begin
    for i:=1 to bitlen do
      writeonebit(b and bitmaskdata[bitlen-i]);
  end;

procedure writedata_fillzero;
  begin
    if bitbuffer_count>0 then
      writebit(0,8-bitbuffer_count);
  end;

procedure writedata(halfbyte:byte; count:integer);
  var bit_need:byte;

function bitlength(halfbyte:byte):byte;
  var tmp:byte;
  begin
    tmp:=8;
    while (halfbyte<128) and (tmp>0) do
      begin
        tmp:=tmp-1;
        halfbyte:=halfbyte*2;
      end;
    bitlength:=tmp;
  end;

  begin
    if count=1 then
      begin
        writebit(0,1);
        writebit(halfbyte,4);
      end
    else
      begin
        writebit(1,1);
        writebit(halfbyte,4);
        bit_need:=bitlength(count-1);
        writebit(bit_need-1,3);
        writebit(count-1,bit_need);
      end;
  end;

(* subroutines : graphic buffer ｶﾗ ﾉ ﾖﾐｺﾐ ｶﾝｹｲ *)

procedure readhalfbyte_init;
  begin
    readbyte_pointer:=0;
    readbyte_position:=UPPER4BIT;
    flag_end_of_data:=false;
  end;

procedure readhalfbyte(var b:byte);
  begin
    if readbyte_position=UPPER4BIT then
      begin
        b:=graphic_buffer[readbyte_pointer] div $10;
        readbyte_position:=LOWER4BIT;
      end
    else
      begin
        b:=graphic_buffer[readbyte_pointer] and $0f;
        readbyte_pointer:=readbyte_pointer+1;
        readbyte_position:=UPPER4BIT;
        if readbyte_pointer>GRAPHIC_MAX then
          flag_end_of_data:=true;
      end;
  end;

(* pack main *)

procedure pack;

  var count:integer;
      halfbyte_first,halfbyte_next:byte;

  begin
    writedata_init;
    readhalfbyte_init;

    readhalfbyte(halfbyte_first);
    count:=1;

    while not flag_end_of_data do
      begin
        readhalfbyte(halfbyte_next);

        if halfbyte_first=halfbyte_next then
          begin
            count:=count+1;
            if count=256 then
              begin
                writedata(halfbyte_first,count);
                count:=0;
              end;
          end
        else
          begin
            writedata(halfbyte_first,count);
            halfbyte_first:=halfbyte_next;
            count:=1;
          end;
      end;

    if count>0 then
      writedata(halfbyte_first,count);

    writedata_fillzero;
  end;

(* main *)

begin
  if paramcount<1 then
    begin
      writeln('sh_pack: filename.pac');
    end
  else
    begin
      assign(f,paramstr(1));
      rewrite(f);

      get_blue(graphic_buffer);  (* blue ﾉ ﾌﾟﾚｰﾝ ﾉ data ｦ get ｼﾏｽ *)
      pack;
      get_red(graphic_buffer);  (* red ﾉ ﾌﾟﾚｰﾝ ﾉ data ｦ get ｼﾏｽ *)
      pack;
      get_green(graphic_buffer);  (* green ﾉ ﾌﾟﾚｰﾝ ﾉ data ｦ get ｼﾏｽ *)
      pack;

      close(f);
    end;
end.