Flame of Soul
Главная | Регистрация | Вход

Мои записи


Главная » Статьи » Алгоритмы » Структуры данных

[PAS] Roll (Список)
== Magic Technologic Inc.==
Volume 0x0c, Algoritms 0x13, Phile #0x0a of 0x0f
|=---------------------------------------------------------------=|
|=----------------=[ Список - Структура данных ]=----------------=|
|=---------------------------------------------------------------=|
|=---------------=[ Copyright (c) Flame Of Soul ]=---------------=|
|=--------------=[
[E-mail]: _allbasse@yandex.ru ]=--------------=|
|=---------------------------------------------------------------=|
|=----------------------------=[ PAS ]=--------------------------=|
|=---------------------------------------------------------------=|
program rolls(input,output);

type
   insto   = (before,after);
   str       = string(10);
   longstr = string(60);
   dtype   = str;
   node       = record
        key  : dtype;
        next : ^ node;
        prev : ^ node;
         end;   
   ptr       = ^ node;
   roll_tp = record
        start : ^ node;
        fin   : ^ node;
        cnt   : integer;
        mark  : ^ node;
         end;    
   roll       = ^ roll_tp;
  
var
   l       : roll;
   a       : str;
   qry       : array [1..10] of str;
   qry_len : integer;
   buff       : longstr;

procedure roll_add (l : roll; val:dtype; dir:insto);
var
   q : ^ node;
begin
   new(q);
   if (l^.mark<>nil) then begin
      with l^.mark^ do begin
     if (dir=before) then begin
        q^.prev:=prev;
        if (prev<>nil) then
           prev^.next:=q
        else
           l^.start:=q;
        prev:=q;
        q^.key:=val;
        q^.next:=l^.mark;
        l^.mark:=q;
     end else begin
        q^.next:=next;
        if (next<>nil) then
           next^.prev:=q
        else
           l^.fin:=q;
        next:=q;
        q^.key:=val;
        q^.prev:=l^.mark;
        l^.mark:=q;
     end;
     inc(l^.cnt);
      end;
   end
   else begin
      with l^ do begin
     mark:=q;
     q^.next:=nil;
     q^.prev:=nil;
     q^.key:=val;
     fin:=q;
     start:=q;
     cnt:=1;
      end;
   end;
end; { roll_add }

procedure roll_rewind(l : roll; mto:integer);
var
   k : integer;
begin
   with l^ do begin
      if (abs(mto)<>cnt) then begin
     if (mto>0) then begin
        while (mto>0) do begin
           dec(mto);
           if (mark^.next=nil) then begin
          writeln ('Roll: Right of roll reached, set last position');
          break;
           end
           else
          mark:=mark^.next;
        end;
     end
     else begin
        while (mto<0) do begin
           inc(mto);
           if (mark^.prev=nil) then begin
          writeln ('Roll: Left of roll reached, set first position');
          break;
           end
           else
          mark:=mark^.prev;
        end;
     end;
      end
      else begin
     if (mto>0) then
        mark:=fin
     else
        mark:=start;
      end;
   end;
end; { roll_rewind }

procedure roll_delete(l : roll; off:integer);
var
   m : ^ node;
begin

   if (off<>0) then
      roll_rewind(l,off);
  
   if (l=nil) then begin
      writeln ("Roll doesn't exist");
      exit;
   end;
  
   if (l^.cnt=1) then begin

      if (l^.mark=nil) then
     writeln('Roll: Mark is null!');
      dispose(l^.mark);
      l^.start:=nil;
      l^.fin:=nil;
      l^.cnt:=0;
      l^.mark:=nil;
      exit;
   end;

   if (l^.cnt=0) then begin
      writeln('Roll: Roll is empty, exit');
      exit;
   end;
  
   if (l^.mark=nil) then begin
      writeln("Roll: can't delete null element, exit");
      exit;
   end;
     
   if (l^.mark^.next<>nil) and (l^.mark^.prev<>nil)
      then begin { 'E' next and prev elements }
     l^.mark^.prev^.next:=l^.mark^.next;
     l^.mark^.next^.prev:=l^.mark^.prev;
     m:=l^.mark;
     l^.mark:=l^.mark^.next;
     dispose(m);
      end
      else begin
     if (l^.mark^.next=nil) then begin { 'E' only prev element }
        roll_rewind(l,l^.cnt);
        l^.mark^.prev^.next:=nil;
        l^.fin:=l^.mark^.prev;
        dispose(l^.mark);
        l^.mark:=l^.fin;
     end
     else begin { 'E' only next element }
        if (l^.mark^.prev=nil) then begin
           roll_rewind(l,-l^.cnt);
           l^.mark^.next^.prev:=nil;
           l^.start:=l^.mark^.next;
           dispose(l^.mark);
           l^.mark:=l^.start;
        end;
     end;
      end;
   dec(l^.cnt);
end; { roll_delete }

function roll_get (l : roll; var val:dtype):boolean;
begin
   if (l^.mark<>nil) then begin
      val:=l^.mark^.key;
      roll_get:=true;
   end else
      roll_get:=false;
end; { roll_get }

procedure new_roll (var l : roll);
begin
   new(l);
   with l^ do begin
      start:=nil;
      fin:=nil;
      cnt:=0;
   end;
end; { new_roll }

function roll_search (var l : roll; val:dtype; dir:insto):boolean;
var
   find    : boolean;
  
procedure find_next(q : ptr);
begin
   if (q<>nil) then begin
      if (q^.key=val) then begin
     find:=true;
     l^.mark:=q;
      end
      else
     if (dir=before) then
        find_next(q^.prev)
     else
        find_next(q^.next);
   end;
end; { find_next }

begin
   find:=false;
   find_next(l^.mark);
   roll_search:=find;
end; { roll_search }

procedure roll_dump (l : roll);
var
   q : ^ node;
begin
   with l^ do begin
      q:=start;
      while (q<>nil) do begin
     write(q^.key:5);
     q:=q^.next;
      end;
      writeln;
   end;
end; { roll_dump }

function roll_cnt (l : roll):integer;
begin
   roll_cnt:=l^.cnt;
end; { roll_cnt }

function roll_eof (l : roll):boolean;
begin
   roll_eof:=(l^.cnt=0);
end; { roll_eof }

procedure break_roll (var l : roll);
begin
   roll_rewind(l,-l^.cnt);
   while (l^.cnt>0) do
      roll_delete(l,0);
   dispose(l);
   l:=nil;
end; { break_roll }

function val (x    : str):integer;
var
   i,res : integer;
   e     : char;
   zn     : integer;
begin
   i:=1;
   e:='1';
   res:=0;
   if (x[1]='-') then begin
      inc(i);
      zn:=-1;
   end
   else
      zn:=1;
  
   while (e<>'') do begin
      e:=x[i];
      if (e>='0') and (e<='9') then
     res:=res*10+ord(e)-ord('0')
      else begin
     break;
      end;
      inc(i);
   end;
   val:=zn*res;
end; { val }
  
procedure readqry(line : longstr);
var
   e     : char;
   i,t,z : integer;
   sp     : integer;
   s     : boolean;
   useq     : boolean;
begin
   qry[1]:='';
   i:=1;
   s:=false;
   useq:=false;
   z:=length(line);
   t:=0;
   while not (t=z) do begin
      inc(t);
      e:=line[t];
      sp:=0;
      if useq then begin
     if (e="'") then begin
        useq:=false;
        sp:=5;
     end;
      end
      else
      case e of
    ' ' :
     sp:=1; { space }
    "'" :
      begin
     useq:=true;
     sp:=2;
      end;
      end; { case }

      if (sp=0) then begin
     qry[i]:=qry[i] + e;
     s:=true;
      end
      else
      if s then begin
     inc(i);
     qry[i]:='';
     s:=false;
      end;
   end;
   qry_len:=i;
end; { readqry }

procedure qry_add;
var
   q : insto;
begin
   if (qry_len=1) then begin
      writeln('Roll: empty query');
      exit;
   end;
  
   if (qry_len<3) then
      q:=after
   else
      if (qry[3]='b') or (qry[3]='before') then
     q:=before
      else
     if (qry[3]='a') or (qry[3]='after') then
        q:=after;
  
   roll_add(l,qry[2],q);
end; { qry_add }
  
procedure qry_delete;
var
   off : integer;
begin
   if (qry_len=1) then
      off:=0
   else
      off:=val(qry[2]);
   roll_delete(l,off);
end; { qry_delete }
  
procedure qry_rewind;
var
   off : integer;
begin
   if (qry_len=1) then
      off:=-roll_cnt(l)
   else begin
      if (qry[2]='s') or (qry[2]='start') then
     off:=-roll_cnt(l)
      else
     if (qry[2]='e') or (qry[2]='end') then
        off:=roll_cnt(l)
     else
        off:=val(qry[2]);
   end;
   roll_rewind(l,off);
end; { qry_rewind }

procedure qry_force_delete;
var
   a : integer;
begin
   if (qry_len=1) then
      a:=roll_cnt(l)
   else
      a:=val(qry[2]);
  
   if (a>roll_cnt(l)) then
      writeln ('Roll: roll shorter that need')
   else begin
      roll_rewind(l,-roll_cnt(l));
      while (a>0) do begin
     dec(a);
     roll_delete(l,0);
      end;
   end;

end; { qry_force_delete }

procedure qry_get;
var
   a : dtype;
begin
   if (roll_get(l,a)) then
      writeln(a)
   else
      writeln('Roll: Some errors on geting value occured');
end; { qry_get }

procedure qry_find;
var
   q : insto;
begin
   if (qry_len=2) then
      q:=after
   else begin
      if (qry[3]='before') or (qry[3]='b') then
     q:=before;
   end;
   if not roll_search(l,qry[2],q) then
      writeln('MERoll: Find have no results');
end; { qry_find }

procedure qry_help;
begin
   writeln("Roll help
 Commands:
[a]dd (key) ([a]fter(def),[b]efore) - insert new node;
[r]ewind (to) - rewind mark to [s]tart, [e]nd or offset;
[g]et - get value of active node;
[d]elete (? offset) - delete active or offset node;
[fd]elete (num) - delete first (num) nodes;
[f]ind (key) (direct, def=after) - set mark poiter to this val
[e]mpty - empty roll or not.
");
end; { qry_help }

procedure qry_go;
begin
   if (qry[1]='add') or (qry[1]='a') then
      qry_add;
   if (qry[1]='delete') or (qry[1]='d') then
      qry_delete;
   if (qry[1]='rewind') or (qry[1]='r') then
      qry_rewind;
   if (qry[1]='print') or (qry[1]='p') then
      roll_dump(l);
   if (qry[1]='get') or (qry[1]='g') then
      qry_get;
   if (qry[1]='help') then
      qry_help;
   if (qry[1]='empty') or (qry[1]='e') then
      writeln(roll_eof(l));
   if (qry[1]='find') or (qry[1]='f') then
      qry_find;
   if (qry[1]='fdelete') or (qry[1]='fd') then
      qry_force_delete;
end; { qry_go }

begin
   qry_help;
   new_roll(l);
   while not eof do begin
      readln(buff);
      readqry(buff);
      qry_go;
   end;
   break_roll(l);
   writeln('Good bye!');
end.
|=-----------------------------=[ PAS ]=---------------------------=|
|=-----------------------------------------------------------------=|
Категория: Структуры данных | Добавил: flame (28.05.2009)
Просмотров: 589 | Рейтинг: 0.0/0 |
Всего комментариев: 0
Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]

Форма входа

Поиск

Статистика


Онлайн всего: 1
Гостей: 1
Пользователей: 0