06.05.2014, 21:46 | #1 (permalink) |
Новичок
Регистрация: 06.05.2014
Сообщений: 5
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
|
USES crt; CONST zs : set of char = ['Ў','ў','Ј','¤','¦','§','«','¬','*' ,'а']; VAR st : string[79]; d, n, k, i : integer; sl, mnechet, mchet, vm : set of char; chet : boolean; c : char; BEGIN clrscr; st:=' Ў®а®§¤*, Ў®а®**, ¦Ёа*д, ЎҐбᮤҐа¦**ЁҐ, ¦*а*'; writeln('‚ўҐ¤ЁвҐ бва®Єг, а*§¤Ґ«пп б«®ў* §*Їпвл¬Ё'); readln(st); writeln; d:=LENGTH(st); while (d>0) and (st[d]=' ') do d:=d-1; if d=0 then write('ЂЌЋЊЂ‹€џ: бва®Є* Їгбв*п') else begin chet:=true; mnechet:=[]; mchet:=[]; n:=1; while n<=d do begin while st[n]=' ' do n:=n+1; k:=POS(',',COPY(st,n,d-n+1)); if k=0 then k:=d else k:=k+n-1-1; { k:=n; while (k<=d) and (st[k]<>',') do k:=k+1; k:=k-1; } chet:=not chet; sl:=[]; for i:=n to k do sl:=sl+[ st[i] ]; if chet then mchet:=mchet+(zs-sl) else mnechet:=mnechet+(zs*sl); n:=k+2; end; vm:=mchet*mnechet; writeln('‡‚ЋЌЉ€… ‘Ћѓ‹Ђ‘Ќ›…, ЉЋ’Ћђ›… ‚•Ћ„џ’ •Ћ’џ Ѓ› ‚ Ћ„ЌЋ Ќ…—…’ЌЋ… ‘‹Ћ‚Ћ'); writeln('€ Ќ… ‚•Ћ„џ’ •Ћ’џ Ѓ› ‚ Ћ„ЌЋ —…’ЌЋ…:'); if vm=[] then write('таких букв нет') else for c:='Ў' to 'а' do if c IN vm then write(c,' '); end; readln; END. |
06.05.2014, 21:46 | |
Helpmaster
Member
Регистрация: 08.03.2016
Сообщений: 0
|
По запросам найдены топики, которые по содержанию схожи с вашим Паскаль. Задача Задача Паскаль Задача. Паскаль Задача, Паскаль Задача на Паскаль ABC Задача Паскаль |
20.05.2014, 22:15 | #3 (permalink) |
Новичок
Регистрация: 06.05.2014
Сообщений: 5
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
|
Нужна помощь.
Здравствуйте!
Я следил за вашим диалогом с pashasnuff. Так как у меня похожая задача. Мне помогли сделать ее. Но она сделана с помощью массива, а задание состоит сделать ее с помощью множеств. Не могли мне помочь выполнить это задание с помощью множеств. Я понимаю, что с помощью массивов сделать ее намного легче. Но преподаватель требует что бы сделали ее с помощью множеств. Задание: Вводится непустая строка из строчных букв(не более 79 символов). Отдельные слова в ней разделены запятыми(слева и справа от запятой могут быть пробелы). Вывести на печать в алфавитном порядке. Гласные, которые не входят более, чем в одно слово. Вот код: program stroki; {uses crt;{Подключение модуля работы с экраном. Есть о обычном Паскале} label 3; procedure vvod(var sp:string; var lp:integer); begin writeln('Введите строку слов, разделенных запятыми:'); readln(sp); sp:=sp+'.'; lp:=length(sp); writeln; end; procedure tek_slovo(sp:string;lp:integer;var ip:integer;var s1p:string;var l1p:integer); begin s1p:=''; while (sp[ip]<>',')and (sp[ip]<>'.')and (sp[ip]<>' ')do begin s1p:=s1p+sp[ip]; l1p:=length(s1p); inc(ip); end; end; var s,s1,s2,s3:string; l,l1,i,j,k,b:integer; a: array[1..20] of string [20]; begin 3: {clrscr;{очистка экрана. Есть в обычном Паскале} writeln('Меню:'); writeln('Слова в алфавитном порядке - 1'); writeln('Уникальные символы строки - 2'); writeln('Выход из программы - 0'); writeln('Выберите номер пункта меню:'); readln(k); case k of 1:begin vvod(s,l); i:=0; b:=0; writeln('Cлова в алфавитном порядке'); while i<=l-1 do begin inc(i); {Выделение текущего слова} if (s[i]<>' ')then begin {в s1 - текущее слово} tek_slovo(s,l,i,s1,l1); inc(b); {b:=b+1} a[b]:=s1; end; end; {сортировка массива слов (массив А)методом "пузырька"} for i:=1 to b-1 do for j:=i+1 to b do if a[i]>a[j] then begin s2:=a[i]; a[i]:=a[j]; a[j]:=s2; end; s3:=''; {слова в алфавитном порядке} for j:=1 to b do s3:=s3+a[j]+', '; writeln (s3); goto 3; end; 2:begin vvod(s,l); i:=0; s3:=''; writeln('Гласные, которые не входят более, чем в одно слово'); while i<=l-1 do begin inc(i); {Выделение текущего слова} if (s[i]<>' ')then begin tek_slovo(s,l,i,s1,l1); s2:=s; {Вспомогательная строка} {Удаление текущего выделенного слова из вспомогательной строки} delete(s2,i-l1,l1); {Если очередная буква выделенного текущего слова ни разу не входит во вспомогательную строку без него и не входит в результирующую строку, содержащую уникальные символы, то она заносится в результирующую строку s3} for j:=1 to l1 do if (pos(s1[j],s2)=0) and (pos(s1[j],s3)=0)then s3:=s3+' ' +s1[j]; end; end; {Уникальные символы} writeln (s3); goto 3; end; {1} 0:exit; end;{case} end. |
21.05.2014, 10:22 | #4 (permalink) | |
Специалист
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
|
Цитата:
|
|
21.05.2014, 16:04 | #5 (permalink) |
Специалист
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
|
А вообще - ладно, . Да и задачка уж больно забавная. Держите:
Код:
Type SC=Set of Char; Const Sonants:SC=['б','в','г','д','ж','з','л','м','н','р']; Var W:Array[1..40] of SC; S:String; C:Char; i,j,N,L:integer; Found:SC; b1,b2:boolean; Begin Writeln('Введите строку:'); Readln(S); L:=Length(S); Writeln; j:=1; i:=0; Repeat W[j]:=[]; repeat Inc(i); If (S[i]<>',') and (i<L) and (S[i] in Sonants) and not (S[i] in W[j]) then W[j]:=W[j]+[S[i]]; until (S[i]=',') or (i=L); if i<L then Inc(j); Until i=L; N:=j; Found:=[]; for C:='б' to 'р' do begin b1:=false; for j:=1 to N do if (j mod 2)=1 then if C in W[j] then b1:=true; if b1 then begin b2:=false; for j:=1 to N do if (j mod 2)=0 then if not (C in W[j]) then b2:=true; end; if b1 and b2 and not (C in Found) then Found:=Found+[C]; end; If Found=[] then Writeln('Таких букв нет!') else begin Writeln('Результат:'); for C:='б' to 'р' do if C in Found then write(C+' '); end; Readln End. |
Ads | |
Member
Регистрация: 31.10.2006
Сообщений: 40200
Записей в дневнике: 0
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 55070
|
|
|