unit fxxfenst; {Fenster fuer die Funktionstasten F1 bis F10}

interface

uses textobjz, graph, crt, dos;

type string50 = string[50];

procedure hilfe;                                            {F1}
procedure bildspeichern(var abbruch: boolean);              {F3}
procedure bildladen;                                        {F4}
procedure muster_und_farben(var farbmuster: farbmustertyp); {F5}
procedure farbpalette_muster(farbmuster: farbmustertyp);    {F6}
procedure farbe_setrgb(farbe : byte);                       {F7}
procedure eig_fuellmuster(farbmuster: farbmustertyp);       {F8}
procedure eig_linienmuster(farbmuster: farbmustertyp);      {F9}
procedure textsettings(var texteinst : textsettingstype);   {F10}

implementation

{*** Fenster ****************************************************************}
{--- F�r alle weiteren Prozeduren -------------------------------------------}

procedure voreinstellungen(var fuellinfo : fillsettingstype;
            var linieinfo: linesettingstype; var farbe: byte);

  begin
    farbe:=getcolor;                                       {Voreinstellungen}
    getfillsettings(fuellinfo);
    getlinesettings(linieinfo);
    setvisualpage(2);
    setactivepage(2);
    setviewport(0, 276, 639, 479, true);
    clearviewport;
    setviewport(0, 0, 639, 479, true);
    settextstyle(2, 0, 5);
    settextjustify(0, 0);
  end;

procedure oberflaeche(x, y: punkt; text: string50);

  begin
    setfillstyle(1, 15);                                {Oberfl„che zeichnen}
    setcolor(0);
    bar(0, 276, 639, 479);
    setlinestyle(0, 0, 1);
    outtextxy(x, y, text);
  end;

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

  begin
    setvisualpage(0);                   {Alte Einstellungen wiederherstellen}
    setcolor(farbe);
    with linieinfo do newsetlinestyle(linestyle, pattern, thickness);
    with FuellInfo do newSetFillStyle(Pattern, Color);
  end;

{--- Hilfe ------------------------------------------------------------------}

procedure hilfe {Zeichnet Hilfebildschirm auf zweiter Bildschimseite};

  var fuellinfo : fillsettingstype;
      linieinfo : linesettingstype;
      ch        : char;
      farbe     : byte;

  begin
    while keypressed do ch:=readkey;
    voreinstellungen(fuellinfo, linieinfo, farbe);
    oberflaeche(0, 0, '');
    settextstyle(2, 0, 4);
    bar(0, 276, 639, 479);                 {16Farben: 5, 32, 639, 338}
    rectangle(10, 280, 635, 451);          {16Farben: 10, 35, 635, 315}
    line(320, 280, 320, 451);              {16Farben: 320, 35, 320, 315}
    line(320, 370, 635, 370);              {16Farben: 320, 200, 635, 200}
    line(10, 430, 320, 430);               {16Farben: 10, 285, 320, 285}

    outtextxy(10, 290,                    {Hilfetext}
     '  ''C''+Enter : Bildschirml”schen (cleardevice)           F5 : Farben/Muster/Linie');
    outtextxy(10, 305,
     '  ''e'' : Ellipse /  ''E'' : gefuellt                        F6 : Farbpalette/Muster');
    outtextxy(10, 320,
     '  ''f'' : Fl„che f�llen                                   F7 : RGB-Anteile „ndern');
    outtextxy(10, 335,
     '  ''k'' : Kreis /    ''K'' : gefuellt                        F8 : eigenes F�llmuster');
    outtextxy(10, 350,
     '  ''l'' : Linie /    ''L'' : gerade                         (F9 : eigenes Linienmuster)');
    outtextxy(10, 365,
     '  ''p'' : Punkt                                         (F10 : Texteinstellungen)');
    outtextxy(10, 380,
     '  ''r'' : Rechteck / ''R'' : gefuellt                           Enter : Koordinaten rechts/links/nicht');
    outtextxy(10, 395,
     ' (''t'' : Text)                                                 F1 : Hilfe');
    outtextxy(10, 410,
     '  ''W'' : Wuerfel  / ''w'' : ohne Deckel                    Esc / F2 : Ende');
    outtextxy(10, 425,
     '                                                            F3 : speichern (save)');
    outtextxy(10, 445,
     '  ''V'' : VergrӇern                                           F4 : laden');
    settextjustify(1, 0);
    outtextxy(320, 465, 'Taste dr�cken');
    repeat until keypressed;                            {Hilfe weg bei Taste}

    alte_einstellungen(fuellinfo, linieinfo, farbe);    
    setactivepage(0);
    while keypressed do ch:=readkey;
  end;

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

procedure eingabeschleife(xz, yz: punkt; var datname: string;
                              var abbruch: boolean);

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

  begin
    x:=0; dateiname:=''; abbruch:=false;
    repeat                                              {Eingabeschleife}
      outtextxy(xz+x*10, yz, '_');   {Cursor}
      ch:=readkey;
      if ch=chr(8) then
        begin
          if (x>=1) then x:=x-1;
          setcolor(15);
          setfillstyle(1, 15);
          bar(xz+x*10, yz-15, xz+20+x*10, yz+15);
          setcolor(0);
          delete(dateiname, x+1, 1);
        end;
      if ch=chr(0) then
        begin
          ch:=readkey;
          ch:=chr(8);      {Es wird kein Zeichen ausgegeben}
        end;
      setcolor(15);
      setfillstyle(1, 15);
      bar(xz+x*10, yz-15, xz+10+x*10, yz+15);
      setcolor(0);
      if (ch=chr(27)) then
        begin
          dateiname:='';
          abbruch:=true;
          ch:=chr(13);
        end;
      if (ch<>chr(13)) and (ch<>chr(8)) then outtextxy(xz+x*10, yz, 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 bildspeichern(var abbruch: boolean);
  {Bild wird gespeichert in Feldern zu 20*20 Pixeln als Bitmap}

  var x, y, farbe : byte;
      i           : integer;
      dateiname   : string;
      bitmapfeld  : array[1..486] of char;
      fuellinfo   : fillsettingstype;
      linieinfo   : linesettingstype;
      datei       : text;

  begin
    voreinstellungen(fuellinfo, linieinfo, farbe);
    oberflaeche(10, 320, 'Name des Bildes [Enter: Nicht speichern] ? : ');
    outtextxy(10, 300, 'Esc: Abbruch');
    eingabeschleife(345, 320, dateiname, abbruch);
    if length(dateiname)>0 then  {Datei speichern}
      begin
        outtextxy(20, 340, 'Das Bild wird jetzt unter dem Namen ');
        outtextxy(20, 360, 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 486 do write(datei, bitmapfeld[i]);
            end;
        close(datei);
      end;
    if length(dateiname)=0 then setactivepage(0);
      {Kein Dateiname-keine Speicherung}
    alte_einstellungen(fuellinfo, linieinfo, farbe);
  end;

procedure bildladen;

  var x, y, farbe : byte;
      i           : integer;
      abbruch     : boolean;
      dateiname   : string;
      bitmapfeld  : array[1..486] of char;
      fuellinfo   : fillsettingstype;
      linieinfo   : linesettingstype;
      datei       : text;

  begin
    voreinstellungen(fuellinfo, linieinfo, farbe);
    oberflaeche(10, 320, 'Name des Bildes ? : ');
    outtextxy(10, 300, 'Esc: Abbruch');
    eingabeschleife(160, 320, dateiname, abbruch);
    if length(dateiname)>0 then  {Bild laden}
      begin
        outtextxy(20, 340, 'Das Bild '+dateiname);
        outtextxy(20, 360, '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 486 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, linieinfo, farbe);
  end;

{--- Muster, Farben, Linien einstellen --------------------------------------}

procedure muster_und_farben(var farbmuster: farbmustertyp);

  var abbruch               : boolean;
      old_farbe, dicke2     : byte;
      ch                    : char;
      code                  : integer;
      fuellinfo             : fillsettingstype;
      linieinfo             : linesettingstype;

  function eingaben(x, y: punkt; alt, bereich: byte; text: string50;
                       var abbruch: boolean): byte;

    var neue_farbe     : byte;
        neue_farbe_str : string;

    begin
      str(alt, neue_farbe_str);
      outtextxy(20, y, text+' ? ['+neue_farbe_str+'] ');
        {Alte Farbe als Default}
      repeat
        eingabeschleife(x, y, neue_farbe_str, abbruch);
        val(neue_farbe_str, neue_farbe, code);
        if code=0 then
          if neue_farbe>bereich then code:=1;
        if code>0 then
          begin
            setfillstyle(1, 15);
            bar(x, y-15, 639, y);
          end;
        if neue_farbe_str='' then code:=0;
      until code=0;
      if not(neue_farbe_str='') then eingaben:=neue_farbe
                                else eingaben:=alt;
    end;

  begin
    voreinstellungen(fuellinfo, linieinfo, old_farbe);
    oberflaeche(20, 300, 'Esc: Abbruch');
    code:=0;
    while keypressed do ch:=readkey;
    with farbmuster do
      begin
        vorder:=eingaben(270, 320, vorder, 255, 'Vordergrundfarbe (0-255)',
                               abbruch);
        if not abbruch then
          hinter:=eingaben(265, 340, hinter, 255,
                           'Hintergrundfarbe (0-255)', abbruch);
        if not abbruch then
          fuell :=eingaben(210, 360, fuell, 255, 'F�llfarbe (0-255)', abbruch);
        if not abbruch then
          muster:=eingaben(200, 380, muster, 20, 'F�llmuster (0-20)', abbruch);
        if not abbruch then
          linie :=eingaben(200, 400, linie, 9, 'Linienmuster (0-9)', abbruch);
        dicke2:=dicke;
        if not abbruch then
          repeat
            dicke2:=eingaben(200, 420, dicke, 3, 'Liniendicke (1/3)', abbruch);
          until (dicke2=1) xor (dicke2=3);
        dicke:=dicke2;
      end;
    alte_einstellungen(fuellinfo, linieinfo, old_farbe);
    setactivepage(0);
  end;

{--- Farbpalette und Muster darstellen -------------------------------------}

procedure farbpalette_muster(farbmuster : farbmustertyp);

  procedure fuellmzeigen;

    var taste, x, y : byte;
        indexstr    : string[2];

    begin
      settextjustify(1, 0); setcolor(0);
      oberflaeche(320, 478, '''Esc'': šbersicht');
      outtextxy(320, 467, 'Muster 12-20 benutzerdefiniert');
      for y:=0 to 2 do
        for x:=0 to 6 do
          begin
            newsetfillstyle((y*7+x) mod 21, farbmuster.fuell);
            bar(19+x*86, 280+y*62, 19+x*86+80, 280+y*62+45);
            rectangle(19+x*86, 280+y*62, 19+x*86+80, 280+y*62+45);
            str((y*7+x) mod 21, indexstr);
            outtextxy(19+x*86+40, 280+y*62+53, indexstr);
          end;
      repeat
        if keypressed then taste:=ord(readkey);
      until taste=27;{'ESC'}
    end;

  procedure linienmzeigen;

    var y, taste : byte;
        indexstr : string[1];

    begin
      settextjustify(1, 0);
      oberflaeche(320, 478, '''Esc'': šbersicht');
      outtextxy(50, 300, 'Liniendicke 1');
      outtextxy(50, 340, 'Muster 4-9');
      outtextxy(50, 350, 'benutzerdefiniert');
      outtextxy(50, 390, 'Liniendicke 3');
      outtextxy(50, 430, 'Muster 4-9');
      outtextxy(50, 440, 'benutzerdefiniert');
      putpixel(320, 300, farbmuster.vorder);          {Hintergrund}
      setfillstyle(1, helldunkel(320, 300));
      bar(100, 278, 620, 470);
      for y:=0 to 9 do                                {d�nne Linien}
        begin
          setcolor(farbmuster.vorder);
          newsetlinestyle(y, 0, 1);
          line(100, 280+y*10, 620, 280+y*10);
          setcolor(0);
          str(y, indexstr);
          outtextxy(625, 280+y*10+3, indexstr);
        end;
      for y:=0 to 9 do                                {dicke Linien}
        begin
          setcolor(farbmuster.vorder);
          newsetlinestyle(y, 0, 3);
          line(100, 375+y*10, 620, 375+y*10);
          setcolor(0);
          str(y, indexstr);
          outtextxy(630, 375+y*10+3, indexstr);
        end;
      repeat
        if keypressed then taste:=ord(readkey);
      until taste=27;{'ESC'}
      setlinestyle(0, 0, 1);
    end;

  procedure farbreihe(colorstart, colorend: byte);

    var ende                                : boolean;
        colorstr, redstr, greenstr, bluestr : string[3];
        x, y, farbaktuell                   : byte;
        farbrgb                             : rgbcolor;

    begin
      ende:=false;
      settextjustify(1, 0);
      oberflaeche(320, 478, '''Esc'': šbersicht');
      settextjustify(0, 0);
      for y:=0 to 2 do
        for x:=0 to 10 do
          begin
            farbaktuell:=colorstart+y*11+x;
            setcolor(0);
            setfillstyle(1, farbaktuell);
            bar(20+x*55, 280+y*65, 20+x*55+45, 280+y*65+45);
            rectangle(20+x*55, 280+y*65, 20+x*55+45, 280+y*65+45);
            readdaccolor(farbaktuell, farbrgb);
            str(farbaktuell:3, colorstr);
            str(farbrgb.r:2, redstr); redstr:=redstr+',';
            str(farbrgb.g:2, greenstr); greenstr:=greenstr+',';
            str(farbrgb.b:2, bluestr);
            outtextxy(20+x*55, 280+y*65+55, redstr+greenstr+bluestr);
            setcolor(helldunkel(20+x*55+10, 280+y*65+10));
            outtextxy(20+x*55+21, 280+y*65+21, colorstr);
          end;
      repeat
        if readkey=chr(27) then ende:=true;
      until ende;
    end;

  procedure allefarben;

    var i, j : byte;
        farbstr         : string[3];

    begin
      for i:=0 to 31 do
        begin
          setfillstyle(1, i);
          bar(19*i+28, 281, 19*i+16+27, 296);
          setcolor(0);
          rectangle(19*i+27, 280, 19*i+17+27, 297);
        end;
      for j:=0 to 8 do  {32-247}
        begin
          str(j+1, farbstr); outtextxy(1, 310+j*19, farbstr+':');
          str(j*24+32, farbstr); outtextxy(10, 310+j*19, farbstr);
          str(j*24+32+23, farbstr); outtextxy(485, 310+j*19, farbstr);
          for i:=0 to 23 do
            begin
              setfillstyle(1, j*24+i+32);
              bar(19*i+28, 299+j*19+1, 19*i+16+27, 299+j*19+16);
              setcolor(0);
              rectangle(19*i+27, 299+j*19, 19*i+17+27, 299+j*19+17);
            end;
        end;
      outtextxy(610, 306, '9:248'); outtextxy(610, 467, '9:255');
      for i:=0 to 7 do
        begin
          setfillstyle(1, 248+i);
          bar(616, 299+i*19+10+1, 630, 299+i*19+10+16);
          setcolor(0);
          rectangle(615, 299+i*19+10, 631, 299+i*19+10+17);
        end;{of for i:=0 to 7}
    end;

  procedure regenbogen;

    procedure farbez(var farbe: byte; add: shortint);

      var xalt, yalt                : punkt;
          rotstr, gruenstr, blaustr : string[2];
          farbstr                   : string[3];
          farbRGB                   : RGBColor;

      begin
        xalt:=getx; yalt:=gety;
        setfillstyle(1, 15);               {alte Farbzahlen l”schen}
        bar(555, 305, 639, 345);
        moveto(xalt, yalt);                {alte Linie l”schen}
        setcolor(15);
        line(getx, 280, getx, 289);
        setcolor(farbe);
        line(getx, 350, getx, 400);
        if (getx+add >= 5) and (getx+add <= 548) then moveto(getx+add, gety);
        farbe:=getpixel(getx, gety);       {neue Linie zeichnen}
        setcolor(helldunkel(getx, 290));
        line(getx, 350, getx, 400);
        setcolor(0);
        line(getx, 280, getx, 289);
        xalt:=getx; yalt:=gety;
        str(farbe, farbstr);               {neue Farbzahl zeichnen}
        ReadDACColor(farbe, farbRGB);
        str(farbRGB.R, rotstr);
        str(farbRGB.G, gruenstr); str(farbRGB.B, blaustr);
        outtextxy(560, 320, farbstr);
        outtextxy(560, 340, rotstr+','+gruenstr+','+blaustr);
        moveto(xalt, yalt);
      end;

    var ende     : boolean;
        i, farbe : byte;
        ch       : char;

    begin
      ende:=false;
      settextjustify(1, 0);
      oberflaeche(320, 478, '''Esc'': šbersicht');
      settextjustify(0, 0);
      for i:=0 to 31 do
        begin
          setfillstyle(1, i);
          bar(5+i*3, 290, 5+i*3+2, 470);
        end;
      for i:=32 to 255 do
        begin
          setcolor(i);
          line(37+i*2, 290, 37+i*2, 470); line(37+i*2+1, 290, 37+i*2+1, 470);
        end;
      outtextxy(560, 400, 'Strich');
      outtextxy(560, 420, 'bewegen mit');
      outtextxy(560, 440, 'Cursortasten');
      settextstyle(2, 0, 6);
      outtextxy(555, 300, 'Farbe:');
      moveto(320, 350);
      farbe:=getpixel(getx, gety);
      farbez(farbe, 0);
      repeat
        ch:=chr(1);
        if keypressed then ch:=readkey;
        if ch=chr(0) then ch:=readkey;
        case ch of
            'K' : farbez(farbe, -1);   {Cursor links}
            'M' : farbez(farbe, +1);   {Cursor rechts}
            'H' : farbez(farbe, -20);  {Cursor hoch}
            'P' : farbez(farbe, +20);  {Cursor runter}
          end;
        if ch=chr(27) then ende:=true;  {'Esc'}
      until ende;
    end;

  var fuellinfo       : fillsettingstype;
      linieinfo       : linesettingstype;
      ch              : char;
      old_farbe       : byte;
      ende, rebuild   : boolean;

  begin
    while keypressed do ch:=readkey;
    voreinstellungen(fuellinfo, linieinfo, old_farbe);
    settextstyle(2, 0, 4);
    rebuild:=true;

    repeat
      ende:=false;
      if rebuild=true then
        begin
          settextjustify(0, 0);
          settextstyle(2, 0, 4);
          oberflaeche(20, 300, '');
          outtextxy(3, 290, '0:0');
          allefarben;
          outtextxy(510, 320, 'Farbreihe:');
          outtextxy(510, 340, 'Tasten ''0''-''9''');
          outtextxy(510, 360, '''F'': F�llmuster');
          outtextxy(510, 380, '''L'': Linienmuster');
          outtextxy(510, 400, '''R'': Regenbogen');
          settextjustify(1, 0);
          outtextxy(320, 478, '''Esc'': Beenden');
        end;{of if rebuild=true}

      repeat until keypressed;
      while keypressed do ch:=readkey;
      ch:=upcase(ch);
      case ch of
          '0'      : farbreihe(0, 31);
          '1'..'8' : farbreihe(32+(ord(ch)-ord('1'))*24, 31+(ord(ch)-ord('0'))*24);
          '9'      : farbreihe(224, 255);
          'F'      : fuellmzeigen;
          'L'      : linienmzeigen;
          'R'      : regenbogen;
          chr(27)  : ende:=true;
          else       Beep(500);
        end;
      rebuild:=false;
      if ((ch>='0') and (ch<='9')) or (ch='F') or (ch='L') or (ch='R')
        then rebuild:=true;
    until ende=true;

    alte_einstellungen(fuellinfo, linieinfo, old_farbe);
    while keypressed do ch:=readkey;
    settextjustify(0, 0);
    setactivepage(0);
  end;

{--- Rot-, Gr�n- und Blau-Anteile der Farben „ndern ------------------------}

procedure farbe_setrgb(farbe : byte);

  procedure dreiecke(x, y: punkt);{Spitze oberes}
    begin
      setcolor(0); setfillstyle(1, 0);
      line(x, y, x-5, y+10); line(x-5, y+10, x+5, y+10);    {oberes}
      line(x+5, y+10, x, y); floodfill(x, y+5, 0);
      rectangle(x+20, y, x+80, y+10);
      line(x, y+25, x-5, y+15); line(x-5, y+15, x+5, y+15); {unteres}
      line(x+5, y+15, x, y+25); floodfill(x, y+20, 0);
      rectangle(x+20, y+15, x+80, y+25);
    end;

  procedure SetDACColor(farbe : integer; var Pal : RGBColor);

    var Regs : Registers;

    begin
      with Regs do
        begin
          AH := $10;
          AL := $12;
          BX := farbe;
          CX := 1;
          ES := Seg(Pal);
          DX := Ofs(Pal);
        end;
      Intr($10, Regs);
    end;

  procedure copyfarbrgb(farbe1, farbe2: byte);

    var farbRGB : RGBColor;

    begin
      ReadDACColor(farbe1, farbRGB);
      SetDACColor(farbe2, farbRGB);
    end;

  procedure writeRGBtext(farbe : byte);

    var farbRGB                   : RGBColor;
        rotstr, gruenstr, blaustr : string[2];
        farbstr                   : string[3];

    begin
      setfillstyle(1, 15);
      Bar(310, 300, 340, 465);
      ReadDACColor(255, farbRGB);
      str(farbe, farbstr); str(farbRGB.R, rotstr);
      str(farbRGB.G, gruenstr); str(farbRGB.B, blaustr);
      settextstyle(2, 0, 6); settextjustify(0, 0);
      outtextxy(312, 315, farbstr); outtextxy(312, 355, rotstr);
      outtextxy(312, 395, gruenstr); outtextxy(312, 435, blaustr);
    end;

  procedure neubalken(var farbe: byte; add: shortint);
    begin
      farbe:=farbe+add;
      case farbe of
          0, 255 : if add=+1 then farbe:=1 else farbe:=254;
          15     : farbe:=farbe+add;
        end;
      copyfarbrgb(farbe, 255);
      setfillstyle(1, farbe); setcolor(0);
      bar(15, 290, 185, 460); rectangle(15, 290, 185, 460);
      setfillstyle(1, 255);
      bar(455, 290, 625, 460); rectangle(455, 290, 625, 460);
      writeRGBtext(farbe);
    end;

  procedure SetRGBColor(farbe:byte; rotadd, gruenadd, blauadd: shortint);

    var farbRGB : RGBColor;

    begin
      ReadDACColor(255, farbRGB);
      if (farbRGB.R+rotadd >= 0) and (farbRGB.R+rotadd <=63)
        then farbRGB.R:=farbRGB.R+rotadd;
      if (farbRGB.G+gruenadd >= 0) and (farbRGB.G+gruenadd <=63)
        then farbRGB.G:=farbRGB.G+gruenadd;
      if (farbRGB.B+blauadd >= 0) and (farbRGB.B+blauadd <=63)
        then farbRGB.B:=farbRGB.B+blauadd;
      setDACColor(255, farbRGB);
      writeRGBtext(farbe);
    end;

  var ende            : boolean;
      ch              : char;
      old_farbe       : byte;
      fuellinfo       : fillsettingstype;
      linieinfo       : linesettingstype;
      farbRGB         : RGBColor;

  begin
    while keypressed do ch:=readkey;                     {Grundaufbau}
    voreinstellungen(fuellinfo, linieinfo, old_farbe);
    settextjustify(1, 0);
    oberflaeche(320, 475, '''Esc'': Abbruch  ''Enter'': Fertig');
    ende:=false;

    neubalken(farbe, +1); neubalken(farbe, -1);  {�berspringt 0, 15, 255}
    settextjustify(0, 0);                              {Farbdarstellung}
    outtextxy(100, 475, 'Alt'); outtextxy(540, 475, 'Neu');
    outtextxy(380, 290, 'Taste'); outtextxy(200, 315, 'Farbe: ');
    outtextxy(200, 355, 'Rot-Anteil: ');
    outtextxy(200, 395, 'Gr�n-Anteil: ');
    outtextxy(200, 435, 'Blau-Anteil: ');
    dreiecke(350, 300); dreiecke(350, 340);
    dreiecke(350, 380); dreiecke(350, 420);
    settextstyle(2, 0, 4); settextjustify(1, 0);
    outtextxy(400, 308, 'auf/rechts'); outtextxy(400, 323, 'ab/links');
    outtextxy(400, 348, 'Einfg'); outtextxy(400, 363, 'Entf');
    outtextxy(400, 388, 'Pos1'); outtextxy(400, 403, 'Ende');
    outtextxy(400, 428, 'Bild auf'); outtextxy(400, 443, 'Bild ab');

    repeat                                            {Neue Anteile}
      ch:=chr(1);
      if keypressed then ch:=readkey;
      if ch=chr(0) then ch:=readkey;
      case ch of
          'H' : neubalken(farbe, +1);         {auf}
          'M' : neubalken(farbe, +20);        {rechts}
          'P' : neubalken(farbe, -1);         {ab}
          'K' : neubalken(farbe, -20);        {links}
          'R' : SetRGBColor(farbe, +1, 0, 0); {Einfg}
          'S' : SetRGBColor(farbe, -1, 0, 0); {Entf}
          'G' : SetRGBColor(farbe, 0, +1, 0); {Pos1}
          'O' : SetRGBColor(farbe, 0, -1, 0); {Ende}
          'I' : SetRGBColor(farbe, 0, 0, +1); {Bild auf}
          'Q' : SetRGBColor(farbe, 0, 0, -1); {Bild ab}
        end;
      if ch=chr(27) then ende:=true;          {Esc}
      if ch=chr(13) then                      {Enter}
         begin
           ende:=true;
           copyfarbrgb(255, farbe);
         end;
    until ende;

    alte_einstellungen(fuellinfo, linieinfo, old_farbe); {Abbau}
    while keypressed do ch:=readkey;
    settextjustify(0, 0);
    setactivepage(0);
  end;

{--- Eigene F�llmuster einstellen ------------------------------------------}

procedure eig_fuellmuster(farbmuster : farbmustertyp);

  procedure copymuster(von, nach : byte);

    begin
      fuellmusterfeld[nach]:=fuellmusterfeld[von];
    end;

  function potenz(z, hoch: byte): byte;

    begin
      if hoch=0 then potenz:=1
                else potenz:=potenz(z, hoch-1)*z;
    end;

  function getposinhalt(muster : byte; pos : shortint): byte;

    var  x, y : byte;

    begin
      x:=potenz(2, 7-(pos mod 10));
      y:=pos div 10;
      if x<>0 then getposinhalt:=(fuellmusterfeld[muster][y] and x) div x;
    end;                                  

  procedure outhexxy(x, y: punkt; z : byte);

    const hexchar: array[0..15] of char = ('0', '1', '2', '3', '4', '5',
                           '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');

    begin
      setfillstyle(1, 15); bar(x, y, x+20, y-10);
      outtextxy(x, y, hexchar[z div 16]+hexchar[z mod 16]);
    end;

  procedure writechangequad(muster : byte);

    var  x, y      : byte;
         musterstr : string[2];

    begin
      setfillstyle(1, 15); setcolor(0);
      bar(215, 310, 250, 330);
      settextjustify(0, 0);
      outtextxy(200, 310, 'Muster: ');
      str(muster, musterstr);
      outtextxy(220, 330, musterstr);
      rectangle(215, 315, 240, 335);
      setcolor(0);
      setfillstyle(1, 15);
      for y:=1 to 8 do
        for x:=0 to 7 do
          begin
            setfillstyle(getposinhalt(muster, y*10+x), 15);
            bar(260+x*15, 275+y*15, 260+x*15+14, 275+y*15+14);
            rectangle(260+x*15, 275+y*15, 260+x*15+15, 275+y*15+15);
            outhexxy(390, 285+y*15, fuellmusterfeld[muster][y]);
          end;
    end;

  procedure marker(var pos : shortint; add : shortint);

    begin
      setfillstyle(1, getpixel(261+(pos mod 10)*15, 276+(pos div 10)*15));
      bar(266+(pos mod 10)*15, 281+(pos div 10)*15,
          269+(pos mod 10)*15, 284+(pos div 10)*15);
      pos:=pos+add;
      if pos mod 10 = 8 then pos:=pos-1;   {rechts šberlauf}
      if pos mod 10 = 9 then pos:=pos+1;   {links šberlauf}
      if pos div 10 = 0 then pos:=pos+10;  {oben šberlauf}
      if pos >= 90 then pos:=pos-10;       {unten šberlauf}
      setfillstyle(1, helldunkel(266+(pos mod 10)*15, 281+(pos div 10)*15));
      bar(266+(pos mod 10)*15, 281+(pos div 10)*15,
          269+(pos mod 10)*15, 284+(pos div 10)*15);
    end;

  procedure neubalken(var muster : byte; add : shortint;
                      var pos: shortint);

    begin
      muster:=muster+add;
      case muster of
          255 : muster:=20;
          21 : muster:=0;
        end;
      copymuster(muster, 21);
      newsetfillstyle(muster, 15); setcolor(0);
      bar(15, 290, 185, 460); rectangle(15, 290, 185, 460);
      newsetfillstyle(21, 15);
      bar(455, 290, 625, 460); rectangle(455, 290, 625, 460);
      writechangequad(muster);
      pos:=10;
      marker(pos, 0)
    end;

  procedure setfeld(muster : byte; pos: shortint);

    begin
      if getpixel(261+(pos mod 10)*15, 276+(pos div 10)*15)=15
        then dec(fuellmusterfeld[21][pos div 10], potenz(2, 7-(pos mod 10)))
        else inc(fuellmusterfeld[21][pos div 10], potenz(2, 7-(pos mod 10)));
      writechangequad(21);
      newsetfillstyle(21, 15);
      bar(455, 290, 625, 460); rectangle(455, 290, 625, 460);
      marker(pos, 0);
    end;

  var ende              : boolean;
      ch                : char;
      pos, i            : shortint;
      old_farbe, muster : byte;
      istr              : string[1];
      fuellinfo         : fillsettingstype;
      linieinfo         : linesettingstype;

  begin
    while keypressed do ch:=readkey;                     {Grundaufbau}
    voreinstellungen(fuellinfo, linieinfo, old_farbe);
    settextjustify(1, 0);
    oberflaeche(320, 475, '''Esc'': Abbruch  ''Enter'': Fertig');

    outtextxy(100, 475, 'Alt'); outtextxy(540, 475, 'Neu');
    settextstyle(2, 0, 4);
    outtextxy(320, 286, 'Bei den Mustern 0 bis 11 werden die Ver„nderungen nicht gespeichert !');
    outtextxy(220, 360, 'Tasten'); outtextxy(220, 370, '''+'', ''-''');
    outtextxy(220, 380, 'f�r andere'); outtextxy(220, 390, 'Muster');
    outtextxy(320, 430, 'Markierung (kleines Quadrat) mit den');
    outtextxy(320, 440, 'Cursortasten bewegen.');
    outtextxy(320, 450, 'Mit Leertaste Feld umschalten.');
    for i:=1 to 8 do
      begin
        str(i, istr);
        outtextxy(253+i*15, 418, istr);
      end;
    settextstyle(2, 1, 4); outtextxy(410, 380, '(hexadezimal)');
    settextstyle(2, 0, 5);
    ende:=false;

    muster:=farbmuster.muster;
    neubalken(muster, 0, pos);
    pos:=10;
    repeat
      ch:=chr(1);
      if keypressed then ch:=readkey;
      if ch=chr(0) then ch:=readkey;
      case ch of
          '+'     : neubalken(muster, +1, pos);
          '-'     : neubalken(muster, -1, pos);
          'K'     : marker(pos, -1);       {Cursor links}  {pos von 10 bis 87}
          'M'     : marker(pos, +1);       {Cursor rechts}
          'H'     : marker(pos, -10);      {Cursor hoch}
          'P'     : marker(pos, +10);      {Cursor runter}
          chr(32) : setfeld(muster, pos);  {Leertaste}
        end;
      if ch=chr(27) then ende:=true;          {Esc}
      if ch=chr(13) then                      {Enter}
         begin
           ende:=true;
           if muster>=12 then copymuster(21, muster);
         end;
    until ende;

    alte_einstellungen(fuellinfo, linieinfo, old_farbe); {Abbau}
    while keypressed do ch:=readkey;
    settextjustify(0, 0);
    setactivepage(0);
  end;

{--- Eigene Linienmuster einstellen ----------------------------------------}

procedure eig_linienmuster(farbmuster: farbmustertyp);

  function potenz(z, hoch : byte): word;

    var erg : word;
        i   : byte;

    begin
      erg:=1;
      for i:=1 to hoch do
        erg:=erg*z;
      potenz:=erg;
    end;

  function getposinhalt(muster : byte; pos : shortint): byte;

    var x : word;

    begin
      x:=potenz(2, pos);
      if x>0 then getposinhalt:=(linmusterfeld[muster] and x) div x;
    end;

  procedure marker(var pos : shortint; add: shortint);

    begin
      setfillstyle(1, 15-helldunkel(22+pos*15, 370));
      bar(26+pos*15, 371, 29+pos*15, 374);
      pos:=pos+add;
      case pos of
          -1 : pos:=0;
          16 : pos:=15;
        end;
      setfillstyle(1, helldunkel(22+pos*15, 370));
      bar(26+pos*15, 371, 29+pos*15, 374);
    end;

  procedure outhexxy(x, y: punkt; z : word);

    const hexchar : array[0..15] of char = ('0', '1', '2', '3', '4', '5',
                           '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');

    var hexstr  : string[4];

    begin
      setfillstyle(1, 15); bar(x, y, x+40, y-10);
      hexstr:='';
      hexstr:=hexstr+hexchar[z mod 16];        {4. Stelle} {Wert(Rang) rechts am h”chsten}
      z:=z div 16;
      hexstr:=hexstr+hexchar[z mod 16];        {3. Stelle}
      z:=z div 16;
      hexstr:=hexstr+hexchar[z mod 16];        {2. Stelle}
      z:=z div 16;
      hexstr:=hexstr+hexchar[z mod 16];        {1. Stelle}
      outtextxy(x, y, hexstr);
    end;


  procedure writechangelinie(muster : byte);

    var x    : punkt;
        xstr : string[2];

    begin
      setlinestyle(0, 0, 1);
      setcolor(0);
      outhexxy(100, 360, linmusterfeld[muster]);
      settextstyle(2, 0, 4);
      for x:=0 to 15 do
        begin
          setfillstyle(getposinhalt(muster, x), 15);
          bar(20+x*15, 365, 35+x*15, 380);
          rectangle(20+x*15, 365, 35+x*15, 380);
          str(x, xstr);
          outtextxy(28+x*15, 390, xstr);
        end;
      outtextxy(150, 360, '(hexadezimal)');
    end;

  procedure copymuster(von, nach : byte);

    begin
      linmusterfeld[nach]:=linmusterfeld[von];
    end;

  procedure neulinie(var muster : byte; add : shortint; var pos : shortint);

    var musterstr : string[1];

    begin
      str(muster, musterstr); settextstyle(2, 0, 5);
      setcolor(15); outtextxy(350, 375, musterstr);
      muster:=muster+add;
      case muster of
          255 : muster:=9;
          10 : muster:=0;
        end;
      setcolor(0);                                           {Altes l”schen}
      newsetlinestyle(0, 0, 1);
      line(60, 290, 620, 290); line(60, 320, 620, 320);
      newsetlinestyle(0, 0, 3);
      line(60, 300, 620, 300); line(60, 330, 620, 330);
      copymuster(muster, 10); setcolor(15);                  {Neues zeichnen}
      newsetlinestyle(muster, 0, 1); line(60, 290, 620, 290);
      newsetlinestyle(muster, 0, 3); line(60, 300, 620, 300);
      newsetlinestyle(10, 0, 1); line(60, 320, 620, 320);
      newsetlinestyle(10, 0, 3); line(60, 330, 620, 330);
      settextstyle(2, 0, 5); setcolor(0);
      outtextxy(280, 375, 'Muster:');
      str(muster, musterstr);
      outtextxy(350, 375, musterstr);
      writechangelinie(muster);
      pos:=0;
      marker(pos, 0)
    end;

  procedure setfeld(muster : byte; pos : shortint);

    begin
      if getpixel(21+pos*15, 370)=15
        then dec(linmusterfeld[10], potenz(2, pos))
        else inc(linmusterfeld[10], potenz(2, pos));
      writechangelinie(10);
      setcolor(0);                                         {Altes l”schen}
      newsetlinestyle(0, 0, 1); line(60, 320, 620, 320);
      newsetlinestyle(0, 0, 3); line(60, 330, 620, 330);
      setcolor(15);
      newsetlinestyle(10, 0, 1); line(60, 320, 620, 320);  {Neues zeichnen};
      newsetlinestyle(10, 0, 3); line(60, 330, 620, 330);
      marker(pos, 0);
    end;

  var ende              : boolean;
      ch                : char;
      pos               : shortint;
      old_farbe, muster : byte;
      fuellinfo         : fillsettingstype;
      linieinfo         : linesettingstype;

  begin
    while keypressed do ch:=readkey;                     {Grundaufbau}
    voreinstellungen(fuellinfo, linieinfo, old_farbe);
    settextjustify(1, 0);
    oberflaeche(320, 475, '''Esc'': Abbruch  ''Enter'': Fertig');
    outtextxy(20, 295, 'Alt:'); outtextxy(20, 325, 'Neu:');
    settextstyle(2, 0, 4);
    outtextxy(150, 410, 'Markierung (kleines Quadrat) mit den');
    outtextxy(150, 420, 'Cursortasten bewegen.');
    outtextxy(150, 430, 'Mit Leertaste Feld umschalten.');
    outtextxy(500, 375, 'Tasten ''+'', ''-'' fuer anderes Muster');
    rectangle(345, 363, 360, 378);
    setfillstyle(1, 0); bar(50, 280, 630, 340);
    setcolor(15); line(50, 310, 630, 310);
    settextjustify(0, 0);

    ende:=false;
    muster:=farbmuster.linie;
    neulinie(muster, 0, pos);
    pos:=0;
    repeat
      ch:=chr(1);
      if keypressed then ch:=readkey;
      if ch=chr(0) then ch:=readkey;
      case ch of
          '+'     : neulinie(muster, +1, pos);
          '-'     : neulinie(muster, -1, pos);
          'K'     : marker(pos, -1);       {Cursor links}  {pos von 0 bis 15}
          'M'     : marker(pos, +1);       {Cursor rechts}
          chr(32) : setfeld(muster, pos);  {Leertaste}
        end;
      if ch=chr(27) then ende:=true;          {Esc}
      if ch=chr(13) then                      {Enter}
         begin
           ende:=true;
           if muster>=4 then copymuster(10, muster);
         end;
    until ende;

    alte_einstellungen(fuellinfo, linieinfo, old_farbe); {Abbau}
    while keypressed do ch:=readkey;
    settextjustify(0, 0);
    setactivepage(0);
  end;

{--- Texteinstellungen „ndern ----------------------------------------------}

procedure textsettings(var texteinst : textsettingstype);

  begin
  end;

{*** Ende Implementation ***************************************************}

begin
end.