program bitmapzeichner;
uses crt, graph, maus;

type punkt = 0..639;

type farbmustertyp = record                {Variablenrecord fr Speicherung}
                         vorder : byte;    {der Einstellungen w„hrend des }
                         hinter : byte;    {Programmlaufes, s. Proz. 'ablauf'}
                         fuell  : byte;
                         muster : byte;
                         linie  : byte;
                         dicke  : byte;
                       end;
     objdaten      = record
                         x1, y1, x2, y2 : punkt;
                         objchar        : char;
                       end;

{*** Prozeduren fuer Beginn des Programms ***********************************}

procedure Vorspann;        {Zeichnet Buchstaben in Farbreihenfolge 'farbfeld'}
                           { und an Punkten 'punktfeld'}
  const textstring : string = 'Bitmap-zeichner';
        punktfeld  : array [1..30] of punkt =
                       (108,  70, 160,  70, 200,  70, 280,  70, 372,  70, 444,
                         70, 524,  70, 104, 220, 172, 220, 222, 220, 272, 220,
                        340, 220, 408, 220, 476, 220, 540, 220);
        farbfeld   : array [0..28] of byte =
                       (1, 2, 3, 4, 5, 6, 7,  9, 10, 11, 12, 13, 14, 15, 1,
                        2, 3, 4, 5, 6, 7, 9, 10, 11, 12, 13, 14, 15, 1);

  var i, j, k : byte;

  begin
    for i:=0 to 2 do                        {Hintergrund-m”gliche Fllmuster}
      for j:=0 to 3 do
        begin
          setfillstyle(i*4+j, 8);
          bar(160*j, 160*i, 160*(j+1), 160*(i+1));
        end;

    settextstyle(3, 0, 2);                  {farbwechselnde Buchstaben}
    settextjustify(1, 2);
    setcolor(15);
    outtextxy(320, 450, 'Taste drcken');
    settextstyle(3, 0, 10);
    k:=0;
    repeat
      for i:=1 to 15 do
        begin
          j:=(i-1)+k;
          setcolor(farbfeld[j]);
          outtextxy(punktfeld[i*2-1], punktfeld[i*2], textstring[i]);
        end;
      delay(400);
      k:=k+1;
      if k=15 then k:=0;
    until keypressed;
  end;

procedure Start {Graphik und Maus starten};

  var gd, gm       : integer;
      inst, grafik : boolean;
      tasten       : word;
      ch           : char;

  begin
    gd:=9; gm:=2;                            {Graphik}
    initgraph(gd, gm, 'd:\tp\bgi');
    cleardevice;
    Vorspann;
    ch:=readkey;
    cleardevice;

    inst:=true; tasten:=3; grafik:=true;     {Maus}
    init_maus(inst, tasten, grafik);
    select_maus(8);
    set_maus(320, 240);
    show_maus;
  end;

{*** Prozeduren fuer Zeichnen ***********************************************}

procedure Beep(hoehe: integer); {Ton bestimmter Hoehe spielen}
                                {500: Fehler, 300 Ende}
  begin
    sound(hoehe);
    delay(200);
    nosound;
  end;

procedure Farben(zeichen: char; var farbmuster: farbmustertyp);
  {Festlegen der Farben mit zwei Zeichen, 1. aus Ablauf-Prozedur}

  var code, farbe : integer;
      zeichen2    : char;

  begin
    zeichen2:=readkey;
    if zeichen='0'
      then val(zeichen2, farbe, code)
      else val(zeichen+zeichen2, farbe, code);
    if farbe<20 then farbmuster.vorder:=farbe;
    if (farbe<40) and (farbe>=20) then farbmuster.hinter:=farbe-20;
    if (farbe<60) and (farbe>=40) then farbmuster.fuell:=farbe-40;
    if (farbe<80) and (farbe>=60) then farbmuster.muster:=farbe-60;
    if (farbe<84) and (farbe>=80) then farbmuster.linie:=farbe-80;
    if (farbe<94) and (farbe>=90) then farbmuster.dicke:=farbe-90;
    if farbe>93 then beep(500);
  end;

procedure vergroessern(x1, y1, x2, y2: punkt);
  {Vergroesserungsmodus: 1 Punkt auf Flaeche 8x8 dargestellt}

  var altefarbe, farbe      : byte;
      code                  : integer;
      xmaus, ymaus, tasten  : word;
      x, y, xv, yv          : punkt;
      zeichen, zeichen2, ch : char;
      zahlstr               : string[2];
      normalmodus, nichtaus : boolean;
      altfuell              : fillsettingstype;
      farbfeld              : array[0..24] of byte;
      mausflaeche           : array[1..94] of char;

  begin
    hide_maus;                          {alte Einstellungen speichern}
    altefarbe:=getcolor;
    getfillsettings(altfuell);

    if x1>x2 then x:=x2 else xv:=x1;    {Oberfl„che vorbereiten}
    if y1>y2 then y:=y2 else yv:=y1;
    setvisualpage(1);
    setactivepage(1);
    setfillstyle(1, 15);
    setcolor(15);
    bar(5, 32, 639, 338);
    setcolor(0);

    settextstyle(2, 0, 7);                           {Text fr Bedienung}
    settextjustify(0, 0);
    outtextxy(490, 70, 'Bedienung');
    outtextxy(470, 100, 'Vergr”įerung :');
    line(470, 105, 630, 105);
    outtextxy(470, 150, ' 00-15 Farbe');
    outtextxy(470, 180, ' Esc   Beenden');
    settextstyle(2, 0, 4);

    for x:=0 to 49 do                                 {Gitter}
      begin
        line(5+8+9*x, 32, 5+8+9*x, 319);
        if ((x mod 10) = 9) then line(5+8+9*x, 319, 5+8+9*x, 330);
        str(x mod 10, zahlstr);
        outtextxy(5+2+9*x, 330, zahlstr);
      end;
    for y:=0 to 31 do
      begin
        line(5, 32+8+9*y, 454, 32+8+9*y);
        str(y, zahlstr);
        outtextxy(455, 32+8+9*y, zahlstr);
      end;

    for y:=0 to 31 do                           {Bildausschnitt lesen}
      begin
        setactivepage(0);
        for x:=0 to 24 do
          farbfeld[x]:=getpixel(xv+x*2, yv+y)*16+getpixel(xv+x*2+1, yv+y);
        setactivepage(1);
        for x:=0 to 24 do
          begin
            setfillstyle(1, farbfeld[x] div 16);
            floodfill(5+9*x*2, 32+9*y, 0);
            setfillstyle(1, farbfeld[x] mod 16);
            floodfill(5+9*x*2+9, 32+9*y, 0);
          end;
      end;
    normalmodus:=false;
    show_maus;
    set_maus(320, 150);

    repeat                        {Schleife fr Ver„nderung des Abschnittes}
      maus_status(xmaus, ymaus, tasten);
      tasten:=0; zeichen:=chr(0);
      xmaus:=0; ymaus:=0;
      zeichen:=chr(0);
      zeichen2:=chr(0);
      repeat
        maus_status(xmaus, ymaus, tasten);
        nichtaus:=(xmaus>8) and (xmaus<455) and (ymaus>35) and (ymaus<319);
        if nichtaus then
          begin
            getimage(xmaus-5, ymaus-5, xmaus+5, ymaus+5, mausflaeche);
            setcolor(15-getpixel(xmaus, ymaus));
            line(xmaus-5, ymaus, xmaus+5, ymaus);
            line(xmaus, ymaus-5, xmaus, ymaus+5);
            delay(10);
            putimage(xmaus-5, ymaus-5, mausflaeche, 0);
          end;
        if nichtaus=false then tasten:=0;
        if keypressed then zeichen:=readkey;
        if keypressed and (zeichen=chr(0)) then zeichen2:=readkey;
      until (tasten=1) or (zeichen>chr(0)) or (zeichen2>chr(0));
      if zeichen>chr(0) then
        case zeichen of
            '0'..'9' : begin
                         ch:=readkey;
                         val(ch, farbe, code);
                         if zeichen='1' then farbe:=farbe+10;
                         setfillstyle(1, farbe);
                       end;
            chr(27)  : normalmodus:=true; {Escape-Taste}
            else       Beep(500);
          end;

      hide_maus;                        {Zeichnen der Punkte}
      if (tasten=1) and (getpixel(xmaus, ymaus)>0) then
        floodfill(xmaus, ymaus, 0);
      if (tasten=1) and (getpixel(xmaus, ymaus)=0) then
        begin
          x:=xmaus-((xmaus-5) mod 9);
          y:=ymaus-((ymaus-32) mod 9);
          setcolor(0);
          bar(x-1, y-1, x+8, y+8);
          rectangle(x-1, y-1, x+8, y+8);
        end;
      show_maus;
      if zeichen2<>chr(0) then Beep(500);
    until normalmodus=true;

    for y:=0 to 31 do                    {Abschnitt auf Hauptbild bertragen}
      for x:=0 to 49 do
        begin
          farbe:=getpixel(5+9*x+1, 32+9*y+1);
          setactivepage(0);
          putpixel(xv+x, yv+y, farbe);
          setactivepage(1);
        end;

    hide_maus;                           {alte Einstellungen wiederherstellen}
    setvisualpage(0);
    setactivepage(0);
    setcolor(altefarbe);
    with altfuell do SetFillStyle(Pattern, Color);
    show_maus;
  end;

procedure Objekt(farbmuster: farbmustertyp; objdat1: objdaten);

  var mx, my, radius1, radius2 : punkt;
      x1, y1, x2, y2           : punkt;
      objchar                  : char;

  begin {Zeichnen der Objekte}
    hide_maus;                      {Einstellungen setzen (Farben, Muster)}
    with farbmuster do
      begin
        setcolor(vorder);
        setbkcolor(hinter);
        setlinestyle(linie, 0, dicke);
      end;
    x1:=objdat1.x1; y1:=objdat1.y1;
    x2:=objdat1.x2; y2:=objdat1.y2;
    objchar:=objdat1.objchar;
    if (objchar='B') or (objchar='I') or (objchar='S') or (objchar='F') then
      setfillstyle(farbmuster.muster, farbmuster.fuell);

    if objchar='B' then bar(x1, y1, x2, y2);      {geflltes Rechteck}

    if objchar='E' then                           {Ellipse}
      begin
        mx:=x2; my:=y1;
        radius1:=x2-x1;
        if radius1<0 then radius1:=-1*radius1;
        radius2:=y1-y2;
        if radius2<0 then radius2:=-1*radius2;
        ellipse(mx, my, 0, 360, radius1, radius2);
      end;

    if objchar='F' then floodfill(x1, y1, getpixel(x2, y2)); {Fllen}

    if objchar='G' then                           {gerade Linie}
      begin
        if x2<x1 then
          begin
            mx:=x2; x2:=x1; x1:=mx;
          end;
        if y2<y1 then
          begin
            my:=y2; y2:=y1; y1:=my;
          end;
        if (y2-y1)<(x2-x1) then line(x1, y1, x2, y1);
        if (y2-y1)>(x2-x1) then line(x1, y1, x1, y2);
      end;

    if objchar='I' then                           {gefllter Kreis}
      begin
        if x2>x1 then radius2:=x2-x1 else radius2:=x1-x2; {Dummy}
        if y2>y1 then radius1:=y2-y1 else radius1:=y1-y2; {Dummy}
        radius1:=round(sqrt(radius1*radius1+radius2*radius2));
        pieslice(x1, y1, 0, 360, radius1);
      end;

    if objchar='K' then                           {Kreis}
      begin
        if x2>x1 then radius2:=x2-x1 else radius2:=x1-x2; {Dummy}
        if y2>y1 then radius1:=y2-y1 else radius1:=y1-y2; {Dummy}
        radius1:=round(sqrt(radius1*radius1+radius2*radius2));
        circle(x1, y1, radius1);
      end;
    if objchar='L' then line(x1, y1, x2, y2);     {Linie}

    if objchar='R' then rectangle(x1, y1, x2, y2);{Rechteck}

    if objchar='S' then                           {gefllte Ellipse}
      begin
        mx:=x2; my:=y1;
        radius1:=x2-x1;
        if radius1<0 then radius1:=-1*radius1;
        radius2:=y1-y2;
        if radius2<0 then radius2:=-1*radius2;
        ellipse(mx, my, 0, 360, radius1, radius2);
        floodfill(mx, my, farbmuster.vorder);
      end;

    if objchar='V' then vergroessern(x1, y1, x2, y2); {Vergr”sserungsmodus}

    show_maus;
  end;

procedure hilfe {Zeichnet Hilfebildschirm auf zweiter Bildschimseite};

  var fuellinfo : fillsettingstype;
      farbe     : word;

  begin
    hide_maus;                                 {alte Einstellungen speichern/}
    farbe:=getcolor;                           { Voreinstellungen}
    getfillsettings(fuellinfo);
    setvisualpage(1);
    setactivepage(1);

    cleardevice;                               {Oberfl„che zeichnen}
    settextstyle(2, 0, 5);
    settextjustify(0, 0);
    setfillstyle(1, 15);
    bar(5, 32, 639, 338);
    setcolor(1);
    setrgbpalette(1, 1, 1, 1);
    rectangle(10, 35, 635, 315);
    line(320, 35, 320, 315);
    line(320, 200, 635, 200);
    line(10, 285, 320, 285);

    outtextxy(10, 50,                    {Hilfetext}
     '  C : Bildschirml”schen (cleardevice)      00-15 : Vordergrundfarbe');
    outtextxy(10, 75,
     '  L : Linie                              20-35 : Hintergrundfarbe');
    outtextxy(10, 100,
     '  B : Balken (geflltes Rechteck)          40-55 : Fllfarbe');
    outtextxy(10, 125,
     '      Punkt L / R / vergr”įert           60-72 : Fllmuster');
    outtextxy(10, 150,
     '  R : Rechteck                           80-83 : Linienmuster');
    outtextxy(10, 175,
     '  K : Kreis                              90/93 : Liniendicke');
    outtextxy(10, 200,
     '  I : gefllter Kreis (Pieslice)');
    outtextxy(10, 225,
     '  S : gefllte Ellipse                           F1 : Hilfe');
    outtextxy(10, 250,
     '  F : Fl„che fllen                       Esc / F2 : Ende');
    outtextxy(10, 275,
     '  G : gerade Linie                             F3 : speichern (save)');
    outtextxy(10, 300,
     '  V : Vergr”įern                               F4 : laden');
    settextjustify(1, 0);
    outtextxy(320, 330, 'Taste drcken');
    repeat until keypressed;                            {Hilfe weg bei Taste}

    setrgbpalette(1, 0, 0, $70);                        {alte Einstellungen}
    setvisualpage(0);                                   {wiederherstellen}
    setactivepage(0);
    setcolor(farbe);
    with FuellInfo do SetFillStyle(Pattern, Color);
    show_maus;
  end;

procedure farbanteile;
  begin
  end;

{--- Dateiarbeit ------------------------------------------------------------}

procedure voreinstellungen(var fuellinfo : fillsettingstype; var farbe: word);

  begin
    hide_maus;                                          {Voreinstellungen}
    farbe:=getcolor;
    getfillsettings(fuellinfo);
    setvisualpage(1);
    setactivepage(1);
    cleardevice;
    settextstyle(2, 0, 6);
    settextjustify(0, 0);
  end;

procedure oberflaeche;

  begin
    setfillstyle(1, 15);                                {Oberfl„che zeichnen}
    bar(5, 32, 639, 338);
    setcolor(1);
    setrgbpalette(1, 1, 1, 1);
    outtextxy(20, 60, 'Name des Bildes ? : ');
  end;

procedure eingabeschleife(var datname: string);

  var x         : byte;
      ch        : char;
      dateiname : string;

  begin
    x:=0; dateiname:='';
    repeat                                              {Eingabeschleife}
      outtextxy(210+x*10, 60, '_');
      ch:=readkey;
      if ch=chr(8) then
        begin
          if (x>=1) then x:=x-1;
          setcolor(15);
          setfillstyle(1, 15);
          bar(210+x*10, 40, 220+x*10, 70);
          setcolor(0);
          delete(dateiname, x+1, 1);
        end;
      setcolor(15);
      setfillstyle(1, 15);
      bar(210+x*10, 40, 220+x*10, 70);
      setcolor(0);
      if (ch<>chr(13)) and (ch<>chr(8)) then outtextxy(210+x*10, 60, ch);
      if (ch<>chr(13)) and (ch<>chr(8)) then dateiname:=dateiname+ch;
      if (ch<>chr(8)) then x:=x+1;       {8=Backspace, 13=Return -> auswerten}
    until ch=chr(13);
    datname:=dateiname;
  end;

procedure alte_einstellungen(fuellinfo: fillsettingstype; farbe: word);

  begin
    setvisualpage(0);                   {Alte Einstellungen wiederherstellen}
    setcolor(farbe);
    setrgbpalette(1, 0, 0, $70);
    with FuellInfo do SetFillStyle(Pattern, Color);
    show_maus;
  end;

procedure bildspeichern;
  {Bild wird gespeichert in Feldern zu 20*20 Pixeln als Bitmap}

  var x, y, i    : byte;
      farbe      : word;
      dateiname  : string;
      bitmapfeld : array[1..246] of char;
      fuellinfo  : fillsettingstype;
      datei      : text;

  begin
    voreinstellungen(fuellinfo, farbe);
    oberflaeche;
    eingabeschleife(dateiname);
    if length(dateiname)>0 then  {Datei speichern}
      begin
        outtextxy(20, 120, 'Das Bild wird jetzt unter dem Namen ');
        outtextxy(20, 180, dateiname+' gespeichert . ');
        setactivepage(0);
        assign(datei, dateiname);
        rewrite(datei);
        for y:=0 to 23 do
          for x:=0 to 31 do
            begin
              getimage(x*20, y*20, x*20+19, y*20+19, bitmapfeld);
              for i:=1 to 246 do write(datei, bitmapfeld[i]);
            end;
        close(datei);
      end;
    if length(dateiname)=0 then setactivepage(0);
      {Kein Dateiname-keine Speicherung}
    alte_einstellungen(fuellinfo, farbe);
  end;

procedure bildladen;

  var x, y, i    : byte;
      farbe      : word;
      dateiname  : string;
      bitmapfeld : array[1..246] of char;
      fuellinfo  : fillsettingstype;
      datei      : text;

  begin
    voreinstellungen(fuellinfo, farbe);
    oberflaeche;
    eingabeschleife(dateiname);
    if length(dateiname)>0 then  {Bild laden}
      begin
        outtextxy(20, 120, 'Das Bild '+dateiname);
        outtextxy(20, 180, 'wird jetzt geladen . ');
        setactivepage(0);
        assign(datei, dateiname);
        reset(datei);
        for y:=0 to 23 do
          for x:=0 to 31 do
            begin
              for i:=1 to 246 do read(datei, bitmapfeld[i]);
              putimage(x*20, y*20, bitmapfeld, 0);
            end;
        close(datei);
      end;
    if length(dateiname)=0 then setactivepage(0);
      {Kein Dateiname-kein Bild laden}
    alte_einstellungen(fuellinfo, farbe);
  end;

{--- Was zeichnen / tun ? ---------------------------------------------------}

procedure Zweitetaste(farbmuster: farbmustertyp; objdat2: objdaten);

  var xm2, ym2, tasten2  : word;

  begin {Koordinaten fr zweiten Punkt einlesen per Maus}
    tasten2:=0;
    xm2:=0; ym2:=0;
    repeat
      delay(50);
      maus_status(xm2, ym2, tasten2);
    until (tasten2=0);
    objdat2.x2:=xm2; objdat2.y2:=ym2;
    Objekt(farbmuster, objdat2);
  end;

procedure Ablauf;
  {steuert Ablauf w„hrend des Programms, Buchstaben siehe Ende}

  var farbe, i                   : byte;
      xmaus, ymaus, tasten       : word;
      beenden, objektja          : boolean;
      zeichen, objchar, zeichen2 : char;
      farbmuster                 : farbmustertyp;
      objdat3                    : objdaten;

  begin
    farbmuster.vorder:=15;                 {Voreinstellungen}
    farbmuster.hinter:=0;
    farbmuster.fuell:=15;
    farbmuster.muster:=1;
    farbmuster.linie:=0;
    farbmuster.dicke:=1;

    repeat                                 {Ablaufschleife}
      maus_status(xmaus, ymaus, tasten);
      tasten:=0; zeichen:=chr(0);
      xmaus:=0; ymaus:=0;
      zeichen:=chr(0);
      zeichen2:=chr(0);

      repeat                               {auf Eingaben warten}
        delay(10);
        maus_status(xmaus, ymaus, tasten);
        if keypressed then zeichen:=readkey;
        if keypressed and (zeichen=chr(0)) then zeichen2:=readkey;
      until (tasten=1) or (zeichen>chr(0)) or (zeichen2>chr(0));

      if zeichen>chr(0) then                  {Eingaben auswerten}
        case zeichen of
            '0'..'9' : Farben (zeichen, farbmuster);
            'B', 'b' : begin objektja:=true; objchar:='B'; end;
            {'C', 'c' : cleardevice;}
            'E', 'e' : begin objektja:=true; objchar:='E'; end;
            'F', 'f' : begin objektja:=true; objchar:='F'; end;
            'G', 'g' : begin objektja:=true; objchar:='G'; end;
            'I', 'i' : begin objektja:=true; objchar:='I'; end;
            'K', 'k' : begin objektja:=true; objchar:='K'; end;
            'L', 'l' : begin objektja:=true; objchar:='L'; end;
            'R', 'r' : begin objektja:=true; objchar:='R'; end;
            'S', 's' : begin objektja:=true; objchar:='S'; end;
            'V', 'v' : begin objektja:=true; objchar:='V'; end;
            chr(27)  : beenden:=true; {Escape-Taste}
            else       Beep(500);
          end;
      if zeichen2>chr(0) then
        case zeichen2 of
            chr(59) : hilfe;               {F1}
            chr(60) : beenden:=true;       {F2}
            chr(61) : bildspeichern;       {F3}
            chr(62) : bildladen;           {F4}
            else      Beep(500);
          end;

      objdat3.x1:=xmaus; objdat3.y1:=ymaus;
      objdat3.objchar:=objchar;
      if (tasten=1) and (objektja=true) then    {šbergabe zur Zeichenprozedur}
        Zweitetaste (farbmuster, objdat3);
    until beenden=true;
    bildspeichern;
  end;

{*** Hauptprogramm **********************************************************}

procedure Ende {Graphik und Maus ausschalten};

  begin
    Beep(300);
    delay(500);
    hide_maus;
    cleardevice;
    closegraph;
  end;

begin
  Start;
  Ablauf;
  Ende;
end.

{                                     Ā
 C : Bildschirmloeschen (cleardevice) ³ 00-15 : Vordergrundfarbe
 L : Linie , G: gerade Linie          ³ 20-35 : Hintergrundfarbe
 B : Balken (gefuelltes Rechteck)     ³ 40-55 : Fuellfarbe
     Punkt L / R / vergr”įert         ³ 60-72 : Fuellmuster
 R : Rechteck                         ³ 80-83 : Linienmuster
 K : Kreis                            ³ 90/93 : Liniendicke
 I : gefuellter Kreis (Pieslice)      ĆÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ“
 S : gefuellte Ellipse                ³       F1 : Hilfe
 F : Flaeche fuellen                  ³ Esc / F2 : Ende
ĆÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ“       F3 : speichern (save)
 V : Vergr”įern                       ³       F4 : Farbanteile der Farben
                                      Į }