Board index » delphi » Smooth Scrolling Text/Source

Smooth Scrolling Text/Source

{ ------------------------------------- }
{ Why does it flicker, when I scroll ?? }
{ ------------------------------------- }

{ Please excuse of posting a source, but I think it is easier to }
{ understand my source than understanding my english             }

{ ------------------------------ CUT HERE ---------------------------------}

{   Scroll Up and Down with "."and ";"  }

{   Most routines are nod made by me ..   }
{   I got them from SWAG i think          }

{ Nearly no documentation :) }

uses crt;

const rows=200;    { Should be greater than 25, do see the problem }

var i     : integer;
    qc    : char;
    qs    : byte;
    Start : pointer absolute $b800:0;        { Eine Zeile VOR dem sichtbaren
    Bereich }
    Blick : pointer absolute $b800:160;      { Sichtbarer Bereich }
    txt   : array[1..rows] of string[80];

procedure vretrace; assembler; { vertical retrace }
asm
  mov dx,3dah
 @vert1:
  in al,dx
  test al,8
  jz @vert1
 @vert2:
  in al,dx
  test al,8
  jnz @vert2
end;

procedure VFine(y:byte);assembler;
asm
    mov  dx,03d4h
    mov  ah,Y
    mov  al,8
    out  dx,ax
end;

{ Not needed by me...  perhaps you'll need that }
{
procedure scroff(soffset:integer);assembler;
asm
  cli
  mov dx,03d4h
  mov bx,soffset
  mov ah,bh
  mov al,00ch
  out dx,ax
  mov ah,bl
  inc al
  out dx,ax
  sti
end;

Quote
}

procedure fasttext(x, y : word; col : byte; what : string);assembler;
asm
      push   ds

      dec    [x]
      dec    [y]
      mov    ax, $b800
      mov    es, ax
      mov    ax, [y]
      mov    bl, 160
      mul    bl
      add    ax, [x]
      add    ax, [x]
      mov    di, ax

      lds    si, what
      cld
      lodsb
      xor    ch, ch
      mov    ah, [col]
      mov    cl, al
      cmp    cx, 0
      jz     @@2

 @@1: lodsb
      stosw
      loop   @@1

 @@2:
      pop    ds
end;

Function formatstr(kette:string;typ,laenge:byte):string;
{ These routines are not fast, but they are not important for me }
{ Wenn Typ=1 dann linksorientiert  }
{      Typ=2 dann Mittig           }
{      Typ=3 dann rechtsorientiert }
begin
  if length(kette)>laenge then
  delete(kette,succ(laenge),length(kette)-laenge);
  Case typ of
        1 : while length(kette)<laenge do
            begin
              insert(' ',kette,succ(length(kette)));
            end;
        2 : while length(kette)<laenge do
            begin
              insert(' ',kette,succ(length(kette)));
              insert(' ',kette,1);
              if length(kette)>laenge then delete(kette,succ(laenge),1);
            end;
            { Schlecht programmiert, aber funktioniert ! }
        3 : while length(kette)<laenge do
            begin
              insert(' ',kette,1);
            end;
  end; { CASE }
  formatstr:=kette;
end;

procedure ScreenDown;
{ What I make is: I scroll the screen (pixel by pixel) and than add a new }
{ line out of the visible Screen }
var n:byte;
begin
  vretrace;
  vfine(0);
  move(Blick,Start,4160);
  inc(qs);
  fasttext (1,27,$0F,txt[qs+26]);
  for n:=0 to 15 do
  begin
    vretrace;
    vfine(n);
  end;
end;

procedure ScreenUp;
{ Here I wanted to do the same (except putting the first line), but some-  }
{ how it has a worse result !                                              }
                                    { Can you please tell me             }
var n:byte;                         { what must I do, to stop flickering }
begin                               { in here ?                          }
  for n:=15 downto 0 do
  begin
    vretrace;
    vfine(n);
  end;
  vretrace;
  move(Start,Blick,4160);
  if qs>1 then fasttext (1,1,$0F,txt[pred(qs)]);
  vfine(15);
  dec(qs);
end;

function I2S(I: Longint): String;
var
  S: string[11];
begin
  Str(I, S);
  s:=formatstr(s,3,3);
  I2S:=S;
end;

procedure make_text;
{ Creates virtual text .. only for testing purposes }
var nn:byte;
begin
  for nn:=1 to rows do
  begin
    txt[nn]:='Line '+i2s(nn)+': '+formatstr('ExampleTxt',random(3)+1,70);
  end;
end;

begin
  textattr := 15;
  clrscr;
  asm        { Cursor Off }
    mov   ah,01
    mov   ch,20h
    int   10h
  end;
  qs:=0;      { Counts the number of current top line }
  make_text;  { Create Virtul Text }
  fasttext(1,1,$0F,formatstr(' ',1,80));    { Make Blank first Line }
  for i:=2 to succ((ord(rows<=30)*rows)+(ord(rows>30)*30)) do
  BEGIN
    fasttext (1,i,$0F,txt[i-1]);
  END;
  for i := 0 to 15 do   {  Scroll a little bit down, to set           }
  begin                 {  the starting Screen to hmmm to that it is  }
    vretrace;           {  working ...                                }
    vfine (i);
  end;
  while keypressed do readkey;
  repeat
    qc:=' ';
    if keypressed then
    begin
      qc:=readkey;
      if (qc='.') and ((qs+25)<rows) then ScreenDown;
      if (qc=';') and (qs>=1) then ScreenUp;
    end;
  until qc='q';
  textmode(co80);
end.

{ ------------------------------ CUT HERE ---------------------------------}

{ Please help me... }
--
Our Project should be  | A Salam Aleikum |     /   |  _     \ |        | |
to rescue the whole    |                 |  _o_\_,_;_(_  '_o_\;__,_,_,_; |
World          {NUSI}  |                 | (    ..       (

 

Re:Smooth Scrolling Text/Source


In article <42fuar$...@news.cs.tu-berlin.de>,
Quote
Nusret Tasci <n...@cs.tu-berlin.de> wrote:

:{ Please excuse of posting a source, but I think it is easier to }
:{ understand my source than understanding my english             }

There is nothing wrong with what you did. Posting TP source code in
plain ascii in clpb is ok as long as it is of reasonable length,
like yours is.

   All the best, Timo

....................................................................
Prof. Timo Salmi   Co-moderator of news:comp.archives.msdos.announce
Moderating at ftp:// & http://garbo.uwasa.fi archives  193.166.120.5
Department of Accounting and Business Finance  ; University of Vaasa
t...@uwasa.fi http://uwasa.fi/~ts BBS 961-3170972; FIN-65101,  Finland

Other Threads