Хостинг портала RFpro.ru:
Московский хостер
Профессиональный ХОСТИНГ на базе Linux x64 и Windows x64

РАССЫЛКИ ПОРТАЛА RFPRO.RU

Чемпионы рейтинга экспертов в этой рассылке

lamed Статус: Профессионал Рейтинг: 2707 ∙ повысить рейтинг »

Boriss Статус: Академик Рейтинг: 2420 ∙ повысить рейтинг »

star9491 Статус: Профессионал Рейтинг: 2087 ∙ повысить рейтинг »

Вопрос № 178613: Помогите решить задачу | вопрос №178498| ( написать программу на языке turbo pascal с использованием динамических переменных, процедур и функций, модуля. Из заданного на плоскости множества точек (их координаты вводить из файла)выбрать те, которые о...

Помогите решить задачу | вопрос №178498| ( написать программу на языке turbo pascal с использованием динамических переменных, процедур и функций, модуля. Из заданного на плоскости множества точек (их координаты вводить из файла)выбрать те, которые образуют треугольники и нарисовать их) именно в среде Turbo Pascal 7.0.

Отправлен: 24.05.2010, 19:24
Вопрос задал: воронова любовь, Посетитель
Всего ответов: 1
Страница вопроса »

Приложение:
Программа: uses uPoints, CRT; const srcFileName = \'points.dat\'; function ReadData(aFileName: string; var m: PStackPoints): LongInt; var f: Text; p: TPoint; count: Longint; begin if m <> nil then pointFree(m); count := 0; ReadData := count; Assign(f, srcFileName); {$I-}Reset(f);{$I+} if IOResult <> 0 then begin WriteLn(\'Не могу открыть файл данных: \', aFileName); Exit end; while NOT EOF(f) do begin {$I-}Read(f, p.X);{$I+} if IOResult <> 0 then begin WriteLn(\'Ошибка чтения \'); continue end; {$I-}Read(f, p.Y);{$I+} if IOResult <> 0 then begin WriteLn(\'Ошибка чтения\'); continue end; pointPush(m, p); inc(count) end; Close(f); ReadData := count end; VAR memBefore, memLosted: Longint; stackP: PStackPoints; stackT: PStackTriangle; p: TPoint; BEGIN ClrScr; memBefore := MemAvail; stackP := nil; stackT := nil; WriteLn(\'Считано точек: \', ReadData(srcFileName, stackP)); pointPrint(stackP); { p.X := 20; p.Y := 20; WriteLn(\'Добавлена точка: \',arrayAdd(stackP, p, 2)); arrayPrint(stackP); if arrayGet(stackP, 0, p) then WriteLn(\'test: \',p.X,\' \',p.Y);} WriteLn(\'len = \', arrayLength(stackP)); if DoPoints(stackT, stackP) <> 0 then DrawAll(stackT); trFree(stackT); pointFree(stackP); memLosted := memBefore - MemAvail; WriteLn(\'Потеря памяти: \',memLosted); END. Модуль:uses uPoints, CRT; const srcFileName = \'points.dat\'; function ReadData(aFileName: string; var m: PStackPoints): LongInt; var f: Text; p: TPoint; count: Longint; begin if m <> nil then pointFree(m); count := 0; ReadData := count; Assign(f, srcFileName); {$I-}Reset(f);{$I+} if IOResult <> 0 then begin WriteLn(\'Не могу открыть файл данных: \', aFileName); Exit end; while NOT EOF(f) do begin {$I-}Read(f, p.X);{$I+} if IOResult <> 0 then begin WriteLn(\'Ошибка чтения \'); continue end; {$I-}Read(f, p.Y);{$I+} if IOResult <> 0 then begin WriteLn(\'Ошибка чтения\'); continue end; pointPush(m, p); inc(count) end; Close(f); ReadData := count end; VAR memBefore, memLosted: Longint; stackP: PStackPoints; stackT: PStackTriangle; p: TPoint; BEGIN ClrScr; memBefore := MemAvail; stackP := nil; stackT := nil; WriteLn(\'Считано точек: \', ReadData(srcFileName, stackP)); pointPrint(stackP); { p.X := 20; p.Y := 20; WriteLn(\'Добавлена точка: \',arrayAdd(stackP, p, 2)); arrayPrint(stackP); if arrayGet(stackP, 0, p) then WriteLn(\'test: \',p.X,\' \',p.Y);} WriteLn(\'len = \', arrayLength(stackP)); if DoPoints(stackT, stackP) <> 0 then DrawAll(stackT); trFree(stackT); pointFree(stackP); memLosted := memBefore - MemAvail; WriteLn(\'Потеря памяти: \',memLosted); END. Модуль: unit uPoints; interface {Точки, стек точек, динамический массив точек} TYPE PPoint = ^TPoint; TPoint = record X, Y: Integer; end; PStackPoints = ^TStackPoints; ParrayPoints = PStackPoints; {второе название} TStackPoints = record p : TPoint; next: PStackPoints; end; PTriangle = ^TTriangle; TTriangle = record A, B, C: TPoint; end; PStackTriangle = ^TStackTriangle; TStackTriangle = record t : TTriangle; next: PStackTriangle; end; {Средства для работы с...} {Точками} function pointPop(var m: PStackPoints; var point: TPoint): Boolean; procedure pointPush(var m: PStackPoints; point: TPoint); function pointPrint(m: PStackPoints): LongInt; {Очистка памяти, занятой стеком очереди. Нужно вызывать для всех стеков точек} procedure pointFree(var m: PStackPoints); function pointEquals(p1, p2: TPoint): Boolean; {массив точек} function arrayAdd(var m: PStackPoints; point: TPoint; elNumber: Longint): LongInt; {добавление точки с заданным индексом. Если больше, чем имелось ранее, то добавляется в конец. Возвращает индекс элемента} function arrayGet(m: PStackPoints; elNumber: Longint; var point: TPoint): Boolean; {Возвращает элемент с заданым индексом. Если больше количества содержащихся, то возвращает FALSE. Если найден, то TRUE} function arrayPrint(m: PStackPoints): Longint; {Определение количества точек в стеке = массиве} function arrayLength(m: PStackPoints): LongInt; {Очистка от остатков точек в динамической памяти} procedure arrayFree(var m: PArrayPoints); {Треугольниками} procedure trPush(var m: PStackTriangle; tr: TTriangle); function trPop( var m: PStackTriangle; var tr: TTriangle): Boolean; procedure trFree(var m: PStackTriangle); {анализирует точки, ищет треугольники и добавляет в стек Возвращает число треугольников} function DoPoints(var t: PStackTriangle; m: PArrayPoints): LongInt; {С масштабом и отступами} procedure DrawTriangle(tr: TTriangle; Scale: Real; margX, margY: Word); procedure DrawAll(var tr: PStackTriangle); {Очищает стек треугольников} implementation uses Graph, CRT; function pointPop(var m: PStackPoints; var point: TPoint): Boolean; var temp: PStackPoints; begin pointPop := FALSE; if m = nil then Exit; temp := m^.next; point := m^.p; Dispose(m); m := temp; pointPop := TRUE end; procedure pointPush(var m: PStackPoints; point: TPoint); var temp: PStackPoints; begin new(temp); temp^.p := point; temp^.next := m; m := temp; end; function pointPrint(m: PStackPoints): LongInt; var temp : PStackPoints; count: Longint; p : TPoint; begin count := 0; temp := nil; while pointPop(m, p) do begin Write(\'(\',p.X:4,\' \',p.Y:4,\') \'); inc(count); pointPush(temp, p) end; WriteLn; pointPrint := count; while pointPop(temp, p) do pointPush(m, p); end; procedure pointFree(var m: PStackPoints); var p: TPoint; begin while pointPop(m, p) do end; function pointEquals(p1, p2: TPoint): Boolean; begin pointEquals := (p1.X = p2.X) and (p1.Y = p2.Y) end; function arrayAdd(var m: PStackPoints; point: TPoint; elNumber: Longint): LongInt; var temp: PStackPoints; p: TPoint; begin {переписываем во временный стек} temp := nil; while elNumber > 0 do begin if pointPop(m, p) then begin pointPush(temp, p); dec(elNumber) end else Break end; pointPush(m, point); while pointPop(temp, p) do begin pointPush(m, p); inc(elNumber) end; arrayAdd := elNumber + 1 end; function arrayGet(m: PStackPoints; elNumber: Longint; var point: TPoint): Boolean; var temp: PArrayPoints; p: TPoint; begin arrayGet := FALSE; temp := nil; if m = nil then exit; if elNumber < 1 then Exit; while elNumber > 0 do begin if pointPop(m, p) then begin pointPush(temp, p); dec(elNumber) end else Break; end; if elNumber = 0 then begin point := p; while pointPop(temp, p) do pointPush(m, p); end else {элементов меньше чем заказано} exit; arrayGet := TRUE end; function arrayPrint(m: PStackPoints): Longint; begin arrayPrint := pointPrint(m); end; function arrayLength(m: PStackPoints): LongInt; var temp: PArrayPoints; p: TPoint; count: longInt; begin temp := nil; count := 0; while pointPop(m, p) do begin inc(count); pointPush(temp, p) end; arrayLength := count; while pointPop(temp, p) do pointPush(m, p) end; procedure arrayFree(var m: PArrayPoints); begin pointFree(m) end; {------------------ Треугольники -----------------------} procedure trPush(var m: PStackTriangle; tr: TTriangle); var temp: PStackTriangle; begin new(temp); temp^.t := tr; temp^.next := m; m := temp end; function trPop( var m: PStackTriangle; var tr: TTriangle): Boolean; var temp: PStackTriangle; begin trPop := FALSE; if m = nil then Exit; tr := m^.t; temp := m^.next; Dispose(m); m := temp; trPop := TRUE end; procedure trFree(var m: PStackTriangle); var temp: PStackTriangle; t: TTriangle; begin While trPop(m, t) do end; function DoPoints(var t: PStackTriangle; m: PArrayPoints): LongInt; var i, j, k, len: LongInt; p: TTriangle; count : LongInt; begin count := 0; if t <> nil then trFree(t); t:= nil; len := arrayLength(m); if len < 3 then Exit; for i := 1 to len-2 do begin if NOT arrayGet(m, i, p.A) then Continue; {Пропускаем} for j := i+1 to len-1 do begin if NOT arrayGet(m, j, p.B) then Continue; for k := j+1 to len do begin if NOT arrayGet(m, k, p.C) then Continue; if pointEquals(p.A, p.B) or pointEquals(p.A, p.C) or pointEquals(p.B, p.C) then Continue; {Проверка - не лежат ли на одной прямой, но запись операции такая, чтобы не произошло деления на 0} if (p.A.Y - p.B.Y)*(p.B.X - p.C.X) = (p.B.Y - p.C.Y)*(p.A.X - p.B.X) then Continue; trPush(t, p); inc(count) end end end; DoPoints := count end; {Рисование} procedure DrawAll(var tr: PStackTriangle); var gd, gm: Integer; t: TTriangle; begin gd := Detect; InitGraph(gd, gm, \'D:/BP/BGI\'); {!!!!!!! не забудьте прописать СВОЙ путь к EGAVGA.BGI} gm := GraphResult; if gm <> grOk then begin WriteLn(\'Ошибка инициализации графики: \', GraphErrorMsg(gm)); Exit; end; SetBkColor(White); SetColor(DarkGray); while trPop(tr, t) do DrawTriangle(t, 1, 0, 0); OutTextXY(10, GetMaxY -10, \'Press any key ...\'); ReadKey; CloseGraph; end; procedure DrawTriangle(tr: TTriangle; Scale: Real; margX, margY: Word); begin MoveTo(round(tr.A.X*Scale)+margX, round(tr.A.Y*Scale)+margY); LineTo(round(tr.B.X*Scale)+margX, round(tr.B.Y*Scale)+margY); LineTo(round(tr.C.X*Scale)+margX, round(tr.C.Y*Scale)+margY); LineTo(round(tr.A.X*Scale)+margX, round(tr.A.Y*Scale)+margY); end; end. Данные для тестирования: 100 100 200 100 100 300 300 300 Прикрепленный файл: загрузить »

-----
Вывод - то место в тексте, где вы устали думать

Ответ отправил: Boriss, Академик
Ответ отправлен: 26.05.2010, 17:36
Номер ответа: 261684

Вам помог ответ? Пожалуйста, поблагодарите эксперта за это! Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 261684 на номер 1151 (Россия) | Еще номера »

Отправить WebMoney: Неплохо (30 руб.) Хорошо (40 руб.) Отлично (55 руб.) БЛЕСТЯЩЕ! (80 руб.)

Оценить выпуск »
Нам очень важно Ваше мнение об этом выпуске рассылки!

Задать вопрос экспертам этой рассылки »