ES BBS Intro

esbbs.pas

{ ES BBS Intro - 1995 }
{ Binary can be get at http://www.pouet.net/prod.php?which=55705 }

{$M $800,0,655360}
{$N-,E-,F+}

uses Strings,XBuf,XMode;

const

  fontBaseColor = 35;

  x_length = 1460;

  exitRequest : boolean = false;
  lastdir     : boolean = true;
  lasty       : integer = 100;
  celsize     : integer = 0;

  maxText = 58;

  text : array[1..maxText] of PChar = (
     '-= Home Of Flyers =-',
  #13'SysOp: Mehmet "BLoodY" Ozturk2',
     'CoSysOp: Sedat "SSG" Kapanoglu',
  #13'(222)-234 58 69',
     'Up to 14400 bps! v42, MNP5',
  #13'KiSS WHQ',
  #1,

  #13'Messaging across Turkiye is',
     'available via:',
     'HiTNeT    8:103/119',
     'TurkNet   P:RIV/ATE',
     'PeaceNet  P:RIV/ATE',
     'FidoNet   2:430/314',
     'IntNet   10:100/128',
  #13'Turkiye HiTBase server',#1,

  #13'Internet e-mail is available NOW!',
  #13,
  #13'Address: es-bbs.ege.edu.tr',#1,

     'Our huge file archive contains:',
  #13'- Game cheats, trainers, walkthru''s    ',
     '- Flight Simulator data & support files',
     '- Dozens of X-Wing editors, cheats     ',
     '- Latest software from KiSS            ',
     '- Win 3.1, Win95 and OS/2 Warp utilz   ',
  #1,

     'ES BBS has now CD-ROM file base!!',
     'Each CD-ROM contains up to 600 megs of',
     'utilities, docs, prog. utils, cheats',
     'aviation support, games...',
  #13'You will find anything you need here',#1,

  #13'Online shopping in ES BBS CyberShop!',#1,

  #13,
  #13'Connect & see what does "FLYING" mean!!',#1,

  #13,'Intro by',
  #13'SSG',#1,
     'Personal greetings go to',
  #13'BLoodY - The SysOp',
     'COder - The Amiga Fan',
     'Boogie - The Wanted',
     'Neco - The Win95 Fan',
     'FatalicA - The AITD3 Fan',
     'Wiseman - The Borland Fan',
     'Tufan - The Tu Fan :)',
     'Stranger - The Stranger',
     'and other forgotten ones',
  #13'Group greetings go to',
  #13'Clique',
     'AccuracY',
     'Compuphiliacs',
  #13'Hmm, a bit short eh?',#1);

procedure FuckScreen;
var
  T:TPalette;
  our:array[fontBaseColor..fontBaseColor+8] of TRGB;
  n:byte;
  f:boolean;
begin
  for n:=1 to 100 do begin
    Sync;
    if exitRequest then exit;
  end;
  GetPalette(T);
  Move(T[fontBaseColor],our,sizeof(our));
  lasty := celsize+10;
  repeat
    f := false;
    for n:=fontBaseColor to fontBaseColor+8 do with our[n] do begin
      if (red>0)or(blue>0)or(green>0) then f:=true;
      if red > 0 then dec(red);
      if green > 0 then dec(green);
      if blue > 0 then dec(blue);
      SetRGB(n,red,green,blue);
      Sync;
    end;
  until not f;
  asm
    mov ax,0a000h
    mov es,ax
    mov ax,celsize
    add ax,10
    mov bx,320
    mul bx
    mov di,ax
    mov bx,ax
    mov ax,64000
    sub ax,bx
    mov cx,ax
    shr cx,1
    xor ax,ax
    rep stosw
  end;
  for n:=fontBaseColor to fontBaseColor+8 do with T[n] do SetRGB(n,red,green,blue);
end;

procedure Scroll(P:PChar);
var
  x:integer;
  finish:integer;
  n:integer;
  len:word;
  ok:boolean;
  s:string;
  distance:word;
  mainsize:word;
  incdec:integer;
  function getdist:word;
  begin
    if lastdir then getdist := x-finish else getdist := finish-x;
  end;
begin
  if exitrequest then exit;
  inc(lasty,10);
  if lasty+10 > 199 then FuckScreen;
  lastdir := not lastdir;
  len := StrLen(P);
  if lastdir then x := 320
             else x := -(len*8);
  finish := (320-(len*8)) div 2;
  ok := false;
  s := StrPas(P);
  mainsize := getdist div 2;
  incdec   := 16;
  while not ok do begin
    WriteStr(x,lasty,s);
    if exitRequest then exit;
    distance := getdist;
    if lastdir then begin
      dec(x,incdec);
    end else begin
      inc(x,incdec);
    end;
    if (distance <= mainsize) and (incdec > 1) then begin
      incdec := incdec div 2;
      mainsize := mainsize div 2;
    end;
    Sync;
    if not lastdir then ok := x > finish else ok := x < finish;
  end;
  Sync;
end;

procedure ESBlue;external;
{$L ESBLUE.OBJ}

procedure ESLogo;external;
{$L ESLOGO.OBJ}

procedure TextJob;
var
  put:boolean;
  Pc:PChar;
  loop:integer;
begin
  SetBIOSFont(fontBaseColor);
  repeat
    for loop:=1 to maxText do begin
      if exitrequest then break;
      put := false;
      case text[loop]^ of
        #13 : begin
                inc(lasty,10);
                put := true;
              end;
        #1  : FuckScreen;
        else Scroll(text[loop]);
      end;
      if put then begin
        Pc := text[loop];
        inc(word(Pc));
        Scroll(Pc);
      end;
    end;
  until exitrequest;
end;

var
  old9:pointer;
  old8:pointer;
  subpal:array[1..48] of byte;

procedure INit;
var
  H:TCELHeader;
  Pc:Pointer;
  PP,PP2:PPalette;
begin
  InitXMode;
  NullPalette;
  PP := @ESBlue;
  inc(word(PP),32);
  Pc := @ESBlue;
  Move(PC^,H,SizeOf(H));
  inc(word(Pc),800);
  _PutImage((320-H.XSize) div 2,0,H.XSize,H.YSize,0,Pc^);
  celsize := H.YSize;
  lasty   := celsize + 10;
  SetSmoothPal(PP^);
  PP2 := PP;
  inc(word(PP2),136*3);
  move32(PP2^,subpal,48);
end;

procedure Finish;
var
  T,T2:TPalette;
  loop:integer;
begin
  GetPalette(T);
  repeat
    for loop:=0 to 255 do with T[loop] do begin
      if red < 63 then inc(red);
      if green < 63 then inc(green);
      if blue < 63 then inc(blue);
    end;
    SetPalette(T);
    Sync;
  until IsEmpty(T,SizeOf(TPalette),63);
  asm
    mov ax,3
    int 10h
  end;
  GetPalette(T2);
  SetPalette(T);
  asm
    push ds
    push cs
    pop  ds
    mov  si,offset ESLogo
    mov  di,0b800h
    mov  es,di
    xor  di,di
    mov  cx,x_length
    mov  ah,7
    xor  dx,dx
  @Loop:
    lodsb
    cmp  al,31
    ja   @Write
    cmp  al,16
    jb   @NewFC
    cmp  al,24
    jb   @NewBC
    cmp  al,24
    je   @CR
    cmp  al,25
    je   @MulSpac
    cmp  al,26
    je   @Mul
    cmp  al,27
    jne  @Continue
    xor  ah,128
    jmp  @Continue
  @Mul:
    lodsb
    mov  bx,cx
    mov  cl,al
    xor  ch,ch
    inc  cx
    lodsb
    rep  stosw
    mov  cx,bx
    sub  cx,2
    jmp  @Continue
  @MulSpac:
    lodsb
    mov  bx,cx
    mov  cl,al
    xor  ch,ch
    inc  cx
    mov  al,32
    rep  stosw
    mov  cx,bx
    dec  cx
    jmp  @Continue
  @CR:
    add  dx,160
    mov  di,dx
    jmp  @Continue
  @NewBC:
    and  ah,$0F
    sub  al,16
    shl  al,4
    or   ah,al
    jmp  @Continue
  @NewFC:
    and  ah,$F0
    or   ah,al
    jmp  @Continue
  @Write:
    stosw
  @Continue:
    loop @Loop

    mov  ah,2
    xor  bh,bh
    mov  dh,21
    xor  dl,dl
    int  10h
    pop  ds
  end;
  SetSmoothPal(T2);
end;

begin
  INit;
  asm
    jmp  @Init
  @New9:
    push ax
    in   al,60h
    cmp  al,1
    jne  @Old
    push ds
    push seg @Data
    pop  ds
    mov  exitRequest,1
    pop  ds
  @Old:
    mov  al,20h
    out  20h,al
    pop  ax
    iret
  @In8:
    db   0
  @Temp:
    dd   0
    db   0
  @New8:
    cmp  byte ptr cs:@In8,0
    jne  @GoOld
    inc  byte ptr cs:@In8
    push ds
    push es
    pusha
    cld
    mov  ax,seg @Data
    mov  ds,ax
    mov  ax,cs
    mov  es,ax
    mov  si,offset subpal
    mov  di,offset @Temp
    movsw
    movsb
    mov  cx,45
    mov  ax,seg @Data
    mov  es,ax
    mov  di,offset subpal
    rep  movsb
    mov  ax,cs
    mov  ds,ax
    mov  ax,seg @Data
    mov  es,ax
    mov  si,offset @Temp
    mov  di,offset subpal
    add  di,45
    movsw
    movsb
    mov  ax,es
    mov  ds,ax
    mov  si,offset subpal
    mov  cx,48
    mov  dx,3c8h
    mov  al,136
    out  dx,al
    inc  dx
    rep  outsb
    popa
    pop  es
    pop  ds
    dec  byte ptr cs:@In8
  @GoOld:
    push ax
    mov  al,20h
    out  20h,al
    pop  ax
    iret
  @Init:
    push ds
    mov  ax,3509h
    int  21h
    mov  word ptr Old9,bx
    mov  word ptr Old9+2,es
    mov  ax,3508h
    int  21h
    mov  word ptr Old8,bx
    mov  word ptr Old8+2,es
    push cs
    pop  ds
    mov  dx,offset @New9
    mov  ax,2509h
    int  21h
    mov  dx,offset @New8
    mov  ax,2508h
    int  21h
    pop  ds
  end;
  TextJob;
  asm
    mov  bx,ds
    mov  dx,word ptr Old9
    mov  ax,word ptr Old9+2
    mov  ds,ax
    mov  ax,2509h
    int  21h
    mov  ds,bx
    mov  dx,word ptr Old8
    mov  ax,word ptr Old8+2
    mov  ds,ax
    mov  ax,2508h
    int  21h
    mov  ds,bx
  end;
  Finish;
end.