home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / ansi.swg / 0032_ANSI File Dump.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-08-24  |  4.4 KB  |  132 lines
  1. {
  2. ML>p.p.s  I also need a routine (preferably in Turbo Pascal 7 ASM) that saves t
  3. ML>       content of the current screen in an ANSI file on the disk.  I saw one
  4. ML>       a while ago in SWAG, but I can't seem to find it now (I'm a dist site
  5. ML>       but still can't find it).
  6.  
  7. Also, since I didn't have anything better to do, I sat down and did a
  8. version of your screen->ANSI.  It's rather primitive... it does a 80x24
  9. dump with auto-EOLn seensing, does no CRLF if the line is 80 chars long
  10. (relies on screen wrap) and no macroing. If you want to, you can add
  11. macroing, which replaces a number of spaces with a single ANSI 'set
  12. cursor' command. Well, here goes...
  13.  
  14. =================================================================== }
  15.  
  16.   Procedure Xlate(var OutFile : text); {by Erik Anderson}
  17.   {The screen is basically an array of elements, each element containing one
  18.    a one-byte character and a one-byte color attribute}
  19.   const
  20.     NUMROWS = 25;
  21.     NUMCOLS = 80;
  22.   type
  23.     ElementType = record
  24.                     ch   : char;
  25.                     Attr : byte;
  26.                   end;
  27.     ScreenType = array[1..NUMROWS,1..NUMCOLS] of ElementType;
  28.  
  29.   {The Attribute is structured as follows:
  30.     bit 0: foreground blue element
  31.     bit 1:     "      green element
  32.     bit 2:     "      red element
  33.     bit 3: high intensity flag
  34.     bit 4: background blue element
  35.     bit 5:     "      green element
  36.     bit 6:     "      red element
  37.     bit 7: flash flag
  38.  
  39.   The following constant masks help the program acess different parts
  40.   of the attribute}
  41.   const
  42.     TextMask = $07; {0000 0111}
  43.     BoldMask = $08; {0000 1000}
  44.     BackMask = $70; {0111 0000}
  45.     FlshMask = $80; {1000 0000}
  46.     BackShft = 4;
  47.  
  48.     ESC = #$1B;
  49.  
  50.   {ANSI colors are not the same as IBM colors... this table fixes the
  51.    discrepancy:}
  52.     ANSIcolors : array[0..7] of byte = (0, 4, 2, 6, 1, 5, 3, 7);
  53.  
  54.     {This procedure sends the new attribute to the ANSI dump file}
  55.     Procedure ChangeAttr(var Outfile : text; var OldAtr : byte; NewAtr : byte);
  56.     var
  57.       Connect : string[1]; {Is a seperator needed?}
  58.     begin
  59.       Connect := '';
  60.       write(Outfile, ESC, '['); {Begin sequence}
  61.       If (OldAtr AND (BoldMask+FlshMask)) <>     {Output flash & blink}
  62.          (NewAtr AND (BoldMask+FlshMask)) then begin
  63.         write(Outfile, '0');
  64.         If NewAtr AND BoldMask <> 0 then write(Outfile, ';1');
  65.         If NewAtr AND FlshMask <> 0 then write(Outfile, ';5');
  66.         OldAtr := $FF; Connect := ';';   {Force other attr's to print}
  67.       end;
  68.  
  69.       If OldAtr AND BackMask <> NewAtr AND BackMask then begin
  70.         write(OutFile, Connect,
  71.               ANSIcolors[(NewAtr AND BackMask) shr BackShft] + 40);
  72.         Connect := ';';
  73.       end;
  74.  
  75.       If OldAtr AND TextMask <> NewAtr AND TextMask then begin
  76.         write(OutFile, Connect,
  77.               ANSIcolors[NewAtr AND TextMask] + 30);
  78.       end;
  79.  
  80.       write(outfile, 'm'); {Terminate sequence}
  81.       OldAtr := NewAtr;
  82.     end;
  83.  
  84.     {Does this character need a changing of the attribute?  If it is a space,
  85.      then only the background color matters}
  86.  
  87.     Function AttrChanged(Attr : byte; ThisEl : ElementType) : boolean;
  88.     var
  89.       Result : boolean;
  90.     begin
  91.       Result := FALSE;
  92.       If ThisEl.ch = ' ' then begin
  93.         If ThisEl.Attr AND BackMask <> Attr AND BackMask then
  94.           Result := TRUE;
  95.       end else begin
  96.         If ThisEl.Attr <> Attr then Result := TRUE;
  97.       end;
  98.       AttrChanged := Result;
  99.     end;
  100.  
  101.   var
  102.     Screen   : ScreenType absolute $b800:0000;
  103.     ThisAttr, TestAttr : byte;
  104.     LoopRow, LoopCol, LineLen : integer;
  105.   begin {Xlate}
  106.     ThisAttr := $FF; {Force attribute to be set}
  107.     For LoopRow := 1 to NUMROWS do begin
  108.  
  109.       LineLen := NUMCOLS;   {Find length of line}
  110.       While (LineLen > 0) and (Screen[LoopRow, LineLen].ch = ' ')
  111.             and not AttrChanged($00, Screen[LoopRow, LineLen])
  112.         do Dec(LineLen);
  113.  
  114.       For LoopCol := 1 to LineLen do begin {Send stream to file}
  115.         If AttrChanged(ThisAttr, Screen[LoopRow, LoopCol])
  116.           then ChangeAttr(Outfile, ThisAttr, Screen[LoopRow, LoopCol].Attr);
  117.         write(Outfile, Screen[LoopRow, LoopCol].ch);
  118.       end;
  119.     If LineLen < 80 then writeln(OutFile); {else wraparound occurs}
  120.     end;
  121.   end; {Xlate}
  122.  
  123. var
  124.   OutFile : text;
  125. begin
  126.   Assign(OutFile, 'dump.scn');
  127.   Rewrite(OutFile);
  128.   Xlate(OUtFile);
  129.   Close(OUtFile);
  130. end.
  131.  
  132.