lsjpeg.pas

在delphi7 下开发医学图象浏览器,对医学图象进行编辑,分析的

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
              if DHTliRA[lFrameCount, lInc] > 0 then
              begin
                DHTstartRA[lFrameCount, lInc] := lIncY + 1;
                for lIncX := 1 to DHTliRA[lFrameCount, lInc] do
                begin
                  inc(lIncY);
                  ReadByte(btS1);
                  lHufRA[lFrameCount, lIncY].HufVal := btS1;
                  lMaxHufVal[lFrameCount] := btS1;
                  if (btS1 >= 0) and (btS1 <= 16) then
                    lHufRA[lFrameCount, lIncY].HufSz := lInc
                  else
                  begin