unit QDArc;

//アーカイブユニット


interface

uses
  Windows, Messages, SysUtils, Classes, Controls;


//QDAのフォーマット…
(*

 OFS  |   SIZE   |  TYPE         | NAME      |   COMMENT
 ------------------------------------------------------------------
  +0    4           Char * 4       Signature    'QDA0'
  +4    4           DWORD          Compress?    0:No Comp.  1:Compressed
  +8    4           DWORD          DataCount    Number of Data
  +12   244         BYTE           Reserved     Reserved

  +256  268*nData   QDADataHeader  dataHeader   informations of each data
  ???   ??? *nData  ???            ---          DataBlock
*)

type EQDAError = class(Exception);

type TQDAFileHeader = packed record
  Compress:DWord;                   //圧縮してる？ 0=No 1=Yes
  Signature:Array[0..3] of Char;    //シグネチャ 'QDA0'
  DataCount:DWord;                  //データ数
  Reserved:Array[1..244] of BYTE;
end;

type TQDADataHeader = packed record
  Offset:DWord;                   //ファイルの「先頭」からのオフセット
  Length:DWord;                   //データの長さ(格納後)
  RestoredLength:DWord;           //データの長さ(解凍後)
  ID:Array[0..255] of Char;       //ID
end;


//コールバック関数
type TQDANotifyEvent = procedure (Progress,FileCount:Integer; SourceFile:String) of object;

//アーカイブの作成
procedure CreateQDAFile(FileName:String; SourceFile, IDs:TStrings; doCompress:Boolean; callback:TQDANotifyEvent);


//アーカイブからの抽出
function  ExtractFromQDAFile(FileName:String; ID:String):TMemoryStream;
function  ExtractFromQDAStream(Source:TStream; ID:String):TMemoryStream;

//アーカイブに入っているデータの情報を得る
function GetQDADataInfo(FileName:String; index:DWord):TQDADataHeader;

//アーカイブの情報を得る
function GetQDAFileInfo(FileName:String):TQDAFileHeader;



implementation

type TQDADataHeaderArray = Array[0..$FFFFF] of TQDADataHeader;
type PQDADataHeaderArray = ^TQDADataHeaderArray;

type TByteArray = Array[0..$FFFFFFF] of Byte;
type PByteArray = ^TByteArray;



//圧縮の挙動に関する定数
const
  THRESHOLD = 3;      //ペア数がこれ以下になったら圧縮をやめる
  MAXCHARS  = 200;    //文字の種類がこれを超えたら、そこでブロックを打ちきる
  BLOCKSIZE = 8192;  //一度に圧縮するサイズ
  HASHSIZE  = BLOCKSIZE;  //ハッシュ表のサイズ


//圧縮
//Byte PairEncodingに基づいて圧縮。
//
function Compress(comp:Boolean; src:TStream):TMemoryStream;
var
  count:Array[0..HASHSIZE-1] of BYTE;       //ペア数
  leftcode,rightcode:Array[0..255] of BYTE; //ペア表
  left,right:Array[0..HASHSIZE-1] of BYTE;  //ハッシュ表
  size:DWord; //現在のデータブロックのサイズ
  buffer:Array[0..BLOCKSIZE-1] of BYTE;     //一ブロックを圧縮するためのバッファ

  leftch,rightch:BYTE;
  code:Integer;
  oldsize:DWord;
  index,r,w,best:DWord;
  done:Boolean;

  dest:TMemoryStream;

  //ハッシュテーブルの参照
  function lookup(a,b:Byte):Integer;
  var
    index:DWord;
  begin
    //まず、ハッシュキーの生成
    index:=((a xor (b shl 5)) And (HASHSIZE-1));

    //キーを使ってペアまたは最初の空きスロットを探す
    while ((left[index] <> a) Or (right[index] <> b)) And (count[index]<>0) do
      index:=(index+1) And (HASHSIZE-1);

    //ペアを表中に記録
    left[index]:=a;
    right[index]:=b;

    result:=index;
  end;

  //SRCの読みこみ(Trueで最後に達している)
  function ReadSrc:Boolean;
  var
    used:Integer;
    c:Byte;
    index:Integer;
    i:Integer;
  begin
    used:=0;

    //表のクリア
    ZeroMemory(@count,sizeof(count));
    ZeroMemory(@rightcode,sizeof(rightcode));
    for i:=0 to 255 do
      leftcode[i]:=i;
    size:=0;

    //バッファか未使用の文字が無くなるまでデータを読む
    while (size < BLOCKSIZE) And (used < MAXCHARS) And (src.Position < src.Size) do begin
      src.Read(c,1);
      if (size > 0) then begin
        index := lookup(buffer[size-1],c);
        if count[index] < 255 then
          Inc(count[index]);
      end;
      buffer[size]:=c;
      Inc(size);

      if rightcode[c] = 0 then begin
        rightcode[c]:=1;
        Inc(used);
      end;
    end;

    result:= src.Position >= src.Size;
  end;

  //書きこみ
  procedure WriteDest;
  var
    i,len:Integer;
    b:Byte;
    c:Integer;
  begin
    c:=0;

    while c < 256 do begin

      //ペアコードで無いなら、文字の並びの長さをカウント
      if (c = leftcode[c]) then begin
        len:=1;
        Inc(c);
        while (len < 127) And (c < 256) And (c = leftcode[c]) do begin
          Inc(len);
          Inc(c);
        end;
        b:=len + 127;
        dest.Write(b,1);
        len:=0;
        if c = 256 then
          break;
      end else begin
        //ペアコードの長さをカウント
        len:=0;
        Inc(c);
        while ((len < 127) And (c < 256) And (c <> leftcode[c])) Or ((len < 125) And (c < 254) And (c+1 <> leftcode[c+1])) do begin
          Inc(len);
          inc(c);
        end;
        b:=len;
        dest.Write(b,1);
        dec(c,len+1);
      end;

      //ペアを連続出力
      for i:=0 to len do begin
        dest.Write(leftcode[c],1);
        if (c <> leftcode[c]) then
          dest.Write(rightcode[c],1);
        Inc(c);
      end;

    end;

    //圧縮後データの出力
    dest.Write(size,4);
    dest.Write(buffer,size);

  end;


begin
  leftch:=0;
  rightch:=0;


  //圧縮後バッファの作成
  dest:=TMemoryStream.Create;

  //別に圧縮し無くても良いなら、そのままコピーして帰る。
  if not comp then begin
    dest.LoadFromStream(src);
    dest.Position:=0;
    result:=dest;
    exit;
  end;

  done:=False;

  while not done do begin
    //一ブロック読みこみ
    done:=ReadSrc;
    code:=256;


    //現在のブロックを圧縮
    while true do begin

      //ペアコードに未使用の文字を割り当て
      dec(code);
      while code>=0 do begin
        if (code = leftcode[code]) And (rightcode[code] = 0) then
          break;
        Dec(code);
      end;

      //未使用の文字が残っていないなら、ループから脱出
      if code < 0 then
        break;

      //最頻出ペアを特定
      best:=2;
      for index:=0 to HASHSIZE-1 do begin
        if count[index] > best then begin
          best:=count[index];
          leftch:=left[index];
          rightch:=right[index];
        end;
      end;

      //これ以上圧縮できないなら、終了
      if best < THRESHOLD then
        break;

      //最頻出ペアをcodeで置き換え、ハッシュ表を修正
      oldsize:=size - 1;
      w:=0;
      r:=0;
      while r<oldsize do begin
        if (buffer[r] = leftch) And (buffer[r+1] = rightch) then begin

          if r > 0 then begin
            index:=lookup(buffer[w-1],leftch);
            if count[index] > 1 then
              Dec(count[index]);
            index:=lookup(buffer[w-1],code);
            if count[index] < 255 then
              Inc(count[index]);
          end;

          if r < oldsize-1 then begin
            index:=lookup(rightch,buffer[r+2]);
            if count[index] > 1 then
              Dec(count[index]);
            index:=lookup(code,buffer[r+2]);
            if count[index] < 255 then
              Inc(count[index]);
          end;

          buffer[w]:=code;
          Inc(w);
          Inc(r);
          Dec(size);
        end else begin
          buffer[w]:=buffer[r];
          Inc(w);
        end;

        Inc(r);
      end;
      buffer[w]:=buffer[r];

      //ペア表に追加
      leftcode[code]:=leftch;
      rightcode[code]:=rightch;

      //ハッシュ表からペアを削除する
      index:=lookup(leftch,rightch);
      count[index]:=1;

    end;

    WriteDest;
  end;

  dest.Position:=0;
  result:=dest;
end;



//展開
function Expand(src:TStream; restoredLength:DWord):TMemoryStream;
var
  left,right:Array[0..255] of BYTE;
  stack:Array[0..255] of BYTE;
  count:Byte;
  c,i,size:DWord;
  b:Byte;
  dest:TMemoryStream;
begin

  dest:=TMemoryStream.Create;
  dest.SetSize(restoredLength);

  //srcの終わりまで、各ブロックを展開
  while Src.Position < Src.Size do begin
    Src.Read(count,1);

    for i:=0 to 255 do
      left[i]:=i;

    //ペア表の読みこみ
    c:=0;
    while True do begin

      //7ビット目が立っているなら、表の格納位置をスキップ
      if count > 127 then begin
        Inc(c,count-127);
        count:=0;
      end;
      if (c = 256) then
        break;

      //そうでないなら、その個数だけペアを読む
      for i:=0 to count do begin
        Src.Read(left[c],1);
        if c <> left[c] then
          Src.Read(right[c],1);
        Inc(c);
      end;
      if (c = 256) then
        break;

      Src.Read(count,1);
    end;


    //圧縮されたデータブロックのサイズを求める
    Src.Read(size,4);

    //データブロックを展開
    i:=0;
    while True do begin
      //スタックかSrcから1バイト読む
      if i > 0 then begin
        Dec(i);
        c:=stack[i];
      end else begin
        if size = 0 then
          break;
        Dec(size);
        Src.Read(b,1);
        c:=b;
      end;

      //1バイト出力するか、スタックにプッシュ
      if c = left[c] then begin
        b:=c;
        dest.Write(b,1);
      end else begin
        stack[i]:=right[c];
        Inc(i);
        stack[i]:=left[c];
        Inc(i);
      end;

    end;

  end;

  result:=dest;
  result.Position:=0;
end;


//アーカイブの作成
procedure CreateQDAFile(FileName:String; SourceFile, IDs:TStrings; doCompress:Boolean; callback:TQDANotifyEvent);
var
  i:Integer;
  qfh:TQDAFileHeader;
  qdh:TQDADataHeader;
  fs:TFileStream;
  datas:TMemoryStream;   //データを入れたストリーム
  ofs:DWord;
  compressed:TMemoryStream; //圧縮済みデータ
begin

  try
    fs:=TFileStream.Create(FileName,fmCreate);
  except
    raise;
    exit;
  end;

  //ヘッダの作成
  ZeroMemory(@qfh,sizeof(qfh));
  with qfh do begin
    Signature[0]:='Q';
    Signature[1]:='D';
    Signature[2]:='A';
    Signature[3]:='0';
    DataCount:=IDs.Count;
  end;

  if doCompress then
    qfh.Compress:=1
  else
    qfh.Compress:=0;

  try
    //ヘッダの書きこみ
    fs.Write(qfh,Sizeof(qfh));

    //ヘッダ情報分を飛ばす。
    fs.Seek(Sizeof(TQDADataHeader)*qfh.DataCount,soFromCurrent);

    for i:=0 to qfh.DataCount-1 do begin
      //ソースの読みこみ
      datas:=TMemoryStream.Create;
      datas.LoadFromFile(SourceFile[i]);
      compressed:=Nil;  //警告回避用

      try
        //データの圧縮・コピー
        compressed:=Compress(doCompress,datas);
        fs.Write(compressed.Memory^,compressed.Size);

        ofs:=fs.Position;                 //現在の書きこみ位置をセーブ

        //データ情報の書きこみ
        fs.Position:=Sizeof(qfh) + SizeOf(qdh) * i;

        ZeroMemory(@qdh,sizeof(qdh));
        qdh.Offset:=ofs - DWord(compressed.Size);
        qdh.RestoredLength:=datas.Size;
        qdh.Length:=compressed.Size;
        StrPCopy(qdh.id,IDs[i]);
        fs.Write(qdh,Sizeof(qdh));
        fs.Position:=ofs;                           //書きこみ位置を戻す


      finally
        datas.Free;
        if Assigned(compressed) then
          compressed.Free;

        //コールバックを呼ぶ
        callback(i+1,qfh.DataCount, SourceFile[i]);
      end;

    end;


  finally
    fs.Free;
  end;


end;


//QDAFileHeaderのチェック
function CheckFileHeader(qfh:TQDAFileHeader):Boolean;
begin
  result:=
    (qfh.Signature[0]='Q') And
    (qfh.Signature[1]='D') And
    (qfh.Signature[2]='A') And
    (qfh.Signature[3]='0');

end;


function  ExtractFromQDAStream(Source:TStream; ID:String):TMemoryStream;
var
  i:Integer;
  qfh:TQDAFileHeader;
  qdh:TQDADataHeader;
  qdhs:PQDADataHeaderArray;
  tmps:TMemoryStream; //解凍用のテンポラリのストリーム、１個のデータを切り出す
  ex:EQDAError;
begin
  qdhs:=Nil;
  result:=Nil;

  try
    //まず、ヘッダを読む
    Source.Read(qfh,Sizeof(qfh));

    if not CheckFileHeader(qfh) then begin
      ex:=EQDAError.Create('Quadruple D Archiveの扱えるデータではありません');
      raise ex;
    end;

    //データヘッダの読みこみ
    GetMem(qdhs,sizeof(qdh)*qfh.DataCount);
    Source.Read(qdhs^,sizeof(qdh)*qfh.DataCount);

    //IDの検索
    Source.Position:=0;
    For i:=0 to qfh.DataCount-1 do begin
      if AnsiLowerCase(StrPas(qdhs^[i].ID)) = AnsiLowerCase(ID) then begin
        qdh:=qdhs^[i];
        Source.Position:=qdhs^[i].Offset;
        break;
      end;
    end;

    //見つからない
    if Source.Position = 0 then begin
      ex:=EQDAError.CreateFmt('アーカイブ内には指定されたID ''%s'' を持つデータが見つかりません',[ID]);
      raise ex;
    end;

    //データの読みこみ
    if qfh.Compress=1 then begin
      tmps:=TMemoryStream.Create;
      tmps.SetSize(qdh.Length);
      Source.Read(tmps.Memory^,qdh.Length);
      result:=Expand(tmps,qdh.RestoredLength);
      tmps.Free;
    end else begin
      result:=TMemoryStream.Create;
      result.SetSize(qdh.RestoredLength);
      Source.Read(result.Memory^,qdh.RestoredLength);
    end;

  finally
    if Assigned(qdhs) then
      FreeMem(qdhs);
  end;

end;


function  ExtractFromQDAFile(FileName:String; ID:String):TMemoryStream;
var
  fs:TFileStream;
begin
  try
    fs:=TFileStream.Create(FileName,fmOpenRead);
  except
    raise;
    exit;
  end;

  result:=ExtractFromQDAStream(fs,ID);
  fs.Free;
end;



//アーカイブに入っているデータの情報を得る
function GetQDADataInfo(FileName:String; index:DWord):TQDADataHeader;
var
  fs:TFileStream;
  qfh:TQDAFileHeader;
  err:EQDAError;
begin
  //有効なインデクスか調べる
  qfh:=GetQDAFileInfo(FileName);
  if (qfh.DataCount <= index) then begin
    err:=EQDAError.CreateFmt('%d は、無効なQDAファイル内のインデクスです',[index]);
    raise err;
  end;

  //読みこみ
  fs:=TFileStream.Create(FileName,fmOpenRead);
  fs.Seek(sizeof(qfh)+index*sizeof(TQDADataHeader),soFromBeginning);
  fs.Read(result,sizeof(TQDADataHeader));
  fs.Free;
end;


//アーカイブの情報を得る
function GetQDAFileInfo(FileName:String):TQDAFileHeader;
var
  fs:TFileStream;
begin
  fs:=TFileStream.Create(FileName,fmOpenRead);
  fs.Read(result,sizeof(TQDAFileHeader));
  fs.Free;
end;


end.
