program weihnachten_1998_vorbereitung;
uses dos, crt, graph, zoominbi;
{$M 42000,0,655360}
{$i d:\tp\tppas1\bgi\svga256.inc}

type bmptyp = array[1..246] of byte;
     grossbmp = array[1..19806] of byte;
     array62 = array[1..54] of byte;
     bmp256typ = array[1..486] of byte;
     array50 = array [1..50] of byte;

var driver, mode, x, y : integer;
    color              : byte;
    bitbmp             : bmptyp;
    loeschen, sp       : boolean;
    ch                 : char;
    yz                 : longint;
    f                  : text;
    buchstaben : array [1..255] of record
                                     line: array[1..50] of byte;
                                     len : byte;
                                    end;

{$F+}
function DetectVGA256 : Integer;

begin
  DetectVGA256 := 2;
end;
{$F-}

procedure initfont;

var fontf : file;
    f     : text;
    fontp : pointer;
    i, j, len, ende : byte;
    st : string;
    durch, durch2: word;

  begin
    assign(fontf, 'd:\tp\bgi\litt.chr');
    reset(fontf, 1);
    getmem(fontp, filesize(fontf));
    blockread(fontf, fontp^, filesize(fontf));
    if registerbgifont(fontp)<0 then writeln('Fehler');
    close(fontf);
    assign(f, 'd:\tp\bgi\litt.chr');
    reset(f);
    durch:=0;
    for j:=1 to 255 do
      for i:=1 to 50 do buchstaben[j].line[i]:=0;
    repeat
      for i:=1 to 255 do st[i]:=' ';
      i:=0;
      ende:=0;
      repeat
        i:=i+1;
        read(f, ch);
        st[i]:=ch;
        if ch=chr(0) then ende:=ende+1
                     else ende:=0;
      until ende=3;
      len:=i;
      durch2:=durch+21;
      if durch2>32 then buchstaben[durch2].len:=len;
      if (len< 51) and (durch2>32) then
      for i:=1 to len do buchstaben[durch2].line[i]:=ord(st[i]);
      if keypressed then ch:=readkey;
      durch:=durch+1;
    until (ord(ch)=27) or (eof(f));
    close(f);
  end;

procedure initgraf;

 var testdriver : integer;

 begin
   testdriver:= Installuserdriver('SVGA256', @DetectVGA256);
 end;

function lesen(x, y: integer; xd: byte; bildp: bmptyp): 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 bildladen;

  var x, y, x2, y2    : byte;
      farbe      : byte;
      dateiname  : string;
      bitmapfeld : bmptyp;
      datei      : text;
      i : integer;
      ch : char;

  begin
    dateiname:='d:\tp\arbeit\weiback.bmp';
    assign(datei, dateiname);
    reset(datei);
    for y:=0 to 23 do
      for x:=0 to 31 do
        begin
          for i:=1 to 246 do
            begin
              read(datei, ch);
              bitmapfeld[i]:=ord(ch);
            end;
          for y2:=0 to 19 do
            for x2:=0 to 19 do
              putpixel(x*20+x2, y*20+y2, lesen(x2, y2, 3, bitmapfeld) mod 16);
          {repeat until keypressed;
          while keypressed do ch:=readkey;}
        end;
    close(datei);
  end;

procedure schlittenladen;

  var x, y, x2, y2    : byte;
      farbe      : byte;
      dateiname  : string;
      bitmapfeld : grossbmp;
      datei      : text;
      i : word;
      ch : char;

  begin
    dateiname:='d:\tp\arbeit\schlitten.bmp';
    assign(datei, dateiname);
    reset(datei);
    for y:=0 to 3 do
      begin
        for i:=1 to 19806 do
          begin
            read(datei, ch);
            bitmapfeld[i]:=ord(ch);
          end;
        putimage(0, y*45, bitmapfeld, 0);
        {repeat until keypressed;
        while keypressed do ch:=readkey;}
      end;
    close(datei);
  end;

procedure bildspeichern;
  {Bild wird gespeichert in 2 Feldern zu 440*90 Pixeln als Bitmap}

  var x, y       : byte;
      dateiname  : string;
      bitmapfeld : grossbmp;
      datei      : text;
      i          : word;

  begin
    dateiname:='d:\tp\arbeit\schlitten.bmp';
    assign(datei, dateiname);
    rewrite(datei);
    setactivepage(2);
    for y:=0 to 3 do
       begin
         getimage(0, 290+y*45, 439, 290+y*45+44, bitmapfeld);
         for i:=1 to 19806 do write(datei, chr(bitmapfeld[i]));
       end;
    close(datei);
    setactivepage(0);
  end;

procedure altesbildschlitten;
  begin
    setactivepage(2);
    for y:=0 to 479 do
      for x:=0 to 639 do
        putpixel(x, y, 0);
    setactivepage(0);
    bildladen;
    setcolor(15);
    rectangle(160, 290, 600, 470);
    for y:=0 to 479 do
     for x:=0 to 639 do
      begin
        if (x>=160) and (x<=600) and (y>=290) and (y<=470)
         then
          begin
            color:=getpixel(x, y);
            loeschen:=(color=2) or (color=3) or (color=15) or (color=12) or (color=13);
            if loeschen then putpixel(x, y, 0);
            if color=0 then putpixel(x, y, 8);
            color:=getpixel(x, y);
            if not(loeschen) then
              begin
                setactivepage(2);
                putpixel(x-160, y, color);
                setactivepage(0);
              end;
          end
         else putpixel(x, y, 0);
      end;
    cleardevice;
    bildspeichern;
  end;

procedure verkleinern2(modus: byte);

  var x, y, xdm, ydm, ym, farbe : integer;
      bitmapfeld : grossbmp;
      yg : byte;
      dateiname : string;
      datei : text;
      i : integer;

  begin
    dateiname:='d:\tp\arbeit\schlitt2.bmp';
    assign(datei, dateiname);
    reset(datei);
    setactivepage(2);
    setfillstyle(1, 0);
    bar(0, 276, 639, 479);
    if modus>1 then
     for yg:=0 to 3 do
      begin
        for i:=1 to 19806 do
          begin
            read(datei, ch);
            bitmapfeld[i]:=ord(ch);
          end;
        putimage(0, 280, bitmapfeld, 0);
        xdm:=448 div modus;
        ydm:=45 div modus;
        for y:=0 to ydm do
          begin
            ym:=y*modus+280;
            for x:=0 to xdm do
              begin
                farbe:=getpixel(x*modus, ym);
                putpixel(x, yg*(45 div modus)+y+330, farbe);
              end{of for x};
          end;{of for y}
      end;{of yg}
    if modus=1 then
      begin
        for y:=0 to 3 do
          begin
            for i:=1 to 19806 do
              begin
                read(datei, ch);
                bitmapfeld[i]:=ord(ch);
              end;
            putimage(0, y*45+280, bitmapfeld, 0);
          end;
      end;
    close(datei);
    setactivepage(0);
  end{of procedure};

function f20(x : integer): integer;
  begin
    f20:=x mod 20;
  end;

procedure verkleinertlesen(xdiv, yort:integer; modus: byte; spiegeln: boolean);

  var x, x2, y, ym, ydm, xdm, xort, versetzt, sp, xz: integer;
      farbe : byte;
      bild, bildback : grossbmp;

  begin
    setactivepage(2);
    versetzt:=330;
    xdm:=448 div modus;
    if spiegeln=true then sp:=640+2*xdm else sp:=0;
    ydm:=184 div modus;
    if modus=2 then
      begin
        dec(xdm, 6);
        dec(ydm, 5);
      end;
    getimage(0, versetzt, xdm, versetzt+ydm, bild);
    setactivepage(0);
    for x2:=(640+xdm-5) div xdiv downto 0 do
      begin
        xort:=x2*xdiv;
        {getimage(xort, yort, xort+xdm, yort+ydm, bildback);}
        for y:=0 to ydm do
          for x:=0 to xdm do
            begin
              xz:=abs(sp-(x+xort))-xdm;
              color:=bild[y*(xdm+1)+x+6];
              if color<>0 then putpixel(xz, y+yort, color)
                          else putpixel(xz, y+yort, 0);
              if ((f20(xz)=13) and (f20(y+yort)=7)) or ((f20(xz)=3) and (f20(y+yort)=3))
                then putpixel(xz, y+yort, 27);
            end;
        delay(20);
        for y:=yort to yort+ydm do
          for x:=xort+xdm-xdiv to xort+xdm do
            begin
              xz:=abs(sp-x)-xdm;
              putpixel(xz, y, 0);
              if ((f20(xz)=13) and (f20(y)=7)) or ((f20(xz)=3) and (f20(y)=3))
                then putpixel(xz, y, 27);
            end;
        {putimage(xort, yort, bildback, 0);}
      end;
  end;

procedure bildzeichnen;

  var x, y, yadd: integer;

  begin
    yadd:=30;                         {unterste Kante: y:=330, x:=430}
    setfillstyle(1, 15);
    bar(0, 140, 639, 479);    {Baeume/Boden}
    setfillstyle(1, 43); setcolor(43);
    bar3d(250, 200+yadd, 390, 300+yadd, 40, false); {Haus}
    line(250, 200+yadd, 320, 150+yadd);  {oberes Dreieck}
    line(320, 150+yadd, 390, 200+yadd);
    line(320, 150+yadd, 370, 120+yadd);  {Dach}
    line(370, 120+yadd, 430, 170+yadd);
    floodfill(320, 180+yadd, 43);
    setcolor(0); setfillstyle(1, 0); {Fenster}
    setfillstyle(1, 103);
    bar(270, 240+yadd, 290, 270+yadd);
    bar(350, 240+yadd, 370, 270+yadd);
    bar(310, 170+yadd, 330, 200+yadd);
    setcolor(115);
    for y:=0 to 3 do
      begin
        rectangle(270+y, 240+y+yadd, 290-y, 270-y+yadd);
        rectangle(350+y, 240+y+yadd, 370-y, 270-y+yadd);
        rectangle(310+y, 170+y+yadd, 330-y, 200-y+yadd);
      end;
    setfillstyle(1, 115);        {Tuer}
    bar(305, 230+yadd, 335, 300+yadd);
    setcolor(0);                   {Balken}
    for y:=1 to 14 do
      for x:=250 to 390 do
        if (getpixel(x+1, y*10+150+yadd)=43)
          then putpixel(x, y*10+150+yadd, 0);
    setcolor(43); setfillstyle(1, 43); {Dach fuellen}
    floodfill(395, 295+yadd, 43);
    setcolor(0);
    line(260, 193+yadd, 260, 300+yadd); line(380, 193+yadd, 380, 300+yadd);
    line(255, 197+yadd, 255, 300+yadd); line(385, 197+yadd, 385, 300+yadd);
    setcolor(12);               {Balken an der Seite}
    for y:=0 to 10 do
      line(390, y*10+200+yadd, 430, y*10+170+yadd);
    for y:=170+yadd to 300+yadd do
      for x:=390 to 430 do
        if (getpixel(x, y)=12)
          then putpixel(x, y, 0);
    setcolor(0); rectangle(250, 200+yadd, 390, 300+yadd);        {Kanten Haus}
    line(320, 150+yadd, 390, 200+yadd); line(250, 200+yadd, 320, 150+yadd);
    line(320, 150+yadd, 370, 120+yadd); line(370, 120+yadd, 430, 170+yadd);
    line(430, 170+yadd, 430, 270+yadd);
    line(338, 153+yadd, 372, 133+yadd); line(372, 133+yadd, 410, 165+yadd); {Dach Rand schwarz}
    line(410, 165+yadd, 380, 185+yadd); line(380, 185+yadd, 338, 153+yadd);
    setfillstyle(1, 0);   {Dach schwarz}
    floodfill(345, 155+yadd, 0);
    setfillstyle(1, 43); {Esse}
    setcolor(43);
    line(338, 160+yadd, 338, 115+yadd); line(338, 115+yadd, 360, 115+yadd);
    line(360, 115+yadd, 360, 170+yadd); line(360, 170+yadd, 338, 160+yadd);
    floodfill(345, 155+yadd, 43); floodfill(340, 118+yadd, 43);
    setcolor(0);
    line(338, 155+yadd, 338, 115+yadd); line(338, 115+yadd, 360, 115+yadd);
    line(360, 115+yadd, 360, 170+yadd); line(360, 170+yadd, 338, 155+yadd);
    for x:=0 to 24 do      {Staemme}
      begin
        if x mod 4 = 2 then setfillstyle(1, 235) else setfillstyle(1, 0);
        bar(x*10, 280, x*10+9, 320);
      end;
    for x:=0 to 20 do
      begin
        if x mod 4 = 2 then setfillstyle(1, 235) else setfillstyle(1, 0);
        bar(x*10+430, 280, x*10+9+430, 320);
      end;
    for y:=280 to 320 do
      for x:=390 to 430 do if getpixel(x, y)=15 then putpixel(x, y, 0);
  end;

procedure bildschreiben;

  var x, y, i: integer;
      datei : file of bmp256typ;
      dateiname: string;
      bitmapfeld : bmp256typ;

  begin
    dateiname:='ra98weih.bmp';
    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);
          write(datei, bitmapfeld);
        end;
    close(datei);
  end;

procedure bildoeffnen;

  var x, y, i: integer;
      datei : file of bmp256typ;
      dateiname: string;
      bitmapfeld : bmp256typ;

  begin
    dateiname:='ra98weih.bmp';
    assign(datei, dateiname);
    reset(datei);
    for y:=0 to 23 do
      for x:=0 to 31 do
        begin
          read(datei, bitmapfeld);
          putimage(x*20, y*20, bitmapfeld, 0);
        end;
    close(datei);
  end;

procedure baumspitzen;

  var x, y : integer;

  begin
    randomize;
    for x:=1 to 19 do
      if (x<>2) and (x<>3) and (x<>6) and (x<>10) and (x<>13) and (x<>16) and (x<>18)
      then begin
          setcolor(15);
          line(x*32-10, 140, x*32+15-10, 130); line(x*32+15-10, 130, x*32+31-10, 140);
          line(x*32-10, 140, x*32+31-10, 140); setfillstyle(1, 15);
          floodfill(x*32, 137, 15);
        end;
    for y:=0 to 3 do
      for x:=0 to 639 do
        if random(3)=0 then putpixel(x, 130+y, 0);
    for y:=0 to 8 do
      for x:=0 to 639 do
        if random(12)=0 then putpixel(x, 134+y, 0);
  end;

procedure paintchar(sterst: array50; len, fak, a: byte; winkel: integer);

  var i, j, act : byte;
      xr, yr, xz, yz, xv1, yv1, xv2, yv2 : integer;
      winkelreal, sinus, cosin, sin45, cos45, x, y, z : real;

  begin
    xz:=getx; yz:=gety;
    winkel:=winkel mod 360;
    if winkel<0 then winkel:=360+winkel;
    winkelreal:=winkel* Pi / 180;
    sinus:=sin(winkelreal); cosin:=cos(winkelreal);
    sin45:=sin(45*Pi/180);
    cos45:=cos(45*Pi/180);
    for i:=1 to (len-2) div 2 do
      begin
        j:=(i-1)*2;
        x:=sterst[j+1] and 127;
        y:=sterst[j+2] and 127;
        if x>=64 then x:=x-128;
        if y>=64 then y:=y-128;
        x:=x*fak;
        y:=y*fak;
        if (a=0) then
          begin
            xr:=round(x*cosin-y*sinus);
            yr:=round(y*cosin+x*sinus);
          end;
        if (a=1) or (a=3) then
          begin
            xr:=round(x);      {Rotationsachse waagerecht}
            x:=round(x*cosin-y*sinus);
            yr:=round(y*cosin+x*sinus);
          end;
        if (a=2) or (a=3) then
          begin
            yr:=round(y);      {Rotationsachse senkrecht}
            y:=round(y*cosin+x*sinus);
            xr:=round(x*cosin-y*sinus);
          end;
        if (a=4) then
          begin
            z:=(sinus)*y;
            y:=(cosin)*y;
            yr:=round(y-(z*sin45));
            xr:=round(x+(z*cos45));
          end;
        if (a=5) then
          begin
            z:=(-sinus)*x;
            x:=(cosin)*x;
            xr:=round(x+(z*cos45));
            yr:=round(y-(z*sin45));
          end;
        if sterst[j+1]>=128 then act:=2
                            else act:=0;
        if sterst[j+2]>=128 then act:=act+1;
        if act=2 then moveto(xz+xr, yz-yr);
        if act=3 then lineto(xz+xr, yz-yr);
      end{ of for};
  end;{ of procedure}

procedure textausgabe(x, y, winkel: integer; faktor, act: byte; text: string);

  var i, j, len, zeichen : byte;
      sterst : array50;

  begin
    moveto(x, y);
    for i:=1 to length(text) do
      begin
        zeichen:=ord(text[i]);
        for j:=1 to 50 do sterst[j]:=buchstaben[zeichen].line[j];
        len:=buchstaben[zeichen].len;
        paintchar(sterst, len, faktor, act, winkel);
      end;
  end;

procedure kugeln(x, y: integer; farbe: byte);
  begin
    setfillstyle(1, farbe); setcolor(farbe);
    circle(x, y, 8); floodfill(x, y, farbe);
    setfillstyle(1, farbe+72); setcolor(farbe+72);
    circle(x+3, y+4, 3); floodfill(x+3, y+4, farbe+72);
  end;

procedure geschenke(x, y: integer; farbe: byte);
  begin
    setfillstyle(1, farbe); setcolor(0);
    bar(x-40, y-20, x+40, y+20); rectangle(x-40, y-20, x+40, y+20);
    setfillstyle(1, 4); setcolor(0);
    bar(x-40, y-5, x+40, y+5); rectangle(x-40, y-5, x+40, y+5);
    bar(x-5, y-20, x+5, y+20); rectangle(x-5, y-20, x+5, y+20);
  end;

begin
  initgraf;
  initfont;
  driver:=Detect;
  initgraph(driver, mode, 'd:\tp\tppas1\bgi');
  setcolor(4);
  bildoeffnen;
  {assign(f, 'ralin98w.bmp');
  reset(f);
  zoombildschreiben(f);
  close(f);}
  setcolor(0);
  line(175, 0, 175, 300);
  line(465, 0, 465, 115);
  setcolor(15);
  line(470, 160, 473, 158);
  setcolor(113);
  line(250, 200, 310, 120);
  line(390, 200, 330, 120);
  setfillstyle(1, 113);
  floodfill(380, 190, 113); floodfill(260, 190, 113);
  setfillstyle(1, 115);
  bar(190, 130, 240, 220);
  bar(400, 130, 450, 220);
  setfillstyle(1, 103);
  bar(196, 136, 234, 214);
  bar(406, 136, 444, 214);
  setfillstyle(1, 6);
  bar(95, 350, 115, 380);
  setcolor(183);
  setfillstyle(1, 183);
  line(70, 400, 95, 380);
  line(95, 380, 115, 380);
  line(115, 380, 140, 400);
  line(140, 400, 70, 400);
  floodfill(105, 390, 183);
  readln;
  assign(f, 'ralin98w.bmp');
  rewrite(f);
  zoombildlesen(f);
  close(f);
  closegraph;
  writeln(yz);
end.