Добавил:
Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз: Предмет: Файл:

roll

.pas
Скачиваний:
19
Добавлен:
16.12.2014
Размер:
9.1 Кб
Скачать
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.