program Image_Editor;

uses Crt,Graph,CGAdrv;

type
  KeyType=array[1..2] of char;
  ImageType=array[1..2610] of byte;
  ScreenType=array[0..99,0..99] of byte;
  DirectionType=(None,Up,Down,Left,Right);
  Str255=string[255];
  Str40=string[40];
  ChrSet=set of char;

var
  Palette,Ctr:word;
  Key:KeyType;
  Image:ImageType;
  Screen:ScreenType;
  FileName:Str40;
  ImFile:file of byte;

procedure Count(var Ctr:integer; Incr,Low,High:integer);
begin
  Ctr:=Ctr+Incr;
  if Ctr<Low then Ctr:=High;
  if Ctr>High then Ctr:=Low;
end;

procedure GetKeyPress(var Key:KeyType);
begin
  while KeyPressed do Key[1]:=ReadKey;
  Key[1]:=UpCase(ReadKey);
  if (Key[1]=#0) and KeyPressed then Key[2]:=ReadKey
  else Key[2]:=#0
end;

procedure KeyMove(Key:KeyType; var MovX,MovY:integer; Flip:boolean);
  procedure Check(var Mov:integer);
  begin
    case Flip of
      True:begin
        if Mov<0 then Mov:=99;
        if Mov>99 then Mov:=0;
      end;
      False:begin
        if Mov<0 then Mov:=0;
        if Mov>99 then Mov:=99;
      end;
    end;
  end;
begin
  if Key[2] in [#71,#72,#73] then Dec(MovY); (*Count(MovY,-1,0,99);*)
  if Key[2] in [#71,#75,#79] then Dec(MovX); (*Count(MovX,-1,0,99);*)
  if Key[2] in [#73,#77,#81] then Inc(MovX); (*Count(MovX,+1,0,99);*)
  if Key[2] in [#79,#80,#81] then Inc(MovY); (*Count(MovY,+1,0,99);*)
  Check(MovX); Check(MovY);
end;

function ChooseKey(Valid:ChrSet; var Key:KeyType):boolean;
begin
  repeat
    GetKeyPress(Key);
    Key[1]:=UpCase(Key[1]);
  until Key[1] in (Valid+[#27]);
  ChooseKey:=(Key[1]<>#27);
end;

procedure ClearImageData;
begin
  FillChar(Image,SizeOf(Image),#0);
  FillChar(Screen,SizeOf(Screen),#0);
end;

procedure Initialise;
var
  Gd,Gm:integer;
begin
  ClearImageData;
  Gd:=CGA; Gm:=CGAC1;
  Palette:=Gm;
	InitCGA(Palette);
(*  InitGraph(Gd,Gm,'');*)
  DirectVideo:=False;
  SetColor(2);
  Rectangle(201,0,319,199);
  Rectangle(218,0,319,101);
  Line(201,101,218,101);
  SetTextStyle(DefaultFont,VertDir,1);
  SetColor(3);
  OutTextXY(214,2,'Image Editor');
  SetTextStyle(DefaultFont,HorizDir,1);
  for Ctr:=0 to 3 do begin
    SetFillStyle(SolidFill,Ctr);
    Bar(Ctr*29+203,190,(Ctr+1)*29+201,197);
  end;
  FileName:='';
end;

procedure ImageEditor;
var
  Quit,Draw,Msg:boolean;
  Cx,Cy,Color,
  Px1,Py1,Px2,Py2:integer;

  procedure Message(Txt:Str255);
  var
    OutTxt:Str255;
    TxtPos,Y:byte;
  begin
    SetFillStyle(SolidFill,0);
    Bar(202,102,318,188);
    SetTextJustify(CenterText,TopText);
    OutTxt:='';
    Y:=110; SetColor(3);
    for TxtPos:=1 to Length(Txt) do begin
      if Txt[TxtPos]<>'^' then OutTxt:=OutTxt+Txt[TxtPos];
      if (Txt[TxtPos]='^') or (TxtPos=Length(Txt)) then begin
        OutTextXY(262,Y,OutTxt);
        Inc(Y,9);
        OutTxt:='';
      end;
    end;
    SetTextJustify(LeftText,TopText);
    Msg:=(Txt<>'');
  end;

  function Sure:boolean;
  begin
    Message('^^Are you sure?');
    GetKeyPress(Key);
    Sure:=(UpCase(Key[1])='Y');
  end;

  function GetFileName:boolean;
  var
    Key:KeyType;
    Keep:boolean;
  begin
    Message('^Enter^filename:^(max. 12 chrs)');
    SetTextJustify(CenterText,TopText);
    SetColor(3);
    OutTextXY(262,152,FileName);
    Keep:=True;
    repeat
      GetKeyPress(Key);
      SetColor(0);
      OutTextXY(262,152,FileName);
      if (Key[1] in [' '..'~']) and (Length(FileName)<12) then begin
        if Keep then begin
          FileName:='';
          Keep:=False;
        end;
        FileName:=FileName+Key[1]
      end else if (Key[1]=#8) and (Length(FileName)>0) then
        Dec(FileName[0]);
      Keep:=False;
      SetColor(3);
      OutTextXY(262,152,FileName);
    until Key[1] in [#13,#27];
    SetTextJustify(LeftText,TopText);
    GetFileName:=(FileName<>'') and (Key[1]=#13);
  end;

  procedure ShowCursor;
  var
    x,y:integer;
  begin
    SetColor(3);
    SetWriteMode(XORput);
    x:=Cx*2-1; y:=Cy*2-1;
    Line(x,y,x+3,y); Line(x+3,y+1,x+3,y+3);
    Line(x+2,y+3,x,y+3); Line(x,y+2,x,y+1);
(*    Rectangle(x,y,x+3,y+3);*)
    SetWriteMode(NormalPut);
  end;

  procedure ShowColor(Incr:integer);
  begin
    if Incr<>0 then begin
      SetColor(0);
      Rectangle(Color*29+202,189,(Color+1)*29+202,198);
    end;
    Count(Color,Incr,0,3);
    SetColor(3);
    Rectangle(Color*29+202,189,(Color+1)*29+202,198);
  end;

  procedure ShowPixel(x,y:integer);
  begin
    SetColor(Screen[x,y]);
    Rectangle(x*2,y*2,x*2+1,y*2+1);
    PutPixel(219+x,1+y,Screen[x,y]);
  end;

  procedure ImgPixel(x,y,Col:integer);
  begin
    if Screen[x,y]<>Col then begin
      Screen[x,y]:=Col;
      ShowPixel(x,y);
    end;
  end;

  function GetColor(var Col:integer):boolean;
  var
    Key:KeyType;
  begin
    repeat
      GetKeyPress(Key);
      if Key=#9#0  then ShowColor(+1);
      if Key=#0#15 then ShowColor(-1);
    until Key[1] in [#27,#13];
    Col:=Color;
    GetColor:=(Key[1]=#13);
  end;

  procedure UpdateImage;
  var
    x,y,Col:integer;
  begin
    Message('^^Updating^image,^^please wait!');
    for x:=0 to 99 do
      for y:=0 to 99 do begin
        Col:=GetPixel(x*2,y*2);
        if Col<>Screen[x,y] then begin
          Screen[x,y]:=Col;
          PutPixel(219+x,1+y,Col);
        end;
      end;
  end;

  procedure UpdateScreen;
  var
    x,y,Col:integer;
  begin
    Message('^^Updating^screen,^^please wait!');
    for x:=0 to 99 do
      for y:=0 to 99 do
        ImgPixel(x,y,GetPixel(219+x,1+y));
  end;


  procedure FillArea(x,y:integer);
  var
    Key:KeyType;
    Fcol,Bcol:integer;
  begin
    Message('^^Choose^^fill color:');
    if not GetColor(Fcol) then Exit;
    Message('^^Choose^^border color:');
    if not GetColor(Bcol) then Exit;
    SetViewPort(0,0,199,199,ClipOn);
    SetFillStyle(SolidFill,FCol);
    FloodFill(x*2,y*2,Bcol);
    SetViewPort(0,0,319,199,ClipOn);
    UpdateImage;
  end;

  function ClearImage:boolean;
  var
    Key:KeyType;
    DoIt:boolean;
  begin
    DoIt:=Sure;
    if DoIt then begin
      ClearImageData;
      SetFillStyle(SolidFill,0);
      Bar(0,0,199,199);
      Bar(219,1,318,100);
    end;
    ClearImage:=DoIt;
  end;

  procedure SaveImage;
  var
    Key:KeyType;
    Ctr,Sx1,Sy1,Sx2,Sy2:integer;
    MoveAll:boolean;

    procedure ShowPart;
    begin
      Rectangle(Px1*2,Py1*2,Px2*2+1,Py2*2+1);
    end;

  begin
    Message('^^W)hole or^P)artial?');
    if not ChooseKey(['W','P'],Key) then Exit;
    case Key[1] of
      'W':begin
        Sx1:=0; Sy1:=0; Sx2:=99; Sy2:=99;
      end;
      'P':begin
        Message('^^Choose image^part to save.');
        SetWriteMode(XORput);
        SetLineStyle(DottedLn,0,1);
        SetColor(1);
        ShowPart;
        MoveAll:=True;
        repeat
          GetKeyPress(Key);
          ShowPart;
          case Key[1] of
            #9:MoveAll:=not MoveAll;
            #0:begin
              if MoveAll then KeyMove(Key,Px1,Py1,False);
              KeyMove(Key,Px2,Py2,False);
              if Px1=99 then Dec(Px1);
              if Py1=99 then Dec(Py1);
              if Px2=Px1 then Inc(Px2);
              if Py2=Py1 then Inc(Py2);
            end;
          end;
          ShowPart;
        until Key[1] in [#13,#27];
        ShowPart;
        SetWriteMode(NormalPut);
        SetLineStyle(SolidLn,0,1);
        if Key[1]=#27 then Exit;
        Sx1:=Px1; Sy1:=Py1; Sx2:=Px2; Sy2:=Py2;
      end;
    end;
    GetImage(219+Sx1,1+Sy1,219+Sx2,1+Sy2,Image);
    if not GetFileName then Exit;
    Assign(ImFile,FileName);
    ReWrite(ImFile);
    for Ctr:=1 to ImageSize(Sx1,Sy1,Sx2,Sy2) do
      Write(ImFile,Image[Ctr]);
    Close(ImFile);
  end;

  procedure LoadImage;
  var
    Key:KeyType;
    Ctr,Xs,Ys:integer;
  begin
    if not GetFileName then Exit;
    if ClearImage then begin
      Assign(ImFile,FileName); {$I-}
      Reset(ImFile);           {$I+}
      if IOresult<>0 then begin
        Message('^^File not^found!');
        GetKeyPress(Key);
        Exit;
      end;
      for Ctr:=1 to 4 do
        Read(ImFile,Image[Ctr]);
      Xs:=Image[1]+Image[2]*256;
      Ys:=Image[3]+Image[4]*256;
      for Ctr:=5 to ImageSize(0,0,Xs,Ys) do
        Read(ImFile,Image[Ctr]);
      Close(ImFile);
      PutImage(268-Xs div 2,50-Ys div 2,Image,NormalPut);
      UpdateScreen;
    end;
  end;

  procedure HorizFlip;
  var
    x,y,y1:integer;
    Temp:byte;
  begin
    for y:=0 to 49 do begin
      y1:=99-y;
      for x:=0 to 99 do
        if Screen[x,y]<>Screen[x,y1] then begin
          Temp:=Screen[x,y];
          ImgPixel(x,y,Screen[x,y1]);
          ImgPixel(x,y1,Temp);
        end;
    end;
  end;

  procedure VertFlip;
  var
    x,y,x1:integer;
    Temp:byte;
  begin
    for x:=0 to 49 do begin
      x1:=99-x;
      for y:=0 to 99 do
        if Screen[x,y]<>Screen[x1,y] then begin
          Temp:=Screen[x,y];
          ImgPixel(x,y,Screen[x1,y]);
          ImgPixel(x1,y,Temp);
        end;
    end;
  end;

  procedure Rotate;
  var
    x,y:integer;
    Scr1:ScreenType;
  begin
    Scr1:=Screen;
    for x:=0 to 99 do
      for y:=0 to 99 do
        ImgPixel(x,y,Scr1[y,99-x]);
  end;

begin
  Quit:=False;
  Draw:=False;
  Msg:=False;
  Cx:=49; Cy:=49;
  Color:=3;
  Px1:=39; Py1:=39;
  Px2:=59; Py2:=59;
  ShowColor(0);
  ShowCursor;
  repeat
    GetKeyPress(Key);
    ShowCursor;
    case Key[1] of
      #0:case Key[2] of
        #82:ImgPixel(Cx,Cy,Color);
        #83:ImgPixel(Cx,Cy,0);
        #15:ShowColor(-1)
        else KeyMove(Key,Cx,Cy,True);
      end;
      #9:ShowColor(+1);
      #13:begin
        Draw:=not Draw;
        SetColor(3*Ord(Draw));
        OutTextXY(309,180,'D');
      end;
      '0','1','2','3':begin
        ShowColor((Ord(Key[1])-48)-Color);
        ImgPixel(Cx,Cy,Color);
      end;
      'C':if ClearIMage then;
      'F':FillArea(Cx,Cy);
      'H':HorizFlip;
      'L':LoadImage;
      'R':Rotate;
      'S':SaveImage;
      'V':VertFlip;
      #27,'Q':Quit:=True;
    end;
    if Msg then Message('');
    if Draw then ImgPixel(Cx,Cy,Color);
    ShowCursor;
  until Quit;
end;

procedure ShutDown;
begin
  CloseGraph;
  RestoreCrtMode;
end;

begin
  Initialise;
  ImageEditor;
(*  ShutDown;*)
end.