Разработка программы «Киноафиши» на языке Turbo Pascal 7.1, страница 7

procedure menu_s(x,y:integer;top:pzds);

var temp:pzds;i,l,poz:integer;codkey:char;

begin

  temp:=top;l:=0;poz:=1;

  while temp<>nil do begin l:=l+1;temp:=temp^.next;end;

  if (l>0)and(l<9) then

  begin

    repeat temp:=top;

      window(x,y,x+12,y+l+1); textcolor(13);

       writeln('ЪДДДДДДДДДДї'); l:=0;

      while temp<>nil do

      begin

        write('і');l:=l+1;if l=poz then textcolor(13) else textcolor(10);write(temp^.capt);textcolor(13);

        writeln('і');temp:=temp^.next;

      end;

      write('АДДДДДДДДДДЩ');

      temp:=top;for i:=1 to poz-1 do temp:=temp^.next;

      gotoxy(2,1+poz);

      codkey:=readkey;

      case codkey of

        #72 : {up}  if poz>1 then

              begin poz:=poz-1;temp:=temp^.pred;end;

        #80 : {down} if poz<l then

              begin poz:=poz+1;temp:=temp^.next;end;

        #13 : {enter} if temp^.down1<>nil

              then menu_s(20+(poz+2),y+5,temp^.down1)

               else trassa(temp^.num_k);

      end;

    until codkey=#27;

    clrscr;

  end;

end;

{-----------------------------------------}

procedure menu_l(x,y:integer;top:pzds);

var temp:pzds;l,i,poz:integer;codkey:char;

begin temp:=top;l:=0;poz:=1;

  while temp<>nil do begin l:=l+1;temp:=temp^.next;end;

  if (l>0)and(l<7) then

  begin

  repeat   temp:=top;

    window(x,y,11*l+x+2,y+2);textcolor(10);

    write('ЪДДДДДДДДДД');for i:=2 to l do write('ДДДДДДДДДДД'); writeln('ї');

    while temp<>nil do

    begin

      write('і',temp^.capt);temp:=temp^.next;

    end;  writeln('і');

    write('АДДДДДДДДДД');for i:=2 to l do write('ДДДДДДДДДДД'); write('Щ');

    temp:=top;for i:=1 to poz-1 do temp:=temp^.next;

    gotoxy(2+11*(poz-1),2);

    codkey:=readkey;

    case codkey of

    #75 : {left}  if poz>1 then

          begin poz:=poz-1;temp:=temp^.pred;

          end;

    #77 : {right} if poz<l then

           begin poz:=poz+1;temp:=temp^.next;

           end;

    #13 : {enter} if temp^.down1<>nil

           then begin textcolor(10);menu_s(2+(poz-1)*11,y+2,temp^.down1);end

          else trassa(temp^.num_k);

    end;

    until codkey=#27;

  clrscr;

  end;

end;

procedure item_add( var t1:pzds; var t2:pzds; c:string; n:integer );

var temp: pzds; yn:integer;

begin  new(temp);

  temp^.capt:=c; temp^.num_k:=n; temp^.next:=nil;

  temp^.down1:=nil; temp^.down2:=nil;

  if t1=nil  then begin t1:=temp;       temp^.pred:=nil end;

  if t2<>nil then begin t2^.next:=temp; temp^.pred:=t2; end;

  t2:=temp;

end;

procedure ds_find(t1:pzds; var tfind:pzds; n:integer);

var temp : pzds;

begin

  if t1<>nil then

  begin temp:=t1;

     while (tfind=nil) and (temp<>nil) do

     begin  if temp^.num_k=n then tfind:=temp

            else if temp^.down1<>nil then ds_find(temp^.down1,tfind,n);

            temp:=temp^.next;

     end;

  end;

end;

procedure file_to_ds(var top:pzds);

var tfind:pzds;n,np:integer; c:string[10]; fn:text;

begin

  new(top);top^.num_k:=0;top^.capt:='___Head___';

  top^.next:=nil;top^.down1:=nil;top^.down2:=nil;

  assign(fn,'g:\menu1.txt');reset(fn);

  while not eof(fn) do

    begin readln(fn,c,n);np:=n div 10;

       tfind:=nil;ds_find(top,tfind,np);

       if tfind=nil

         then writeln('!paren np=',np,' not found, ntem n=',n:2,' not install!')

         else item_add( tfind^.down1,tfind^.down2,c,n);

    end;

  close(fn);

end;

begin

assign(Spisok, 'Spisok');

   assign(tabl,   'g:\Tabl.txt');

   textbackground(0); textcolor(14);

   a.nom:=0; n:=0; top_menu:=nil;

   clrscr;

   file_to_ds(top_menu);

   menu_l(2,1,top_menu^.down1);

end.

Список использованной литературы

1.  Т. А. Павловская, «Паскаль. Программирование на языке высокого уровня»; Питер, М. – 2007;

2.  «Турбо Паскаль 7.0.», Алексеев Е.Р. и др.; NT Press, М. – 2006;

3.  Лекции по дисциплине «Информатика и программирование» канд.техн.наук, доц. Е.В. Редькова.