program weihnachten_1998_vorbereitung;
uses dos, crt, graph, zoominbi;
{Programm vollst„ndig funktionsf„hig mit allen Dateien im Verzeichnis
kleine Weihnachtsanimation, etwas versp„tet, ohne Ton
{Beachte Verzeichnisangabem in den Zeilen 7, 45, 51, 97, 242, 351, 376}
{$M 42000,0,655360}
{$i d:\tp\tppas1\bgi\svga256.inc}

type grossbmp = array[1..19806] of byte;
     bmp256typ = array[1..486] of byte;
     array50 = array [1..50] of byte;
     RGBColor   = record
                      R, G, B : byte;
                    end;
     VGAPalette = array[0..255] of RGBColor;

var driver, mode, x, y : integer;
    sp : boolean;
    f : text;
    pal : vgapalette;
    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;
    ch : char;

  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;

procedure verkleinern2(modus: byte);

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

  begin
    dateiname:='d:\tp\arbeit\weihnach\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 ReadDACBlock(Start, Count : integer; var Pal : VGAPalette);
var
  Regs : Registers;
begin
  with Regs do
  begin
    AH := $10;
    AL := $17;
    BX := Start;
    CX := Count;
    ES := Seg(Pal);
    DX := Ofs(Pal);
  end;
  Intr($10, Regs);
end;

procedure SetDACBlock(Start, Count : integer; var Pal : VGAPalette);
var
  Regs : Registers;
begin
  with Regs do
  begin
    AH := $10;
    AL := $12;
    BX := Start;
    CX := Count;
    ES := Seg(Pal);
    DX := Ofs(Pal);
  end;
  Intr($10, Regs);
end;

procedure writeinpal(color, r, g, b: byte; var pal: vgapalette);
  begin
    pal[color].r:=r;
    pal[color].g:=g;
    pal[color].b:=b;
  end;

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

  var x, x2, y, ym, ydm, xdm, xort, versetzt, sp, xz: integer;
      color : 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 (endx div xdiv) do
      begin
        xort:=x2*xdiv;
        for y:=0 to ydm-2 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, bgc);
              if ((f20(xz)=13) and (f20(y+yort)=7)) or ((f20(xz)=3) and (f20(y+yort)=3))
                then putpixel(xz, y+yort, 28);
            end;
        if x2 mod 20 = 10 then writeinpal(28, 42, 42, 42, pal);
        setdacblock(0, 256, pal);
        delay(20);
        if (x2<>(endx div xdiv)) then
          for y:=yort to yort+ydm-2 do
            for x:=xort+xdm-xdiv to xort+xdm do
              begin
                xz:=abs(sp-x)-xdm;
                putpixel(xz, y, bgc);
                if ((f20(xz)=13) and (f20(y)=7)) or ((f20(xz)=3) and (f20(y)=3))
                  then putpixel(xz, y, 28);
              end;
        if x2 mod 20 = 0 then writeinpal(28, 63, 63, 63, pal);
        setdacblock(0, 256, pal);
      end;
  end;

procedure bildoeffnen;

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

  begin
    dateiname:='i98weih.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 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 schriftdrehen(modus: byte);

  var x : integer;

  begin
    for x:=1 to 45 do
      begin
        setcolor(15);
        textausgabe(320, 240, (x-1)*8, 3, modus, 'Weihnachten');
        setcolor(4);
        textausgabe(320, 240, x*8, 3, modus, 'Weihnachten');
        delay(30);
      end;
  end;

begin
  initgraf;
  initfont;
  driver:=Detect;
  initgraph(driver, mode, 'd:\tp\tppas1\bgi');
  setcolor(4);
  schriftdrehen(0);                        {drehende Schrift}
  delay(1000);
  schriftdrehen(2);
  delay(500);
  schriftdrehen(4);
  delay(2000);
  cleardevice;
  bildoeffnen;
  readdacblock(0, 256, pal);
  for y:=0 to 479 do                            {glitzern}
    for x:=0 to 639 do
      if ((x mod 20 = 13) and (y mod 20 = 7)) or ((x mod 20 = 3) and (y mod 20 = 3))
        then putpixel(x, y, 28);
  sp:=false;                                    {schlitten bewegen}
  for y:=5 downto 2 do
    begin
      verkleinern2(y*2);
      verkleinertlesen(10-y*2+5, 50, y*2, sp, 0, 0);
      sp:=not(sp);
    end;
  verkleinern2(2);
  verkleinertlesen(30, 30, 2, sp, 0, 430);
  delay(2000);
  assign(f, 'ralin98w.bmp');
  reset(f);
  zoombildschreiben(f);
  close(f);
  readln;
  closegraph;
end.