The Equalizer BBS/equalizer-bbs-collection_2004.zip/equalizer-bbs-collection/DEMOSCENE-STUFF/K-INVIT.ZIP/XN_INV.PAS

Pascal/Delphi Source File | 1996-05-18 | 15KB | 583 lines

{═════════════════════════════════════════════════════════════════════════════
                                                    Gautier Portet  FD/KNIGHTS
  "Invitation"                                      3, Place Ferdinand Buisson
Copyright KNIGHTS  1996                             31240 St Jean       France
Music by Benji / JFF
All Code by ƒire drαgΘ∩ . KNIGHTS             FAX: [phone] (EcLiPsE)
══════════════════════════════════════════════════════════════════════════════
             │
            -.▄█  ██▄ ▄█   █▄  ▄█  ▄████▄  ▄█   █▄ ▀████▄ ▄█████▄
             │██ ██   ███  ██  ██  ██      ██   ██   ██   ██
              ███▌    ██ █ ██  ██  ██ ▄██▄ ███████   ██    █████▄
              ██ ██   ██  ███  ██  ██    █ ██   ██   ██        ██
              ▀█  ██▄ ▀█   █▀  █▀  ▀█████▀ ▀█   █▀   █▀   ▄█████▀
                                                       εcLiPsε ]<
"INVITATION"
coded by Fire Dragon 15..17/04/96
[ KNIGHTS Official Source Code ]

- MIDAS Sound System, Copyright 1995 Petteri Kangaslampi and Jarno Paananen
- Couleurs de tapette, Copyright Remdy / CeQuiVaAvecLaBrosseàDent 1996
- 80% pur Pascal (lame!) code , Copyright FD/KNIGHTS 1996

You can do whatever you want with this source code.
It is PUBLIC DOMAIN.
But as I'm the creator of it, I want the credits and Greets if you use it (?!)
Next time ----> PUR ASM CODE !!    ( And maybe Textmode too !! :)
}


{$DEFINE MIDAS}



{$M 4096,0,640000}

{$IFDEF MIDAS}
uses midas, mfile, mplayer, modp, errors, mconfig;
{$ENDIF}


var n , m,i,j : integer;
cursor_shape : word;
k : char;

procedure WAITVBL; assembler;
asm
    mov    dx,3DAh
@t1:
    in    al,dx
    test    al,8
    jz    @t1
    cli
@t2:
    in    al,dx
    test    al,8
    jnz    @t2
    sti
end;

procedure DPrint(Ligne,colonne, Couleur : byte; St : string);
{ BIBLE PC : ecrit un caractère dans la mémoire vidéo }
{aie, il faut que je le fasse en asm en vitesse ... }
var PAGE_OFS : word absolute $0040:$004E;
    Offset   : word;
    i, j     : byte;
    Attribut : word;
begin
  Offset := Ligne * 160 + Colonne shl 1 + 0;
  Attribut := Couleur shl 8;
  i := length( St );
  for j:=1 to i do
    begin
      memw[$b800:Offset] := Attribut or ord( St[j] );
      Offset := Offset + 2;
    end;
end;


procedure SetRGB(color : integer; r,g,b : byte); assembler;
asm
    cli
    mov    dx,$3C8
    mov    ax,color
    out    dx,al
    inc    dx
    mov    al,r
    out    dx,al
    mov    al,g
    out    dx,al
    mov    al,b
    out    dx,al
    sti
end;

procedure set_adress(n: word);
{TEXT MODE : SET LSA + VertPAN }
var l,m : word;
begin
       l := (n shr 4 ) * 80 ;          { on met en word-LSA et byte-PANNING }
       m := n mod 16 ;
asm
{wait_in_display}
  mov dx,3dah
  @wait1:
  in al,dx
  test al,8h
  jnz @wait1
{setstart / addresse de depart de la mem. video }
  mov dx,3d4h
  mov al,0ch
  mov ah,byte ptr l + 1
  out dx,ax
  mov al,0dh
  mov ah,byte ptr l
  out dx,ax
{wait_in_retrace}
  mov dx,3dah
@wait2:
  in al,dx
  test al,8h
  jz @wait2
{set_Vertical_panning / registre de smooth scrolling }
  mov dx,3d4h
  mov al,8h
  mov ah,byte ptr m
  out dx,ax
End;
end;

const  max_text = 10;
texte : array[1..max_text,1..5] of string[40]=
(
(
'Bienvenue à tous, ',
'Cette intro est destinée à ',
'vous informer d'' un ',
'Projet qui nous tient à coeur',
chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+
chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)+chr(3)
),
(
'',
'Nous voudrions pouvoir',
'sortir un Music-Disk ',
'TOUS les mois. ',
'                                        '
),
(
'Mais notre groupe n''a pas encore',
'assez de membres. ',
'donc, nous faisons appel à ',
'VOUS',
'                               '
),
(
'Si vous êtes Musicien,       ',
'Codeur ou Graphiste',
'Déjà dans un groupe ou non,',
'Contactez-nous .....',
'                               '
),
(
'',
'',
'',
'',
''
),
(
'',
'Pour plus d''informations,',
'Demarrez KNIGHTS.EXE',
'',
'                        '
),
(
'INTRO faite en vitesse par :',
'      CODE  : Fire Dragon',
'      MUSIC : Benji / JFF',
'      ASCII : Eclipse & FD',
'(couleurs de tapette : REMDY :)   '
),
(
'Greets :                 ',
'The SkyRangers Team, ',
'MC Bidule, Axel & Benji [JFF], ',
'Makiabelik, and all the PC ZIK-men',
'See you soon  ?                  '
),
(
'Wisdom,JFF,Dentifrice,Pussy Cat',
'Typhoon, Olympus, NTSC, ',
'',
'',
'                       '
),
(
'                     ',
'',
'... RESTARTING ...',
'    Press  ESC',
'                       '
)
);


var
car,line,page : byte;

scr_index : byte;

temp : string[40];
 scroll : string;

 x : array[1..20] of byte;
 y : array[1..20] of byte;
 xo: array[1..20] of byte;
 yo: array[1..20] of byte;
 xi : array[1..20] of shortint;
 yi : array[1..20] of shortint;



procedure do_scroll;
var n : byte;
begin
inc(scr_index);
if scr_index > ord(scroll[0]) then scr_index := 1;
for n := 1 to 39 do
temp[n]:= temp[n+1];
temp[40] := scroll[scr_index];
dprint(124,20,16+7,temp);

for n := 1 to 20 do
begin
inc(x[n],xi[n]);
inc(y[n],yi[n]);
if x[n] < 1 then begin
                 x[n] := 1;
                 xi[n] := -xi[n];
                 end;
if x[n] > 30 then begin
                 x[n] := 30;
                 xi[n] := -xi[n];
                 end;
if y[n] < 1 then begin
                 y[n] := 1;
                 yi[n] := -yi[n];
                 end;
if y[n] > 10 then begin
                 y[n] := 10;
                 yi[n] := -yi[n];
                 end;
dprint(110+yo[n],xo[n]+45,0,chr(0));
dprint(110+y[n],x[n]+45,1,chr(14));
xo[n] := x[n];
yo[n] := y[n];

end;

end;


procedure do_text;
begin
dprint(108+2*line,car+10,7,texte[page,line,car]);
inc(car);
if car > length(texte[page,line]) then
begin
car := 1;
inc(line);
if line = 6 then begin
line := 1;
inc(page);
dprint(110,car+10,7,'                                        ');
dprint(112,car+10,7,'                                        ');
dprint(114,car+10,7,'                                        ');
dprint(116,car+10,7,'                                        ');
dprint(118,car+10,7,'                                        ');

if page > max_text then page := 1;
end;
end;
end;


procedure main;
var n,m : integer;
adr : word;
begin
for n := 1 to 20 do
begin
x[n] := random(30);
y[n] := random(10);
xi[n] := random(1)+1;
yi[n] := random(1)+1;
end;

setrgb(1,60,26,48);

scroll := ' K N I G H T S /     Invitation    --->    Coded by Fire Dragon , Ansi by Eclipse & FD       '
+' Music by Benji / JFF    Couleurs de tapette : Remdy                             ';
temp := '                                               ';
line := 1;
page := 1;
car := 1;
setrgb(7,30,30,30);

for n := 0 to 63 do
begin
setrgb(0,n,(n*2) div 3 ,n);
waitvbl;
end;

adr := 16*113;


dprint(101,0,7,'             │');
dprint(102,0,7,'            -.▄█  ██▄ ▄█   █▄  ▄█  ▄████▄  ▄█   █▄ ▀████▄ ▄█████▄');
dprint(103,0,7,'             │██ ██   ███  ██  ██  ██      ██   ██   ██   ██');
dprint(104,0,7,'              ███▌    ██ █ ██  ██  ██ ▄██▄ ███████   ██    █████▄');
dprint(105,0,7,'              ██ ██   ██  ███  ██  ██    █ ██   ██   ██        ██');
dprint(106,0,7,'              ▀█  ██▄ ▀█   █▀  █▀  ▀█████▀ ▀█   █▀   █▀   ▄█████▀');
dprint(107,0,7,'                                                       εcLiPsε ]< ');
for n := 00 to 63 do
begin
dec(adr,3);
set_adress(adr);
setrgb(7,n,n,n);
end;

waitvbl;
for n := 0 to 79 do
dprint(124,n,16+7,chr(3));

{ BOUCLE pricipale }
repeat
waitvbl;
do_scroll;
waitvbl;
do_scroll;
waitvbl;
do_scroll;
do_text;
until port[$60] = 1;  { Wait for ESC}


n := 0;
repeat
inc(n);
dec(adr,n);
set_adress(adr);
do_scroll;
until adr  < 80*16 ;




end;


procedure XN;
const XN_text : array[1..7]of string[80]=
('             │                                                    ',
'            -.▄█  ██▄ ▄█   █▄  ▄█  ▄████▄  ▄█   █▄ ▀████▄ ▄█████▄',
'             │██ ██   ███  ██  ██  ██      ██   ██   ██   ██',
'              ███▌    ██ █ ██  ██  ██ ▄██▄ ███████   ██    █████▄',
'              ██ ██   ██  ███  ██  ██    █ ██   ██   ██        ██',
'              ▀█  ██▄ ▀█   █▀  █▀  ▀█████▀ ▀█   █▀   █▀   ▄█████▀',
'                                                                 ');
{ decidement, je l'aime bien ce logo !!!!!}

var n , m : integer;
begin
setrgb(7,63,63,63);
waitvbl;
set_adress(51*16+8);

for m := 10 to 65 do
for n := 10 downto 0 do
begin
waitvbl;
{ Pascal UNROLL  :) }
dprint(60+n,m,7,xn_text[1,m]);
dprint(61+n,m,7,xn_text[2,m]);
dprint(62+n,m,7,xn_text[3,m]);
dprint(63+n,m,7,xn_text[4,m]);
dprint(64+n,m,7,xn_text[5,m]);
dprint(65+n,m,7,xn_text[6,m]);
dprint(66+n,m,7,xn_text[7,m]);

end;
for n := 63 downto 0 do
begin
waitvbl;
setrgb(7,63,n,63);
setrgb(0,n,(n*2) div 3 ,n);
end;

for n := 60 downto 00 do
begin
waitvbl;
setrgb(7,n,0,n);
end;

waitvbl;
end;



procedure intro;
begin
set_adress(50*16);
setrgb(7,0,0,0);
waitvbl;


m := 25;
dprint(60+n,m,7,'▀ █ █ █ █ ▀ ██  █  ██ ▀ ███ █ █');
dprint(61+n,m,7,'█ █▌█ █ █ █ ▐▌ █ █ ▐▌ █ █ █ █▌█');
dprint(62+n,m,7,'█ █▐█ █ █ █ ▐▌ ███ ▐▌ █ █ █ █▐█');
dprint(63+n,m,7,'█ █ █  █  █ ▐▌ █ █ ▐▌ █ ███ █ █');

for n := 0 to 63 do
begin
waitvbl;
setrgb(7,n,n,n);
end;

for n := 63 downto 0 do
begin
waitvbl;
setrgb(7,n,n,n);
end;

m := 25;
dprint(60+n,m,7,'                               ');
dprint(61+n,m,7,'                               ');
dprint(62+n,m,7,'                               ');
dprint(63+n,m,7,'                               ');
end;



{$IFDEF MIDAS}
function toASCIIZ(dest : PChar; str : string) : PChar;
{MIDAS}
var
    spos, slen : integer;
    i : integer;

begin
    spos := 0;                          { string position = 0 }
    slen := ord(str[0]);                { string length }

    { copy string to ASCIIZ conversion buffer: }
    while spos < slen do
    begin
        dest[spos] := str[spos+1];
        spos := spos + 1;
    end;

    dest[spos] := chr(0);               { put terminating 0 to end of string }

    toASCIIZ := dest;
end;

var
    module : PmpModule;
     error, isConfig : integer;
    str : array [0..256] of char;
    configured : byte;
{$ENDIF}



begin
{$IFDEF MIDAS}
    midasSetDefaults;                   { set MIDAS defaults }
    if error <> OK then
        midasError(error);

    configured := midasConfig;
    if error <> OK then
        midasError(error);
    if configured = 1 then
    begin
        WriteLn('Configuration OK');
    end
    else
    begin
        { Configuration unsuccessful: }
        WriteLn('NOT CORRECT configuration');
    end;

    midasInit;                          { initialize MIDAS Sound System }
    if error <> OK then
        midasError(error);
     toASCIIZ(str, 'tripto7.mod');
    module := midasLoadModule(str, @mpMOD, NIL);
    midasPlayModule(module, 0);
{$ENDIF}


asm
mov ax,0003h
int 10h
end;
        intro;
        main;
        xn;

asm
mov ax,0003h
int 10h
end;
setrgb(7,0,0,0);

write('════════════════════════════════════════════════════════════════════════════════');
write('                                                      Gautier Portet  FD/KNIGHTS');
write('  "Invitation"                                        3, Place Ferdinand Buisson');
write('Copyright KNIGHTS  1996                               31240 St Jean       France');
write('Music by Benji / JFF                                                            ');
write('All Code by ƒire drαgΘ∩ . KNIGHTS               FAX: [phone] (EcLiPsE)');
write('════════════════════════════════════════════════════════════════════════════════');
writeln('             │');
writeln('            -.▄█  ██▄ ▄█   █▄  ▄█  ▄████▄  ▄█   █▄ ▀████▄ ▄█████▄');
writeln('             │██ ██   ███  ██  ██  ██      ██   ██   ██   ██');
writeln('              ███▌    ██ █ ██  ██  ██ ▄██▄ ███████   ██    █████▄');
writeln('              ██ ██   ██  ███  ██  ██    █ ██   ██   ██        ██');
writeln('              ▀█  ██▄ ▀█   █▀  █▀  ▀█████▀ ▀█   █▀   █▀   ▄█████▀');
writeln('                                                       εcLiPsε ]< ');
writeln('');
writeln('     GREETS : ( If you are not here, you are not cool (or I forgot you) :)');
writeln('    ->                                                                   <-');
writeln('    -> Atlantis,Bitline,Sherlock[WiSdom] MK[Pussy Cat] Remdy[Dentifrice] <-   ');
writeln('    ->     Senser[Typhoon] Axel,Benji,Exocet,Judge Miguel,Kezax[JFF]     <-   ');
writeln('    -> Pollux[Olympus]   The SkyRangers Team  All the members of KNIGHTS <-   ');
writeln('    ->                           MIDAS forever !!                        <-');
writeln('    ->       Qui a dit que l''on ne peut rien faire en mode texte ?      <-');


for n := 0 to 40 do
begin
waitvbl;
setrgb(7,n,n,n);
end;

{$IFDEF MIDAS}
    midasStopModule(module);            { stop playing }
    midasFreeModule(module);            { deallocate module }
    midasClose;                         { uninitialize MIDAS }
{$ENDIF}
end.

{═══════════════════════════════════════════════════════════════════════════════
                                                      Gautier Portet  FD/KNIGHTS
  "Invitation"                                        3, Place Ferdinand Buisson
Copyright KNIGHTS  1996                               31240 St Jean       France
Music by Benji / JFF
All Code by ƒire drαgΘ∩ . KNIGHTS               FAX: [phone] (EcLiPsE)
════════════════════════════════════════════════════════════════════════════════
             │
            -.▄█  ██▄ ▄█   █▄  ▄█  ▄████▄  ▄█   █▄ ▀████▄ ▄█████▄
             │██ ██   ███  ██  ██  ██      ██   ██   ██   ██
              ███▌    ██ █ ██  ██  ██ ▄██▄ ███████   ██    █████▄
              ██ ██   ██  ███  ██  ██    █ ██   ██   ██        ██
              ▀█  ██▄ ▀█   █▀  █▀  ▀█████▀ ▀█   █▀   █▀   ▄█████▀
                                                       εcLiPsε ]<
"INVITATION"
coded by Fire Dragon 15..17/04/96
[ KNIGHTS Official Source Code ]

- MIDAS Sound System, Copyright 1995 Petteri Kangaslampi and Jarno Paananen
- Couleurs de tapette, Copyright Remdy / CeQuiVaAvecLaBrosseàDent 1996
- 80% pur Pascal (lame!) code , Copyright FD/KNIGHTS 1996

You can do whatever you want with this source code.
It is PUBLIC DOMAIN.
But as I'm the creator of it, I want the credits and Greets if you use it (?!)
}