program bitmapdrehen;
{$M 40000, 0, 655360}
{siehe auch Program bmpdreh.pas}
uses crt, graph;

type bfeld = array[1..18830] of byte;

var gd, gm, i : integer;
    gr : longint;
    ps : arccoordstype;
    fe : byte;
    ch : char;
    bildp, bildp2 : bfeld;

procedure fillcoords(xs, ys, xe, ye, xm, ym : integer; var arcvar: arccoordstype);
  begin         {punkte in arcvar eintragen}
    with arcvar do
      begin
        Xstart:=xs; Ystart:=ys;
        Xend:=xe; Yend:=ye;
        X:=xm; Y:=ym;
      end;
  end;

function lesen(x, y: integer; xd: byte; bildp: bfeld): byte;
   {liest Farbe vom Punkt x,y(0, 0 ist 1.Punkt in Bitmap) aus Bitmap bfeld}
  var f1, f2, f3, f4 : byte;
      stelle         : integer;
      j, k, av, fl   : byte;

  begin
    stelle:=5 + xd*4*(y) + (x div 8);
    f1:=bildp[stelle];
    f2:=bildp[stelle+xd];
    f3:=bildp[stelle+xd*2];
    f4:=bildp[stelle+xd*3];
    k:=x mod 8;
    av:=128;
    if k>=2 then
      for j:=1 to k-1 do
        av:=av div 2;
    fl:=((f1 and av) div av) * 8 + ((f2 and av) div av) * 4;
    fl:=fl + ((f3 and av) div av) * 2 + ((f4 and av) div av) * 1;
    lesen:=fl;
  end;

procedure eintragen(x, y : integer; fl, xd: byte; var bildp: bfeld);
   {schreibt Farbe vom Punkt x,y(0, 0 ist 1.Punkt in Bitmap) in bitmap bfeld}
  var f1, f2, f3, f4 : byte;
      stelle         : integer;
      j, k, av    : byte;

  begin
    stelle:=4 + xd*4*(y-1) + (x div 8);
    f1:=bildp[stelle];
    f2:=bildp[stelle+xd];
    f3:=bildp[stelle+xd*2];
    f4:=bildp[stelle+xd*3];
    if x>0 then k:=x mod 8
           else k:=1;
    av:=128;
    if k>=2 then
      for j:=1 to k-1 do
        av:=av div 2;

    if (((f1 and av) div av)=0) and ((fl and 8) div 8=1) then
      f1:=f1+((fl and 8) div 8)*av;
    if (((f1 and av) div av)=1) and ((fl and 8) div 8=0) then
      f1:=f1-((fl and 8) div 8)*av;

    if (((f2 and av) div av)=0) and ((fl and 4) div 4=1) then
      f2:=f2+((fl and 4) div 4)*av;
    if (((f2 and av) div av)=1) and ((fl and 4) div 4=0) then
      f2:=f2-((fl and 4) div 4)*av;

    if (((f3 and av) div av)=0) and ((fl and 2) div 2=1) then
      f3:=f3+((fl and 2) div 2)*av;
    if (((f3 and av) div av)=1) and ((fl and 2) div 2=0) then
      f3:=f3-((fl and 2) div 2)*av;

    if (((f4 and av) div av)=0) and ((fl and 1) div 1=1) then
      f4:=f4+((fl and 1) div 1)*av;
    if (((f4 and av) div av)=1) and ((fl and 1) div 1=0) then
      f4:=f4-((fl and 1) div 1)*av;

    bildp[stelle]:=f1;
    bildp[stelle+xd]:=f2;
    bildp[stelle+xd*2]:=f3;
    bildp[stelle+xd*3]:=f4;
  end;

procedure bmpdrehen(punkte : arccoordstype; winkel:integer; var fehler:byte;
                    var bildgroesse:longint; var bildp, bildp2: bfeld);

{Punkte: Xstart, Ystart: linke obere Koordinate;
         Xend,   Yend  : rechte untere Koordinate;
         X, Y          : Drehmittelpunkt;
 winkel: Drehwinkel in Grad;
 Fehler 1: Bildfl�che zu gro�;
 Fehler 2: Bildrand �berschritten (kein Abbruch)}
{dreht bildausschnitt um winkel: liest Punkt f�r Punkt und berechnet neuen Ort->schreiben}
  var xl, yl, i : longint;
      fl : byte;
      xd, x, y, xs, ys, xe, ye, xm, ym, xi, yi : integer;
      winkd, winkr, radr : real;
      bool : boolean;

  begin
    fehler:=0;
    xl:=abs(punkte.Xend-punkte.Xstart);
    yl:=abs(punkte.Yend-punkte.Ystart);
    if xl*yl>115200 then fehler:=1;
    if fehler=1 then exit;
    with punkte do
      begin
        bildgroesse:=imagesize(Xstart, Ystart, Xend, Yend);
        {getmem(bildp, bildgroesse);}
        getimage(Xstart, Ystart, Xend, Yend, bildp);
        xd:=((Xend-Xstart) div 8) + 1;
        xs:=Xstart; xe:=Xend;
        ys:=Ystart; ye:=Yend;
        xm:=x;      ym:=y;
      end;
    {freemem(bildp, bildgroesse);}
    for i:=1 to bildgroesse do bildp2[i]:=bildp[i];
    for i:=5 to bildgroesse do bildp2[i]:=0;
    winkd:=winkel*Pi/180;
    for yi:=Ys to Ye do
      for xi:=Xs to Xe do
        begin
          fl:=lesen(xi-xs+1, yi-ys+1, xd, bildp);
          {fl:=getpixel(xi, yi);}
          radr:=sqrt((yi-ym)*(yi-ym)+(xi-xm)*(xi-xm));
          if (xm-xi)<>0 then winkr:=winkd+arctan((yi-ym)/(xm-xi))
                        else winkr:=winkd;
          if xm>xi then winkr:=winkr+Pi;
          x:=round(xm+cos(winkr)*radr);
          y:=round(ym-sin(winkr)*radr);
          bool:=(x>=Xs) and (x<=Xe) and (y>=Ys) and (y<=Ye);
          if bool=true then eintragen(x-xs, y-ys, fl, xd, bildp2)
                       else eintragen(x-xs, y-ys, 0, xd, bildp2);
          {putpixel(x+100, y+100, fl);}
        end;
    cleardevice;
    putimage(xs, ys, bildp2, 0);
  end;

function imgs(x1, y1, x2, y2: integer):longint;
 {errechnet Bildgr��e=imagesize von Unit Graph}
  begin
    imgs:=(y2-y1+1)*(((x2-x1) div 8) + 1)*4 +6;
  end;

procedure bmpfarben(bildp: bfeld);
 {errechnet Farben der Punkte aus bildp, �hnlich Funktion lesen}
  var xl, yl, x, y : integer;
      feld1 : bfeld;
      feld2 : array[1..3200] of byte;
      av, i : byte;

  begin
    xl:=(bildp[2]*256+bildp[1]) div 8;
    yl:=bildp[4]*256+bildp[3];
    for y:=0 to yl do
      for x:=0 to xl do
        for i:=1 to 4 do
          feld1[x*4+i]:=bildp[(i-1)*(xl+1)+x+1+4];
    for x:=0 to xl do
      begin
        av:=128;
        for i:=1 to 8 do
          begin
            feld2[x*8+i]:=((feld1[x*4+1] and av) div av)*8;
            feld2[x*8+i]:=feld2[x*8+i] + ((feld1[x*4+2] and av) div av)*4;
            feld2[x*8+i]:=feld2[x*8+i] + ((feld1[x*4+3] and av)div av)*2;
            feld2[x*8+i]:=feld2[x*8+i] + ((feld1[x*4+4] and av)div av)*1;
            av:=av div 2;
          end;
      end;
    writeln(xl);
    for x:=1 to (xl+1)*8 do write(feld2[x], ' ');
  end;

begin
  gd:=9; gm:=2;
  initgraph(gd, gm, 'd:\tp\bgi');
  cleardevice;
  settextstyle(1, 0, 1);
  {for i:=1 to 180 do
    begin
      setcolor(i);
      line(0, 100+i-1, 200, 100+i-1);
    end;}
  outtextxy(50, 100, 'Stefan');
  repeat until keypressed;
  fillcoords(50, 100, 250, 160, 150, 110, ps);
  bmpdrehen(ps, 20, fe, gr, bildp, bildp2);
  outtextxy(50, 50, 'Stefan');
  repeat ch:=readkey; until not(keypressed);
  repeat until keypressed;
  closegraph;
  writeln(ps.Xstart, ' ', ps.Ystart, ' ', ps.Xend, ' ', ps.Yend, ' ', ps.x, ' ', ps.y);
  writeln(fe, ' ', gr);
  writeln(maxavail);
  writeln(imgs(0, 100, 200, 280));
  {for i:=1 to gr do
    begin
      textcolor(11);
      write(bildp[i]:3, ' ');
      textcolor(2);
      write(bildp2[i]:3, ' ');
      if i mod 160=0 then readln;
    end;}
  writeln;
  textcolor(7);
  {bmpfarben(bildp);}
end.