cpwbuf.pas

生物信息学中的遗传数据分析的delphi源码。

      FirstChar := Buffer[0];
   end;

   { ANSI 'null' character }
   procedure BUFFEROBJ.AppendNull;
   begin
      Buffer[BufPtr] := #0;
   end;

   { Append CR/LF to string }
   procedure BUFFEROBJ.LineBreak;
   begin
     AppendChar (#13);
     AppendChar (#10);
   end;

   procedure BUFFEROBJ.AppendChar (ch:char);
   begin
      Buffer[BufPtr] := ch;
      Inc (BufPtr);
   end;

   procedure BUFFEROBJ.AppendString (s:string);
   var
      i: integer;
   begin
      for i := 1 to Length(s) do
         AppendChar (s[i]);
   end;

   { Draw a line from Start to Stop using Symbol }
   procedure BUFFEROBJ.InsertLine (Symbol:char; Start, Stop:integer);
   begin
      FillChar (Buffer[start], Succ (Stop - Start), Symbol);
      if BufPtr <= Stop then
         BufPtr := Succ(Stop);
   end;

   {$IFDEF MSDOS}
   procedure BUFFEROBJ.Show;
   var
      s: string;
   begin
      s := ToString;
      writeln (output, s);
   end;
   {$ENDIF}

   {$IFDEF WINDOWS}
   procedure BUFFEROBJ.Show;
   begin
      AppendNull;        { append #0 }
      writeln (output, Buffer);
   end;
   {$ENDIF}

{$IFDEF DEVICE}
{-----------------------------Display--------------------------------------}

   { Write the buffer to the display buffer text device }
   procedure BUFFEROBJ.Display;
   begin
      AppendNull;
      writeln (NEWLOG, Buffer);
   end;
{$ENDIF}


   procedure BUFFEROBJ.InsertChar (ch:char; there:integer);
   begin
      Buffer[There] := ch;
      if (There >= BufPtr) then
         BufPtr := Succ(There);
   end;

   procedure BUFFEROBJ.AppendInteger (i:longint);
   var
      TempString: string;
   begin
      Str (i, TempString);
      AppendString (TempString);
   end;

   { Append a formated integer }
   procedure BUFFEROBJ.AppendSInteger (i:longint;Spaces:integer);
   var
      TempString: string;
   begin
     Str (i:Spaces, TempString);
     AppendString (TempString);
   end;

   { Append a formated integer }
   procedure BUFFEROBJ.AppendSReal (r:real; n, m: integer);
   var
      TempString:string;
   begin
      Str (r:n:m, TempString);
      AppendString (TempString);
   end;

   procedure BUFFEROBJ.InsertInteger (i, there:integer);
   var
      TempStr: string;
   begin
      Str (i, TempStr);
      InsertString (TempStr, there);
   end;

   procedure BUFFEROBJ.InsertString (S: string; there:integer);
   var
      i, j: integer;
   begin
      j := There;
      for i := 1 to Length (S) do begin
         Buffer[j] := S[i];
         Inc (j);
         end;
      if (BufPtr < j) then
         BufPtr := j;
   end;


   procedure BUFFEROBJ.NewLine;
   begin
      Clear;
      Show;
   end;


   procedure BUFFEROBJ.Title (s:string);
   begin
      Clear;
      AppendString (s);
      Show;
   end;


   procedure BUFFEROBJ.AValue (ATitle:string; value:longint);
   begin
      Clear;
      AppendString (ATitle);
      AppendInteger (value);
   end;


{**********************}
{                      }
{  TEXTBUFFER object   }
{                      }
{**********************}


{$IFDEF WINDOWS}
constructor TEXTBUFFER.Init (LogWindow: PWindow; szUserProgName:PChar);
begin
   BufPtr        := 0;
   Head          := 0;
   Tail          := Head;
   Lines         := 0;
   Overwriting   := False;
   Echo          := False;
   Strip         := False;
   DisplayWindow := LogWindow;
   IsModified    := False;

   StrCopy (szProgName, szUserProgName);

   GetMem (Buffer, TEXTBUFFERSIZE+1);

{$IFDEF DEVICE}
   AssignLog (NewLog);
   Rewrite (NewLog);
   writeln (NewLog, szProgName);
   writeln (NewLog, DateStr + ', ' + TimeStr);
{$ELSE}
   ALine.Clear;
{$ENDIF}
end;

{$ELSE}
constructor TEXTBUFFER.Init;
begin
   BufPtr        := 0;
   Head          := 0;
   Tail          := Head;
   Lines         := 0;
   Overwriting   := False;
   Echo          := False;
   Strip         := False;
   ALine.Clear;
   GetMem (Buffer, TEXTBUFFERSIZE+1);
end;
{$ENDIF}



destructor TEXTBUFFER.Done;
begin
   { The order here is very important because the
     text device driver uses the display buffer. }

   {1. Send any remaining input to the display buffer. }
   {$IFDEF DEVICE}
   Close (NewLog);
   {$ENDIF}

   {2. Close log file (if any). }
   {$IFDEF WINDOWS}
   CloseLogFile;
   {$ENDIF}

   {3. Dispose of the buffer. }
   FreeMem (Buffer, TEXTBUFFERSIZE+1);
end;


{-----------------------------OverFlow-------------------------------------}

{ Bytes by which a line of text being added overflows
  past the end of the buffer. }
function TEXTBUFFER.Overflow (Length:integer):integer;
begin
   Overflow := (BufPtr + Length) - TEXTBUFFERSIZE;
end;

{-----------------------------InsertText-----------------------------------}

{ Insert a line buffer into the text buffer }
procedure TEXTBUFFER.InsertText (var S: ABUFFER);
var
   TextLength,
   Extra: integer;
begin
   IsModified := True;

   if Strip then
      {$IFDEF WINDOWS}
      OemToAnsi (S, S);
      {$ELSE}
      StripOEM (s);
      {$ENDIF}

   if Echo then begin
      {$I-}
      Write (LogFile, s);
      {$I+}
      ErrorRec.UpDate (IOResult);
      if ErrorRec.NotOK then
         Exit;
      end;

   TextLength := StrLen (S);
   Extra      := Overflow (TextLength);
   if (Extra > 0) then begin
      { S will go past the end of our text buffer, i.e.:

        abcdefghij
        ----
           x=end of buffer

        so break into two bits:

       efghij        abcd
       ------........----
       012345........   x

       and add the excess part to the start of the buffer,
       overwriting the previous contents. }

      if not Overwriting then
         Overwriting := True;

      if Overwriting then
         { Count the number of lines that S will overwrite }
         Lines := Lines - LinesBetween (Tail, Pred (Extra)) + 1
      else
         {$IFDEF DEVICE}
         { remember that not every string placed in the buffer
           will be a complete line. }
         if (S[Pred(TextLength)] = #10) then
            Inc(Lines);
         {$ELSE}
         Inc (Lines);
         {$ENDIF}

      Move (S[0], Buffer^[Tail], Succ(TextLength - Extra));
      Move (S[Succ(TextLength - Extra)], Buffer^[0], Pred(Extra));
      BufPtr := Pred (Extra);
      Tail   := BufPtr;
      if Overwriting then
         { move head }
         if (Tail < TEXTBUFFERSIZE) then
            Head := Succ (Tail)
         else Head := 0;
      end
   else begin

      { S will fit into buffer without having to be
        "wrapped" around. }

      { Keep track of lines }
      if Overwriting then
         { Count the number of lines that S will overwrite }
         Lines := Lines - LinesBetween (Tail, Tail + Pred (TextLength)) + 1
      else
         {$IFDEF DEVICE}
         { remember that not every string placed in the buffer
           will be a complete line. }
         if (S[Pred(TextLength)] = #10) then
            Inc(Lines);
         {$ELSE}
         Inc (Lines);
         {$ENDIF}

      Move (S[0], Buffer^[Tail], TextLength);
      BufPtr := BufPtr + TextLength;
      Tail   := BufPtr;
      if Overwriting then
         { move head }
         if (Tail < TEXTBUFFERSIZE) then
            Head := Succ (Tail)
         else Head := 0;
      end;
end;

{-----------------------------InsertPChar---------------------------------}

{ Insert a line buffer into the text buffer }
procedure TEXTBUFFER.InsertPChar (S: PChar);
var
   TextLength,
   Extra: integer;
begin
   IsModified := True;
   if Strip then
      OemToAnsi (S, S);
   if Echo then begin
      {$I-}
      Write (LogFile, s);
      {$I+}
      ErrorRec.UpDate (IOResult);
      if ErrorRec.NotOK then
         Exit;
      end;

   TextLength := StrLen (S);
   Extra      := Overflow (TextLength);
   if (Extra > 0) then begin
      { S will go past the end of our text buffer, i.e.:

        abcdefghij
        ----
           x=end of buffer

        so break into two bits:

       efghij        abcd
       ------........----
       012345........   x

       and add the excess part to the start of the buffer,
       overwriting the previous contents. }

      if not Overwriting then
         Overwriting := True;

      if Overwriting then
         { Count the number of lines that S will overwrite }
         Lines := Lines - LinesBetween (Tail, Pred (Extra)) + 1
      else
         {$IFDEF DEVICE}
         { remember that not every string placed in the buffer
           will be a complete line. }
         if (S[Pred(TextLength)] = #10) then
            Inc(Lines);
         {$ELSE}
         Inc (Lines);
         {$ENDIF}

      Move (S[0], Buffer^[Tail], Succ(TextLength - Extra));
      Move (S[Succ(TextLength - Extra)], Buffer^[0], Pred(Extra));
      BufPtr := Pred (Extra);
      Tail   := BufPtr;
      if Overwriting then
         { move head }
         if (Tail < TEXTBUFFERSIZE) then
            Head := Succ (Tail)
         else Head := 0;
      end
   else begin

      { S will fit into buffer without having to be
        "wrapped" around. }

      { Keep track of lines }
      if Overwriting then
         { Count the number of lines that S will overwrite }
         Lines := Lines - LinesBetween (Tail, Tail + Pred (TextLength)) + 1
      else
         {$IFDEF DEVICE}
         { remember that not every string placed in the buffer
           will be a complete line. }
         if (S[Pred(TextLength)] = #10) then
            Inc(Lines);
         {$ELSE}
         Inc (Lines);
         {$ENDIF}

      Move (S[0], Buffer^[Tail], TextLength);
      BufPtr := BufPtr + TextLength;
      Tail   := BufPtr;
      if Overwriting then
         { move head }
         if (Tail < TEXTBUFFERSIZE) then
            Head := Succ (Tail)
         else Head := 0;
      end;
end;


{-----------------------------NextLineBreak--------------------------------}

{ Find next linebreak symbol in text buffer }
function TEXTBUFFER.NextLineBreak (From:integer):integer;
var
   i:integer;
begin
   i := From;
   repeat
      Inc (i);
   until (i = TEXTBUFFERSIZE) or (Buffer^[i] = LineBreak);
   NextLineBreak := i;
end;

{-----------------------------LinesBetween---------------------------------}

{ Return the number of lines stored in the buffer between
  L and R. If L > R then wrap around the buffer. }
function TEXTBUFFER.LinesBetween (L, R:integer):integer;
var
   Count: integer;
   i, Stop : integer;
begin
   Count := 0;
   if (L > R) then
      Stop := TEXTBUFFERSIZE
   else Stop := R;
   for i := L to Stop do
      if (Buffer^[i] = LineBreak) then
         Inc (Count);
   if (Stop = TEXTBUFFERSIZE) then begin
      Stop := R;
      for i := 0 to Stop do
         if (Buffer^[i] = LineBreak)then
            Inc (Count);
      end;
   LinesBetween := Count;
end;

{-----------------------------ShowLines------------------------------------}

{ Write a line to the file f }
procedure TEXTBUFFER.ShowLines (var f:text; Start, Stop:integer);
var
   LineEnd,
   Count   : 0..TEXTBUFFERSIZE;
   S       : array[0..LINEBUFFERSIZE] of char;
begin
   while (Start < Stop) do begin
      LineEnd := NextLinebreak (Start);     { end of line in buffer }
      Count   := Succ (LineEnd - Start);    { bytes in line }
      Move (Buffer^[Start], S[0], Count);   { move line to display buffer }
      S[Count] := #0;                       { append #0 }
      write (f, S);                         { display, already has CR/LF }
      Start := Start + Count;               { next line }
      end;
end;

{-----------------------------Show-----------------------------------------}

{ Send the whole buffer to the text file f }
procedure TEXTBUFFER.Show (var f:text);
var
   Start,
   Stop: integer;
begin
   Start := Head;
   if (Tail < Head) then begin
      { The buffer has been overwritten }
      Stop := TEXTBUFFERSIZE;
      ShowLines (f, Start, Stop);
      ShowLines (f, 0, Tail);
      end
   else begin
      { We haven't yet started to overwrite the buffer }
      Stop := Max (BufPtr, Tail);
      ShowLines (f, Start, Stop);
      end;
end;

{-----------------------------Dump-----------------------------------------}

{$IFDEF debug}
procedure TEXTBUFFER.Dump (var f:text);
var
   i:integer;
begin
   writeln (f, 'Head   = ',Head);
   writeln (f, 'Tail   = ', Tail);
   writeln (f, 'BufPtr = ',BufPtr);
   if Overwriting then
      writeln (f, 'OverWrite');
   for i := 0 to TEXTBUFFERSIZE do
      case Buffer^[i] of
         #32..#255: write (f, '  ',Buffer^[i]);
         else write (f, ord (Buffer^[i]):3);
         end;
   writeln (f);
end;
{$ENDIF}

{-----------------------------SetEcho--------------------------------------}

procedure TEXTBUFFER.SetEcho (Flag:Boolean);
begin
   Echo := Flag;
   if not Echo then
      Close (LogFile)   { Close the file for safety }