program Draw;

{
  the current folder needs to be in draw folder or the parent of
  draw folder, for the program to compile (use 'Change Dir' in File menu)
}

{ in the edit mode. the cursor goes to the 80 column. don't change this just
  now, incase it creates bugs }

uses
   crt,dos;

const
   LEFT    = #75;
   RIGHT   = #77;
   UP      = #72;
   DOWN    = #80;
   RETURN  = #13;
   ESCAPE  = #27;
   SPACE   = #32;
   F1      = #59;
   F2      = #60;
   F3      = #61;
   F4      = #62;
   F5      = #63;
   F10     = #68;
   SPC     = ' ';
   PATHLEN = 79;

   winexp  : boolean = false;


   colourNames : array[1..15] of string[12] =
  ('Blue','Green','Cyan','Red','Magenta','Brown','LightGray','DarkGray',
   'LightBlue','LightGreen','LightCyan','LightRed','LightMagenta','Yellow',
   'White');

   modetext : array[1..3] of string[6] = ('Normal','Draw','Erase');

type
   pattern_record =
   RECORD
      storex,storey : byte;
      col2,letter2  : byte;
   END;

   progType    = array[1..{MAX}1] of boolean; {for setup assoc}

   DataRecord = {for setup assoc}
   RECORD
      path  : string;{[MaxPath]}
      osver : byte;
      prog  : progType;
      icons : array[1..4] of boolean;
   END;

   FileType   = file of pattern_record;
   PathString = string[PATHLEN];

var
   recordsize : word;


procedure writeto(text : string;
                   x,y : byte;
                colour : byte);

begin
   textcolor(colour);
   gotoxy(x,y);
   write(text);
end;


procedure writexy(text : string;
                     y : byte;
                colour : byte);

begin
   gotoxy(40 - (length(text) div 2),y);
   textcolor(colour);
   write(text);
end;


function conv(number : longint) : string;

var
   tmpstr : string;

begin
   str(number,tmpstr);
   conv := tmpstr;
end;


procedure clear;

begin
   textcolor(black);
   clrscr;
end;


procedure multicolour(text : string;
                column,row : byte);

var
   num,i : byte;
   error : integer;

begin
   gotoxy(column,row);
   for i := 1 to length(text) do
   begin
      if text[i] = '#' then
      begin
         val(text[i+1],num,error);
         textcolor(num);
         inc(i,2);
      end;
      write(text[i]);
   end;
end;


procedure pause(var ch : char);

begin
   ch := readkey;

   if keypressed then
      ch := readkey;

   if ch = #3 then { Ctrl-C }
   begin
      textcolor(lightgray);
      clrscr;
      nosound;
      halt;
   end;
end;


function fillstr(len : byte;
                  ch : char) : string;

var
   i   : byte;
   tmp : string[80]; { column width }

begin
   tmp := '';

   for i := 1 to len do
      tmp := tmp + ch;

   fillstr := tmp;
end;


procedure limits(var number : byte;
                    min,max : byte);

begin
   if number <= min then
      number := min
   else
   if number >= max then
      number := max;
end;


procedure clrwin(x1,y1,x2,y2 : byte);

begin
   window(x1,y1,x2,y2);
   clear;
   window(1,1,80,25);
end;


procedure check_keys(choices : string;
                     var key : char);
var
   i  : byte;
   ok : boolean;

begin
   ok := false;
   repeat
      pause(key);

      for i := 1 to length(choices) do
         if choices[i] = upcase(key) then
            ok := true;
   until ok;
end;


function choice : boolean;

var
   hold : char;

begin
   check_keys('YN',hold);

   case upcase(hold) of
      'N' : choice := false;
      'Y' : choice := true;
   end;
end;


procedure display_cursor(x,y : byte;
                   var wait : char);

begin
   writeto('X',x,y,12);
   writeto('',80,25,black);
   pause(wait);
   gotoxy(x,y);
   write(SPC);
end;


procedure display_tools_details(letter : byte;
                             cursorCol : byte;
                                  mode : byte;
                                   x,y : byte);
begin
   gotoxy(8,1);
   write(SPC:8);

   multicolour('#9Mode : #3'+modetext[mode],1,1);

   writeto('Character : ',67,1,12);
   textcolor(9);

   case letter of
      219 : write('Û');
      220 : write('Ü');
      223 : write('ß');
   end;

   write(SPC);

   gotoxy(67,25);
   write(SPC:13);

   writeto(colourNames[cursorCol],68,25,cursorCol);
   multicolour('#9X = #3'+conv(x)+' #9Y = #3'+conv(y)+SPC,1,25);
end;


procedure help_page2;

const
   Samples : array[1..12] of string[20] =
   ('59','Nop','Sample1','Batty\batty','Batty\gameover','Batty\help',
   'Batty\hi-score','Batty\options','Comp\disk','Comp\resarf','Comp\setup',
   'Comp\winbase');

var
   key : char;
   a   : byte;

begin
   clear;
   writeto('Sample files are included in the graphics folder. Type a filename below into the',1,3,5);
   writeto('Load Menu. Or double click on a .gfx file in Windows.',1,4,5);

   for a := 1 to 14 do
      writeto(Samples[a],3,5+a,3);

   pause(key);
   clear;
end;


procedure help_page;

var
   wait : char;
   a     : byte;

begin
   clear;
   writexy('Help Page',1,9);

   writeto('Controls',18,4,5);
   writeto('Cursor keys',18,5,9);

   writeto('Modes',18,7,5);
   multicolour('#9F1  - #3Normal Mode',18,8);
   multicolour('#9F2  - #3Draw Mode',18,9);
   multicolour('#9F3  - #3Erase Mode',18,10);
   multicolour('#9F5  - #3Clear Screen',18,11);
   multicolour('#9F10 - #3Full Screen',18,12);

   writeto('Characters',18,14,5);
   multicolour('#9q - #3Û',18,15);
   multicolour('#9w - #3Ü',18,17);
   multicolour('#9e - #3ß',18,19);

   writeto('Move the image',18,21,5);
   multicolour('#9z,x - #3Left and Right',18,22);
   multicolour('#9p,l - #3Up and Down',18,23);

   writeto('Colours',48,4,5);
   writeto(conv(0)+'  '+colourNames[10],48,14,10);
   writeto('Press SHIFT + numbers',48,16,5);

   for a := 1 to 9 do
      writeto(conv(a)+'  '+colourNames[a],48,4+a,a);

   for a := 1 to 5 do
      writeto(conv(a)+'  '+colourNames[a+10],48,16+a,a+10);

   pause(wait);
end;


function file_exists(filename : string) : boolean;

var
   tmpfile : file;

begin
   file_exists := false;

   assign(tmpfile,filename);
   {$I-} reset(tmpfile); {$I+}

   if IOResult = 0 then
   begin
      file_exists := true;
      close(tmpfile);
   end;
end;


procedure readto(var text : string;
                      x,y : byte;
                  col,max : byte);

var
   count : byte;
   ch    : char;

begin
   text := '';
   count := 1;
   repeat
      pause(ch);
      case ch of
         #8 :
         if count > 1 then
         begin
            write(#8,SPC,#8);
            dec(count);
            delete(text,count,1);
         end;
         SPACE..#127,#156 :
         if count <= max then
         begin
            writeto(ch,x+count-1,y,col);
            inc(count);
            text := text + ch;
         end;
         ESCAPE :
         begin
            count := 1;
            gotoxy(x,y);
            clreol;
            text := '';
         end;
      end;
   until ch = RETURN;
end;


procedure type_filename(var quit : boolean;
                       var Fname : PathString;
                            path : string);

var
   filename : string;
   ch       : char;
   ok       : boolean;
   len      : byte;

   P : PathStr;
   D : DirStr;
   N : NameStr;
   E : ExtStr;

begin
   quit := false;
   ok := false;
   clear;
   len := length(path+'graphics\')+15+1;

   repeat
{      textcolor(black);}
      clrwin(1,13,80,13);
      clrwin(1,16,80,16);

      writexy('Load Pattern',9,5);
      writexy('Type x to exit',10,7);
      writexy('Type ''s'' and press return, for a list of sample graphics',25,7);

      writeto('Type filename: ',1,13,6);
      writeto(path+'graphics\',16,13,4);

      readto(filename,len,13,6,31);

      if filename = 'x' then
      begin
         quit := true;
         exit;
      end;

      if filename = 's' then
         help_page2
      else
      begin
         P := filename;
         Fsplit(P,D,N,E);

         if E <> '.gfx' then
            insert('.gfx',filename,length(filename)+1);
      end;

      if filename <> 's' then
         if file_exists(path+'graphics\'+filename) then
         begin
            ok := true;
            Fname := filename;
         end else
         if pos('.gfx',filename) = 0 then
         begin
            writexy('The file has to be a .gfx file',16,15);
            pause(ch);
         end else
         begin
            writexy('This file does not exist',16,15);
            pause(ch);
         end;
   until ok;
end;


procedure load_pattern(var T : FileType;
                   var Fname : PathString;
                        path : string;
                        once : boolean);

var
   F       : FileType;
   quit    : boolean;
   pattern : pattern_record;
   hold    : char;

begin
   if once then
      assign(F,paramstr(1))
   else
   begin
      type_filename(quit,Fname,path);

      if quit then
         exit;

      assign(F,path+'graphics\'+Fname);
      winexp := false;
   end;

   reset(F);
   rewrite(T);

   while not eof(F) do
   begin
      read(F,pattern);
      write(T,pattern);
   end;

   reset(T);
   close(F);

   recordsize := filesize(T);

   if not winexp then
   begin
      writexy('File Loaded',17,15);
      writexy(conv(recordsize)+' XY''s',18,14);
      pause(hold);
   end;
end;


procedure save_filename(var quit : boolean;
                       var Fname : PathString;
                            path : string);

var
   F       : FileType;
   tmpstr  : string;
   len     : byte;
   ok      : boolean;
   key     : char;
   tmpname : string;

   P : PathStr;
   D : DirStr;
   N : NameStr;
   E : ExtStr;

begin
   writexy('Save Pattern',9,5);
   writexy('Type x to exit',10,7);
   writexy('Press Return on its own to save with Orginal Filename',25,7);

   writeto('Type filename: ',1,13,6);
   writeto(path+'graphics\',16,13,4);

   tmpname := Fname;
   len := length(path+'graphics\')+15+1;
   ok := false;

   repeat
      writeto(fillstr(31,SPC),len,13,0);
      readto(tmpstr,len,13,6,31);

      if tmpstr = 'x' then
      begin
         quit := true;
         exit;
      end;

      if tmpstr <> '' then
         Fname := tmpstr;

      P := Fname;
      Fsplit(P,D,N,E);

      if E <> '.gfx' then
         insert('.gfx',Fname,length(Fname)+1);

      if file_exists(path+'graphics\'+Fname) then
      begin
         writexy('The file '+Fname+' exists',16,15);
         writexy('Do you want to overwrite?',17,15);
         writexy('Yes / No',19,14);
         if choice then
            ok := true
         else
         begin
            ok := false;
            Fname := tmpname;
         end;
         clrwin(1,16,79,19)
      end
      else
      begin
         ok := true;
         assign(F,path+'graphics\'+Fname);

         {$I-}
         rewrite(F);
         {$I+}

         if IOresult <> 0 then
         begin
            writexy('Error with filename',16,15);
            pause(key);
            writexy('                   ',16,15);
            ok := false;
            Fname := tmpname;
         end;
      end;
   until ok;
end;


procedure save_pattern(var T : FileType;
                   var Fname : PathString;
                        path : string);

var
   F       : FileType;
   pattern : pattern_record;
   quit    : boolean;
   key     : char;

begin
   if winexp then
      assign(F,paramstr(1))
   else
   begin
      quit := false;
      save_filename(quit,Fname,path);

      if quit then
         exit;

      assign(F,path+'graphics\'+Fname);
   end;

   rewrite(F);
   reset(T);

   while not eof(T) do
   begin
      read(T,pattern);
      write(F,pattern);
   end;

   close(F);

   writexy('File saved',16,15);

   if winexp then
      writexy(paramstr(1),17,14)
   else
      writexy(Fname,17,14);

   pause(key);
end;


procedure clear_pattern(var T : FileType;
                    var Fname : PathString);

begin
   winexp := false;
   Fname := 'blank.gfx';
   rewrite(T);
   clear;
end;


procedure calculate_perimeter(var T : FileType);

var
   minX,minY : byte;
   maxX,maxY : byte;
   pattern   : pattern_record;

begin
   minX := 80; minY := 25;
   maxX := 0;  maxY := 0;

   reset(T);

   while not eof(T) do
   begin
      read(T,pattern);
      with pattern do
      begin
         if storex < minX then
            minX := storex;
         if storey < minY then
            minY := storey;
         if storex > maxX then
            maxX := storex;
         if storey > maxY then
            maxY := storey;
      end;
   end;

   clrwin(minX,minY,maxX,maxY);
end;


procedure move_pattern(wait : char;
                       var T : FileType;
                    var mode : byte);

var
   pattern : pattern_record;

begin
   if filesize(T) = 0 then  { exits if no picture }
      exit;

   mode := 1;
   calculate_perimeter(T);
   reset(T);

   while not eof(T) do
   begin
      read(T,pattern);

      with pattern do
      begin
         case wait of
            'z' : dec(storex);
            'x' : inc(storex);
            'p' : dec(storey);
            'l' : inc(storey);
         end;
         writeto(chr(letter2),storex,storey,col2);
      end;

      seek(T,pred(filepos(T)));
      write(T,pattern);
   end;
end;


function select_option : char;

var
   key : char;

begin
   while not (key in [F1..F5]) do
      pause(key);
   select_option := key;
end;


procedure menu(var option : char);

begin
   clear;
   writexy('DRAW',10,9);
   multicolour('#5F1#3...#5Edit',36,12);
   multicolour('#5F2#3...#5Load',36,13);
   multicolour('#5F3#3...#5Save',36,14);
   multicolour('#5F4#3...#5Help',36,15);
   multicolour('#5F5#3...#5Exit',36,16);
   option := select_option;
   clear;
end;


procedure init(var x,y : byte;
         var cursorCol : byte;
            var letter : byte;
              var mode : byte;
            var toggle : boolean);

begin
   x := 40;
   y := 13;
   cursorCol := 5;
   letter := 219;
   mode := 1;
   toggle := false;
end;


procedure choose_keys(wait : char;
                    var x,y : byte;
                 var letter : byte;
              var cursorCol : byte;
                      var T : FileType;
                  var Fname : PathString;
                   var mode : byte;
                 var toggle : boolean);

begin
   case wait of
      UP       : dec(y,1);
      DOWN     : inc(y,1);
      LEFT     : dec(x,1);
      RIGHT    : inc(x,1);
      '0'..'9' : cursorCol := ord(wait)-48;
      '!'..'%','œ' : cursorCol := ord(wait)-22;
      'q'      : letter := 219;
      'w'      : letter := 220;
      'e'      : letter := 223;
      F1       : mode := 1;
      F2       : mode := 2;
      F3       : mode := 3;
      F5       : clear_pattern(T,Fname);
      F10      : toggle := true;
      'z','x','p','l' : move_pattern(wait,T,mode);
      else
         wait := #0;
   end;

   limits(x,1,80);
   limits(y,1,25);

   if wait = #156 then  { Tests for SHIFT+3 (œ sign) }
      cursorCol := 13;

   if cursorCol = 0 then
      cursorCol := 10;
end;


procedure calculate_paint_direction(wait : char;
                                      x,y : byte;
                            var dirX,dirY : shortint);

begin
   dirX := 0;
   dirY := 0;

   case wait of
      LEFT  : dirX := 1;
      RIGHT : dirX := -1;
      UP    : dirY := 1;
      DOWN  : dirY := -1;
   end;
end;

{ If the cursor is on a character then the character is read then written
  back. If the cursor is on a blank space then nothing happens }

procedure normal_mode(letter : byte;
                   cursorCol : byte;
                         x,y : byte;
                   dirX,dirY : shortint;
                       var T : FileType);

var
   pattern : pattern_record;
   success : boolean;

begin
   success := false;
   reset(T);
   while not eof(T) do
   begin
      read(T,pattern);
      if (pattern.storex = x+dirX) and (pattern.storey = y+dirY) then
      begin
         success := true;
         break;
      end;
   end;

   if not success then
      exit;

   with pattern do
      writeto(chr(letter2),storex,storey,col2);

   seek(T,pred(filepos(T)));
   write(T,pattern);
end;

{ If the cursor is on a character then the character is overwritten. If the
  cursor is on a blank space then the new character is written }

procedure draw_mode(letter : byte;
                 cursorCol : byte;
                       x,y : byte;
                 dirX,dirY : shortint;
                     var T : FileType);

var
   pattern : pattern_record;

begin
   reset(T);
   while not eof(T) do { checks if the character is already on the screen }
   begin
      read(T,pattern);
      if (pattern.storex = x+dirX) and (pattern.storey = y+dirY) then
      begin
         seek(T,pred(filepos(T))); { if so then overwrite record }
         break;
      end;
   end;

   writeto(chr(letter),x+dirX,y+dirY,cursorCol);

   with pattern do
   begin
      storex  := x+dirX;
      storey  := y+dirY;
      col2    := cursorCol;
      letter2 := letter;
   end;
   write(T,pattern);
end;

{ If the cursor is on a character then the record is deleted. If the cursor
  is on a blank space nothing happens }

procedure erase_mode(x,y : byte;
               dirX,dirY : shortint;
                   var T : FileType);

var
   pattern    : pattern_record;
   i          : word;
   LastRecNum : word;
   RecNum     : word;
   success    : boolean;

begin
   success := false;
   reset(T);
   LastRecNum := pred(filesize(T));

   while not eof(T) do
   begin
      read(T,pattern);
      if (pattern.storex = x+dirX) and (pattern.storey = y+dirY) then
      begin
         success := true;
         RecNum := filepos(T);
         break;
      end;
   end;

   if not success then { only deletes record if character is on screen }
      exit;

   for i := RecNum to LastRecNum do
   begin
      seek(T,i);
      read(T,pattern);
      seek(T,i-1);
      write(T,pattern);
   end;

   seek(T,LastRecNum);
   Truncate(T);

   writeto(SPC,x+dirX,y+dirY,black);
end;


procedure edit_pattern(var T : FileType;
                   var Fname : PathString);

var
   x,y       : byte;
   wait     : char;
   dirX,dirY : shortint;
   cursorCol : byte;
   letter    : byte;
   pattern   : pattern_record;
   mode      : byte;
   toggle    : boolean;

begin
   init(x,y,cursorCol,letter,mode,toggle);
   reset(T);

   while not eof(T) do
   begin
      read(T,pattern);
      with pattern do
         writeto(chr(letter2),storex,storey,col2);
   end;

   repeat
{      writeto('Max Record     : '+conv(recordsize)+'  ',1,4,6);
      writeto('Present Record : '+conv(filesize(T))+'  ',1,5,6);}

      display_tools_details(letter,cursorCol,mode,x,y);
      display_cursor(x,y,wait);

      choose_keys(wait,x,y,letter,cursorCol,T,Fname,mode,toggle);
      calculate_paint_direction(wait,x,y,dirX,dirY);

      if toggle then
      begin
         clear;

         reset(T);
         while not eof(T) do
         begin
            read(T,pattern);
            with pattern do
               writeto(chr(letter2),storex,storey,col2);
         end;
         pause(wait);
         toggle := false;
      end;

      case mode of
         1 : normal_mode(letter,cursorCol,x,y,dirX,dirY,T);
         2 : draw_mode(letter,cursorCol,x,y,dirX,dirY,T);
         3 : erase_mode(x,y,dirX,dirY,T);
      end;
   until wait = ESCAPE;
end;


{procedure type_path(var path : string);

var
   done  : boolean;
   wait : char;

begin
   done := false;
   path := '';
   clear;
   repeat
      clrwin(1,15,80,15);
      clrwin(1,12,80,12);

      writeto('Please type path : ',10,12,6);
      textcolor(4);
      readln(path);

      if path = '' then
         path := 'c:\mydocu~1\pascal\draw\';

      if path = 'x' then
         halt;

      if path[length(path)] <> '\' then
         insert('\',path,length(path)+1);

      if file_exists(path+'draw.exe') then
         done := true
      else
      begin
         writexy('This is the wrong directory',15,7);
         pause(wait);
      end;
   until done;
   clear;
end;}


procedure find_path(var path : string);

var
   T    : file of DataRecord; {for setup assoc}
   data : DataRecord;

begin
   if paramstr(1) <> '' then
   begin
      assign(T,'c:\windows\Batcomp.ini');
      {$I-} reset(T); {$I+}

      if IOresult = 0 then { file exists }
      begin
         read(T,data);
         path := data.path+'\draw\';
         close(T);
      end else
      begin
         clrscr;
         halt;
      end;
   end
   else
   begin
      GetDir(0,path); { 0 = Current drive }

      if file_exists(path+'\draw\nul') then
         path := path+'\draw\'
      else
         path := path + '\';
   end;
end;


  { Start of Main Program }


var
   T      : FileType;
   option : char;
   quit1  : boolean;
   Fname  : PathString;
   path   : string{[PATHLEN]};

begin
   textmode(80);
   find_path(path);

   assign(T,path+'draw.tmp');
   rewrite(T);

   Fname := 'blank.gfx';

   if paramstr(1) <> '' then
   begin
      winexp := true;
      load_pattern(T,Fname,path,true);
      edit_pattern(T,Fname);
   end;

   repeat
      menu(option);
      case option of
         F1 : edit_pattern(T,Fname);
         F2 : load_pattern(T,Fname,path,false);
         F3 : save_pattern(T,Fname,path);
         F4 : help_page;
         F5 : quit1 := true;
      end;
   until quit1;

   close(T);
   erase(T);

   textcolor(lightgray);
   clrscr;
end.


  { End okf Main Program }