Turkish DemoScene News reader

tdsn.pas

{ - arteffect tdsn reader - (c) 1997 SSG/arteffect - 28th Sep 97 - 15:54 - }

uses

  XStream,XColl,XBuf,XMouse,Objects,qText,XStr,Dos;

type

  PArticle = ^TArticle;
  TArticle = record
    Offs      : longint;
    Title     : string[40];
    Author    : string[39];
    IsArticle : boolean;
  end;

  PArticleCOll = ^TArticleColl;
  TArticleColl = object(TCollection)
    procedure FreeItem(item:pointer);virtual;
  end;

const

  Articles : PArticleColl = NIL; {hehe.. PArticle = particle.. partikul :)}
  Article  : PTextCollection = NIL;
  TitleStr : string[79] = '';

  MouseOK: boolean = false;

  t1 : string[79] = '"2%8V$'#19#23#18#19#4'V'#0'DXFV[V^'#21'_VGO';
  TitleSig : string[4] = 'ÄÄÄ[';
  ArtiSig  : string[9] = 'ÄarticleÄ';
  t2 : string[79] = 'OAV%%1Y'#23'$'#2'3'#16#16'35'#2'V[V'#30#2#2#6'LYY';

  TDSNFile : string[12] = 'tdsn.1';
  t3 : string[79] = #23#4#2#19#16#16#19#21#2'X'#30#25#27#19'X'#27#26'X'#25#4#17;


  kbEsc = $011b; {1b}
  kbEnter = $1c0d; {0d}
  kbDown = $5000;
  kbEnd   = $4f00;
  kbHome = $4700;
  kbLeft = $4b00;
  kbPgDn = $5100;
  kbPgUp = $4900;
  kbRight = $4d00;
  kbUp = $4800;

  SaveInt09 : Pointer = NIL;
  OldExitProc : Pointer = NIL;

var

  timer : ^longint;

procedure Error(msg:string);
begin
  qSetMode(3);
  qWriteln('The reader stuck... '+msg);
  halt(1);
end;

procedure TArticleColl.FreeItem;
begin
  Dispose(PArticle(item));
end;

procedure wrinx(port:word; inx,val:byte);assembler;
asm
  mov  dx,port
  mov  al,inx
  out  dx,al
  inc  dx
  mov  al,val
  out  dx,al
end;

function rdinx(port:word; inx:byte):byte;assembler;
asm
  mov  dx,port
  mov  al,inx
  out  dx,al
  inc  dx
  in   al,dx
end;

const

  CRTC=$3d4;

procedure setPanning(b:byte);
begin
  wrinx($3d4,8,b);
end;

procedure setScrStart(w:word);
begin
  wrinx(crtc,$c,hi(w));
  wrinx(crtc,$d,lo(w));
end;

procedure setLineCOmpare(w:word);
begin
  wrinx(crtc,$18,lo(w));
  wrinx(crtc,7,(rdinx(crtc,7) and $df) or ((w and $100) shr 3));
  wrinx(crtc,9,(rdinx(crtc,9) and $bf) or ((w and $200) shr 3));
end;

procedure tdsnFont;external;
{$L tdsnfnt}

procedure setRgb(c,r,g,b:byte);assembler;
asm
  mov  dx,3c8h
  mov  al,c
  out  dx,al
  inc  dx
  mov  al,r
  out  dx,al
  mov  al,g
  out  dx,al
  mov  al,b
  out  dx,al
end;

procedure sync;assembler;
asm
  mov  dx,3dah
@1:
  in   al,dx
  test al,8
  jne   @1
@2:
  in   al,dx
  test al,8
  je   @2
end;

function tdsnGetKey:word;
var
  k:word;
begin
  if MouseOK then begin
    Mouse_SetPos(320,96);
    repeat until Mouse_GetButtons = 0;
  end;
  repeat
    if qIsKey then begin
      tdsnGetKey := qGetKey;
      exit;
    end;
    if MouseOK then begin
      case Mouse_GetButtons of
        1: begin
          tdsnGetKey := kbEnter;
          exit;
        end;
        2: begin
          tdsnGetKey := kbEsc;
          exit;
        end;
      end; {Case}
      k := MOuse_GetY div 8;
      if k < 12 then begin
        tdsnGetKey := kbUp;
        exit;
      end else if k > 12 then begin
        tdsnGetKey := kbDown;
        exit;
      end;
    end;
  until false;
  tdsnGetKey := k;
end;

procedure ReadTDSN(filename:string);
var
  T:TDosStream;
  s:string;
  P:PArticle;
  lastpos:longint;
  start:longint;
  c:byte;
  function getSub(bs,be:char):string;
  var
    hebe:String;
  begin
    c := pos(bs,s);
    if c > 0 then begin
      hebe := copy(s,c+1,255);
      c := pos(be,hebe);
      if c > 0 then  hebe := copy(hebe,1,c-1);
      Strip(hebe);
      getSub := hebe;
    end else getSub := '';
  end;
begin
  T.Init(filename,stOpenRead);
  if T.Status <> stOK then Error('Open error');
  TDSNFile := filename;
  lastpos := 0;
  c := 0;
  start := timer^;
  qSetFC(7);
  SetRGB(7,0,0,0);
  repeat
    lastpos := T.GetPos;
    SReadln(T,s);
    if IOResult <> 0 then Error('Read error');
    inc(c);
    if c > 24 then break;
    if pos(TitleSig,s) > 0 then break;
    qwriteln(s);
  until T.GetPos = T.GetSize;
  if T.GetPos = T.GetSize then Error('Not a TDSN file?');
  SetRGB(7,30,40,30);
  New(Articles,Init(20,20));
  T.Seek(lastpos);
  while T.GetPos < T.GetSize do begin
    lastpos := T.GetPos;
    SReadln(T,s);
    if pos(TitleSig,s) > 0 then begin
      qLocate(75,24);
      qWrite(z2s((T.getSize-T.GetPos)*1000 div T.GetSize,3));
      New(P);
      P^.Title := getSub('[',']');
      if P^.Title = 'END OF TDSN' then begin
        Dispose(P);
        break;
      end;
      P^.Author := getSub('(',')');
      c := pos(ArtiSig,s);
      P^.IsArticle := c > 0;
      P^.Offs := T.GetPos;
      Articles^.Insert(P);
    end;
  end;
  repeat until timer^-start > 55;
  c := 32;
  repeat
    setRGb(7,(c*30) div 40,c,(c*30) div 40);
    start := timer^;
    dec(c,8);
    while timer^-start = 0 do ;
  until c = 0;
end;

function ChooseTDSN(s:string):string;
begin
  s := getParse(s,'|',1); {tis gonna be better}
end;

procedure ReadTDSNs;
var
  dirinfo:SearchRec;
  b:byte;
  w:word;
  s:string;
begin
  if paramCount > 0 then s := ParamStr(1) else begin
    FindFirst('tdsn.*',Archive+Hidden+SysFile+ReadOnly,dirinfo);
    s := '';
    while DosError = 0 do begin
      b := pos('.',dirinfo.name);
      if b > 0 then begin
        w := s2l(copy(dirinfo.name,b+1,3));
        if w > 0 then s := s + dirinfo.name+'|';
      end;
      FindNext(dirinfo);
    end;
    if s <> '' then dec(byte(s[0]));
    b := pos('|',s);
    if b > 0 then s := ChooseTDSN(s);
  end;
  ReadTDSN(s);
end;

procedure Waybe;
var
  b:byte;
begin
  titleStr := t1+t2+t3;
  for b:=1 to length(TitleStr) do TitleStr[b] := char(byte(TitleStr[b]) xor $76);
end;

procedure ReadArticle(P:PArticle);
var
  T:TDosStream;
  s:String;
begin
  T.Init(TDSNFile,stOpenRead);
  if T.Status <> stOK then Error('open error: '+tdsnfile);
  T.Seek(P^.Offs);
  if Article = NIL then New(Article,Init(25,25)) else Article^.FreeAll;
  while T.GetPos < T.GetSize do begin
    setRgb(5,Random(63),Random(63),Random(63));
    SReadln(T,s);
    setRgb(5,63,0,63);
    if pos(titleSig,s) > 0 then break;
    if s = '' then s := #32;
    Article^.Insert(NewStr(s));
  end;
  T.Done;
end;

procedure ViewArticle(index:integer);
var
  k:word;
  scrtop:longint;
  scrend:longint;
  lasttop:longint;
  P:PArticle;
  procedure initArticle;
  begin
    P := Articles^.At(index);
    ReadArticle(P);
    setLineCompare(400-17);
    setScrStart(160);
    qLocate(0,0);
    qSetColor(5,1);
    qWrite(' '+Fix(P^.Title,50)+' '+RFix(P^.Author,27)+' ');
    lasttop := -1;
    scrtop := 0;
    scrend := (Article^.Count-23)*16;
    if scrend < 0 then scrend := 0;
  end;

  procedure DrawArticle;
  var
    y:integer;
    s:string;
    top:longint;
    ofs:longint;
  begin
    qSetColor(7,0);
    top := scrtop div 16;
    ofs := scrtop mod 16;
    Sync;
    SetPanning(ofs);
    if lasttop = top then exit;
    for y:=0 to 25 do begin
      qLocate(0,y+1);
      if y+top <= Article^.Count-1 then s := PString(Article^.At(y+top))^
                                      else s := '';
      FastFix(s,80);
      qWrite(s);
    end;
    lasttop := top;
  end;

  procedure go(where:longint);
  var
    dist:longint;
    delta:longint;
    curdist:longint;
    di:integer;
    start:longint;
  begin
    if where < 0 then where := 0;
    if where > scrend then where := scrend;
    dist := where-scrtop;
    if dist < 0 then begin
      delta := -1;
      dist := abs(dist);
    end else delta := 1;
    di := delta;
    start := scrtop;
    repeat
      inc(scrtop,delta);
      if scrtop < 0 then scrtop := 0;
      if scrtop > scrend then scrtop := scrend;
      Sync;
      DrawArticle;
      curdist := abs(scrtop-start);
      if curdist >= dist then break;
      if curdist >= (dist div 2) then begin
        dec(delta,di);
        if delta = 0 then delta := di;
      end else inc(delta,di);
      if qIsKey then qGetKey;
    until false;
    ScrTop := where;
    DrawArticle;
  end;

  procedure FastGo(where:longint);
  var
    i:longint;
    x:longint;
  begin
    if where < 0 then where := 0;
    if where > scrend then where := scrend;
    x := scrtop;
    if where < scrtop then for i := x downto where do begin
      scrtop := i;
      Sync;
      DrawArticle;
    end else for i := x to where do begin
      scrtop := i;
      Sync;
      DrawArticle;
    end;
  end;

begin
  initArticle;
  repeat
    DrawArticle;
    k := tdsnGetKey;
    case k of
      kbUp : Go(scrtop-16);
      kbDown : Go(scrtop+16);
      kbPgUp : Go(scrtop-(23*16));
      kbPgDn : Go(scrtop+(23*16));
      kbHome : Go(0);
      kbEnd  : Go(scrend);
      kbLeft : begin
        dec(index);
        if index < 0 then index := Articles^.Count-1;
        initArticle;
      end;
      kbRight,kbEnter : begin
        index := (index+1) mod Articles^.Count;
        initArticle;
      end;
      kbEsc : break;
    end; {case}
  until false;
  qSetColor(7,0);
  qCls;
  setLineCompare(400);
  setPanning(0);
  setScrStart(0);
end;

procedure GoRead;
const
  ctable : array[3..19] of byte =
    (1,2,3,3,4,4,4,4,5,4,4,4,4,3,3,2,1);
  bval : array[1..5] of byte =
    (25,30,40,50,63);
var
  k:word;
  focused:integer;
  procedure DrawMenu;
  var
    s:string;
    P:PArticle;
    n:integer;
    scrtop:integer;
    y:byte;
  begin
    Sync;
    scrtop := focused-8;
    for y:=3 to 19 do begin
      n := (y-3)+scrtop;
      if (n>=0) and (n<Articles^.Count) then begin
        P := Articles^.At(n);
        if P^.IsArticle then s := '    "'+P^.Title+'"'
                        else s := P^.Title;
        FastFix(s,40);
        if P^.Author <> '' then s := s + RFix('('+P^.Author+')',25);
      end else s := '';
      FastFix(s,75);
      qLocate(5,y);
      qSetFC(ctable[y]);
      qWrite(s);
    end;
  end;
begin
  qCls;
  setRgb(0,0,0,0);
  setRgb(7,40,40,30);
  setRgb(6,40,50,40);
  for k:=1 to 5 do setRgb(k,bVal[k],0,bVal[k]);
  while qIsKey do qGetChar;
  focused := 0;
  qLocate(0,0);
  qWrite(titleStr);
  repeat
    DrawMenu;
    k := tdsnGetKey;
    case k of
      kbUp : if focused > 0 then dec(focused);
      kbDown : if focused < Articles^.Count-1 then inc(focused);
      kbEnter : begin
        ViewArticle(focused);
        qLocate(0,0);
        qWrite(titleStr);
      end;
    end; {Case}
  until k=kbEsc;
  qSetMode(3);
  qWriteln(titleStr);
end;

procedure init;
begin
  if paramCount > 0 then if paramStr(1) = '/?' then begin
    qWriteln('Usage: TDSN [filename]');
    halt(1);
  end;
  timer := Ptr(Seg0040,$6c);
  MouseOK := Mouse_init;
  if MouseOK then Mouse_Hide;
  qSetMode(3);
  qCursor(false);
  qSetFont(@tdsnFont^);
  Waybe;
end;

begin
  init;
  ReadTDSNs;
  GoRead;
end.