stlarr.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

procedure TStLMatrix.Get(Row, Col : Cardinal; var Value);
(* model for assembly language below
begin
  move((PChar(lmData)+(Row*FCols+Col)*FElSize)^, Value, FElSize);
end;
*)
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if (Row >= Rows) or (Col >= Cols) then
      RaiseContainerError(stscBadIndex);
    asm
      mov eax,Self
      push esi
      push edi
      mov edi,Value
      mov esi,Row
      imul esi,TStLMatrix([eax]).FCols
      add esi,Col
      mov ecx,TStLMatrix([eax]).FElSize
      db $0F,$AF,$F1     {imul esi,ecx, compiler bug workaround}
      add esi,TStLMatrix([eax]).lmData
      mov eax,ecx
      shr ecx,2
      rep movsd
      mov ecx,eax
      and ecx,3
      rep movsb
      pop edi
      pop esi
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLMatrix.GetRow(Row : Cardinal; var RowValue);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if Row >= Rows then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    move((PChar(lmData)+(LongInt(Row)*lmRowSize))^, RowValue, lmRowSize);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLMatrix.lmSetCols(Cols : Cardinal);
var
  CurSize, NewSize, CurRowSize, NewRowSize, BufSize : LongInt;
  R, CurCols : Cardinal;
  CurFData, NewFData, RowData : Pointer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Cols = FCols then
      Exit;

    {validate new size}
    if (Cols = 0) or
    ProductOverflow(Cols, FRows) or
    ProductOverflow(LongInt(Cols)*LongInt(FRows), FElSize) then
      RaiseContainerError(stscBadSize);

    {compute and save various sizes}
    CurSize := FCount*FElSize;
    NewSize := LongInt(Cols)*LongInt(FRows)*FElSize;
    CurRowSize := lmRowSize;
    NewRowSize := LongInt(Cols)*FElSize;
    CurCols := FCols;
    CurFData := lmData;

    {allocate data block of new size}
    HugeGetMem(NewFData, NewSize);

    {allocate a buffer to transfer row data}
    if NewRowSize > CurRowSize then
      BufSize := NewRowSize
    else
      BufSize := CurRowSize;
    try
      HugeGetMem(RowData, BufSize);
    except
      HugeFreeMem(NewFData, NewSize);
    end;

    {transfer rows from old array to new}
    if Cols > CurCols then
      HugeFillChar(RowData^, BufSize, 0);
    for R := 0 to FRows-1 do begin
      FCols := CurCols;
      lmRowSize := CurRowSize;
      lmData := CurFData;
      GetRow(R, RowData^);
      FCols := Cols;
      lmRowSize := NewRowSize;
      lmData := NewFData;
      PutRow(R, RowData^);
    end;
    HugeFreeMem(RowData, BufSize);

    FCount := LongInt(Cols)*LongInt(FRows);

    {free original data area}
    HugeFreeMem(CurFData, CurSize);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLMatrix.lmSetRows(Rows : Cardinal);
var
  CurSize, NewSize : LongInt;
  CurFData : Pointer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Rows = FRows then
      Exit;

    {validate new size}
    if (Rows = 0) or
    ProductOverflow(Rows, FCols) or
    ProductOverflow(LongInt(Rows)*LongInt(FCols), FElSize) then
      RaiseContainerError(stscBadSize);

    CurSize := FCount*FElSize;
    NewSize := LongInt(Rows)*LongInt(FCols)*FElSize;
    CurFData := lmData;

    {allocate data block of new size}
    HugeGetMem(lmData, NewSize);

    FCount := LongInt(Rows)*LongInt(FCols);
    FRows := Rows;

    {fill extra area with zeros and copy old data}
    if NewSize > CurSize then begin
      Clear;
      NewSize := CurSize;
    end;
    HugeMove(CurFData^, lmData^, NewSize);

    {free original data area}
    HugeFreeMem(CurFData, CurSize);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLMatrix.Put(Row, Col : Cardinal; const Value);
(* model for assembly language below
begin
  move(Value, (PChar(lmData)+(Row*FCols+Col)*FElSize)^, FElSize);
end;
*)
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if (Row >= Rows) or (Col >= Cols) then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    asm
      mov eax,Self
      push esi
      push edi
      mov esi,Value
      mov edi,Row
      imul edi, TStLMatrix([eax]).FCols
      add edi,Col
      mov ecx,TStLMatrix([eax]).FElSize
      db $0F,$AF,$F9     {imul edi,ecx, compiler bug workaround}
      add edi,TStLMatrix([eax]).lmData
      mov eax,ecx
      shr ecx,2
      rep movsd
      mov ecx,eax
      and ecx,3
      rep movsb
      pop edi
      pop esi
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLMatrix.PutRow(Row : Cardinal; const RowValue);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if Row >= Rows then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    move(RowValue, (PChar(lmData)+(LongInt(Row)*lmRowSize))^, lmRowSize);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLMatrix.SortRows(KeyCol : Cardinal; Compare : TUntypedCompareFunc);
const
  StackSize = 32;
type
  Stack = array[0..StackSize-1] of LongInt;
var
  L : LongInt;
  R : LongInt;
  PL : LongInt;
  PR : LongInt;
  CurEl : Pointer;
  PivEl : Pointer;
  StackP : Integer;
  LStack : Stack;
  RStack : Stack;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if KeyCol >= FCols then
      RaiseContainerError(stscBadIndex);

    {Need at least 2 rows to sort}
    if FRows <= 1 then
      Exit;

    GetMem(CurEl, FElSize);
    try
      GetMem(PivEl, FElSize);

      {Initialize the stacks}
      StackP := 0;
      LStack[0] := 0;
      RStack[0] := FRows-1;

      {Repeatedly take top partition from stack}
      repeat

        {Pop the stack}
        L := LStack[StackP];
        R := RStack[StackP];
        Dec(StackP);

        {Sort current partition}
        repeat

          {Load the pivot element}
          Get((L+R) div 2, KeyCol, PivEl^);
          PL := L;
          PR := R;

          {Swap items in sort order around the pivot index}
          repeat
            Get(PL, KeyCol, CurEl^);
            while Compare(CurEl^, PivEl^) < 0 do begin
              Inc(PL);
              Get(PL, KeyCol, CurEl^);
            end;
            Get(PR, KeyCol, CurEl^);
            while Compare(PivEl^, CurEl^) < 0 do begin
              Dec(PR);
              Get(PR, KeyCol, CurEl^);
            end;
            if PL <= PR then begin
              if PL <> PR then
                {Swap the two elements}
                ExchangeRows(PL, PR);
              Inc(PL); {assume we'll never sort 2 billion elements}
              Dec(PR);
            end;
          until PL > PR;

          {Decide which partition to sort next}
          if (PR-L) < (R-PL) then begin
            {Right partition is bigger}
            if PL < R then begin
              {Stack the request for sorting right partition}
              Inc(StackP);
              LStack[StackP] := PL;
              RStack[StackP] := R;
            end;
            {Continue sorting left partition}
            R := PR;
          end else begin
            {Left partition is bigger}
            if L < PR then begin
              {Stack the request for sorting left partition}
              Inc(StackP);
              LStack[StackP] := L;
              RStack[StackP] := PR;
            end;
            {Continue sorting right partition}
            L := PL;
          end;

        until L >= R;
      until StackP < 0;

      FreeMem(PivEl, FElSize);
    finally
      FreeMem(CurEl, FElSize);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLMatrix.LoadFromStream(S : TStream);
var
  Data         : pointer;
  Reader       : TReader;
  NumRows      : longint;
  NumCols      : longint;
  ElementSize  : cardinal;
  R, C         : longint;
  TotSize      : longint;
  StreamedClass : TPersistentClass;
  StreamedClassName : string;
  Value        : TValueType;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Clear;
    Reader := TReader.Create(S, 1024);
    try
      with Reader do
        begin
          StreamedClassName := ReadString;
          StreamedClass := GetClass(StreamedClassName);
          if (StreamedClass = nil) then
            RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
          if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
             (not IsOrInheritsFrom(TStLMatrix, StreamedClass)) then
            RaiseContainerError(stscWrongClass);
          NumRows := ReadInteger;
          NumCols := ReadInteger;
          ElementSize := ReadInteger;
          if (NumRows <> LongInt(Rows)) or (NumCols <> LongInt(Cols)) or 
             (LongInt(ElementSize) <> FElSize) then                    
            begin
              HugeFreeMem(lmData, FCount*FElSize);
              FElSize := ElementSize;
              FRows := NumRows;
              FCols := NumCols;
              FCount := LongInt(NumRows)*NumCols;
              lmRowSize := LongInt(NumCols)*LongInt(ElementSize);      
              HugeGetMem(lmData, FCount*LongInt(ElementSize));         
              Clear;
            end;
          ElementsStorable := ReadBoolean;
          if ElementsStorable then
            begin
              Read(Value, sizeof(Value)); {s/b vaBinary}
              Read(TotSize, sizeof(longint));
              GetMem(Data, FElSize);
              try
                for R := 0 to pred(FRows) do
                  for C := 0 to pred(FCols) do
                     begin
                       Read(Data^, FElSize);
                       Put(R, C, Data^);
                     end;
              finally
                FreeMem(Data, FElSize);
              end;
            end
          else
            begin
              ReadListBegin;
              for R := 0 to pred(FRows) do
                for C := 0 to pred(FCols) do begin
                  Data := DoLoadData(Reader);
                  Put(R, C, Data^);
                end;
              ReadListEnd;
            end;
        end;
    finally
      Reader.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLMatrix.StoreToStream(S : TStream);
var
  Writer : TWriter;
  R, C   : integer;
  Data   : pointer;
  TotSize: longint;
  Value  : TValueType;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Writer := TWriter.Create(S, 1024);
    try
      GetMem(Data, FElSize);
      try
        with Writer do
          begin
            WriteString(Self.ClassName);
            WriteInteger(FRows);
            WriteInteger(FCols);
            WriteInteger(FElSize);
            WriteBoolean(FElStorable);
            if ElementsStorable then
              begin
                Value := vaBinary;
                Write(Value, sizeof(Value));
                TotSize := FCount * FElSize;
                Write(TotSize, sizeof(longint));
                for R := 0 to pred(FRows) do
                  for C := 0 to pred(FCols) do
                    begin
                      Get(R, C, Data^);
                      Write(Data^, FElSize);
                    end;
              end
            else
              begin
                WriteListBegin;
                for R := 0 to pred(FRows) do
                  for C := 0 to pred(FCols) do
                    begin
                      Get(R, C, Data^);
                      DoStoreData(Writer, Data);
                    end;
                WriteListEnd;
              end;
          end;
      finally
        FreeMem(Data, FElSize);
      end;
    finally
      Writer.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;


end.