lsjpeg.pas

用Delphi做的读取医学图片的控件及代码

unit lsjpeg;
{//$DEFINE Stream}
//rev13: changes by CR and JGS
//rev19: uses Lookup table for decoding Huffman table: this doubles the speed
interface

uses
{$IFDEF Linux}
  SysUtils,QDialogs,QControls,define_types;
{$ELSE}
  dialogs,sysutils,windows,define_types,classes;
{$ENDIF}
type
    HufRA = record
           HufSz,HufCode,HufVal: Integer;
    end;
{$IFDEF Stream}
  procedure DecodeJPEG(var lStream: TMemoryStream; var lOutSmallRA: SmallIntP0; var lImgRAz: ByteP0;lOutputSz,lCptPosition,lCptSize: integer; lVerbose: boolean);
{$ELSE}
  procedure DecodeJPEG(var infp: file; var lOutSmallRA: SmallIntP0; var lImgRAz: ByteP0;lOutputSz,lCptPosition,lCptSize: integer; lVerbose: boolean);
{$ENDIF}
implementation

{$IFDEF Stream}
  procedure DecodeJPEG(var lStream: TMemoryStream; var lOutSmallRA: SmallIntP0; var lImgRAz: ByteP0;lOutputSz,lCptPosition,lCptSize: integer; lVerbose: boolean);
{$ELSE}
procedure DecodeJPEG(var infp: file; var lOutSmallRA: SmallIntP0; var lImgRAz: ByteP0;lOutputSz,lCptPosition,lCptSize: integer; lVerbose: boolean);
{$ENDIF}
const
     kmaxFrames = 4;
label
     666 {EOF};
  var
    lRawRA: bytep;
    lImgRA: WordP;
    lHufVal,lAbba,lOffset,lLineStart,lPredicted,lPredictedG,lPredictedB,lRestartSegmentSz,
    lSz,k,Code,Si,lIncX,lIncY,lInc,lPredA,lPredB,lPredC,lCurrentBitPos,btS1,btS2, btMarkerType,
    DHTnLi,DHTtcth,SOFprecision,SOSpttrans, SOFnf,SOFarrayPos,SOSns,SOSarrayPos,SOSss,SOSse,SOSahal:integer;//byte;
    lHufTable,lnHufTables,{lDecode,}lImgStart,lRawSz,lRawPos,lItems,SOFydim, SOFxdim: integer;
    lMaxHufSi,lMaxHufVal: array [1..kmaxFrames] of integer;
    DHTLiRA,DHTstartRA: array [1..kmaxFrames,0..31] of integer;//byte;
    lBitMask: array [1..17] of integer;
    lSSSSszRA: array [1..kMaxFrames,0..17] of byte;
    lLookUpRA: array [1..kMaxFrames,0..255] of byte; //lists all possible SSSS with <= 8bits
    lHufRA: array [1..kMaxFrames,0..31] of HufRA;
    lFrameCount,lSegmentLength,lSegmentEnd,lI: integer;
    lImgTypeC3,lHdrOK: boolean;
function ReadBit: integer; //Read the next single bit
begin
     result := (lRawRA[lRawPos] shr (7-lCurrentBitPos)) and 1;
     lCurrentBitPos := lCurrentBitPos + 1;
     if (lCurrentBitPos = 8) then begin
        lRawPos := 1+lRawPos;
        lCurrentBitPos := 0;
     end;
end;

//Disabled Procedures
// These functions are not used: these routines have been inlined (following VTune profiling)
// but they are useful utilities if you want to explore Huffman Tables
(*function ReadBits2_9 ( lNum: integer): integer; //lNum: bits to read, not to exceed 9
//wo Advance: does not increment the Byte/Bit position. Use AdvanceBitPos to do this
begin
     result := lRawRA[lRawPos];
     result := result shl 8 + lRawRA[lRawPos+1];
     //result := result shl 8 + lRawRA[lRawPos+2];
     result := (result shr (16-lCurrentBitPos-lNum)) and lBitMask[lNum]; //lCurrentBitPos is incremented from 1, so -1
     lCurrentBitPos := lCurrentBitPos + lNum;
     if (lCurrentBitPos > 7) then begin
        lRawPos := lRawPos+(lCurrentBitPos shr 3{div 8});
        lCurrentBitPos := (lCurrentBitPos and 7{mod 8});
     end;
end;
procedure RetractBitPos(lNum: integer);
begin
  lCurrentBitPos := lCurrentBitPos - lNum;
  while (lCurrentBitPos < 0) do begin
    lRawPos := lRawPos - 1;
    lCurrentBitPos := lCurrentBitPos + 8;
  end;
end;
procedure AdvanceBitPos(lNum: integer);
//Advances Bit/Byte counters
begin
     lCurrentBitPos := lCurrentBitPos + lNum;
     if (lCurrentBitPos > 7) then begin
        lRawPos := lRawPos+(lCurrentBitPos shr 3{div 8});
        lCurrentBitPos := (lCurrentBitPos and 7{mod 8});
     end;
end;*)

function ReadBits ( lNum: integer): integer; //lNum: bits to read, not to exceed 16
begin
     result := lRawRA[lRawPos];
     result := result shl 8 + lRawRA[lRawPos+1];
     result := result shl 8 + lRawRA[lRawPos+2];
     result := (result shr (24-lCurrentBitPos-lNum)) and lBitMask[lNum]; //lCurrentBitPos is incremented from 1, so -1
     lCurrentBitPos := lCurrentBitPos + lNum;
     if (lCurrentBitPos > 7) then begin
        lRawPos := lRawPos+(lCurrentBitPos shr 3{div 8});
        lCurrentBitPos := (lCurrentBitPos and 7{mod 8});
     end;
end;

function DecodePixelDifference( lFrame: integer): integer;//Red/Green/Blue each a separate 'Frame': can have unique huffman tables
var
   lByte,lHufValSSSS,lInput,lInputbits,lDiff,lI: integer;
begin
  // read one byte from the stream, without modifying the pointer
  lByte := (lRawRA[lRawPos] shl lCurrentBitPos) + (lRawRA[lRawPos+1] shr (8-lCurrentBitPos));
  lByte := lByte and 255;
  lHufValSSSS := lLookUpRA[lFrame,lByte];
  //lLookUpRA: array [1..kMaxFrames,0..255] of byte; //lists all possible SSSS with <= 8bits
  if lHufValSSSS < 255 then begin
     lCurrentBitPos := lSSSSszRA[lFrame,lHufValSSSS] + lCurrentBitPos;
     lRawPos := lRawPos + (lCurrentBitpos shr 3);
     lCurrentBitpos := lCurrentBitpos and 7;
     //AdvanceBitPos(lSSSSszRA[lFrame,lSSSS]), but inlined;
  end else begin //full SSSS is not in the first 8-bits
   if (lByte < 0) or (lByte > 255) then showmessage('yikes');
   lInput := lByte;
   lInputBits := 8;
   inc(lRawPos); // forward 8 bits = precisely 1 byte
   repeat
      Inc(lInputBits);
      lInput := lInput shl 1 + ReadBit;
      if DHTLiRA[lFrame,lInputBits] <> 0 then begin //if any entires with this length
         for lI := DHTstartRA[lFrame,lInputBits] to (DHTstartRA[lFrame,lInputBits]+DHTLiRA[lFrame,lInputBits]-1) do begin
            if (lInput = lHufRA[lFrame,lI].HufCode) then
             lHufValSSSS := lHufRA[lFrame,lI].HufVal;
         end; //check each code
      end; //if any entires with this length
      if (lInputBits >= lMaxHufSi[lFrame]) and (lHufValSSSS > 254) then begin//exhausted options CR: added rev13
         lHufValSSSS := lMaxHufVal[lFrame]; 
      end;
   until (lHufValSSSS < 255){found};
  end; //answer in first 8 bits
  //The HufVal is referred to as the SSSS in the Codec, so it is called 'lHufValSSSS'
  case lHufValSSSS of
          0: result:= 0;
          1: if ReadBit = 0 then result := -1 else result := 1;
          (*BELOW only a tiny bit faster to separate 2..15 into 2..9 and 10..15, requires extra procedure and more
          2..9: begin //see 10..15 for explanation
                     lDiff := ReadBits2_9(lHufValSSSS);
                     if (lDiff > (lBitMask[lHufValSSSS-1])) then  //add
                        result := lDiff
                     else //negation
                          result := lDiff - lBitMask[lHufValSSSS];
                end; //2..9 *)
          2..15: begin
          //Osiris includes extra bits after SSSS=16...a violation of the standard See "TABLE H.2 - Difference categories for lossless Huffman coding" of the codec ITU-T81
          //According to the Codec H.1.2.2 "No extra bits are appended after SSSS = 16 is encoded."
          //To patch for Osiris Change case from 2..15 to 2..16
          //  This will work for Osiris images, but will break non-Osiris images
              lDiff := ReadBits(lHufValSSSS);
              if (lDiff > (lBitMask[lHufValSSSS-1])) then  //add
                  result := lDiff
                  // this is slightly unintuitive: the positive bit is identical to the offset shown in TABLE H.2, a slower but more intuitive way to do this is:
                  //result := (lDiff and lBitMask[lHufVal-1]) + (1 shl (lHufval-1));
                  //where you clip off the sign bit and then SHL appropriately
              else //negation
                 result := lDiff - lBitMask[lHufValSSSS];
                 //NEXT to lines are a bit more intuitive:
                 {lDiff := lBitMask[lHufVal-1]- lDiff;
                 result := -(lDiff + (1 shl (lHufval-1)));}//negation
          end; //10..15
          else {16, not osiris}
               result := 32768;
  end; //case HuffVal
end; //func DecodePixelDifference

procedure ReadByte(var lByte: integer);
begin
     inc(lRawPos);
     lByte := lRawRA[lRawPos];
end;

function ReadWord: word;
var
   lbtL1, lbtL2: byte;
begin
     inc(lRawPos);
     lbtL1 := lRawRA[lRawPos];
     inc(lRawPos);
     lbtL2 := lRawRA[lRawPos];
     result := (256 * lbtL1 + lbtL2)
end;
//NEXT: main procedure
  begin
    lAbba := 4;
    lnHufTables := 0;
    lRawSz := lCptSize;
    lRawPos := 0;
    lRestartSegmentSz := 0;
    lImgTypeC3 := false;
    SOFxdim:= 1;
    if lRawSz < 32 then goto 666;
    for lFrameCount := 1 to kMaxFrames do
      for lInc := 1 to 16 do
        DHTstartRA[lFrameCount,lInc] := 0;
    SOFydim := 1;
    SOSpttrans := 0;
    lHdrOK := false;
    SOFnf := 0;
    SOSns := 0;
    GetMem( lRawRA, lRawSz);
{$IFDEF Stream}
    lStream.Seek(lCptPosition, soFromBeginning);
    lStream.readBuffer(lRawRA^, lRawSz);
{$ELSE}
    Seek(infp,lCptPosition);
    BlockRead(infp, lRawRA^, lRawSz);
{$ENDIF}
    ReadByte(btS1);
    ReadByte(btS1);
    repeat
      repeat
            if lRawPos <= lRawSz then ReadByte(btS1);
            if btS1 <> $FF then begin
               goto 666;
            end;
            if lRawPos <= lRawSz then  ReadByte( btMarkerType);
            case btMarkerType of //only process segments with length fields
                 $0,$1,$D0..$D7,$FF: btMarkerType := 0; //0&FF = fillers, $1=TEM,$D0..D7=resync
            end;
      until (lRawPos >= lRawSz) or (btMarkerType <> 0);
      lSegmentLength := ReadWord;
      lSegmentEnd := lRawPos+(lSegmentLength - 2);
      if lSegmentEnd > lRawSz then goto 666;
      if (btMarkerType = $C3)  then
         lImgTypeC3 := true;
       if lverbose then showmessage( {result+}inttohex(btMarkerType,2){':'+inttostr( lSegmentLength )+'@'+inttostr(positon)+' '});
      case btMarkerType of
           $0: ; //filler - ignore
           $C0..$C3,$C5..$CB,$CD..$CF: begin //read SOF FrameHeader
             ReadByte(SOFprecision);
             SOFydim := ReadWord;
             SOFxdim:= ReadWord;
             ReadByte(SOFnf);
             if lverbose then Showmessage('[precision:'+inttostr(SOFprecision)+' X*Y:'+inttostr(SOFxdim)+'*'+inttostr(SOFydim)+'nFrames:'+inttostr(SOFnf)+'] ');
             if (not lImgTypeC3) or ((SOFnf <> 1) and (SOFnf <> 3)) then begin
                 showmessage('Unable to extract this file format.');
             end;
             SOFarrayPos := lRawPos;
             lRawPos := (lSegmentEnd);
           end; //SOF FrameHeader
           $C4: begin //DHT Huffman
              if lverbose then showmessage( 'HuffmanLength'+inttostr(lSegmentLength)+':');
            //if SOFnf <1 then SOFnf := 1; //we may not know SOFnf yet!
            lFrameCount := 1;
            repeat
             ReadByte( DHTtcth);
             //showmessage(inttostr(lFrameCount)+'@'+inttostr(DHTtcth and 15)+'x'+inttostr(DHTtcth ));
             DHTnLi := 0;
             for lInc := 1 to 16 do begin
                 ReadByte(DHTliRA[lFrameCount,lInc]);
                 DHTnLi := DHTnLi +  DHTliRA[lFrameCount,lInc];
                 if DHTliRA[lFrameCount,lInc] <> 0 then lMaxHufSi[lFrameCount] := lInc;
                 //showmessage(inttostr(DHTliRA[lFrameCount,lInc])+'@'+inttostr(lMaxHufSi));
             end;
             if DHTnLi > 17 then begin
                showmessage('Huffman table corrupted.');
                goto 666;
             end;
             lIncY := 0; //frequency

             for lInc := 0 to 31 do begin
               lHufRA[lFrameCount, lInc].HufVal := -1;
               lHufRA[lFrameCount, lInc].HufSz := -1;
               lHufRA[lFrameCount, lInc].HufCode := -1;
             end;

             for lInc := 1 to 16 do begin //set the huffman size values