unit textobjz;

interface

uses crt, graph, maus, dos;

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;
     linmustertyp   = array[0..10] of word;
     fuellmustertyp = array[0..21] of fillpatterntype;
                {21. f�r Beibehaltung des anlten Musters bei
                 Prozedur eig_fuellmuster in Unit fxxfenst.pas}
     punkt          = 0..639;
     RGBColor       = record
                          R, G, B : byte;
                        end;
     objdaten       = record
                          x1, y1, x2, y2 : punkt;
                          objchar        : char;
                        end;


var linmusterfeld   : linmustertyp;
    fuellmusterfeld : fuellmustertyp;

procedure ReadDACColor(farbe : integer; var Pal : RGBColor);
procedure newsetlinestyle(linestyle, pattern, thickness: word);
procedure newsetfillstyle(fillstyle, color: word);
procedure Beep(hoehe: integer);
procedure vergroessern(x1, y1, x2, y2: punkt);
procedure Objekt(farbmuster: farbmustertyp; objdat1: objdaten);

function helldunkel(x, y: punkt): byte;

implementation

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

{--- Init -------------------------------------------------------------------}

procedure setlinmusterfeld;
  begin                        {         0123456789ABCDEF}
    linmusterfeld[0]:=$FFFF;   {         ����������������}
    linmusterfeld[1]:=$CCCC;   {         ���۰��۰��۰���}
    linmusterfeld[2]:=$FC78;   {         ������۰��������}
    linmusterfeld[3]:=$F8F8;   {         �������۰�������}
    linmusterfeld[4]:=22447;   {16 Pixel:���۰۰���۰۰۰}
    linmusterfeld[5]:=30167;   {         ��۰۰��۰۰��۰}
    linmusterfeld[6]:=22359;   {         ��۰۰۰��۰۰۰}
    linmusterfeld[7]:=10023;   {         ��۰�۰���۰�۰�}
    linmusterfeld[8]:=14631;   {         ��۰�۰�۰���۰�}
    linmusterfeld[9]:=10131;   {         �۰�۰����۰�۰�}
  end;

procedure setfuellmusterfeld;

  const GKaro : FillPatternType = ($18, $3C, $7E, $FF, $FF, $7E, $3C, $18);
        kKaro : FillPatternType = ($00, $08, $1C, $3E, $1C, $08, $00, $00);
        GQuad : FillPatternType = ($00, $7E, $42, $42, $42, $42, $7E, $00);
        kQuad : FillPatternType = ($00, $00, $3C, $3C, $3C, $3C, $00, $00);
        GDrei : FillPatternType = ($18, $18, $3C, $3C, $7E, $7E, $FF, $FF);
        kDrei : FillPatternType = ($00, $00, $08, $1C, $1C, $3E, $00, $00);
        Kreis : FillPatternType = ($3C, $42, $81, $81, $81, $81, $42, $3C);
        kKrei : FillPatternType = ($00, $00, $18, $3C, $3C, $18, $00, $00);
        FKrei : FillPatternType = ($00, $18, $3C, $7E, $7E, $3C, $18, $00);
          {ab hier vordefiniert von Tubo Pascal BGI}
        EmptyFill      : FillPatterntype = ($00, $00, $00, $00, $00, $00, $00, $00);
             {�   0  F�llen mit Hintergrundfarbe}
        SolidFill      : FillPatterntype = ($FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF);
             {�   1  F�llen mit der Zeichenfarbe}
        LineFill       : FillPatterntype = ($FF, $FF, $00, $00, $FF, $FF, $00, $00);
             {�   2  ---}
        LtSlashFill    : FillPatterntype = ($01, $02, $04, $08, $10, $20, $40, $80);
             {�   3  ///}
        SlashFill      : FillPatterntype = ($E0, $C1, $83, $07, $0E, $1C, $38, $70);
             {�   4  /// mit dicken Linien}
        BkSlashFill    : FillPatterntype = ($F0, $78, $3C, $1E, $0F, $87, $C3, $E1);
             {�   5  \\\ mit dicken Linien}
        LtBkSlashFill  : FillPatterntype = ($A5, $D2, $69, $B4, $5A, $2D, $96, $4B);
             {�   6  \\\}
        HatchFill      : FillPatterntype = ($FF, $88, $88, $88, $FF, $88, $88, $88);
             {�   7  leicht schraffiert}
        XHatchFill     : FillPatterntype = ($81, $42, $24, $18, $18, $24, $42, $81);
             {�   8  stark schraffiert, �berkreuzend}
        InterleaveFill : FillPatterntype = ($CC, $33, $CC, $33, $CC, $33, $CC, $33);
             {�   9  abwechselnde Linien}
        WideDotFill    : FillPatterntype = ($80, $00, $08, $00, $80, $00, $08, $00);
             {�  10  weit auseinanderliegende Punkte}
        CloseDotFill   : FillPatterntype = ($88, $00, $22, $00, $88, $00, $22, $00);
             {�  11  eng beieinanderliegende Punkte}


  var i : byte;

  begin
    fuellmusterfeld[0]:= EmptyFill;     fuellmusterfeld[1]:= SolidFill;
    fuellmusterfeld[2]:= LineFill;      fuellmusterfeld[3]:= LtSlashFill;
    fuellmusterfeld[4]:= SlashFill;     fuellmusterfeld[5]:= BkSlashFill;
    fuellmusterfeld[6]:= LtBkSlashFill; fuellmusterfeld[7]:= HatchFill;
    fuellmusterfeld[8]:= XHatchFill;    fuellmusterfeld[9]:= InterleaveFill;
    fuellmusterfeld[10]:=WideDotFill;   fuellmusterfeld[11]:=CloseDotFill;

    fuellmusterfeld[12]:=GKaro; fuellmusterfeld[13]:=kKaro;
    fuellmusterfeld[14]:=GQuad; fuellmusterfeld[15]:=kQuad;
    fuellmusterfeld[16]:=GDrei; fuellmusterfeld[17]:=kDrei;
    fuellmusterfeld[18]:=Kreis; fuellmusterfeld[19]:=kKrei;
    fuellmusterfeld[20]:=FKrei;
  end;

{--- Allgemeine Nutzung -----------------------------------------------------}

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

var Regs : Registers;

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

function helldunkel(x, y: punkt): byte;

  var farbe       : byte;
      verhaeltnis : integer;
      anteile     : RGBColor;

  begin
    farbe:=getpixel(x, y);
    ReadDACColor(farbe, anteile);
    verhaeltnis:=((anteile.r+anteile.g+anteile.b) div 3) mod 64;
    if verhaeltnis>32 then helldunkel:=0
                      else helldunkel:=15;
  end;

procedure newsetlinestyle(linestyle, pattern, thickness: word);
  begin
    if linestyle<4
      then setlinestyle(linestyle, pattern, thickness)
      else setlinestyle(4, linmusterfeld[linestyle], thickness);
  end;

procedure newsetfillstyle(fillstyle, color: word);
  begin
    if fillstyle<12
      then setfillstyle(fillstyle, color)
      else begin
             setfillstyle(12, color);
             setfillpattern(fuellmusterfeld[fillstyle], color);
           end;
  end;

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

{--- Vergroesserungsmodus ---------------------------------------------------}

procedure text_und_gitter;

  var x, y : punkt;
      zahlstr                    : string[2];

  begin
    settextstyle(2, 0, 7);                           {Text f�r Bedienung}
    settextjustify(0, 0);
    outtextxy(490, 300, 'Bedienung');
    outtextxy(470, 330, 'Vergr��erung :');
    line(470, 335, 630, 335);
    outtextxy(470, 380, ' Farbe:');
    outtextxy(470, 400, ' 0-255 +Enter');
    outtextxy(470, 450, ' Esc   Beenden');
    settextstyle(2, 0, 4);

    line(5, 280, 5, 460);
    line(5, 280, 454, 280);
    for x:=0 to 49 do                                 {Gitter}
      begin
        line(5+9+9*x, 280, 5+9+9*x, 462);
        if ((x mod 10) = 9) then line(5+9+9*x, 460, 5+9+9*x, 471);
        str(x mod 10, zahlstr);
        outtextxy(5+2+9*x, 471, zahlstr);
      end;
    for y:=0 to 19 do
      begin
        line(5, 280+9+9*y, 456, 280+9+9*y);
        str(y, zahlstr);
        outtextxy(459, 280+9+9*y, zahlstr);
      end;
  end;

procedure abschnittveraenderung;

  var normalmodus, nichtaus : boolean;
      zeichen, zeichen2, ch : char;
      farbe, farbeing       : byte;
      code                  : integer;
      x, y                  : punkt;
      xmaus, ymaus, tasten  : word;
      mausflaeche           : array[1..182] of char;

  procedure eingaben;
    begin
      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);       {Maus-Ort}
        ymaus:=ymaus+258;
        nichtaus:=(xmaus>5) and (xmaus<455) and (ymaus>280) and (ymaus<471);
        if not(nichtaus) then
          begin
            if xmaus<=5 then xmaus:=6;
            if xmaus>=455 then xmaus:=454;
            if ymaus<=280 then ymaus:=281;
            if ymaus>=471 then ymaus:=470;
            set_maus(xmaus, ymaus-258);
          end;
        getimage(xmaus-5, ymaus-5, xmaus+5, ymaus+5, mausflaeche);
             {Maus zeichnen}
        setcolor(helldunkel(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);
        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));
  end;

  begin
    normalmodus:=false;
    set_maus(320, 100);
    repeat                        {Schleife f�r Ver�nderung des Abschnittes}
      eingaben;
      if zeichen>chr(0) then
        case zeichen of
            '0'..'9' : begin
                         farbe:=0;
                         val(zeichen, farbeing, code);
                         repeat
                             farbe:=farbe*10+farbeing;
                             ch:=readkey;
                             val(ch, farbeing, code);
                         until ch=chr(13);
                         farbe:=farbe mod 256;
                         setfillstyle(1, farbe);
                       end;
            chr(27)  : normalmodus:=true; {Escape-Taste}
            else       Beep(500);
          end;

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

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

  var altefarbe, farbe : byte;
      x, y, xv, yv     : punkt;
      ch               : char;
      altfuell         : fillsettingstype;
      altlinie         : linesettingstype;
      farbfeld         : array[0..49] of byte;

  begin
    altefarbe:=getcolor;                       {alte Einstellungen speichern}
    getfillsettings(altfuell);
    getlinesettings(altlinie);
    while keypressed do ch:=readkey;

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

    text_und_gitter;

    for y:=0 to 19 do                           {Bildausschnitt lesen}
      begin
        setactivepage(0);
        for x:=0 to 49 do
          farbfeld[x]:=getpixel(xv+x, yv+y);
        setactivepage(2);
        for x:=0 to 49 do
          begin
            setfillstyle(1, farbfeld[x]);
            floodfill(5+9*x+2, 280+9*y+1, 0);
          end;
      end;

    abschnittveraenderung;

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

    setvisualpage(0);                   {alte Einstellungen wiederherstellen}
    setactivepage(0);
    setcolor(altefarbe);
    with altlinie do newsetlinestyle(linestyle, pattern, thickness);
    with altfuell do newsetFillStyle(Pattern, Color);
  end;

{--- Objekte zeichnen -------------------------------------------------------}

procedure xmaxymax(var x1, y1, x2, y2: punkt);
   {Der kleinere x-Wert wird auf x1 gesetzt, genauso bei y1/y2}

  var hilfxy : punkt;

  begin
    if x1>x2 then
      begin
        hilfxy:=x1; x1:=x2; x2:=hilfxy;
      end;
    if y1>y2 then
      begin
        hilfxy:=y1; y1:=y2; y2:=hilfxy;
      end;
  end;

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

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

  begin {Zeichnen der Objekte}
    with farbmuster do                {Einstellungen setzen (Farben, Muster)}
      begin
        setcolor(vorder);
        setbkcolor(hinter);
        newsetlinestyle(linie, 0, dicke);
      end;
    x1:=objdat1.x1; y1:=objdat1.y1;
    x2:=objdat1.x2; y2:=objdat1.y2;
    xmaxymax(x1, y1, x2, y2);
    objchar:=objdat1.objchar;
    if (objchar='R') or (objchar='E') or (objchar='K')
        or (objchar='F') or (objchar='w') or (objchar='W')
      then newsetfillstyle(farbmuster.muster, farbmuster.fuell);

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

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

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

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

    if objchar='k' then                           {Kreis}
      begin
        radius1:=y2-y1;
        radius2:=x2-x1;
        radius1:=round(sqrt(radius1*radius1+radius2*radius2));
        circle(x1, y1, radius1);
      end;

    if objchar='l' then line(x1, y1, x2, y2);     {Linie}

    if objchar='L' then                           {gerade Linie}
      begin
        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='R' then bar(x1, y1, x2, y2);      {gef�lltes Rechteck}

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

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

    if objchar='W' then                               {W�rfel mit Deckel}
      begin
        radius1:=abs(x2-x1) div 2;
        bar3d(x1, y1, x2, y2, radius1, topon);
      end;

   if objchar='w' then                                {W�rfel ohne Deckel}
      begin
        radius1:=abs(x2-x1) div 2;
        bar3d(x1, y1, x2, y2, radius1, topoff);
        lineto(x2, y1);
      end;
  end;

{*** Implementationsprogramm (Init) *****************************************}


begin
  setlinmusterfeld;
  setfuellmusterfeld;
end.