ieraw.pas

来自「·ImageEn 2.3.0 ImageEn一组用于图像处理、查看和分析的Del」· PAS 代码 · 共 2,418 行 · 第 1/5 页

  data:array [0..1940-1] of byte;
  dp:pbytearray;
  pixel:array [0..1552-1] of word;
  pix:pwordarray;
  row, col:integer;
begin
  with rec^ do
  begin
    xprogress.per1 := 100 / height / 2;
    for row:=0 to height-1 do
    begin

      with xprogress do
        if assigned(fOnProgress) then
          fOnProgress(Sender, trunc(per1 * row));

      ifp.Read(data[0],raw_width * 10 div 8); //  fread (data, raw_width * 10 / 8, 1, ifp);
      dp:=@data;
      pix:=@pixel;
      while (integer(pix) < integer(@pixel)+raw_width*sizeof(word)) do
      begin
        pix[0] := (dp[1] shl 2) + (dp[0] shr 6);
        pix[1] := (dp[0] shl 4) + (dp[3] shr 4);
        pix[2] := (dp[3] shl 6) + (dp[2] shr 2);
        pix[3] := (dp[2] shl 8) + (dp[5]     );
        pix[4] := (dp[4] shl 2) + (dp[7] shr 6);
        pix[5] := (dp[7] shl 4) + (dp[6] shr 4);
        pix[6] := (dp[6] shl 6) + (dp[9] shr 2);
        pix[7] := (dp[9] shl 8) + (dp[8]     );
        inc(pbyte(dp),10);
        inc(pword(pix),8);
      end;
      for col:=0 to width-1 do
        BAYER(rec^,row,col)^ := (pixel[col] and $3ff) shl 4;
      for col:=width to raw_width-1 do
        inc(black , pixel[col] and $3ff);
    end;
    if (raw_width > width) then
      black := ( black shl 4) div ((raw_width - width) * height);
  end;
end;

(*
   getbits(-1) initializes the buffer
   getbits(n) where 0 <= n <= 25 returns an n-bit integer
 *)
function getbits (var rec:TRec; nbits:integer):dword;
var
  c, ret:dword;
begin
  with rec do
  begin
    if (nbits = 0) then
    begin
      result:=0;
      exit;
    end;
    if (nbits = -1) then
    begin
      getbits_vbits := 0;
      getbits_bitbuf := 0;
      ret := 0;
    end
    else
    begin
      ret := getbits_bitbuf shl (LONG_BIT - getbits_vbits) shr (LONG_BIT - nbits);
      dec(getbits_vbits , nbits);
    end;
    while (getbits_vbits < LONG_BIT - 7) do
    begin
      c := fgetc(ifp);
      getbits_bitbuf := (getbits_bitbuf shl 8) + c;
      if (c = $ff) and (zero_after_ff<>0) then
        fgetc(ifp);
      inc(getbits_vbits , 8);
    end;
    result:=ret;
  end;
end;

procedure memset(P: Pointer; B: Byte; count: Integer);
begin
  FillChar(P^, count, B);
end;

procedure init_decoder(var rec:TRec);
begin
  with rec do
  begin
    memset (@first_decode, 0, sizeof(first_decode));
    free_decode := @first_decode;
  end;
end;

(*
   Construct a decode tree according the specification in *source.
   The first 16 bytes specify how many codes should be 1-bit, 2-bit
   3-bit, etc.  Bytes after that are the leaf values.

   For example, if the source is

    { 0,1,4,2,3,1,2,0,0,0,0,0,0,0,0,0,
      0x04,0x03,0x05,0x06,0x02,0x07,0x01,0x08,0x09,0x00,0x0a,0x0b,0xff  },

   then the code is

	00		0x04
	010		0x03
	011		0x05
	100		0x06
	101		0x02
	1100		0x07
	1101		0x01
	11100		0x08
	11101		0x09
	11110		0x00
	111110		0x0a
	1111110		0x0b
	1111111		0xff
 *)
function make_decoder (var rec:TRec; source:pbytearray; level:integer):pbyte;
var
  cur:pdecode;
  i, next:integer;
begin
  with rec do
  begin
    if (level=0) then
      make_decoder_leaf:=0;
    cur := free_decode;
    inc(free_decode);
    if (integer(free_decode) > integer(@first_decode)+2048*sizeof(decode)) then
      raise Exception.Create(': decoder table overflow');

    i:=0;
    next:=0;
    while (i <= make_decoder_leaf) and (next < 16) do
    begin
      inc(i , source[next]);
      inc(next);
    end;
    if (i > make_decoder_leaf) then
    begin
      if (level < next) then
      begin
        cur^.branch[0] := free_decode;
        make_decoder (rec,source, level+1);
        cur^.branch[1] := free_decode;
        make_decoder (rec,source, level+1);
      end
      else
      begin
        cur^.leaf := source[16 + make_decoder_leaf];
        inc(make_decoder_leaf);
      end;
    end;
    result:= pbyte( integer(source) + 16 + make_decoder_leaf );
  end;
end;

procedure crw_init_tables (var rec:TRec; table:dword);
const
  first_tree:array [0..3-1] of array [0..29-1] of byte = (
    ( 0,1,4,2,3,1,2,0,0,0,0,0,0,0,0,0,
      $04,$03,$05,$06,$02,$07,$01,$08,$09,$00,$0a,$0b,$ff  ),

    ( 0,2,2,3,1,1,1,1,2,0,0,0,0,0,0,0,
      $03,$02,$04,$01,$05,$00,$06,$07,$09,$08,$0a,$0b,$ff  ),

    ( 0,0,6,3,1,1,2,0,0,0,0,0,0,0,0,0,
      $06,$05,$07,$04,$08,$03,$09,$02,$00,$0a,$01,$0b,$ff  )
  );

  second_tree:array [0..3-1] of array [0..180-1] of byte = (
    ( 0,2,2,2,1,4,2,1,2,5,1,1,0,0,0,139,
      $03,$04,$02,$05,$01,$06,$07,$08,
      $12,$13,$11,$14,$09,$15,$22,$00,$21,$16,$0a,$f0,
      $23,$17,$24,$31,$32,$18,$19,$33,$25,$41,$34,$42,
      $35,$51,$36,$37,$38,$29,$79,$26,$1a,$39,$56,$57,
      $28,$27,$52,$55,$58,$43,$76,$59,$77,$54,$61,$f9,
      $71,$78,$75,$96,$97,$49,$b7,$53,$d7,$74,$b6,$98,
      $47,$48,$95,$69,$99,$91,$fa,$b8,$68,$b5,$b9,$d6,
      $f7,$d8,$67,$46,$45,$94,$89,$f8,$81,$d5,$f6,$b4,
      $88,$b1,$2a,$44,$72,$d9,$87,$66,$d4,$f5,$3a,$a7,
      $73,$a9,$a8,$86,$62,$c7,$65,$c8,$c9,$a1,$f4,$d1,
      $e9,$5a,$92,$85,$a6,$e7,$93,$e8,$c1,$c6,$7a,$64,
      $e1,$4a,$6a,$e6,$b3,$f1,$d3,$a5,$8a,$b2,$9a,$ba,
      $84,$a4,$63,$e5,$c5,$f3,$d2,$c4,$82,$aa,$da,$e4,
      $f2,$ca,$83,$a3,$a2,$c3,$ea,$c2,$e2,$e3,$ff,$ff  ),

    ( 0,2,2,1,4,1,4,1,3,3,1,0,0,0,0,140,
      $02,$03,$01,$04,$05,$12,$11,$06,
      $13,$07,$08,$14,$22,$09,$21,$00,$23,$15,$31,$32,
      $0a,$16,$f0,$24,$33,$41,$42,$19,$17,$25,$18,$51,
      $34,$43,$52,$29,$35,$61,$39,$71,$62,$36,$53,$26,
      $38,$1a,$37,$81,$27,$91,$79,$55,$45,$28,$72,$59,
      $a1,$b1,$44,$69,$54,$58,$d1,$fa,$57,$e1,$f1,$b9,
      $49,$47,$63,$6a,$f9,$56,$46,$a8,$2a,$4a,$78,$99,
      $3a,$75,$74,$86,$65,$c1,$76,$b6,$96,$d6,$89,$85,
      $c9,$f5,$95,$b4,$c7,$f7,$8a,$97,$b8,$73,$b7,$d8,
      $d9,$87,$a7,$7a,$48,$82,$84,$ea,$f4,$a6,$c5,$5a,
      $94,$a4,$c6,$92,$c3,$68,$b5,$c8,$e4,$e5,$e6,$e9,
      $a2,$a3,$e3,$c2,$66,$67,$93,$aa,$d4,$d5,$e7,$f8,
      $88,$9a,$d7,$77,$c4,$64,$e2,$98,$a5,$ca,$da,$e8,
      $f3,$f6,$a9,$b2,$b3,$f2,$d2,$83,$ba,$d3,$ff,$ff  ),

    ( 0,0,6,2,1,3,3,2,5,1,2,2,8,10,0,117,
      $04,$05,$03,$06,$02,$07,$01,$08,
      $09,$12,$13,$14,$11,$15,$0a,$16,$17,$f0,$00,$22,
      $21,$18,$23,$19,$24,$32,$31,$25,$33,$38,$37,$34,
      $35,$36,$39,$79,$57,$58,$59,$28,$56,$78,$27,$41,
      $29,$77,$26,$42,$76,$99,$1a,$55,$98,$97,$f9,$48,
      $54,$96,$89,$47,$b7,$49,$fa,$75,$68,$b6,$67,$69,
      $b9,$b8,$d8,$52,$d7,$88,$b5,$74,$51,$46,$d9,$f8,
      $3a,$d6,$87,$45,$7a,$95,$d5,$f6,$86,$b4,$a9,$94,
      $53,$2a,$a8,$43,$f5,$f7,$d4,$66,$a7,$5a,$44,$8a,
      $c9,$e8,$c8,$e7,$9a,$6a,$73,$4a,$61,$c7,$f4,$c6,
      $65,$e9,$72,$e6,$71,$91,$93,$a6,$da,$92,$85,$62,
      $f3,$c5,$b2,$a4,$84,$ba,$64,$a5,$b3,$d2,$81,$e5,
      $d3,$aa,$c4,$ca,$f2,$b1,$e4,$d1,$83,$63,$ea,$c3,
      $e2,$82,$f1,$a3,$c2,$a1,$c1,$e3,$a2,$e1,$ff,$ff  )
  );
begin
  with rec do
  begin
    if (table > 2) then
      table := 2;
    init_decoder(rec);
    make_decoder ( rec,@first_tree[table], 0);
    second_decode := free_decode;
    make_decoder ( rec,@second_tree[table], 0);
  end;
end;

(*
   Return 0 if the image starts with compressed data,
   1 if it starts with uncompressed low-order bits.

   In Canon compressed data, 0xff is always followed by 0x00.
 *)
function canon_has_lowbits(var rec:TRec):integer;
var
  test:array [0..$4000-1] of byte;
  ret, i:integer;
begin
  with rec do
  begin
    ret:=1;
    ifp.Position:=0;//fseek (ifp, 0, SEEK_SET);
    ifp.Read(test[0],sizeof(test));//fread (test, 1, sizeof test, ifp);
    for i:=540 to sizeof(test) - 2 do
      if (test[i] = $ff) then
      begin
        if (test[i+1]<>0) then
        begin
          result:=1;
          exit;
        end;
        ret:=0;
      end;
    result:=ret;
  end;
end;

procedure canon_compressed_load_raw(rec:PRec);
var
  pixel:pwordarray;
  prow:pword;
  lowbits, shift, i, row, r, col, save, val:integer;
  irow, icol:dword;
  decode, dindex:pdecode;
  block, leaf, len, diff, carry, pnum :integer ;
  diffbuf: array [0..64-1] of integer;
  base: array [0..2-1] of integer;
  c:byte;
  bblack:int64;

begin
  with rec^ do
  begin
    carry:=0;
    pnum:=0;
    bblack:=0;

    pixel := allocmem (raw_width*8 * sizeof(word));
    merror (pixel, 'canon_compressed_load_raw()');
    lowbits := canon_has_lowbits(rec^);
    shift := 4 - lowbits*2;
    ifp.Position:=540 + lowbits*raw_height*raw_width div 4; //fseek (ifp, 540 + lowbits*raw_height*raw_width/4, SEEK_SET);
    zero_after_ff := 1;
    getbits(rec^,-1);
    row := 0;

    xprogress.per1 := 100 / raw_height / 2;

    while (row < raw_height ) do
    begin

      with xprogress do
        if assigned(fOnProgress) then
          fOnProgress(Sender, trunc(per1 * row));

      for block:=0 to (raw_width shr 3)-1 do
      begin
        memset (@diffbuf, 0, sizeof(diffbuf));
        decode := @first_decode;
        i:=0;
        while i<64 do
        begin
          dindex:=decode;
          while ( dindex^.branch[0]<>nil ) do
            dindex := dindex^.branch[getbits(rec^,1)];
          leaf := dindex^.leaf;
          decode := second_decode;
          if (leaf = 0) and (i<>0) then
            break;
          if (leaf = $ff) then
          begin
            inc(i);
            continue;
          end;
          inc(i , leaf shr 4);
          len := leaf and 15;
          if (len = 0) then
          begin
            inc(i);
            continue;
          end;
          diff := getbits(rec^,len);
          if ((diff and (1 shl (len-1))) = 0) then
            dec(diff , (1 shl len) - 1);
          if (i < 64) then
            diffbuf[i] := diff;
          inc(i);
        end;
        inc(diffbuf[0] , carry);
        carry := diffbuf[0];
        for i:=0 to 64-1 do
        begin
          if (pnum mod raw_width = 0) then
          begin
            base[1] := 512;
            base[0] := base[1];
          end;
          inc(pnum);
          inc(base[i and 1] , diffbuf[i]);
          pixel[(block shl 6) + i] := ( base[i and 1] );
        end;
      end;
      if (lowbits<>0) then
      begin
        save := ftell(ifp);			(* Don't lose our place *)
        ifp.Position:=26 + row*raw_width div 4; //fseek (ifp, 26 + row*raw_width/4, SEEK_SET);
        prow:=pword(pixel);
        for i:=0 to raw_width*2-1 do
        begin
          c := fgetc(ifp);
          r:=0;
          while ( r < 8 ) do
          begin
            val := (prow^ shl 2) + ((c shr r) and 3);
            if (raw_width = 2672) and (val < 512) then
              inc(val , 2);
            prow^ := val;
            inc(r,2);
            inc(prow);
          end;
        end;
        ifp.Position:=save; //fseek (ifp, save, SEEK_SET);
      end;
      for r:=0 to 8-1 do
      begin

        irow := row - top_margin + r;

        if (dword(irow) >= dword(height)) or (irow<0) then
          continue;

        for col := 0 to raw_width-1 do
        begin

          icol := col - left_margin;

          if (dword(icol) < dword(width)) and (icol>=0) then
            //BAYER(irow,icol)^ := pixel[r*raw_width+col] shl shift
            image[(irow shr shrink)*iwidth + (icol shr shrink)][ (filters shr (((irow shl 1 and 14) + (icol and 1)) shl 1) and 3) ]
              :=
            pixel[r*raw_width+col] shl shift
          else
            inc(bblack , pixel[r*raw_width+col] );
        end;
      end;
      inc(row , 8);
    end;
    freemem(pixel);
    if (raw_width > width) then
      black := (bblack shl shift) div ((raw_width - width) * height);
  end;
end;

procedure kodak_curve (var rec:TRec; curve:pwordarray);
var
  i, entries, tag, len, val:integer;
begin
  with rec do
  begin
    for i:=0 to $1000-1 do
      curve[i] := i;
    if strcasecmp(make,'KODAK')<>0 then
      exit;
    if (curve_offset<>0) then
    begin
      ifp.Position:=12; //fseek (ifp, 12, SEEK_SET);
      entries := fget2(rec,ifp);
      while entries<>0 do
      begin
        dec(entries);
        tag  := fget2(rec,ifp);
        fget2(rec,ifp);
        len  := fget4(rec,ifp);
        val  := fget4(rec,ifp);
        if (tag = $90d) then
        begin
          curve_offset := val;
          curve_length := len;
        end;
      end;
    end;
    if (curve_offset<>0) then
    begin
      ifp.Position:=curve_offset; //fseek (ifp, curve_offset, SEEK_SET);
      i:=0;
      while i<curve_length do
      begin
        curve[i] := fget2(rec,ifp);
        inc(i);
      end;
      while i < $1000 do
      begin
        curve[i] := curve[i-1];
        inc(i);
      end;
      rgb_max := curve[i-1] shl 2;
    end;
    ifp.Position:=data_offset; // fseek (ifp, data_offset, SEEK_SET);
  end;
end;

var test:integer;

(*
   Not a full implementation of Lossless JPEG,
   just enough to decode Canon and Kodak images.
 *)
procedure lossless_jpeg_load_raw(rec:PRec);
var
  tag, len, jhigh, jwide, jrow, jcol, jidx, diff, i, row, col:integer;
  data:array [0..256-1] of byte;
  dp:pbyte;
  vpred, hpred:array [0..1] of integer;
  dstart:array [0..2-1] of pdecode;
  dindex:pdecode;
  curve:array [0..$1000-1] of word;
  bblack:int64;
  min:integer;
begin
  with rec^ do
  begin
    jhigh:=0;
    jwide:=0;
    vpred[0] := $800;
    vpred[1] := $800;
    bblack:=0;
    min:=maxint;

    kodak_curve(rec^,@curve);
    order := $4d4d;
    if (fget2(rec^,ifp) <> $ffd8) then
      exit;
    repeat
      tag := fget2(rec^,ifp);
      len := fget2(rec^,ifp) - 2;
      if (tag <= $ff00) or (len > 255) then
        exit;