ieraw.pas

·ImageEn 2.3.0 ImageEn一组用于图像处理、查看和分析的Delphi控件。能够保存几种图像格式

      end;
    end;
    needrot45:=true;
  end;
end;

procedure fuji_s5000_load_raw(rec:PRec);
begin
  with rec^ do
  begin
    ifp.position:=ifp.position+ (1472*4+24)*2; //fseek (ifp, (1472*4+24)*2, SEEK_CUR);
    fuji_common_load_raw (rec^,1472, 1423, 2152);
  end;
end;

procedure fuji_s7000_load_raw(rec:PRec);
begin
  fuji_common_load_raw (rec^,2048, 2047, 3080);
end;

(*
   The Fuji Super CCD SR has two photodiodes for each pixel.
   The secondary has about 1/16 the sensitivity of the primary,
   but this ratio may vary.
 *)
procedure fuji_f700_load_raw(rec:PRec);
var
  pixel: array [0..2944-1] of word;
  row, col, r, c, val:integer;
begin
  with rec^ do
  begin
    xprogress.per1 := 100 / 2168 / 2;
    for row:=0 to 2168-1 do
    begin

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

      ifp.read(pixel[0],2*2944); //fread (pixel, 2, 2944, ifp);
      if (ntohs($aa55) = $aa55)	then(* data is little-endian *)
        swab (pchar(@pixel), pchar(@pixel), 2944*2);
      for col:=0 to 1440-1 do
      begin
        r := 1439 - col + (row shr 1);
        c := col + ((row+1) shr 1);
        val := pixel[col+16 + use_secondary*1472];
        BAYER(rec^,r,c)^ := val;
      end;
    end;
    needrot45:=true;
  end;
end;

procedure rollei_load_raw(rec:PRec);
var
  pixel:array [0..10-1] of byte;
  iten, isix, i, buffer, row, col:dword;
  todo:array [0..16-1] of dword;
  qq:integer;
begin
  with rec^ do
  begin
    iten:=0;
    buffer:=0;

    isix := raw_width * raw_height * 5 div 8;
    while true do
    begin
      qq:=ifp.Read(pixel[0],10); //fread (pixel, 1, 10, ifp)
      if qq<>10 then
        break;
      i:=0;
      while ( i < 10) do
      begin
        todo[i]   := iten; inc(iten);
        todo[i+1] := pixel[i] shl 8 or pixel[i+1];
        buffer    := pixel[i] shr 2 or buffer shl 6;
        inc(i,2);
      end;
      while ( i < 16 ) do
      begin
        todo[i]   := isix; inc(isix);
        todo[i+1] := buffer shr (14-i)*5;
        inc(i,2);
      end;
      i:=0;
      while ( i < 16 ) do
      begin
        row := todo[i] div raw_width - top_margin;
        col := todo[i] mod raw_width - left_margin;
        if (row < height) and (col < width) then
          BAYER(rec^,row,col)^ := (todo[i+1] and $3ff) shl 4;
        inc(i,2);
      end;
    end;
  end;
end;

procedure phase_one_load_raw(rec:PRec);
var
  row, col, a, b:integer;
  pixel:array [0..4134-1] of word;
  akey, bkey:word;
begin
  with rec^ do
  begin
    ifp.Position:=ifp.Position+ 8; //fseek (ifp, 8, SEEK_CUR);
    ifp.Position:=ifp.Position+ fget4(rec^,ifp) + 296; //fseek (ifp, fget4(ifp) + 296, SEEK_CUR);
    akey := fget2(rec^,ifp);
    bkey := fget2(rec^,ifp);
    ifp.Position:=data_offset + 12 + top_margin*raw_width*2; //fseek (ifp, data_offset + 12 + top_margin*raw_width*2, SEEK_SET);
    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(pixel[0],2*raw_width); //fread (pixel, 2, raw_width, ifp);
      col:=0;
      while ( col < raw_width ) do
      begin
        a := ntohs(pixel[col+0]) xor akey;
        b := ntohs(pixel[col+1]) xor bkey;
        pixel[col+0] := (b and $aaaa) or (a and $5555);
        pixel[col+1] := (a and $aaaa) or (b and $5555);
        inc(col,2);
      end;
      for col:=0 to width-1 do
        BAYER(rec^,row,col)^ := pixel[col+left_margin];
    end;
  end;
end;

procedure ixpress_load_raw(rec:PRec);
var
  pixel:array [0..4090-1] of word;
  row, col:integer;
begin
  with rec^ do
  begin
    ifp.Position:=304 + 6*2*4090; //fseek (ifp, 304 + 6*2*4090, SEEK_SET);
    xprogress.per1 := 100 / height / 2;
    row:=height;
    dec(row);
    while ( row >= 0 ) do
    begin

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

      ifp.Read(pixel[0],2*4090); //fread (pixel, 2, 4090, ifp);
      if (ntohs($aa55) = $aa55)	then (* data is little-endian *)
        swab (pchar(@pixel), pchar(@pixel), 4090*2);
      for col:=0 to width-1 do
        BAYER(rec^,row,col)^ := pixel[width-1-col];
      dec(row);
    end;
  end;
end;

(* For this function only, raw_width is in bytes, not pixels! *)
procedure packed_12_load_raw(rec:PRec);
var
  row, col:integer;
begin
  with rec^ do
  begin
    getbits(rec^,-1);
    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));

      for col:=0 to width-1 do
        BAYER(rec^,row,col)^ := getbits(rec^,12) shl 2;
      for col := width*3 div 2 to raw_width-1 do
        getbits(rec^,8);
    end;
  end;
end;

procedure unpacked_load_raw (var rec:TRec; xorder:integer; rsh:integer);
var
  pixel:pwordarray;
  row, col:integer;
begin
  with rec do
  begin
    pixel := allocmem(raw_width * sizeof(word));
    merror (pixel, 'unpacked_load_raw()');
    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(pixel[0],2*raw_width); //fread (pixel, 2, raw_width, ifp);

      if (xorder <> ntohs($55aa)) then
        swab (pchar(pixel), pchar(pixel), width*2);

      for col:=0 to width-1 do
        BAYER(rec,row,col)^ := pixel[col] shl 8 shr (8+rsh);
    end;
    freemem(pixel);
  end;
end;

procedure be_16_load_raw(rec:PRec);		(* "be" = "big-endian" *)
begin
  unpacked_load_raw (rec^,$55aa, 0);
end;

procedure be_high_12_load_raw(rec:PRec);
begin
  unpacked_load_raw (rec^,$55aa, 2);
end;

procedure be_low_12_load_raw(rec:PRec);
begin
  unpacked_load_raw (rec^,$55aa,-2);
end;

procedure be_low_10_load_raw(rec:PRec);
begin
  unpacked_load_raw (rec^,$55aa,-4);
end;

procedure le_high_12_load_raw(rec:PRec);	(* "le" = "little-endian" *)
begin
  unpacked_load_raw (rec^,$aa55, 2);
end;

procedure olympus_cseries_load_raw(rec:PRec);
var
  irow, row, col:integer;
begin
  with rec^ do
  begin
    xprogress.per1 := 100 / height / 2;
    for irow:=0 to height-1 do
    begin

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

      row := irow * 2 mod height + irow div (height div 2);
      if (row < 2) then
      begin
        ifp.Position:= data_offset - row*(-width*height*3 div 4 and -2048); //fseek (ifp, data_offset - row*(-width*height*3/4 & -2048), SEEK_SET);
        getbits(rec^,-1);
      end;
      for col:=0 to width-1 do
        BAYER(rec^,row,col)^ := getbits(rec^,12) shl 2;
    end;
  end;
end;

procedure eight_bit_load_raw(rec:PRec);
var
  pixel:pbytearray;
  row, col:integer;
begin
  with rec^ do
  begin
    pixel := allocmem(raw_width * sizeof(byte));
    merror (pixel, 'eight_bit_load_raw()');
    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(pixel[0],raw_width); //fread (pixel, 1, raw_width, ifp);
      for col:=0 to width-1 do
        BAYER(rec^,row,col)^ := pixel[col] shl 6;
    end;
    freemem (pixel);
  end;
end;

procedure casio_qv5700_load_raw(rec:PRec);
var
  data:array [0..3232-1] of byte;
  dp:pbytearray;
  pixel:array [0..2576-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],3232); //fread (data, 1, 3232, ifp);
      dp:=@data;
      pix:=@pixel;
      while ( integer(dp) < integer(@data)+3220 ) do
      begin
        pix[0] := (dp[0] shl 2) + (dp[1] shr 6);
        pix[1] := (dp[1] shl 4) + (dp[2] shr 4);
        pix[2] := (dp[2] shl 6) + (dp[3] shr 2);
        pix[3] := (dp[3] shl 8) + (dp[4]     );
        inc(dp,5);
        inc(pix,4);
      end;
      for col:=0 to width-1 do
        BAYER(rec^,row,col)^ := (pixel[col] and $3ff) shl 4;
    end;
  end;
end;

procedure nucore_load_raw(rec:PRec);
var
  data:pbytearray;
  dp:pbytearray;
  irow, row, col:integer;
begin
  with rec^ do
  begin
    data := allocmem(width * 2);
    merror (data, 'nucore_load_raw()');
    xprogress.per1 := 100 / height / 2;
    for irow:=0 to height-1 do
    begin

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

      ifp.Read(data^,2*width); //fread (data, 2, width, ifp);
      if (model[0] = 'B') and (width = 2598) then
        row := height - 1 - irow div 2 - height div 2 * (irow and 1)
      else
        row := irow;
      dp:=data;
      for col:=0 to width-1 do
      begin
        BAYER(rec^,row,col)^ := (dp[0] shl 2) + (dp[1] shl 10);
        inc(pbyte(dp),2);
      end;
    end;
    freemem(data);
  end;
end;

function make_decoder_int (var rec:TRec; source:pintegerarray; level:integer):pintegerarray;
var
  cur:pdecode;
begin
  with rec do
  begin
    cur := free_decode; inc(free_decode);
    if (level < source[0]) then
    begin
      cur^.branch[0] := free_decode;
      source := make_decoder_int (rec,source, level+1);
      cur^.branch[1] := free_decode;
      source := make_decoder_int (rec,source, level+1);
    end
    else
    begin
      cur^.leaf := source[1];
      inc(pinteger(source) , 2);
    end;
    result:=source;
  end;
end;

function radc_token (var rec:TRec; tree:integer):integer;
const
  source:array [0..259] of integer = (
    1,1, 2,3, 3,4, 4,2, 5,7, 6,5, 7,6, 7,8,
    1,0, 2,1, 3,3, 4,4, 5,2, 6,7, 7,6, 8,5, 8,8,
    2,1, 2,3, 3,0, 3,2, 3,4, 4,6, 5,5, 6,7, 6,8,
    2,0, 2,1, 2,3, 3,2, 4,4, 5,6, 6,7, 7,5, 7,8,
    2,1, 2,4, 3,0, 3,2, 3,3, 4,7, 5,5, 6,6, 6,8,
    2,3, 3,1, 3,2, 3,4, 3,5, 3,6, 4,7, 5,0, 5,8,
    2,3, 2,6, 3,0, 3,1, 4,4, 4,5, 4,7, 5,2, 5,8,
    2,4, 2,7, 3,3, 3,6, 4,1, 4,2, 4,5, 5,0, 5,8,
    2,6, 3,1, 3,3, 3,5, 3,7, 3,8, 4,0, 5,2, 5,4,
    2,0, 2,1, 3,2, 3,3, 4,4, 4,5, 5,6, 5,7, 4,8,
    1,0, 2,2, 2,-2,
    1,-3, 1,3,
    2,-17, 2,-5, 2,5, 2,17,
    2,-7, 2,2, 2,9, 2,18,
    2,-18, 2,-9, 2,-2, 2,7,
    2,-28, 2,28, 3,-49, 3,-9, 3,9, 4,49, 5,-79, 5,79,
    2,-1, 2,13, 2,26, 3,39, 4,-16, 5,55, 6,-37, 6,76,
    2,-26, 2,-13, 2,1, 3,-39, 4,16, 5,-55, 6,-76, 6,37
  );
var
  t:integer;
begin
  with rec do
  begin
    if (free_decode = @first_decode) then
    begin
      radc_token_s:=@source;
      for t:=0 to 18-1 do
      begin
        radc_token_dstart[t] := free_decode;
        radc_token_s := make_decoder_int (rec,radc_token_s, 0);
      end;
    end;
    if (tree = 18) then
    begin
      if (model[2] = '4') then
      begin
        result:= (getbits(rec,5) shl 3) + 4;	(* DC40 *)
        exit;
      end
      else
      begin
        result:= (getbits(rec,6) shl 2) + 2;	(* DC50 *)
        exit;
      end;
    end;
    radc_token_dindex := radc_token_dstart[tree];
    while( radc_token_dindex^.branch[0]<>nil ) do
      radc_token_dindex := radc_token_dindex^.branch[getbits(rec,1)];
    result:= radc_token_dindex^.leaf;
  end;
end;

procedure memcpy(dest, source: Pointer; count: Integer);
begin
  Move(source^, dest^, count);
end;

// replacement of "!x" where "x" is "int"
function IENOT(x:integer):integer;
begin
  result:=integer(not boolean(x));
end;

//#define PREDICTOR (c ? (buf[c][y-1][x] + buf[c][y][x+1]) / 2 : (buf[c][y-1][x+1] + 2*buf[c][y-1][x] + buf[c][y][x+1]) / 4)

procedure kodak_radc_load_raw(rec:PRec);
var
  row, col, tree, nreps, rep, step, i, c, s, r, x, y, val:integer;
  last:array [0..3-1] of smallint;
  mul:array [0..3-1] of smallint;
  buf:array [0..3-1] of array [0..3-1] of array [0..386-1] of smallint;

  function PREDICTOR:integer;
  begin
    result:=IEIFI(c<>0 , (buf[c][y-1][x] + buf[c][y][x+1]) div 2 , (buf[c][y-1][x+1] + 2*buf[c][y-1][x] + buf[c][y][x+1]) div 4);
  end;

begin
  with rec^ do
  begin
    last[0]:=16;
    last[1]:=16;
    last[2]:=16;

    init_decoder(rec^);
    getbits(rec^,-1);
    for i:=0 to sizeof(buf) div sizeof(smallint)-1 do
      buf[0][0][i] := 2048;
    xprogress.per1 := 100 / height / 2;
    row:=0;
    while (row < height) do
    begin