CD Actual 15/CDACTUAL15.iso/cdactual/program/pascal/EDSCREEN.ZIP/SCREEN.PAS

Pascal/Delphi Source File | 1987-05-18 | 28.5 KB | 928 lines

(*****************************************************************************)
(*                                                                           *)
(*                   F U L L   S C R E E N   E D I T O R                     *)
(*                                                                           *)
(*                           By Martine Wedlake                              *)
(*                                                                           *)
(*       This  programme  may be copied,  or modified in  any way  for non-  *)
(*  commercial uses.  If you would like to use this programme in a business  *)
(*  environment please write  me for licencing,  and so I can keep track of  *)
(*  its success.   If you like this programme a  donation would  be awfully  *)
(*  nice of you.  Thanks!                                                    *)
(*                                Martine Wedlake                            *)
(*                                4551 N.E. Simpson St.                      *)
(*                                Portland Or                                *)
(*                                97218                                      *)
(*                                                                           *)
(*****************************************************************************)

program screen;
const
  version='1.5';
type
  str15=string[15];
  string_of_10=STRING[10];                  {These are here because they are}
  string_of_255=STRING[255];                {use in procedure/function }
  string_of_80=STRING[80];
  Character_12_array=ARRAY[1..12] OF CHAR;
  hexword=string[4];
var
  f_screen:file;                            {the input file}
  f_source:text;                            {the output file}
  screen:byte;
  procname:string[100];
  dates:str15;
  key:char;
  direct:boolean;
  background:integer;

function hex(v:integer):hexword;

const
  map:array[0..15] of char ='0123456789ABCDEF';

var
  tmp:hexword;

begin
  tmp[4]:=map[(v and $7FFF) mod 16];
  tmp[3]:=map[(v shr 4) mod 16];
  tmp[2]:=map[(v shr 8) mod 16];
  tmp[1]:=map[(v shr 12) mod 16];
  tmp[0]:=#4;
  hex:=tmp;
end;

function upstring(str:string_of_255){------returns uppercase strings}
                  :string_of_255;

{ This will take a string and return it's uppercase counterpart.}

var
  temp_str:string_of_255;
  temp:integer;
begin
  temp:=1;                                 {initialize the counter variable}
  temp_str:='';                            {initialize the dummy string}
  for temp:=1 to length(str) do            {loop and set it to upper case}
  temp_str:=temp_str+upcase(copy(str,temp,1));
  upstring:=temp_str;                      {return the correct value}
end;                                       {end of the upstring function}

PROCEDURE cursor(on:BOOLEAN);{---------------This sets the cursor on/off}

{procedure cursor will set the cursor on or off depending if the argument sent
 is true or false.  If the argument is false the cursor will be turned off,
 if the argument is true the cursor is the cursor is turned on.}

CONST
  video_io=$10;                             {this is the interrupt number}
VAR
  regs:RECORD CASE INTEGER OF               {this sets up the registers}
                1: (AX,BX,CX,DX,BP,DI,SI,DS,ES,Flags: INTEGER);
                2: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
              END;
BEGIN
  IF on THEN                                {if the user wants a cursor then}
  BEGIN
    regs.ch:=$06;                           {set the registers up for display}
    regs.cl:=$07;                           {ch = start line, cl = end line}
  END
  ELSE                                      {else, the cursor is not displayed}
  BEGIN
    regs.ch:=$20;                           {set the register up for non-}
    regs.cl:=$00;                           {display, ch=$20 doesn't display}
  END;
  regs.ah:=$01;
  regs.al:=$00;
  Intr(video_io,regs);
END;

procedure center(stringy:string_of_80);{-----this centers a line of text}

{ Centers a line of text at the present Y co-ordinate.}

var
  endpos:integer;
begin
  gotoxy(40-length(stringy) div 2,wherey);  {goto position}
  write(stringy);                           {write string}
end;                                        {end of center procedure}

PROCEDURE Dir(msk:character_12_array);{------this prints a directory out}

{ Dir returns the directory of the default disk drive.  To use you must
  call dir(mask)  where mask is a string of 12 characters to look for.  You
  must have all 12 characters for this to work.  If you want a directory of
  the whole disk use '????????.???' for input. }

TYPE
  String20= STRING[ 20 ];
  RegRec=RECORD                             {set up the registers}
           AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : INTEGER;
         END;                               {end of regrec}
VAR
  Regs : RegRec;                            {the registers}
  DTA  : ARRAY [ 1..43 ] OF Byte;
  Mask : Character_12_array;                {The mask used for lookup}
  NamR : String20;                          {resulting filename}
  Error,                                    {errors that may occur}
  I    : INTEGER;                           {counter}
BEGIN                                       {main body of program DirList}
  FillChar(DTA,SIZEOF(DTA),0);              {Initialize the DTA buffer}
  FillChar(Mask,SIZEOF(Mask),0);            {Initialize the mask}
  FillChar(NamR,SIZEOF(NamR),0);            {Initialize the file name}
  Regs.AX := $1A00;                         {Function used to set the DTA}
  Regs.DS := Seg(DTA);                      {store the parameter segment in DS}
  Regs.DX := Ofs(DTA);                      {  "    "      "     offset in DX}
  MSDos(Regs);                              {Set DTA location}
  Error := 0;                               {no error at start}
  mask:=msk;                                {Mask must be initialized here}
  Regs.AX := $4E00;                         {Get first directory entry}
  Regs.DS := Seg(Mask);                     {Point to the file Mask}
  Regs.DX := Ofs(Mask);                     {Points the offset of mask}
  Regs.CX := 22;                            {Store the option}
  MSDos(Regs);                              {Execute MSDos call}
  Error := Regs.AX AND $FF;                 {Get Error return}
  I := 1;                                   {initialize 'I' to the 1st element}
  IF (Error = 0) THEN                       {if no error then...}
    REPEAT                                  {repeat until invalid chars}
      NamR[I] := CHR(Mem[Seg(DTA):Ofs(DTA)+29+I]);{get character of filename}
      I := I + 1;                           {increment pointer}
    UNTIL NOT (NamR[I-1] IN [' '..'~']) OR (I>20);{check validity}
  NamR[0] := CHR(I-1);                      {set string length because}
  WRITE(namR:20);
  WHILE (Error = 0) DO BEGIN                {assigning by element does not set}
    Error := 0;                             {length}
    Regs.AX := $4F00;                       {Function used to get the next}
                                            {directory entry}
    Regs.CX := 22;                          {Set the file option}
    MSDos( Regs );                          {Call MSDos}
    Error := Regs.AX AND $FF;               {get the Error return}
    I := 1;                                 {intialize pointer}
    REPEAT                                  {repeat until not valid chars}
      NamR[I] := CHR(Mem[Seg(DTA):Ofs(DTA)+29+I]);{get character of filename}
      I := I + 1;                           {increment pointer}
    UNTIL NOT (NamR[I-1] IN [' '..'~'] ) OR (I > 20);{check validity}
    NamR[0] := CHR(I-1);
    IF (Error = 0)                          {if no error found}
      THEN WRITE(NamR:20)                   {write filename}
  END;
  IF WhereX<>1 THEN WRITELN;
END;                                        {of program DirList  }

procedure border(x,y,x2,y2,forg,{------------This makes a lined border}
                 back:integer;
                 double:boolean);

{ Border will put a double or single lined border by specifying the top left
  and bottom left co-ordinates for the border.  x,y is the co-ordinate of the
  top left.  x2,y2 is the co-ordinate of the bottom right.  Forg is the
  forground colour, while Back is the background colour.  If double is true
  the border will be a double line.  If it is false, then it will be a single
  line border.}

var
  old_x,
  old_y,
  loop:integer;
  top_left,
  top_right,
  bot_left,
  bot_right,
  accross,
  down:char;
BEGIN
  if (x2<x) or (y2<y) or (y>24) or (x>80)   {check to see that parameters valid}
            or (y<1) or (x<1) then
  begin                                     {if not valid then write error}
    clrscr;
    textcolor(white);
    textbackground(black);
    writeln('ERROR in procedure boarder.  Co-ordanates incorrect.');
    halt;
  end;
  old_x:=wherex;                            {remember x,y of currsor}
  old_y:=wherey;
  TextColor(forg);                          {set the colours to be used}
  textbackground(back);
  if double then                            {assign the various characters for}
  begin                                     {corners, vertical, and horizontal}
    top_left:=#201;                         {lines}
    top_right:=#187;
    bot_left:=#200;
    bot_right:=#188;
    accross:=#205;
    down:=#186;
  end
  else
  begin                                     {For single lines}
    top_left:=#218;
    top_right:=#191;
    bot_left:=#192;
    bot_right:=#217;
    accross:=#196;
    down:=#179;
  end;
  gotoxy(x,y);
  WRITE(top_left);                          {output the corner pieces}
  gotoxy(x2,y);
  WRITELN(top_right);
  gotoxy(x,y2);
  WRITE(bot_left);
  gotoxy(x2,y2);
  WRITE(bot_right);
  FOR loop:=x+1 TO x2-1 DO                 {loop for the horz. line}
  begin
    gotoxy(loop,y);
    WRITE(accross);
    gotoxy(loop,y2);
    write(accross);
  end;
  for loop:=y+1 to y2-1 do                  {loop for the vert. lines}
  begin
    gotoxy(x,loop);
    WRITE(down);
    gotoxy(x2,loop);
    write(down);
  end;
  gotoxy(old_x,old_y);                      {restore cursor pos}
  textcolor(white);                         {set colour to "normal"}
  textbackground(black);
END;

PROCEDURE title(title1:string_of_80);{-------this prints out the title}

{ Title prints out a nice title with the title automatically centered
  on the screen and with a border around it.  Use title(name)  where the
  title you want to print is name.  Name must be a string.  It can be any
  length. }

VAR
  loop,                                     {a loop counter}
  string_length,                            {the length of the title string}
  x_position:INTEGER;                       {the position for centering title}
BEGIN
  ClrScr;
  GotoXY(1,3);
  TextColor(white);                         {title is in white}
  Center(title1);                           {write title out}
  string_length:=LENGTH(title1);            {assigns the length of title}
  x_position:=40-(string_length DIV 2)-1;
  border(x_position,2,x_position+string_length+1,
         4,lightblue,black,true);
  TextColor(lightblue);                     {frame is lightblue}
  gotoxy(1,6);
END;

FUNCTION date:string_of_10;{-----------------returns the date in the system}

{  Date returns a string composing of the date.  To use code
   Date_now:=date;  The date is return in the format of mm-dd-yy.}

PROCEDURE zerofill(VAR sample:string_of_10);{replaces spaces with 0's}
VAR
  I:INTEGER;                                {i is just a counter}
BEGIN
  FOR i:=1 TO LENGTH(sample) DO IF sample[i]=' ' THEN sample[i]:='0';
END;

VAR
  DateString:string_of_10;                  {the string of date}
  month,                                    {the various time frames}
  day,
  year:STRING[2];
  regs:RECORD CASE INTEGER OF               {this sets up the registers}
                1: (AX,BX,CX,DX,BP,DI,SI,DS,ES,Flags: INTEGER);
                2: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
              END;
BEGIN
WITH regs DO                                {use the defined registers}
 BEGIN
   AH:=$2A;                                 {pass 2Ah through AH}
   Flags:=0;                                {reset flags}
   MSDos(Regs);                             {call interrupt 21h}
   STR((CX MOD 100):2,year);                {do convertions for year}
   STR(DL:2,Day);                           {"      "        "  day }
   STR(DH:2,Month);                         {"      "        "  month}
   DateString:=month+'-'+day+'-'+Year;      {put the date together}
   zerofill(DateString);                    {fill in any spaces}
   date:=datestring                         {pass date to function call}
 END                                        {end of with regs}
END;                                        {end of date function}


PROCEDURE waitkey;{--------------------------Press any key to continue proc.}

{ This is a very simple but useful procedure to wait for a keypress to
  continue with the program.}

VAR
  key:CHAR;
BEGIN
  cursor(FALSE);                            {turn cursor off}
  GotoXY(1,25);                             {set colour and position}
  TextColor(black);
  TextBackGround(white);
  center('Press any key to continue with program.');{write message}
  REPEAT UNTIL KeyPressed;                  {wait for key}
  READ(Kbd,key);                            {store the key so it won't}
  GotoXY(1,25);                             {screw up the next read(kbd)}
  TextColor(white);                         {restore colour}
  TextBackGround(black);
  DelLine;                                  {erase message}
  cursor(TRUE);                             {restore cursor}
END;                                        {end of the waitkey procedure}


procedure video(cond:boolean);{--------------Turns on or off the display}

{ This will turn the display on or off.  You can still write to the screen
  but the text will not be seen until you set video(on).  I have set up two
  constants for this procedure -- On=True, Off=false.  You can use these
  constants instead of true/false. NOTE: Some turbo instuctions will auto-
  matically set the video as on.  Some are ClrScr, TextMode, etc}

begin
  repeat until port[$3da] and 8=8;          {wait for video sync}
  if cond then
    port[$3d8]:=mem[$40:$65] or 8           {restore display}
  else
    port[$3d8]:=$25;                        {turn off display by setting regs}
end;                                        {end of video procedure}

procedure readatt(x,y:integer;{--------------Reads in the char/attribute of screen}
                  var forg,back:integer;
                  var chrr:char);
var
  regs:RECORD CASE INTEGER OF               {this sets up the registers}
                1: (AX,BX,CX,DX,BP,DI,SI,DS,ES,Flags: INTEGER);
                2: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
              END;
  old_x,
  old_y,
  chrs:integer;
  blink:boolean;

begin
  old_x:=wherex;                            {save old cursor pos to restore}
  old_y:=wherey;
  gotoxy(x,y);                              {set cursor, for bios routine}
  with regs do
  begin
    ah:=$08;                                {set function, read char/attribute}
    bh:=$00;                                {page = 0}
    intr($10,regs);
    chrr:=chr(al);                          {al is the character}
    forg:=ah and 15;                        {take out the forground}
    if ah and 128=128 then forg:=forg or 16; {is the blinking on, if so set bit}
    back:=(ah and 112) shr 4;               {take out background and shift right}
  end;
  gotoxy(old_x,old_y);                      {restore cursor position}
end;                                        {end of readatt procedure}

function exist(filename:string_of_255){------tests if a file exists}
               :boolean;

{ This routine will check to see if a file exists or not.}

var
  f_test:file;

begin
  assign(f_test,filename);
  {$I-}
  reset(f_test);
  {$I+}
  exist:=(ioresult = 0);
  close(f_test);
end;                                        {End of function exist}

function quit_yn:boolean;
begin
  clrscr;
  gotoxy(22,12);
  write('Do you want to exit the program? Y/N ');
  repeat
    read(kbd,key);
    key:=upcase(key);
  until key in['Y','N'];
  quit_yn:=key='Y';
end;

procedure quit;
begin
  title(' E X I T ');
  gotoxy(1,6);
  {$I-}
  close(f_source);
  {$i+}
  if ioresult<>0 then ;
  textcolor(lightgray);
  halt;
end;

procedure error(err_num:integer);
var
  key:char;
begin
  case err_num of
    1:begin
        gotoxy(1,24);
        textcolor(black);
        textbackground(white);
        center(#7+'ERROR - File does not exist!  Please Re-enter.');
        textcolor(white);
        textbackground(black);
        waitkey;
        gotoxy(1,24);
        clreol;
      end;
  end;
end;

function colr(colr_num:integer):str15;
var
  blink:boolean;
  colrs:str15;
begin
  if colr_num >= 16 then
  begin
    blink:=true;
    colr_num:=colr_num - 16;
  end
  else
    blink:=false;
  case colr_num of
    0 :colrs:='Black';
    1 :colrs:='Blue';
    2 :colrs:='Green';
    3 :colrs:='Cyan';
    4 :colrs:='Red';
    5 :colrs:='Magenta';
    6 :colrs:='Brown';
    7 :colrs:='LightGray';
    8 :colrs:='DarkGray';
    9 :colrs:='LightBlue';
    10:colrs:='LightGreen';
    11:colrs:='LightCyan';
    12:colrs:='LightRed';
    13:colrs:='LightMagenta';
    14:colrs:='Yellow';
    15:colrs:='White';
  end;
  if blink then colrs:=colrs+'+Blink';
  colr:=colrs;
end;

PROCEDURE TitleScreen;
var
  counter:integer;
  key:char;
BEGIN
  TextColor(LightGray);
  TextBackground(Black);
  ClrScr;
  video(false);
  gotoxy(19,1);
  TextColor(White);
  TextBackground(Cyan);
  Writeln('┌────────────────────────────────────────┐');
  gotoxy(19,2);
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  TextColor(LightGray);
  TextBackground(Blue);
  Write(' ╔═══╕   ╔══╕  ╔══╗  ╔══╕  ╔══╕  ╔╗  ╥  ');
  TextColor(White);
  TextBackground(Cyan);
  Writeln('│');
  gotoxy(19,3);
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  TextColor(LightGray);
  TextBackground(Blue);
  Write(' ╚═══╗   ║     ║  ║  ║     ║     ║╚╗ ║  ');
  TextColor(White);
  TextBackground(Cyan);
  Writeln('│');
  gotoxy(19,4);
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  TextColor(LightGray);
  TextBackground(Blue);
  Write('     ║   ║     ╠═╦╝  ╠╡    ╠╡    ║ ╚╗║  ');
  TextColor(White);
  TextBackground(Cyan);
  Writeln('│');
  gotoxy(19,5);
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  TextColor(LightGray);
  TextBackground(Blue);
  Write(' ╘═══╝   ╚══╛  ╨ ╚╕  ╚══╛  ╚══╛  ╨  ╚╝  ');
  TextColor(White);
  TextBackground(Cyan);
  Writeln('│');
  gotoxy(19,6);
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  TextColor(LightGray);
  TextBackground(Blue);
  Write(' ╥   ╥   ╔══╗  ╒╦╕  ╒══╦══╕  ╔══╕  ╔══╗ ');
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  gotoxy(19,7);
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  TextColor(LightGray);
  TextBackground(Blue);
  Write(' ║   ║   ║  ║   ║      ║     ║     ║  ║ ');
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  gotoxy(19,8);
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  TextColor(LightGray);
  TextBackground(Blue);
  Write(' ║╔╧╗║   ╠═╦╝   ║      ║     ╠╡    ╠═╦╝ ');
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  gotoxy(19,9);
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  TextColor(LightGray);
  TextBackground(Blue);
  Write(' ╚╝ ╚╝   ╨ ╚╕  ╘╩╛    ─╨─    ╚══╛  ╨ ╚╕ ');
  TextColor(White);
  TextBackground(Cyan);
  Write('│');
  gotoxy(19,10);
  TextColor(White);
  TextBackground(Cyan);
  Writeln('└────────────────────────────────────────┘');
  video(true);
  TextColor(LightGray);
  TextBackground(Black);
  gotoxy(27,12);
  Write('S O U R C E   W R I T E R');
  gotoxy(29,14);
  Writeln('By Martine B. Wedlake');
  Writeln;
  Writeln('':7,'The author wishes to note that this programme may be freely copied');
  Writeln('':7,'and distributed as long as there are no costs imposed for the copy');
  Writeln('':7,'other than prices  for the media itself.  If anyone has any querys');
  Writeln('':7,'he can reach me at:');
  Writeln('':28,'Martine Wedlake');
  Writeln('':28,'4551 N.E. Portland, OR');
  Writeln('':28,'97218');
  writeln;
  Writeln('':21,'(C) Copywrite 1987, Martine B. Wedlake');
  write('':30,'<<< Press a Key >>>');
  counter:=0;
  repeat
    counter:=counter+1;
  until keypressed or (counter=30000);
  if keypressed then read(kbd,key);
  clrscr;
END;

procedure filenames;         {This procedure gets and opens the files}
var
  fil1,
  fil2:string[12];
  ok:boolean;
  key:char;
begin
  repeat
    title(' S C R E E N   W R I T E R ');
    gotoxy(1,6);
    center('Version: '+version);
    fil1:='';
    gotoxy(1,8);
    center('Use <DIR> for directory, or <CR> to exit.');
    gotoxy(1,10);
    write('Enter file name to read in from ScrEdit :');
    clreol;
    readln(fil1);
    if fil1='' then quit;                   {Check to see if user quits}
    fil1:=upstring(fil1);
    if fil1 ='DIR' then
    begin
      title(' D I R E C T O R Y ');
      gotoxy(1,6);
      dir('????????.SCR');
      fil1:=#255;
      waitkey;
    end
     else
    begin
      if pos('.',fil1) = 0 then fil1:=fil1+'.SCR';  {add on extention}
      gotoxy(42,10);
      write(fil1);
      if not exist(fil1) then error(1);           {give error if not on disk}
    end;
  until exist(fil1);
  assign(f_screen,fil1);
  reset(f_screen);
  repeat
    fil2:='';
    gotoxy(1,12);
    write('Enter file name to output the source to :');
    clreol;
    readln(fil2);
    if fil2='' then quit;
    fil2:=upstring(fil2);
    if fil2 ='DIR' then
    begin
      title(' D I R E C T O R Y ');
      gotoxy(1,6);
      dir('????????.PAS');
      waitkey;
      title(' S C R E E N   W R I T E R ');
      gotoxy(1,6);
      center('Version: '+version);
      gotoxy(1,8);
      center('Use <DIR> for directory, or <CR> to exit.');
      gotoxy(1,10);
      write('Enter file name to read in from ScrEdit :',fil1);
      gotoxy(1,12);
      write('Enter file name to output the source to :');
      ok:=false;
    end
     else
    begin
      if pos('.',fil2) = 0 then fil2:=fil2+'.PAS';     {add extention}
      gotoxy(42,12);
      write(fil2);
      if exist(fil2) then        {check to make sure user wants to overwrite}
      begin
        gotoxy(1,24);
        center('File Already exists!  Press <O> Overwrite, <R> Re-enter, <E> Exit');
        repeat
          read(kbd,key);
          key:=upcase(key);
        until key in['O','R','E'];
        gotoxy(1,24);
        clreol;
        if key='E' then quit;
        ok:=(key = 'O');
      end
      else ok:=true;
    end;
  until ok;
  assign(f_source,fil2);
  rewrite(f_source);
  gotoxy(1,14);
  write('Please enter todays date: ',date,#8#8#8#8#8#8#8#8); {write sytem date}
  readln(dates);
  if dates='' then dates:=date;
  gotoxy(1,16);
  write('Please enter the name of your procedure: TitleScreen');
  gotoxy(42,16);
  repeat until keypressed;
  clreol;
  procname:='';
  read(procname);
  if procname='' then procname:='TitleScreen';
  gotoxy(42,16);
  write(procname);
  gotoxy(1,18);
  write('Do you want [D]irect Screen Writing, or [S]ource Code [D/S]? ');
  repeat
    read(kbd,key);
    key:=upcase(key);
  until key in['D','S'];
  direct:=(key='D');
end;

function find_prominent:integer;
var
  lett:char;
  colours:array[0..7] of integer;
  forg,
  back,
  x,
  y,
  max:integer;
begin
  for x:=0 to 7 do colours[x]:=0;
  for x:=1 to 80 do
  begin
    for y:=1 to 24 do
    begin
      readatt(x,y,forg,back,lett);
      colours[back]:=colours[back]+1;
    end;
  end;
  max:=0;
  for x:=0 to 7 do if colours[x]>max then max:=colours[x];
  x:=0;
  while colours[x]<>max do x:=x+1;
  find_prominent:=x;
end;

procedure do_source_header;    {THis will put the procedure header on file}
begin
  writeln(f_source,'PROCEDURE ',Procname,';');
  writeln(f_source,'BEGIN');
  writeln(f_source,'  {This screen was done with the aid of the Screen Writer program}');
  writeln(f_source,'  {Date: ',dates,'}');
  writeln(f_source,'  TextColor(LightGray);');
  writeln(f_source,'  TextBackground(',colr(background),');');
  writeln(f_source,'  ClrScr;');
end;

procedure load;          {THis loads in the picture file}
var
  counter:integer;
  scrn_mem:array[0..1920] of integer;
begin
  reset(f_screen);
  blockread(f_screen,scrn_mem,30);
  close(f_screen);
  for counter:=0 to 1919 do memw[$B800:counter*2]:=scrn_mem[counter];
end;

procedure start_line(ln:boolean);
begin
  write(f_source,'  Write');
  if ln then write(f_source,'ln');
  write(f_source,'(''');
end;

procedure end_line;
begin
  writeln(f_source,''');');
end;

procedure do_textcolor(forg:integer);
begin
  writeln(f_source,'  TextColor(',colr(forg),');');
end;

procedure do_textbackground(back:integer);
begin
  writeln(f_source,'  TextBackground(',colr(back),');');
end;

function sol(background,y:integer):integer;
var
  counter,
  forground,
  colour:integer;
  letter:char;
begin
  counter:=0;
  repeat
    counter:=counter+1;
    readatt(counter,y,forground,colour,letter);
  until (colour <> background) or (letter <> ' ') or (counter = 80);
  sol:=counter;
end;

function eol(background,y:integer):integer;
var
  counter,
  forground,
  colour:integer;
  letter:char;
begin
  counter:=80;
  repeat
    counter:=counter-1;
    readatt(counter,y,forground,colour,letter);
  until (colour <> background) or (letter <> ' ') or (counter = 1);
  eol:=counter;
end;

procedure do_source1;               {THis will create source code }
var
  old_forg,
  old_back,
  forg,
  back,
  x,y:integer;
  character:char;
begin
  readatt(1,1,old_forg,old_back,character);   {set up origional colours}
  do_textcolor(old_forg);
  do_textbackground(old_back);
  start_line(true);
  for y:= 1 to 24 do
  begin
    for x:=sol(old_back,y) to eol(old_back,y) do
    begin
      gotoxy(1,y);
      readatt(x,y,forg,back,character);
      if (forg<>old_forg) or (back<>old_back) then
      begin
        end_line;
        if forg<>old_forg then
        begin
          do_textcolor(forg);
          old_forg:=forg;
        end;
        if back<>old_back then
        begin
          do_textbackground(back);
          old_back:=back;
        end;
        start_line(false);
        case character of
          #39:write(f_source,#39#39);
          #26:write(f_source,''',#26,''');
          else write(f_source,character);
        end;
      end
      else
      begin
        case character of
          #39:write(f_source,#39#39);
          #26:write(f_source,''',#26,''');
          else write(f_source,character);
        end;
      end;
    end;
    end_line;
    if y<>24 then
      start_line(true);
      end;
  writeln(f_source,'END;');
end;

procedure do_source2;          {THis is the direct screen write method}
var
  forg,
  back,
  screen_mem,
  value,
  x,
  y:integer;
  let:char;
  cr:boolean;
begin
  x:=1;
  y:=1;
  cr:=false;
  for screen_mem:=0 to 1919 do     {loop through the screen}
  begin
    gotoxy(x,y);
    value:=memw[$b800:screen_mem*2];      {get value}
    readatt(x,y,forg,back,let);           {just for cursor and background}
    if not ((let=' ') and (back=background)) then  {try to get rid of useless chars}
    begin
      write(f_source,'  MemW[$b800:$',hex(screen_mem*2),']:=$',hex(value),';');
      if cr then writeln(f_source);
      cr:=not cr
    end;
    x:=x+1;
    if x>80 then
    begin
      x:=1;
      y:=y+1;
    end;
  end;
  {$i-}
  if cr then writeln(f_source);
  writeln(f_source,'END;');
  {$i+}
  if ioresult<>0 then
  begin
    clrscr;
    write(ioresult);
    halt;
  end;
end;

begin
  titlescreen;
  repeat
    filenames;
    cursor(false);
    load;
    background:=find_prominent;
    do_source_header;
    cursor(true);
    gotoxy(1,1);
    if not direct then
      do_source1
    else
      do_source2;
    close(f_source);
    waitkey;
  until quit_yn;
  title(' E N D   O F   T H E   P R O G R A M ');
  textcolor(lightgray);
end.