home *** CD-ROM | disk | FTP | other *** search
/ The Equalizer BBS / equalizer-bbs-collection_2004.zip / equalizer-bbs-collection / DEMOSCENE-STUFF / KN-BBS.ZIP / CALL-IT.PAS < prev    next >
Pascal/Delphi Source File  |  1996-07-11  |  9KB  |  358 lines
  1. Program Call_It;
  2. {═════════════════════════════════════════════════════════════════════════════
  3.                                                Gautier Portet  impulse/KNIGHTS
  4.   "BBS Advert for LiTHiUM"                          3, Place Ferdinand Buisson
  5. Copyright KNIGHTS  1996                             31240 St Jean       France
  6.  
  7. All Code by impulse . KNIGHTS             FAX: (+33) 35 69 44 83 (EcLiPsE)
  8. ══════════════════════════════════════════════════════════════════════════════
  9.              │
  10.             -.▄█  ██▄ ▄█   █▄  ▄█  ▄████▄  ▄█   █▄ ▀████▄ ▄█████▄
  11.              │██ ██   ███  ██  ██  ██      ██   ██   ██   ██
  12.               ███▌    ██ █ ██  ██  ██ ▄██▄ ███████   ██    █████▄
  13.               ██ ██   ██  ███  ██  ██    █ ██   ██   ██        ██
  14.               ▀█  ██▄ ▀█   █▀  █▀  ▀█████▀ ▀█   █▀   █▀   ▄█████▀
  15.                                                        εcLiPsε ]<
  16. coded by impluse 08..09/07/96
  17. [ KNIGHTS Official Source Code ]
  18.  
  19. - Couleurs de t...... , Copyright Remdy / CeQuiVaAvecLaBrosseàDent 1996
  20. - 60% pur Pascal (lame!) code , Copyright FD/KNIGHTS 1996
  21.  
  22. You can do whatever you want with this source code.
  23. It is PUBLIC DOMAIN.
  24. But as I'm the creator of it, I want the credits and Greets if you use it (?!)
  25.  
  26. }
  27.  
  28. {$M 1024,0,0}
  29. {$G+}
  30. {$B-}
  31. {$D-}
  32. {$A+}
  33. {$N-}
  34.  
  35.  
  36. const
  37. Sinus : Array[0..255] of byte = (
  38.  63,
  39.  69,  75,  81,  87,  93,  98, 103, 108, 112, 116, 119, 121, 123, 125, 126, 126,
  40. 126, 125, 123, 121, 118, 115, 111, 107, 102,  97,  92,  86,  81,  75,  68,  62,
  41.  56,  50,  44,  38,  33,  27,  22,  18,  14,  10,   7,   4,   2,   1,   0,   0,
  42.   0,   1,   3,   5,   8,  11,  15,  19,  24,  29,  35,  40,  46,  52,  58,  65,
  43.  71,  77,  83,  89,  94,  99, 104, 109, 113, 116, 119, 122, 124, 125, 126, 126,
  44. 125, 124, 123, 120, 118, 114, 110, 106, 101,  96,  91,  85,  79,  73,  67,  61,
  45.  54,  48,  42,  37,  31,  26,  21,  17,  13,   9,   6,   4,   2,   1,   0,   0,
  46.   1,   2,   4,   6,   9,  12,  16,  21,  25,  30,  36,  42,  48,  54,  60,  66,
  47.  72,  78,  84,  90,  96, 101, 105, 110, 114, 117, 120, 122, 124, 125, 126, 126,
  48. 125, 124, 122, 120, 117, 113, 109, 105, 100,  95,  89,  84,  78,  72,  65,  59,
  49.  53,  47,  41,  35,  30,  25,  20,  16,  12,   8,   6,   3,   2,   1,   0,   0,
  50.   1,   2,   4,   7,  10,  13,  17,  22,  27,  32,  37,  43,  49,  55,  61,  68,
  51.  74,  80,  86,  91,  97, 102, 107, 111, 115, 118, 121, 123, 125, 126, 126, 126,
  52. 125, 124, 122, 119, 116, 112, 108, 104,  99,  93,  88,  82,  76,  70,  64,  58,
  53.  51,  45,  40,  34,  29,  24,  19,  15,  11,   8,   5,   3,   1,   0,   0,   0,
  54.   1,   3,   5,   7,  10,  14,  18,  23,  28,  33,  39,  45,  51,  57,  63 );
  55. { iMPULSE's Sinus Generator version 5.4 }
  56.  
  57. const logo : array[1..14] of string[80] = (
  58. ' █          ████       ████       █     █    ████       █     █    █     █   ',
  59. ' ██         ██████     ██████     ██    ██   ██████     ██    ██   ██    ██  ',
  60. ' ███        ████████   ████████   ███   ███  ████████   ███   ███  ███   ███ ',
  61. ' ████       ██████████ ██████████ ████  ████ ██████████ ████  ████ ████  ████',
  62. ' ████          █          █       ████  ████    █       ████  ████ █████ ████',
  63. ' ████          ██         ██      ████  ████    ██      ████  ████ ██████████',
  64. ' ████   '+chr(24)+'      ███        ███     ████  ████    ███     ████  ████ ████  ████',
  65. ' ████  '+chr(27)+'■'+chr(26)+'     ████       ████    █████ ████    ████    ████  ████ ████  ████',
  66. ' ████   '+chr(25)+'      ████       ████    ██████████    ████    ████  ████ ████  ████',
  67. ' ████          ████       ████    ████  ████    ████    ████  ████ ████  ████',
  68. ' █████████  ██████████    ████    ████  ████ ██████████ ████  ████ ████  ████',
  69. ' █████████  ██████████    ████    ████  ████ ██████████ ████  ████ ████  ████',
  70. ' █████████  ██████████    ████    ████  ████ ██████████ █████ ████ ████  ████',
  71. ' █████████  ██████████    ████    ████  ████ ██████████ ██████████ ████  ████');
  72.  
  73. number : array[1..8] of string[80] = (
  74. '  ██ ██████ ██████ ██ ███    ██████ ███    ██████ ██████ ██████ ██████ ██████',
  75. '  █     ███    ███  █ ███    ███    ███       ███    ███    ███    ███    ███',
  76. '  █     ███    ███  █ ███    ███    ███       ███    ███    ███    ███    ███',
  77. '  █     ███    ███  █ ███    ███    ███       ███    ███    ███    ███    ███',
  78. '  █     ███    ███  █ ███    ███    ███       ███    ███    ███    ███    ███',
  79. '  █    ████ ██████  █~██████ ██████~██████   ████~  ████    ███~  ████ ██████',
  80. '  █     ███ ███     █ ██▌▐██    ███ ██▌▐██    ███    ███    ███    ███ ███   ',
  81. '  ██ ██████ ██████ ██ ██████ ██████ ██████ ██████ ██████    ███ ██████ ██████');
  82.  
  83.  
  84.  
  85. var
  86.  
  87. n , m ,add1,add2,phi    : word;
  88. fin                     : boolean;
  89. index,add_index         : byte;
  90.  
  91.  
  92.  
  93. PROCEDURE Init_Curseur; ASSEMBLER;
  94. { Vire cette saloperie de putain de curseur !!!!!}
  95. ASM
  96.   mov     ah,1
  97.   mov     cx,2020h
  98.   int     10h
  99. end;
  100.  
  101.  
  102. procedure print(x,y : byte ;st : string; c : byte);
  103. { affiche une chaine ... repompé ?!?!        :) }
  104. var Offset   : word;
  105.     i, j     : byte;
  106.     Attribut : word;
  107.     colonne  : byte;
  108. begin
  109.   Offset := y * 160 + x shl 1 ;
  110.   Attribut := c shl 8;
  111.   i := length( St );
  112.   for j:=1 to i do
  113.     begin
  114.       memw[$b800:Offset] := Attribut or ord( St[j] );
  115.       Offset := Offset + 2;
  116.     end;
  117. end;
  118.  
  119. procedure SetRGB(color : integer; r,g,b : byte); assembler;
  120. asm
  121.     cli
  122.     mov    dx,$3C8
  123.     mov    ax,color
  124.     out    dx,al
  125.     inc    dx
  126.     mov    al,r
  127.     out    dx,al
  128.     mov    al,g
  129.     out    dx,al
  130.     mov    al,b
  131.     out    dx,al
  132.     sti
  133. end;
  134.  
  135. procedure wait_VBL; assembler;
  136. asm
  137.     mov    dx,3DAh
  138. @t1:
  139.     in    al,dx
  140.     test    al,8
  141.     jz    @t1
  142.     cli
  143. @t2:
  144.     in    al,dx
  145.     test    al,8
  146.     jnz    @t2
  147.     sti
  148. end;
  149.  
  150. procedure do_vagues ;assembler ;
  151. asm
  152.    mov  ax,0b800h
  153.    mov  es,ax
  154.    mov  di,49*160+1
  155.    xor  cx,cx
  156.    mov  bl,index
  157.    mov  dx,32
  158.    mov  si,n
  159.    mov  bx,phi
  160.  
  161. @loop:
  162.          add  si,add1
  163.          add  bx,add2
  164.          and  bx,255
  165.          and  si,255
  166.          mov  cl,byte ptr sinus[si]
  167.          add  cl,byte ptr sinus[bx]
  168.          mov  dx,32
  169.          shr  cl,3
  170.          sub  dl,cl
  171.          mov  ax,1+16*2
  172.          inc  cl
  173. @loop1:
  174.                 mov  es:[di],al
  175.                 add  di,2
  176.                 dec  cx
  177.              jnz  @loop1
  178.  
  179.              mov  ax,1
  180. @loop2:
  181.                 mov  es:[di],al
  182.                 add  di,2
  183.                 dec  dl
  184.              jnz  @loop2
  185.  
  186.          sub  di,160+66
  187.          or   di,di
  188.        jns  @loop
  189.  
  190. end;
  191.  
  192.  
  193.  
  194. procedure intro;
  195. const max = 4;
  196.  
  197. const scroll : string =
  198. (
  199. '                           Call LiTHiUM bbs           KNIGHTS Belgium  HeadQuarter       (32)-65-63-37-32                '
  200. +'                                  ');
  201.  
  202. const texte : array[1..max] of string[80] =
  203. (
  204. '      !! W A R N I N G !!      ',
  205. '   K · N · I · G · H · T · S   ',
  206. '      Belgium HeadQuarter      ',
  207. '          CALL  NOW :          '
  208. );
  209. const pos : array [1..max] of byte =
  210. (34,35,36,37);
  211.  
  212. var sc_i : byte;
  213. st : string[28];
  214. i : byte;
  215.  
  216. begin
  217. st := '';
  218. setrgb(0,0,0,0);
  219. setrgb(1,0,0,0);
  220. setrgb(2,0,0,0);
  221. index := 0;
  222. fin := false;
  223. add1 := 0;
  224. add2 := 0;
  225.  
  226. for n := 1 to 14 do
  227. print(0,n+16,logo[n],1);
  228.  
  229. for n := 1 to 8 do
  230. print(0,n+40,number[n],1);
  231. for n := 1 to 8 do
  232. print(0,n+1,number[n],1);
  233. sc_i := 1;
  234.  
  235.  
  236. for n := 0 to 10 do
  237. begin
  238. setrgb(0,n*4,n*3,n*4);
  239. setrgb(1,n*4,n*3,n*4);
  240. setrgb(2,n*4,n*3,n*4);
  241. wait_vbl;
  242. end;
  243.  
  244. for n := 0 to 20 do
  245. begin
  246. wait_vbl;
  247. setrgb(1,40+n,30+n,40+n);
  248. setrgb(2,40-(n shr 1),30-(n shr 1),40-(n shr 1));
  249. end;
  250. randomize;
  251.  
  252. { boucle principale }
  253. repeat
  254. begin
  255. wait_vbl;
  256. inc(n);
  257. if (n mod 200 ) = 0 then begin
  258.                        phi := n;
  259.                        add1 := random(5)+1;
  260.                        add2 := random(5)+1;
  261.                        end;
  262.  
  263.  
  264. i := 2+( sinus[n  and 255] )div 3;
  265. for m := 1 to max do
  266. print(i,pos[m],texte[m],1);
  267.  
  268. sc_i := (sc_i+1) and 127;
  269. st := copy(scroll,sc_i,28);
  270. print(25,13,'['+st+']',1);
  271.  
  272. do_vagues;
  273.  
  274.  
  275. { quitte si ESC appuyé }
  276. asm
  277.    in   al,60h
  278.    cmp  al,1
  279.    jne  @fin_KKK
  280.    mov  fin,true
  281. @fin_KKK:
  282. end;
  283.  
  284. end;
  285. until fin  = true;
  286.  
  287. { vide le buffer de clavier }
  288. asm
  289. @debut:
  290.     mov ax,0100h
  291.     int 16h
  292.     jz  @fin
  293.     xor ax,ax
  294.     int 16h
  295.  
  296.     jmp @debut
  297.     @fin:
  298. end;
  299.  
  300. end;
  301.  
  302. procedure endtro;
  303. begin
  304. asm
  305.      mov        ax,0003h
  306.      int        10h
  307. end;
  308. setrgb(7,0,0,0);
  309. for n := 1 to 154 do write('LiTHiUM bbs  ');
  310. writeln('Code, Ascii by impulse / KNIGHTS ');
  311. print(30,12,'    LITHIUM  bbs    ',0+16*7);
  312. print(0,13,'                               KNIGHTS Belgium HQ                               ',0+16*7);
  313. print(30,14,'  (32)-65-63-37-32  ',0+16*7);
  314.  
  315. for n := 0 to 63 do
  316. begin
  317. wait_vbl;
  318. wait_vbl;
  319. setrgb(7,n,n,n);
  320. end;
  321. for n := 63 downto 40 do
  322. begin
  323. wait_vbl;
  324. wait_vbl;
  325. setrgb(7,n,n,n);
  326. end;
  327.  
  328. end;
  329.  
  330.  
  331.  
  332.  
  333. begin
  334.  
  335.      asm
  336. { Verifie si VGA }
  337.         mov  ax,01a00h
  338.         int  10h
  339.         cmp  al,1ah
  340.         je  @suite
  341.         mov ax,4c00h
  342.         int 21h
  343.  
  344. @suite:
  345. { passe en mode 80*50 }
  346.         mov     ax,0003h
  347.         int     10h
  348.         mov     ax,1112h
  349.         mov     bx,0000h
  350.         int     10h
  351.      end;
  352.      init_curseur;
  353.  
  354.  
  355.      intro;
  356.      endtro;
  357.  
  358. end.