program weihnach99;
uses crt, dos, graph;
{$M 42000,0,655360}

type azaehl= (lg, lh, lv, la, ls,
              c0, ck0, d0, dk0, e0, f0, fk0, g0, gk0, a0, ak0, b0,
              c1, ck1, d1, dk1, e1, f1, fk1, g1, gk1, a1, ak1, b1,
              c2, ck2, d2, dk2, e2, f2, fk2, g2, gk2, a2, ak2, b2,
              aus);
              {Ganze, halbe, viertel, achtel, sechzentel, tiefes A bis hohes B
               Ton aus}
     string20 = string[20];
     array50 = array [1..50] of byte;
     bmp256typ = array[1..486] of byte;

const laenge1 = 34;
      laenge2 = 71;
      notenfeld : array[azaehl, 1..2] of byte =
                ((16, 250), ( 8, 250), (  4, 250), (  2, 250), (  1, 250),
                ($AE, $2A), ($6B, $2D), ($81, $2D), ($98, $2D), ($B0, $2D),
                { c0         ck0         d0          dk0         e0}
                ($CA, $2D), ($E5, $2D), ($02, $2E), ($20, $2E),
                { f0         fk0         g0          gk0         a0}
                ($41, $2E), ($63, $2E), ($87, $2E),
                { a0         ak0         b0}
                ($AE, $2E), ($6B, $31), ($81, $31), ($98, $31), ($B0, $31),
                { c1         ck1         d1          dk1         e1}
                ($CA, $31), ($E5, $31), ($02, $32), ($20, $32),
                { f1         fk1         g1          gk1  }
                ($41, $32), ($63, $32), ($87, $32),
                { a1         ak1         b1}
                ($AE, $32), ($6B, $35), ($81, $35), ($98, $35), ($B0, $35),
                { c2         ck2         d2          dk2         e2}
                ($CA, $35), ($E5, $35), ($02, $36), ($20, $36),
                { f2         fk2         g2          gk2         a2}
                ($41, $36), ($63, $36), ($87, $36), ($00, $00));
                { a2         ak2         b2          aus      }
                {1..5: L„nge: 1.*2. Inhalt, 6..32: H”he T”ne, 33: Ton aus}

      lied2 : array[0..laenge2-1, 1..3] of azaehl =
                ((g1, g1, la), (g1, g1, la), (c2, e1, lv), (b1, g1, lv),{>}
                (a1, f1, lv), (g1, e1, lv), (c2, e1, lv), (e1, e1, lv),
                (g1, g1, lv), (d2, g1, lv), (b1, f1, lv), (c2, e1, lh),{:||}
                (g1, g1, la), (g1, g1, la), (c2, e1, lv), (b1, g1, lv),{2}
                (a1, f1, lv), (g1, e1, lv), (c2, e1, lv), (e1, e1, lv),
                (g1, g1, lv), (d2, g1, lv), (b1, f1, lv), (c2, e1, lh),{||:}
                (d2, g1, lv), (e2, c2, lv), (c2, c2, lv), (e2, c2, lv),{>}
                (d2, g1, lv), (g1, g1, lv), (d2, g1, lv), (e2, c2, lv),
                (c2, e1, lv), (a1, f1, lv), (g1, g1, lh), (g1, g1, lv),{||}
                (c2, e1, lv), (b1, g1, lv), (a1, f1, lv), (g1, e1, lv),
                (c2, e1, lv), (e1, e1, la), (e1, e1, la), (g1, g1, lv),
                (d2, g1, lv), (b1, f1, lv), (c2, e1, lh),              {:||}
                (d2, g1, lv), (e2, c2, lv), (c2, c2, lv), (e2, c2, lv),                {2}
                (d2, g1, lv), (g1, g1, lv), (d2, g1, lv), (e2, c2, lv),
                (c2, e1, lv), (a1, f1, lv), (g1, g1, lh), (g1, g1, lv), {||}
                (c2, e1, lv), (b1, g1, lv), (a1, f1, lv), (g1, e1, lv),
                (c2, e1, lv), (e1, e1, la), (e1, e1, la), (g1, g1, lv),
                (d2, g1, lv), (b1, f1, lv), (c2, e1, lh), (aus, aus, lh));{:||>}
                {Lied: "Guten Abend, sch”n Abend"(zweistimmig)}
         lied2wort : array[0..3*laenge2-1] of string20 =
                 ('Gu-ten', 'Gu-ten', 'A-bend,', 'A-bend,', 'sch”n',
                  'A-bend,', 'A-bend,', 'es', 'weih-nach-tet',
                  'weih-nach-tet', 'weih-nach-tet', 'schon.', 'Gu-ten',
                  'Gu-ten', 'A-bend,', 'A-bend,', 'sch”n', 'A-bend,',
                  'A-bend,', 'es', 'weih-nach-tet', 'weih-nach-tet',
                  'weih-nach-tet', 'schon.',
                  'Am', 'Kran-ze', 'Kran-ze', 'die', 'Lich-ter,', 'Lich-ter,',
                  'die', 'leuch-ten', 'leuch-ten', 'so', 'fein,', 'sie',
                  'ge-ben', 'ge-ben', 'der', 'Hei-mat', 'Hei-mat', 'ei-nen',
                  'ei-nen', 'hell-lich-ten', 'hell-lich-ten', 'hell-lich-ten',
                  'Schein.', 'Am', 'Kran-ze', 'Kran-ze', 'die', 'Lich-ter,',
                  'Lich-ter,', 'die', 'leuch-ten', 'leuch-ten', 'so', 'fein,',
                  'sie', 'ge-ben', 'ge-ben', 'der', 'Hei-mat', 'Hei-mat',
                  'ei-nen', 'ei-nen', 'hell-lich-ten', 'hell-lich-ten',
                  'hell-lich-ten', 'Schein.', '',
                  'Gu-ten', 'Gu-ten', 'A-bend,', 'A-bend,', 'sch”n', 'A-bend,',
                  'A-bend,', 'es', 'weih-nach-tet', 'weih-nach-tet',
                  'weih-nach-tet', 'schon.', 'Gu-ten', 'Gu-ten', 'A-bend,',
                  'A-bend,', 'sch”n', 'A-bend,', 'A-bend,', 'es',
                  'weih-nach-tet', 'weih-nach-tet', 'weih-nach-tet',
                  'schon.',
                  'Der', 'Schnee', 'f„llt', 'in', 'Flok-ken', 'Flok-ken',
                  'und', 'weiá', 'steht', 'der', 'Wald.', 'Nun', 'freut',
                  'euch,', 'ihr', 'Kin-der,', 'Kin-der,', 'd-ie', 'd-ie',
                  'Weih-nacht', 'Weih-nacht', 'kommt', 'bald.', 'Der',
                  'Schnee', 'f„llt', 'in', 'Flok-ken', 'Flok-ken', 'und',
                  'weiá', 'steht', 'der', 'Wald.', 'Nun', 'freut', 'euch,',
                  'ihr', 'Kin-der,', 'Kin-der,', 'die-ie', 'die-ie', 'Weih-nacht',
                  'Weih-nacht', 'kommt', 'bald.', '',
                  'Gu-ten', 'Gu-ten', 'A-bend,', 'A-bend,', 'sch”n', 'A-bend,',
                  'A-bend,', 'es', 'weih-nach-tet', 'weih-nach-tet',
                  'weih-nach-tet', 'schon.', 'Gu-ten', 'Gu-ten', 'A-bend,',
                  'A-bend,', 'sch”n', 'A-bend,', 'A-bend,', 'es',
                  'weih-nach-tet', 'weih-nach-tet', 'weih-nach-tet',
                  'schon.',
                  'Nun', 'singt', 'es', 'und', 'klingt', 'es', 'so',
                  'lieb-lich', 'lieb-lich', 'und', 'fein.', 'Wir', 'si-ngen',
                  'si-ngen', 'die', 'fr”h-li-che-he', 'fr”h-li-che-he',
                  'fr”h-li-che-he', 'fr”h-li-che-he', 'Weih-nachts-zeit',
                  'Weih-nachts-zeit', 'Weih-nachts-zeit', 'ein.', 'Nun',
                  'singt', 'es', 'und', 'klingt', 'es', 'so', 'lieb-lich',
                  'lieb-lich', 'und', 'fein.', 'Wir', 'si-ngen', 'si-ngen',
                  'die', 'fr”h-li-che-he', 'fr”h-li-che-he', 'fr”h-li-che-he',
                  'fr”h-li-che', 'Weih-nachts-zeit', 'Weih-nachts-zeit',
                  'Weih-nachts-zeit', 'ein.', '');

var i, driver, mode : integer;
    buchstaben : array [1..255] of record
                                     line: array[1..50] of byte;
                                     len : byte;
                                    end;

procedure ausgabe(regi, wert : integer);
  begin
    port[$0228]:=regi;
    delay(5);
    port[$0229]:=wert;
    delay(5);
  end;

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

  var i, j, act : byte;
      xr, yr, xz, yz, xv1, yv1, xv2, yv2 : integer;
      x, y: integer;

  begin
    xz:=getx; yz:=gety;
    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 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+x, yz-y);
        if act=3 then lineto(xz+x, yz-y);
       end{ of for};
  end;{ of procedure}

procedure textausgabe(x, y:integer; faktor: 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);
      end;
  end;

procedure notenplay(stimme1, stimme2: byte; note1, note2, len: azaehl; wort: string20);

  var i: byte;

  begin
    ausgabe(stimme1+$A0, notenfeld[note1, 1]);     {Ton an}
    ausgabe(stimme2+$A0, notenfeld[note2, 1]);

    if note1<>aus then ausgabe($BD, $22);

    ausgabe(stimme1+$B0, notenfeld[note1, 2]);
    ausgabe(stimme2+$B0, notenfeld[note2, 2]);

    setcolor(15);
    textausgabe(320-(textwidth(wort) div 2), 475, 2, wort);
    delay( (notenfeld[len, 1] * notenfeld[len, 2]) );  {L„nge}
  end;

procedure notenaus(stimme1, stimme2: byte);
  begin
    ausgabe(stimme1+$A0, notenfeld[aus, 1]);          {Ton aus}
    ausgabe(stimme2+$A0, notenfeld[aus, 1]);

    ausgabe($BD, $02);

    ausgabe(stimme1+$B0, notenfeld[aus, 2]);
    ausgabe(stimme2+$B0, notenfeld[aus, 2]);

    setcolor(0);
    setfillstyle(1, 0);
    bar(200, 460, 440, 479);
  end;

procedure aktion(i: integer);
  begin
    if lied2wort[i]='leuch-ten' then
      begin
        setrgbpalette(245, 42, 42, 0);  {Kerzen an}
        setrgbpalette(15, 63, 63, 63);  {Zimmer hell}
      end;
    if i > 100 then
      begin
        if i mod 2 = 0 then
          begin
            setrgbpalette(2, 63, 63, 63);  {Schnee oben}
            setrgbpalette(1, 0, 0, 0);
          end;
        if i mod 2 = 1 then
          begin
            setrgbpalette(1, 63, 63, 63);  {Schnee unten}
            setrgbpalette(2, 0, 0, 0);  {alles aus}
          end;
      end
      else delay(20);
    if lied2wort[i]='Kin-der,' then
      begin
        setrgbpalette(246, 63, 47, 31);  {Mund :-| aus}
        setrgbpalette(247, 42,  0,  0);  {Mund :-) an}
      end;
  end;

procedure playlied;

  var i : integer;

  begin
    notenplay(0, 1, aus, aus, lg, '');
    for i:=0 to 3*laenge2-1 do
      begin
        notenplay(0, 1, lied2[i mod laenge2, 1], lied2[i mod laenge2, 2],
                  lied2[i mod laenge2, 3], lied2wort[i]);
        aktion(i);
        notenaus(0, 1);
      end;
  end;

procedure initsound;
  begin
    port[$0226]:=01;
    delay(100);
    port[$0226]:=0;
    delay(100);
    port[$022C]:=$0D1;
    delay(100);
    ausgabe($01, $20);
    ausgabe($02, $00); ausgabe($03, $00); ausgabe($04, $00);
    ausgabe($08, $00);
    ausgabe($23, $20); ausgabe($20, $B0);
    ausgabe($24, $20); ausgabe($21, $30);
    for i:=$10 to $15 do ausgabe($20+i, $20);
    ausgabe($43, $0C); ausgabe($40, $0C);
    ausgabe($44, $16); ausgabe($41, $16);
    for i:=$10 to $15 do ausgabe($40+i, $24);
    ausgabe($63, $92); ausgabe($60, $92);
    ausgabe($64, $92); ausgabe($61, $92);
    for i:=$10 to $15 do ausgabe($60+i, $95);
    ausgabe($83, $F2); ausgabe($80, $F2);
    ausgabe($84, $FC); ausgabe($81, $FC);
    for i:=$10 to $15 do ausgabe($80+i, $FF);
    delay(1);
    ausgabe($C0, $11);
    ausgabe($C1, $10);
    for i:=$6 to $8 do ausgabe($C0+i, $FF);
    ausgabe($E3, $01); ausgabe($E0, $00);
    ausgabe($E3, $00); ausgabe($E0, $00);
    for i:=$10 to $15 do ausgabe($E0+i, $00);
    delay(500);
  end;

{$F+}
function DetectVGA256 : Integer;

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

procedure initgraf;

 var testdriver : integer;

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

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]);
      durch:=durch+1;
    until (eof(f));
    close(f);
  end;

procedure bildoeffnen;

  var x, y, i: integer;
      datei : file of bmp256typ;
      dateiname: string;
      bitmapfeldzeile : array[0..31] of bmp256typ;

  begin
    dateiname:='iweihn99.bmp';
    assign(datei, dateiname);
    reset(datei);
    for y:=0 to 22 do
      begin
        for x:=0 to 31 do
          read(datei, bitmapfeldzeile[x]);
        for i:=23 downto y do
          begin
            for x:=0 to 31 do
              putimage(x*20, i*20, bitmapfeldzeile[x], 0);
            delay(50);
            setcolor(0);
            setfillstyle(1, 0);
            if i>y then bar(0, i*20, 639, i*20+19);
          end;
      end;
    close(datei);
  end;

procedure startfarben;
  begin
    setrgbpalette(246, 42, 0, 0);    {rot}
    setrgbpalette(247, 63, 47, 31);   {hautfarben, 66}
    setrgbpalette(1, 0, 0, 0);       {schwarz}
    setrgbpalette(2, 0, 0, 0);
    setrgbpalette(245, 45, 45, 45);  {hellgrau}
    setrgbpalette(15, 45, 45, 45);
  end;

procedure schnee;
  var P      : pointer;
      Size   : Word;
      x, y   : integer;

  begin
    Size := ImageSize(80, 65, 130, 105);
    GetMem(P, Size); { Get memory from heap }
    GetImage(80, 65, 130, 105, P^);
    for y:=0 to 1 do
      for x:=0 to 3 do
        PutImage(80+x*50, 65+y*60, P^, NormalPut);
  end;

begin
  initgraf;
  initfont;
  driver:=Detect;
  initgraph(driver, mode, 'd:\tp\tppas1\bgi');
  initsound;
  startfarben;
  bildoeffnen;
  schnee;
  repeat until keypressed;
  settextstyle(3, 0, 1);
  playlied;
  delay(1000);
  closegraph;
end.