Модераторы: Poseidon, Snowy, bems, MetalFan

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> Конкурс среди Delphi-программистов, Объявляется набор участников. 
:(
    Опции темы
Alexeis
  Дата 10.10.2008, 09:53 (ссылка) |    (голосов:19) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459




Конкурс среди Delphi-программистов


Мы объявляем о начале конкурса по программированию. Участие в конкурсе – отличный способ 
оценить уровень своих знаний. Каждый день мы пишем какой-то код, решая различные задачи. Но 
все эти задачи являются типовыми и со временем выполняются на «автомате». Повышение 
мастерства программиста, наоборот, происходит при решении оригинальных задач, при изучении 
нового материала, когда программист думает. Данный конкурс позволит всем желающим проверить 
уровень своих знаний и сообразительность.
Данный конкурс является первым у нас, и мы надеемся, что проведение подобных конкурсов в 
будущем станет хорошей традицией.

Правила участия в конкурсе по программированию

1.Регистрация участников
К участию в конкурсе допускаются все желающие, при соблюдении данных правил.
Для того, чтобы стать участником, нужно быть зарегистрированным участником форума Vingrad. 

До 15 октября 2008 года надо направить заявку на участие в конкурсе.  Для этого необходимо
 написать сообщение в данной теме с содержанием «Буду участвовать» или отправить ПМ представителям комиссии. Отправляем сюда 
Участие в конкурсе бесплатное.


2.Сроки проведения конкурса 
Конкурсное задание высылается всем участникам по внутренней почте форума (PM) и публикуется на
 форуме 16 октября в 12-00 (МСК).
С 16 по 19 октября 2008 года включительно будут приниматься решения внутреннюю почту (PM) участника Отправляем сюда 
C 20 по 23 октября будет проводиться рассмотрение предоставленных решений путем тайного 
голосования внутри комиссии по проведению конкурса.
К 24 октября будет объявлен победитель с его решением. И выставлены все решения, для того чтобы 
все убедились в справедливости решения.

3.Выбор победителя 
Победа в конкурсе подразумевает 100% правильное решение задачи (при всевозможных входных условиях задачи программа давала заданный условием результат).
При отсутствии решений в соответствии с вышесказанным условием конкурс может быть признан 
недействительным.
Критерии оценки правильности решения будут указаны в тексте задачи.
По результатам конкурса будет только один победитель. Если решений, которые претендуют на 
победу, больше – будет отобрано то, которые было прислано раньше.

4.Призы 
Победитель будет немедленно переведен в группу «Эксперт», а также получит 5 баллов репутации. 
Всем участникам предоставившим рабочее решение хотя бы одной задачи будет повышена репутация на один балл. Занявшим 2 и 3е место на 3 и 2 бала соответственно.

5.Заключительные положения 
Исходные тексты решения необходимо писать 100% на Delphi в любой версии, но используя 
синтаксис Delphi 7.
Информация о победителе и его решение будет опубликовано на форуме.
Выбор победителей проводится силами комиссии по проведению конкурса. Её состав : Rrader
AlexeisSnowyGirderDecember.
Победитель объявляется один раз, без возможности пересмотра.
Данный конкурс является некоммерческим. 
Комиссия по проведению конкурса обязуется неукоснительно соблюдать данные правила. В случае 
возникновения разногласий, которые на урегулированы данными правилами, – комиссия по 
проведению конкурса оставляет за собой право вносить односторонние изменения в правила с 
последующим уведомлением всех участников.

---------------------------------------------------

Зарегистрированные участники: 
morpheyushkakemiistoTHandleStaruhaCoderjsaBose
MakPocctHE_EGOiSTEmr.AndersonQu1ntMetalFanChristoph
aktubaSneG0KPoseidon,klimrmadWaReZMENILyAHA
ilBEastline0nVICTARigimonBaD_SeCt0RVanHelsing
ShaggyMadCoder,586MriboAversSanechichek,DCeres,
Frees,Telepyz,safon777,Rennigth,pseud,bems~FoX~
AndreyZ53,AntonN,Alix,Felan,RockClimber,Matematik,
Solitaire,Pichuser,Yanis,actualSajtran,Mauzer91MERLIN123.

-------------------------------------------------------------------------------------------------------------------

Задания на конкурс

1) Задача на алогоритм
Дана матрица случайных чисел m x n (m и n) константы (например 10 на 10). Требуется отсортировать ее элементы по спирали. Т.е. для матрицы 3 х 3 получить примерно такой результат. 
123
894
765

Вывод по своему усмотрению. Можно и в консоль.

Критерии оценки задания: лучшим будет считаться такое решение, которое будет быстрее всех.
------------------------------------------------------------------------------------

2)Задача на потоки.
  Условие: Есть Хулиган с мусорными пакетиками и дворник. Задача хулигана разбросать все мусорные пакетики и при этом не попасться на глаза дворнику. Задача дворника убирать мусор и накостылять хулигану smile . 
  Поле состоит из 60 ячеек (одномерное). 
  Хулиган появляется в произвольной позиции на поле и выбрасывает за раз только 1 пакетик (занимает ячейку) в течении 60мс, после чего он исчезает чтобы через 300 мс появиться в новой позиции начать там гадить. У хулигана запас 22 пакетика.
  Дворник бегает от края до края поля за раз сметая 3 бумажки (очищая 3 соседние ячейки) в течении 400мс.
  Условие поимки. Попытка одновременного доступа (2х потоков) к общей ячейке.

  Требование к решению. В программе должно быть 3 потока (Основной, дворник, хулиган) + простейшая отрисовка в виде ячеек.

  В атаче пример реализации (зеркало http://narod.ru/disk/3216906000/huligan_vs_Dvornik.zip.html) . 3 красных квадарата это дворник в процессе уборки. Ячейки рисуются по XOR во время уборки и заполняется белым после очистки, пакетик хулигана на время выброса становиться желтым, а после ухода становиться синим. Красным кружком помечается позиция где пойман хулиган.

  Примечание: графическая отрисовка может отличаться от предложенной, но тогда, дополнительно, потребуется ее описание. 

Критерии оценки задания: лучшим будет считаться такое решение, которое будет правильнее всех, т.е. грамотная синхронизация потоков, без лишних простоев и одновременных обращений к общей памяти. Также будет учитываться прозрачность кода и наглядность визуализации.
--------------------------------------------------------------------------------------

3) На знание внутренних механизмов Delphi.

В Delphi конструктор любого класса может работать в двух режимах:

1) Режим создания нового экземпляра объекта:
Код

...
var
  Button: TButton;
begin
  Button := TButton.Create(Nil);
end;


2) Но можно сделать и так:
Код

...
var
  Button: TButton;
begin
  Button := TButton.Create(Nil);
  Button.Create(Nil);
end;


Во втором случае просто произойдет реинициализация экземпляра класса.

Представьте, что перед Вами возникла задача создать экземпляр некоторого класса в "чужом" приложении. Что для этого нужно? Ну, во-первых, сам класс, который будет создан, во-вторых, режим работы (создание нового или реинициализация уже созданного экземпляра).
Если конструктор класса может принимать параметры, то они также понадобятся. Зная адрес конструктора, его можно вызвать. 

Отмечу один из важнейших моментов при работе с "чужими" приложениями - для начала все действия нужно проверять на своем приложении. Задание посвящено методике создания классов в "чужих" приложениях.

Итак, дан простой класс, имеющий конструктор с целочисленным параметром. Он просто выводит сообщение с переданным при создании числом.

Код

type
 TDummy = class(TObject)
  private
    FValue: Integer;
  public
    procedure ShowValue; virtual;
    constructor Create(Value: Integer); virtual;
  end;

implementation

{ TDummy }

constructor TDummy.Create(Value: Integer);
begin
  inherited Create;
  FValue := Value;
  ShowValue;
end;

procedure TDummy.ShowValue;
begin
  ShowMessage('Value is: ' + IntToStr(FValue));
end;


Требуется:

1) Написать обыкновенную функцию (не метод) CreateClass, которая бы создавала объект класса TDummy (т.е. написать аналог родного конструктора). Параметры функции - на Ваше усмотрение.

Иными словами: 

Dummy := TDummy.Create(); 

будет эквивалентен коду:

Dummy := CreateClass();

2) Написать простой пример использования функции, создав экземпляр класса (в локальной переменной), передав в конструктор произвольное значение.

Входные данные:
1) Можно пользоваться классом TDummy как типом данных.

Условия:
1) Не использовать ассемблер.
2) Не вызывать конструктор напрямую:

Код

...
var
  Dummy: TDummy;
begin
  Dummy := TDummy.Create(123); // Подобные вызовы в любом месте решения запрещены!
end;


3) Все остальное делать можно smile

Критерии оценки задания: лучшим будет считаться такое решение, которое будет идеально моделировать "родной" конструктор в любом режиме его работы.

Полезность задачи - позволяет динамически создавать классы и компоненты в "чужих" приложениях без использования модулей VCL в своих.

----------------------------------------------------------------------------------------------------------------


Победители конкурса. 

Всего можно было набрать 60 баллов, 10 за 1ю, 30 за 2ю, 20 за 3ю

bems      - 53
MetalFan    - 53
actual    - 45

Sajtran    - 41
aktuba    - 30
AntonN    - 27
Poseidon    - 24
jsa       - 23
THandle - 19


ne0n             - 10
Shaggy          - 9
Felan             - 9 
tHE_EGOiSTE - 4
Qu1nt             - 3
mr.Anderson   -2
Staruha          - 2

Очень хорошие решения представили Sajtran,  AntonNaktubajsa
Суперское решение первой задачи представили ne0nbems и Shaggy
Очень хорошо 3е задание решил bems.
2е задание лучше всех удалось MetalFan. Очень грамотно, аккуратно, эффективно и прозрачно.

Как и обещалось все кто прислал решения хотя бы одной задачи или попытку решения, получат по одному +

 Все задачи были просмотрены на предмет упущений, отступлений от задания, т.е. весьма подробно.

 


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
MetalFan
Дата 22.10.2008, 12:24 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Аццкий Сотона
****


Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128



CodeMonkey, я думаю - не может (в случае, если исключение возникнет в конструкторе, то Result := nil и все ок, если возникнет позже, то Result <> nil и опять же все ок). 
если всетаки может - объясни почему.
добавлено позже: нет, всетаки может. если в деструкторе объекта возникнет исключение.

Это сообщение отредактировал(а) MetalFan - 22.10.2008, 12:25


--------------------
There are always someone smarter than you...
PM MAIL   Вверх
pseud
Дата 22.10.2008, 14:14 (ссылка) |    (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Экспёрт Тыдыщ
***


Профиль
Группа: Завсегдатай
Сообщений: 1175
Регистрация: 18.5.2007
Где: Минск, Беларусь

Репутация: 10
Всего: 40



Цитата(MetalFan @  22.10.2008,  12:24 Найти цитируемый пост)
добавлено позже: нет, всетаки может. если в деструкторе объекта возникнет исключение.

того же мнения. 
значит необходима конструксион:
Код

function GetSomeObject: TSomeClass;
begin
  Result := nil;
  try
    Result := TSomeClass.Create;
    // ... действия с Result, его инициализиация, заполнение и т.п.
  except
    try
      FreeAndNil(Result);  
    except
    end;
  end;
end;



--------------------
Испытание чужого терпения можно считать успешным, если оно лопнуло...
PM MAIL   Вверх
MetalFan
Дата 22.10.2008, 21:59 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Аццкий Сотона
****


Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128



а результаты когда предположительно станут известны?


--------------------
There are always someone smarter than you...
PM MAIL   Вверх
Alexeis
Дата 22.10.2008, 22:09 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459



Цитата(MetalFan @  22.10.2008,  20:59 Найти цитируемый пост)
а результаты когда предположительно станут известны? 

  Думаю завтра. 2е и 3е задачи проверены, остались первые. Вас много, а нас мало smile .


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
CodeMonkey
Дата 23.10.2008, 09:06 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Завсегдатай
Сообщений: 1839
Регистрация: 24.6.2008
Где: Россия, Тверь

Репутация: 38
Всего: 89



MetalFan, да в такой формулировке ответ найти легко, а вот в другом виде он был бы не так очевиден, т.к. если функция обёрнута в try/except на все исключения, то "есть интуитивное представление", что наружу выпускать исключения она не может - их же "except обрабатывает".


--------------------
Опытный программист на C++ легко решает любые не существующие в Паскале проблемы.
PM MAIL WWW ICQ Skype GTalk Jabber   Вверх
Alexeis
Дата 23.10.2008, 22:16 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459



Извините за задержку. Победителя 2, решаем как поступить  smile 


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
Christoph
Дата 23.10.2008, 22:38 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 667
Регистрация: 23.1.2008
Где: Харьков

Репутация: 1
Всего: 11



Дайте им еще одно задание smile а можно я им придумаю?  smile 


--------------------
user posted image
PM MAIL ICQ   Вверх
ne0n
Дата 24.10.2008, 00:37 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


PlayBoy
**


Профиль
Группа: Участник
Сообщений: 733
Регистрация: 5.8.2005
Где: Н.Новгород

Репутация: 1
Всего: 11



Цитата(Alexeis @  23.10.2008,  22:16 Найти цитируемый пост)
Извините за задержку. Победителя 2, решаем как поступить  



что тут решать, обоим присудить победу!!! smile 
PM MAIL ICQ   Вверх
Alexeis
Дата 24.10.2008, 08:04 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459



Цитата(ne0n @  23.10.2008,  23:37 Найти цитируемый пост)
что тут решать, обоим присудить победу!!!

  Я не то не против, но все от меня зависит. Сейчас решения 3х победителей пересматривает Girder, думаю у него могут получиться другие балы. Наберитесь терпения. Пока что можно объявить только места ниже 3го, начить торжественную раздачу плюсеков и публикацию решений.


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
Poseidon
Дата 24.10.2008, 08:39 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Delphi developer
****


Профиль
Группа: Комодератор
Сообщений: 5273
Регистрация: 4.2.2005
Где: Гомель, Беларусь

Репутация: 53
Всего: 133



Цитата(Alexeis @  24.10.2008,  08:04 Найти цитируемый пост)
Пока что можно объявить только места ниже 3го, начить торжественную раздачу плюсеков и публикацию решений. 
Ну и..? Огласите весь список, пжалуста (с) smile



--------------------
Если хочешь, что бы что-то работало - используй написанное, 
если хочешь что-то понять - пиши сам...
PM MAIL ICQ   Вверх
Alexeis
Дата 24.10.2008, 09:49 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459



Цитата(Poseidon @  24.10.2008,  07:39 Найти цитируемый пост)
Ну и..? Огласите весь список, пжалуста (с) 

ТАДАМ smile

Объявляем победителей конкурса. Всего можно было набрать 60 баллов, 10 за 1ю, 30 за 2ю, 20 за 3ю
bems      - ?
MetalFan    - ?
actual    - ?

Sajtran    - 41
aktuba    - 30
AntonN    - 27
Poseidon    - 24
jsa       - 23
THandle - 19


ne0n             - 10
Shaggy          - 9
Felan             - 9 
tHE_EGOiSTE - 4
Qu1nt             - 3
mr.Anderson   -2
Staruha          - 2

Очень хорошие решения представили Sajtran,  AntonNaktubajsa
Суперское решение первой задачи представили ne0nbems и Shaggy
Очень хорошо 3е задание решил bems.
2е задание лучше всех удалось MetalFan. Очень грамотно, аккуратно, эффективно и прозрачно.

Как и обещалось все кто прислал решения хотя бы одной задачи или попытку решения, получат по одному +

 Все задачи были просмотрены на предмет упущений, отступлений от задания, т.е. весьма подробно.

 


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
Poseidon
Дата 24.10.2008, 09:58 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Delphi developer
****


Профиль
Группа: Комодератор
Сообщений: 5273
Регистрация: 4.2.2005
Где: Гомель, Беларусь

Репутация: 53
Всего: 133



Блин, я в шоке. Обошел людей, которых считал в начале фаворитами. Ааааа  smile 

Ждем обьявления победителей и лучшие решения smile


--------------------
Если хочешь, что бы что-то работало - используй написанное, 
если хочешь что-то понять - пиши сам...
PM MAIL ICQ   Вверх
Alexeis
Дата 24.10.2008, 10:08 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459



Публикую все решения, в порядке их прихода.

----------------------------------------------------------------------

tHE_EGOiSTE
1)
Код

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
type
  TForm1 = class(TForm)
    Label1: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Label2: TLabel;
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    Button3: TButton;
    Edit3: TEdit;
    Label5: TLabel;
    label4: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
  Mas, Mas2: array[1..200, 1..200] of integer;
  ar: array[1..500] of integer;
  i, j, m, n, k, h, l, p, kol_vo: integer;
  str, str2: string;
begin
  Memo1.Clear;
// проверка на ошибки
  if (edit1.Text = '') or (edit2.Text = '') then begin
    exit;
  end;
  Label4.Caption := 'Элементы матрицы заданы произвольно';
// считывание m и n
  n := StrToInt(edit1.text);
  m := StrToInt(edit2.text);
// заполнение матрицы
  randomize;
  for i := 1 to n do begin
    for j := 1 to m do
    begin
      Mas[i, j] := random(10);
      Mas[j, i] := Mas[i, j];
    end;
  end;
// вывод матрицы
  memo1.Lines.Add('Матрица :');
  for i := 1 to n do begin
    str := ''; str2 := '';
    for j := 1 to m do begin
      str := IntToStr(Mas[i, j]);
      str2 := str2 + str + '   ';
    end;
    memo1.Lines.Add(str2);
  end;
// подсчет кол-ва елементов в матрице
  kol_vo := 0;
  for i := 1 to n do begin
    for j := 1 to m do kol_vo := kol_vo + 1;
  end;
// выполнение обхода
  k := 1; h := 2;
  repeat
    if (m = 1) and (n = 1) then begin ar[k] := Mas[n, m]; k := k + 1; end;
    if (m = 1) and (n > 1) then begin
      for i := 1 to n do begin
        ar[k] := Mas[i, m];
        k := k + 1;
      end; end;
    if (n = 1) and (m > 1) then begin
      for i := 1 to m do begin
        ar[k] := Mas[n, i];
        k := k + 1;
      end; end;
    if (m > 1) and (n > 1) then begin
      for j := 1 to m - h + 1 do begin
        ar[k] := Mas[1, j];
        k := k + 1;
      end;
      for j := 1 to n - h + 1 do begin
        ar[k] := Mas[j, m];
        k := k + 1;
      end;
      for j := m downto 2 do begin
        ar[k] := Mas[n, j];
        k := k + 1;
      end;
      for j := n downto 2 do begin
        ar[k] := Mas[j, 1];
        k := k + 1;
      end;
    end;
    if (n > 2) and (m > 2) then begin
      l := h;
      for i := h - 1 to n do begin
        p := h;
        for j := h - 1 to m do begin
          Mas2[i, j] := Mas[l, p];
          p := p + 1;
        end;
        l := l + 1;
      end;
      for i := 1 to n - 2 do begin
        for j := 1 to m - 2 do begin
          Mas[i, j] := Mas2[i, j];
        end; end;
      n := n - 2; m := m - 2;
    end;
  until (k - 1 = kol_vo);
// вывод результата
  str := '';
  for i := 1 to k - 1 do
    str := str + IntToStr(ar[i]) + '  ';
  edit3.Text := str;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
  Label4.Caption := '        ';
  edit1.Text := '';
  edit2.Text := '';
  edit3.Text := '';
  Memo1.Clear;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
  close;
end;
end.

или проект http://rapidshare.com/files/154508437/____..._____1.rar.html

3)
Код

(* Разработал tHE_EGOiSTE *)
(*!!! Суть в применении механизма виртуальных
 конструкторов совместно со ссылкой на класс !!!*)
unit UMain;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, XPMan;
type
  TDummy = class(TObject)
  private
    fValue: Integer;
  public
    { Виртуальный конструктор }
    constructor Create(Value: Integer); virtual;
    { Показ переданного значения }
    procedure ShowValue; virtual;
  end;
  { Новый тип ссылки на класс }
  TFooDummy = class of TDummy;
type
  TForm1 = class(TForm)
    mmoLog: TMemo;
    Panel1: TPanel;
    btnCreateObj: TButton;
    XPManifest1: TXPManifest;
    Edit1: TEdit;
    Label1: TLabel;
    procedure btnCreateObjClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
  { Создание объекта класса TDummy }
  function CreateClass(DummyClassRef: TFooDummy; Value: Integer): TDummy;
var
  Form1: TForm1;
implementation
{$R *.dfm}
function CreateClass(DummyClassRef: TFooDummy; Value: Integer): TDummy;
begin
    Result := DummyClassRef.Create(Value);
//    with Result do
//    begin
//        fValue := Value;
//        ShowValue;
//    end;
end;
procedure TForm1.btnCreateObjClick(Sender: TObject);
var
    Dummy: TDummy;            { объект }
    DummyClassRef: TFooDummy; { класс }
    x: Integer;               { параметр конструктора }
begin
    { Инициализируем переменную }
    DummyClassRef := TDummy;
    x := StrToInt(Edit1.Text);
    try
        Dummy := CreateClass(DummyClassRef, x);
        mmoLog.Lines.Add('    объект создан');
    finally
        { Уничтожаем созданный объект }
        FreeAndNil(Dummy);
        mmoLog.Lines.Add('    объект уничтожен'#13#10);
    end;
    end;
{ TDummy }
constructor TDummy.Create;
begin
    inherited Create;
    fValue := Value;
    ShowValue;
end;
procedure TDummy.ShowValue;
begin
    ShowMessage('Value is: ' + IntToStr(fValue));
end;
end.


------------------------------------------------------------------------------------------------------------------------------------------------------

mr.Anderson
1)
Код

program Project1;
{$APPTYPE CONSOLE}
const
  M = 2;
  N = 3;
  Z = M * N;
var
  Matrix: Array [1..M, 1..N] Of Integer;
  Max: Array [1..Z] Of Integer;
  I, J, C, K: Integer;
  Ii, Ij: Integer;
  Ci, Cj: Integer;
//внутри используем глобальный массив без передачи в аргументе, это увеличит скорость
procedure QuickSort(L, R: Integer);
var
  I, J, X, Y: Integer;
begin
  I := L; 
  J := R; 
  X := Max[(R+L) shr 1];
  repeat
    while Max[I] < x do
      Inc(I);
    while X < Max[J] do
      Dec(J);
    if (I <= J) then
    begin
      if (Max[I] > Max[J]) then
      begin
        Y := Max[I]; 
        Max[I] := Max[J]; 
        Max[J] := Y; 
      end; 
      Inc(I);
      Dec(J);
    end;
  until I > J;
  
  if (L < J) then
    QuickSort(L, J);
  if (I < R) then
    QuickSort(I, R);
end;
begin
  Randomize;
  C := 1;
  for I := 1 to M do
    for J := 1 to N do
    begin
      Matrix[I, J] := 0;
      Max[C] := Random(1000);
      Inc(C);
    end;
  QuickSort(1, Z); //сортируем по возрастанию шустрой сортировкой :)
  //сортируем спиралью
  Ii := 0;
  Ij := 0;
  Ci := 1;
  Cj := 1;
  K := 1;
  while true do
  begin
    Ci := Ci + Ii;
    Cj := Cj + Ij;
    Matrix[Ci, Cj] := Max[K];
    Inc(K);
    if (K > Z) then
      break;
    
    if (Cj+1 <= N) then
    begin
      if (Matrix[Ci, Cj+1] = 0) then //по столбцам ->
      begin
        Ii := 0;
        Ij := 1;
      end;
    end
    else if (Ci+1 <= M) then
    begin
      if (Matrix[Ci+1, Cj] = 0) then //по строкам v
      begin
        Ii := 1;
        Ij := 0;
      end;
    end
    else if (Cj-1 >= 1) then
    begin
      if (Matrix[Ci, Cj-1] = 0) then //по столбцам <-
      begin
        Ii := 0;
        Ij := -1;
      end;
    end
    else if (Ci-1 >= 1) then
    begin
      if (Matrix[Ci-1, Cj] = 0) then //по строкам ^
      begin
        Ii := -1;
        Ij := 0;
      end;
    end;
  end;
  //выведем получившуюся матрицу
  for I := 1 to M do
  begin
    for J := 1 to N do
      Write(Matrix[I, J]:4, ' ');
    WriteLn;
  end;
  ReadLn; //глянем, что у нас получилось ;)
end.


--------------------------------------------------------------------------------------------------------------------------

aktuba
1) 
Код

program N1;

{$APPTYPE CONSOLE}

uses
  SysUtils;

const
  C_QSCutOff = 15;

var
  Arr: array of array of Integer;
  m, n: Integer;
  i, j: Integer;

// Используем алгоритм быстрой сортировки
procedure QuickSort(var AArray: array of Integer; AFirst, ALast: Integer);
var
  L, R: Integer;
  lPivot: Integer;
  lTemp: Integer;
  lStack: array[0..63] of Integer;
  lSP: Integer;
begin
  lStack[0] := AArray[AFirst];
  lStack[1] := AArray[ALast];
  lSP := 2;
  while lSP <> 0 do
  begin
    Dec(lSP, 2);
    AFirst := lStack[lSP];
    ALast := lStack[lSP + 1];
    while ((ALast - AFirst) > C_QSCutOff) do
    begin
      R := (AFirst + ALast) div 2;
      if AArray[AFirst] > AArray[R] then
      begin
        lTemp := AArray[AFirst];
        AArray[AFirst] := AArray[R];
        AArray[R] := lTemp;
      end;
      if AArray[AFirst] > AArray[ALast] then
      begin
        lTemp := AArray[AFirst];
        AArray[AFirst] := AArray[ALast];
        AArray[ALast] := lTemp;
      end;
      if AArray[R] > AArray[ALast] then
      begin
        lTemp := AArray[R];
        AArray[R] := AArray[ALast];
        AArray[ALast] := lTemp;
      end;
      lPivot := AArray[R];
      L := AFirst;
      R := ALast;
      while True do
      begin
        Repeat
          Dec®;
        Until AArray[R] <= lPivot;
        Repeat
          Inc(L);
        Until AArray[L] >= lPivot;
        if (l >= R) then
          Break;
        lTemp := AArray[L];
        AArray[L] := AArray[R];
        AArray[R] := lTemp;
      end;
      if (R - AFirst) < (ALast - R) then
      begin
        lStack[lSP] := Succ®;
        lStack[lSP + 1] := ALast;
        Inc(lSP, 2);
        ALast := R;
      end
      else
      begin
        lStack[lSP] := AFirst;
        lStack[lSP + 1] := R;
        Inc(lSP, 2);
        AFirst := Succ®;
      end;
    end;
  end;
end;

procedure QuickInsSort(var AArray: array of Integer; AFirst, ALast: Integer);
var
  i, j: Integer;
  lIndex: Integer;
  lTemp: Integer;
begin
  lIndex := AFirst;
  j := C_QSCutOff;
  if j > ALast then
    j := ALast;
  for i := Succ(AFirst) to j do
    if AArray[i] < AArray[lIndex] then
      lIndex := i;
  if AFirst <> lIndex then
  begin
    lTemp := AArray[AFirst];
    AArray[AFirst] := AArray[lIndex];
    AArray[lIndex] := lTemp;
  end;
  for i := AFirst + 2 to ALast do
  begin
    lTemp := AArray[i];
    j := i;
    while lTemp < AArray[j - 1] do
    begin
      AArray[j] := AArray[j - 1];
      Dec(j);
    end;
    AArray[j] := lTemp;
  end;
end;

procedure DoSort(var AArray: array of Integer);
begin
  QuickSort(AArray, 0, High(AArray));
  QuickInsSort(AArray, 0, High(AArray));
end;

procedure SpirSort;
var
  lTempArr: array of Integer;
  IdxM, IdxN: Integer;
  lCount: Integer;
  f: Boolean;
  xf, yf, x, y: Integer;
  lArr: array of array of Boolean;
begin
  // Подготовка данных для сортировки
  SetLength(lTempArr, m * n);
  lCount := 0;
  for IdxN := 0 to n - 1 do
    for IdxM := 0 to m - 1 do
    begin
      lTempArr[lCount] := Arr[IdxN, IdxM];
      Inc(lCount);
    end;

  // Сортировка временного массива
  DoSort(lTempArr);

  // Инициализация данных для расстановки результатов сортировки
  xf := 1;
  yf := 1;
  f := True;
  x := 0;
  y := 0;
  SetLength(lArr, n);
  for IdxN := 0 to n - 1 do
    SetLength(lArr[IdxN], m);
  for IdxN := 0 to n - 1 do
    for IdxM := 0 to m - 1 do
      lArr[IdxN, IdxM] := False;

  // Расставляем по спирали
  for lCount := 0 to High(lTempArr) do
  begin
    Arr[y, x] := lTempArr[lCount];
    lArr[y, x] := True;
    if f then
    begin
      Inc(x, xf);
      if (x < 0) or (x >= m) or lArr[y, x] then
      begin
        xf := -xf;
        f := not f;
        Inc(x, xf);
        Inc(y, yf);
      end;
    end
    else
    begin
      Inc(y, yf);
      if (y < 0) or (y >= n) or lArr[y, x] then
      begin
        yf := -yf;
        f := not f;
        Inc(y, yf);
        Inc(x, xf);
      end;
    end;
  end;
  
  // Уничтожение временных массивов
  for IdxM := 0 to m - 1 do
    SetLength(lArr[IdxM], 0);
  SetLength(lArr, 0);
  SetLength(lTempArr, 0);
end;

begin
  Randomize;

  // Инициализация данных
  m := 6;
  n := 4;
  SetLength(Arr, n);
  for i := 0 to n - 1 do
    SetLength(Arr[i], m);

  for j := 0 to m - 1 do
    for i := 0 to n - 1 do
      Arr[i, j] := Random(100);

  // Сортируем и расставляем
  SpirSort;

  // Выводим результат
  for j := 0 to n - 1 do
  begin
    for i := 0 to m - 1 do
      write(Arr[j, i], ' ');
    writeln;
  end;

  // Деинициализация
  for i := 0 to n - 1 do
    SetLength(Arr[i], 0);
  SetLength(Arr, 0);
  readln;
end.

2) В архиве
http://aktuba.ru/N2.rar

---------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Staruha
1)
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids, Buttons;

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    Button2: TButton;
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button2Click(Sender: TObject);
 var
 k1,k,i:integer;
 myarray:array[1..10,1..3] of integer;
 mi1:array[1..3] of integer;
 flag:boolean;

begin
        for k := 1 to 10 do
    for i := 1 to 3 do
      myarray[k,i] := Random(30);
 repeat

   flag:=false;
   for k:= 1 to 9 do
   begin

     if   myarray[k,1]>myarray[k+1,1] then

       begin
              for i := 1 to 3 do
        begin
             mi1[i]:=myarray[k,i];
             myarray[k,i]:=myarray[k+1,i];
              myarray[k+1,i]:=mi1[i];

       end;
          flag:=true;
   end;

   end;
 until not flag;
      k1:=1;
      for k :=1 to 9 do
    begin

           k1:=k1+1;

          if k1=3 then
            begin
              for i := 1 to 3 do
        begin
             mi1[i]:=myarray[k,i];
             myarray[k,i]:=myarray[k+1,i];
             myarray[k+1,i]:=mi1[i];

            end;

           k1:=0;

       end;

  end;
         for k := 1 to 10 do
    for i := 1 to 3 do
      StringGrid1.Cells[i, k] := inttostr(myarray[k,i]);
 end;


---------------------------------------------------------------------------------------------------------------------------------------------------------------------

Shaggy
1)
Код

Program
  Task_Matrix;
{$APPTYPE CONSOLE}
Uses
  Types,
  Windows, Dialogs;
Const
  M = 16;
  N = 8;
Type
  TElementType = Integer;
Type
  TMatrix = Packed Array [0..M-1,0..N-1] Of TElementType;
  TVector = Packed Array [0..M*N-1] Of TElementType;
Const
  Delta:Array [0..3] Of TPoint =
    ((X:1;Y:0),(X:0;Y:1),(X:-1;Y:0),(X:0;Y:-1));
Var
  Matrix:TMatrix;
  Vector:TVector;
Procedure Sort(Var AVector:TVector;ALo,AHi:Integer);
Var
  Lo,Hi,Mid,B:Integer;
Begin
  Lo:=ALo;
  Hi:=AHi;
  Mid:=AVector[(Lo+Hi) Shr 1];
  Repeat
    While AVector[Lo]<Mid Do
      Inc(Lo);
    While AVector[Hi]>Mid Do
      Dec(Hi);
    If Lo<=Hi
    Then
      Begin
        B:=AVector[Lo];
        AVector[Lo]:=AVector[Hi];
        AVector[Hi]:=B;
        Inc(Lo);
        Dec(Hi);
      End;
  Until Lo>Hi;
  If Hi>ALo
  Then
    Sort(AVector,ALo,Hi);
  If Lo<AHi
  Then
    Sort(AVector,Lo,AHi);
End;
Procedure Roll(Const ASource:TVector;Var ADest:TMatrix);
Var
  Position,Size,Buf:TPoint;
  Index,Step:Integer;
Begin
  Step:=0;
  Buf:=Point(M,N);
  Size:=Buf;
  Position:=Point(0,0);
  For Index:=1 To M*N Do
  Begin
    ADest[Position.X,Position.Y]:=ASource[Index-1];
    Dec(Size.X,Abs(Delta[Step].X));
    Dec(Size.Y,Abs(Delta[Step].Y));
    If (Size.X=0) Or (Size.Y=0)
    Then
      Begin
        Step:=(Step+1) And 3;
        Dec(Buf.X,Abs(Delta[Step].X));
        Dec(Buf.Y,Abs(Delta[Step].Y));
        Size:=Buf;
      End;
    Inc(Position.X,Delta[Step].X);
    Inc(Position.Y,Delta[Step].Y);
  End;
End;
Procedure Fill;
Var
  Index:Integer;
Begin
  For Index:=0 To M*N-1 Do
    Matrix[Index Mod M, Index Div M]:=Random(100);
End;
Procedure Print;
Var
  Index:Integer;
Begin
  For Index:=0 To M*N-1 Do
  Begin
    Write(Matrix[Index Mod M, Index Div M]:3);
    If Index Mod M=M-1
    Then
      WriteLn;
  End;
  WriteLn;
End;
begin
  Randomize;
  // Çàïîëíÿåì ìàòðèöó
  Fill;
  Print;
  // Êîïèðóåì è ñîðòèðóåì
  Move(Matrix,Vector,SizeOf(TVector));
  Sort(Vector,0,High(Vector));
  // Çàïîëíÿåì ïî ñïèðàëè
  Roll(Vector,Matrix);
  Print;
  
  ReadLn;
End.


Добавлено через 3 минуты и 28 секунд
------------------------------------------------------------------------------------------------------------------------------------

jsa
1)
Код

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids;
type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    Button1: TButton;
    SGSource: TStringGrid;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FState, FIndx: Integer;
    FCol, FRow, FCycleCol, FCycleRow: Integer;
    FNumbers: TStringList;
    procedure ChangeCellsPos;
    procedure Spirale;
    function FreeCell(ACol, ARow: Integer): Boolean;
    procedure SortNumbers;
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
const
  MSize = 9;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
  SortNumbers;
  FCol:=0;
  FRow:=0;
  FState:=0;
  FIndx:=0;
  FCycleCol:=0;
  FCycleRow:=0;
  Spirale;
end;
procedure TForm1.ChangeCellsPos;
begin
  case FState of
    0:  begin
          Inc(FCol);
          if(FCol = MSize) or (not FreeCell(FCol + 1, FRow)) then
            begin
              FState:=1;
            end;
        end;
    1:  begin
          Inc(FRow);
          if (FRow = MSize) or (not FreeCell(FRow + 1, FCol)) then
            begin
              FState:=2;
            end;
        end;
    2:  begin
          Dec(FCol);
          if (FCol = 0) or (not FreeCell(FCol - 1, FRow)) then
            begin
              FState:=3;
            end;
        end;
    3:  begin
          Dec(FRow);
          if (FRow = 0) or (not FreeCell(FCol, FRow - 1)) then
            begin
              FState:=0;
              Inc(FCycleCol);
              Inc(FCycleRow);
              FCol:=FCycleCol - 1;
              FRow:=FCycleRow;
            end;
        end;
  end;
end;
function TForm1.FreeCell(ACol, ARow: Integer): Boolean;
begin
  Result:=StringGrid1.Cells[ACol, ARow] = '';
end;
procedure TForm1.Spirale;
begin
  StringGrid1.Cells[FCol, FRow]:=FNumbers.Strings[FIndx];
  ChangeCellsPos;
  Inc(FIndx);
  if FIndx < FNumbers.Count then
    Spirale;
end;
procedure TForm1.Button2Click(Sender: TObject);
var I, J, Rnd: Integer;
begin
  FNumbers.Clear;
  Randomize;
  for I:=0 to MSize do
    for J:=0 to MSize do
      begin
        Rnd:=Random(1000);
        SGSource.Cells[I, J]:=IntToStr(Rnd);
        FNumbers.AddObject(IntToStr(Rnd), TObject(Rnd));
      end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  FNumbers:=TStringList.Create;
end;
procedure TForm1.SortNumbers;
  procedure sort(a,c: Integer);
  var x,y,z: Integer;
      p1, p2: Integer;
  begin
    x:=a;
    y:=a+1;
    z:=c;
    repeat
      p1:=Integer(FNumbers.Objects[x]);
      p2:=Integer(FNumbers.Objects[y]);
      if p1 > p2 then
       FNumbers.Exchange(x,y);
      x:=y+1;
      y:=x+1;
    until Y > FNumbers.Count - 1;
    Inc(z);
    if z <= FNumbers.Count then
     begin
       if a = 0 then sort(1,z) else sort(0,z);
     end;
  end;
begin
  sort(0,0);
end;
end.

Код

object Form1: TForm1
  Left = 291
  Top = 192
  Width = 870
  Height = 640
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object StringGrid1: TStringGrid
    Left = 16
    Top = 248
    Width = 273
    Height = 217
    ColCount = 10
    DefaultColWidth = 25
    DefaultRowHeight = 20
    FixedCols = 0
    RowCount = 10
    FixedRows = 0
    TabOrder = 0
  end
  object Button1: TButton
    Left = 304
    Top = 248
    Width = 105
    Height = 25
    Caption = '2 Sort by sprirale'
    TabOrder = 1
    OnClick = Button1Click
  end
  object SGSource: TStringGrid
    Left = 16
    Top = 16
    Width = 273
    Height = 217
    ColCount = 10
    DefaultColWidth = 25
    DefaultRowHeight = 20
    FixedCols = 0
    RowCount = 10
    FixedRows = 0
    TabOrder = 2
  end
  object Button2: TButton
    Left = 304
    Top = 16
    Width = 105
    Height = 25
    Caption = '1 generate random'
    TabOrder = 3
    OnClick = Button2Click
  end
end



--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
Alexeis
Дата 24.10.2008, 10:22 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459



jsa
2)
Описание раскраски для Второй задачи

Красный - дворник чистит пустую ячейку
Темно-красный - дворник чистит ячейку с мусором
Зеленый -  хулиган получил дюлей
Желтый - хулиган хулиганит - выкидывает мусор
Синий - мусор

Код

unit Main;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids;
type
  TFieldCellState = (fcsEmpty, fcsCleanEmpty, fcsCleanTrash,  fcsTrashPut, fcsTrashFill, fcsKilled);
    TKeeperMove = (kmForward, kmBackward);
  TObjType = (otKeeper, otHooligan);
  TFieldCell = class(TObject)
    private
        FState: TFieldCellState;
    public 
        property State: TFieldCellState read FState write FState;        
    end;
    
    TFieldCells = class(TObject)
    private
        FList: TList;
        function GetCellState(ACell: Byte): TFieldCellState;
    public
        property CellState[ACell: Byte]: TFieldCellState read GetCellState;
        constructor Create;
        destructor Destroy; override;
        procedure SetCellState(ABeginC, AEndC: Byte; AState: TFieldCellState);
        
    end;
  TMainForm = class(TForm)
    SGField: TStringGrid;
    ButtonStart: TButton;
    Label1: TLabel;
    procedure ButtonStartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure SGFieldDrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
  private
    { Private declarations }
    FCol: Byte;
  public
    { Public declarations }
    procedure RepaintField;
    procedure DoneXThread(Sender: TObject); 
  end;
  TXThread = class(TThread)
  private
    FObjType: TObjType;
    FKeeperPos, FKeeperMaxPos, FKeeperMinPos: Byte;
    FKeeperMove: TKeeperMove;
    FHooliganPos: Byte;
    FHooliganSleep: Word;
    procedure ChangeCellState;
    procedure KeeperChangeCellState;
    procedure KeeperFreeCells;
    procedure KeeperFillCells;
    procedure KeeperChangePos;
    procedure HooliganChangeCellState;
    procedure HooliganFreeCell;
    procedure HooliganFillCell;
    procedure HooliganChangePos;
  protected
    procedure Execute; override;
  public
    constructor Create(AObjType: TObjType);
  end;
var
  MainForm: TMainForm;
  CS: TRTLCriticalSection;
  FieldCells: TFieldCells;
var
  Pack, Killed: Byte;
implementation
{$R *.dfm}
procedure TMainForm.ButtonStartClick(Sender: TObject);
//var KeeperThread: TXThread;
begin
  Pack:=0;
  Killed:=0;
  InitializeCriticalSection(CS);
  TXThread.Create(otKeeper);
  TXThread.Create(otHooligan);
end;
{ TXThread }
procedure TXThread.ChangeCellState;
begin
  case FObjType of
    otKeeper: KeeperChangeCellState;
    otHooligan: HooliganChangeCellState;
  end;
end;
constructor TXThread.Create(AObjType: TObjType);
begin
  FObjType:=AObjType;
  FKeeperPos:=0;
  FKeeperMaxPos:=19;
  FKeeperMinPos:=0;
  FHooliganSleep:=60;
  FreeOnTerminate:=True;
  OnTerminate:=MainForm.DoneXThread;
  inherited Create(False);
end;
procedure TXThread.Execute;
begin
  while not Terminated do
    begin
      EnterCriticalSection(CS);
      if (Pack > 21) then
        Terminate
      else
        ChangeCellState;
      LeaveCriticalSection(CS);
      Synchronize(MainForm.RepaintField);
      case FObjType of
        otKeeper: Sleep(400);
        otHooligan: Sleep(FHooliganSleep);
      end;
    end;
  Terminate;
end;
procedure TMainForm.RepaintField;
var I: Byte;
begin
  for I:=0 to 59 do
    begin
      FCol:=I;
      SGField.Repaint;
      DoneXThread(Label1);
    end;
end;
procedure TXThread.HooliganChangeCellState;
begin
  HooliganFreeCell;
  HooliganFillCell;
end;
procedure TXThread.HooliganChangePos;
begin
  Randomize;
  FHooliganPos:=Random(59);
end;
procedure TXThread.HooliganFillCell;
var CS, NCS: TFieldCellState;
begin
  FHooliganSleep:=300;
  CS:=FieldCells.CellState[FHooliganPos];
  case CS of
    fcsEmpty: NCS:=fcsTrashPut;
    fcsCleanEmpty, fcsCleanTrash: NCS:=fcsKilled;
    fcsTrashFill: NCS:=fcsTrashPut;
  else
    NCS:=CS;
  end;
  if NCS = fcsKilled then
    Inc(Killed);
  FieldCells.SetCellState(FHooliganPos, FHooliganPos, NCS);
end;
procedure TXThread.HooliganFreeCell;
var CS, NCS: TFieldCellState;
begin
  FHooliganSleep:=60;
  CS:=FieldCells.CellState[FHooliganPos];
  case CS of
    fcsTrashPut: NCS:=fcsTrashFill;
  else
    NCS:=CS;
  end;
  if NCS = fcsTrashFill then
    Inc(Pack);
  FieldCells.SetCellState(FHooliganPos, FHooliganPos, NCS);
  HooliganChangePos;
end;
procedure TXThread.KeeperChangeCellState;
begin
  KeeperFreeCells;
  KeeperFillCells;
end;
procedure TXThread.KeeperChangePos;
begin
  case FKeeperMove of
    kmForward:
      begin
        Inc(FKeeperPos);
        if (FKeeperPos = FKeeperMaxPos) then
         FKeeperMove:=kmBackward
      end;
    kmBackward:
      begin
        Dec(FKeeperPos);
        if (FKeeperPos = FKeeperMinPos) then
         FKeeperMove:=kmForward;
      end;
  end;
end;
procedure TXThread.KeeperFillCells;
var CS, NCS: TFieldCellState;
    J, I: Byte;
begin
  J:=FKeeperPos * 3;
  for I:=J to J + 2 do
    begin
      CS:=FieldCells.CellState[I];
      case CS of
        fcsEmpty: NCS:=fcsCleanEmpty;
        fcsCleanEmpty: NCS:=fcsCleanEmpty;
        fcsCleanTrash: NCS:=fcsCleanTrash;
        fcsTrashPut: NCS:=fcsKilled;
        fcsTrashFill: NCS:=fcsCleanTrash;
      else
        NCS:=CS;
      end;
      if NCS = fcsKilled then
        Inc(Killed);
      FieldCells.SetCellState(I, I, NCS);
    end
end;
procedure TXThread.KeeperFreeCells;
var CS, NCS: TFieldCellState;
    J, I: Byte;
begin
  J:=FKeeperPos * 3;
  for I:=J to J + 2 do
    begin
      CS:=FieldCells.CellState[I];
      case CS of
        fcsEmpty: NCS:=fcsEmpty;
        fcsCleanEmpty: NCS:=fcsEmpty;
        fcsCleanTrash: NCS:=fcsEmpty;
      else
        NCS:=CS;
      end;
  
      FieldCells.SetCellState(I, I, NCS);
    end;
  KeeperChangePos;
end;
{ TFieldCells }
constructor TFieldCells.Create;
var FieldCell: TFieldCell;
    I: Byte;
begin
  FList:=TList.Create();
  for I:=0 to 59 do
    begin
      FieldCell:=TFieldCell.Create();
      FieldCell.State:=fcsEmpty;
      FList.Add(FieldCell);
    end;
end;
destructor TFieldCells.Destroy;
var FieldCell: TFieldCell;
    I: Byte;
begin
  FList:=TList.Create;
  for I:=0 to 59 do
    begin
      FieldCell:=TFieldCell.Create;
      FieldCell.State:=fcsEmpty;
      FList.Add(FieldCell);
    end;
  inherited Destroy;
end;
function TFieldCells.GetCellState(ACell: Byte): TFieldCellState;
begin
  Result:=TFieldCell(FList.Items[ACell]).State;
end;
procedure TFieldCells.SetCellState(ABeginC, AEndC: Byte;
  AState: TFieldCellState);
var I: Byte;
begin
  for I:=ABeginC to AEndC do
      TFieldCell(FList.Items[I]).State:=AState;
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
  FieldCells:=TFieldCells.Create;
end;
procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FieldCells.Free;
end;
procedure TMainForm.SGFieldDrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var FS: TFieldCellState;
begin
  with (Sender as TStringGrid).Canvas do
    begin
      if ACol = FCol then
        begin
          FS:=FieldCells.CellState[FCol];
          case FS of
            fcsEmpty: Brush.Color:=clWhite;
            fcsCleanEmpty: Brush.Color:=clRed;
            fcsTrashPut: Brush.Color:=clYellow;
            fcsTrashFill: Brush.Color:=clBlue;
            fcsCleanTrash: Brush.Color:=clMaroon;
            fcsKilled: Brush.Color:=clGreen;
          end;
          FillRect(Rect);
          DrawFocusRect(Rect);
        end;
    end;
end;
procedure TMainForm.DoneXThread(Sender: TObject);
begin
  Label1.Caption:='Packs: ' + IntToStr(Pack) + ' Killed: ' + IntToStr(Killed);
end;
end.

DFM
Код

object MainForm: TMainForm
  Left = 392
  Top = 241
  Width = 698
  Height = 123
  Caption = 'Task 2'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 96
    Top = 56
    Width = 32
    Height = 13
    Caption = 'Label1'
  end
  object SGField: TStringGrid
    Left = 8
    Top = 24
    Width = 673
    Height = 25
    ColCount = 60
    DefaultColWidth = 10
    DefaultRowHeight = 10
    DefaultDrawing = False
    FixedCols = 0
    RowCount = 1
    FixedRows = 0
    Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine]
    TabOrder = 0
    OnDrawCell = SGFieldDrawCell
  end
  object ButtonStart: TButton
    Left = 8
    Top = 56
    Width = 75
    Height = 25
    Caption = 'Start'
    TabOrder = 1
    OnClick = ButtonStartClick
  end
end


--------------------------------------------------------------------------------------------------------

1) Felan
http://rapidshare.de/files/40696662/Matrix.rar.html 

--------------------------------------------------------------------------------------------------------

1), 2)
AntonN
http://antonn.com/xlam/vg_1.zip
http://antonn.com/xlam/vg_2.zip 


--------------------------------------------------------------------------------------------------------

Sajtran
1, 2, 3 В одном архиве
http://mudclient.narod.ru/Zadachi.rar 

--------------------------------------------------------------------------------------------------------

Poseidon

http://narod.ru/disk/3373823000/Zadanie1%2...eidon).rar.html
http://narod.ru/disk/3373824000/Zadanie2%2...eidon).rar.html

--------------------------------------------------------------------------------------------------------

bems,
1) 2) 3)

http://narod.ru/disk/3373825000/bems.rar.html

--------------------------------------------------------------------------------------------------------

MetalFan, 1) 2) 3)
http://slil.ru/26250387

--------------------------------------------------------------------------------------------------------

actual 1) 2) 3)
http://visualtasktips.com/public/Vingrad.Solutions.zip

--------------------------------------------------------------------------------------------------------

ne0n
Код

program Project1;
{$APPTYPE CONSOLE}
uses
  SysUtils;
const
    n = 8; //строк
    m = 10; // столбцов
type
  TMatrix = array [ 1..n, 1..m ] of integer;
  TVector = array [1..m*n] of integer;
var
    i, j, _i, _j, iBarrier, jBarrier, ind : integer;
    mymatrix : TMatrix;
    tmp_vector : TVector;
//Пираминадьная сортировка. Чесно скомунизденно из Википедии =)
procedure Sort(var Arr: array of integer; Count: Integer);
  procedure DownHeap(index, Count: integer; Current: integer);
  //Функция пробегает по пирамиде восстанавливая ее
  //Также используется для изначального создания пирамиды
  //Использование: Передать номер следующего элемента в index
  //Процедура пробежит по всем потомкам и найдет нужное место для следующего элемента
  var
    Child: Integer;
  begin
    while index < Count div 2 do begin
      Child := (index+1)*2-1;
      if (Child < Count-1) and (Arr[Child] < Arr[Child+1]) then
        Child:=Child+1;
      if Current >= Arr[Child] then
        break;
      Arr[index] := Arr[Child];
      index := Child;
    end;
    Arr[index] := Current;
  end;
 
//Основная функция
var
  i: integer;
  Current: integer;
begin
  //Собираем пирамиду
  for i := (Count div 2)-1 downto 0 do
    DownHeap(i, Count, Arr[i]);
  //Пирамида собрана. Теперь сортируем
  for i := Count-1 downto 1 do begin
    Current := Arr[i]; //перемещаем верхушку в начало отсортированного списка
    Arr[i] := Arr[0];
    DownHeap(0, i, Current); //находим нужное место в пирамиде для нового элемента
  end;
end;
function MtrxToVect( matr : TMatrix ) : TVector;
var
    vec : TVector;
    i, j, k : Integer;
begin
    k := 0;
    for i := 1 to n do
        for j := 1 to m do
            begin
                inc(k);
                vec[k] := matr[i, j];
            end;
    result := vec;
end;
begin
    ind := 1;
    iBarrier := n;
    jBarrier := m;
    _j := 1;
    _i := 1;
    Randomize;
    //Генериться матрица
     for i := 1 to n do
     for j := 1 to m do mymatrix[i,j] := Random(100);
   writeln('Original: ');
     for i := 1 to n do
        begin
            for j := 1 to m do write(mymatrix[i,j]:4);
            writeln;
        end;
     // Людям в здравлм уме и рассудке категоричски запрещено
     // это смотреть =)
     tmp_vector := MtrxToVect(mymatrix);
     Sort(tmp_vector,n*m);
  // Пошло заполнение по спирали
    while( _i <= iBarrier ) and (_j <= jBarrier) do
        begin
            for j := _j to jBarrier do
                begin
                    mymatrix[_i, j] := tmp_vector[ind];
                    inc(ind)
                end;
            if _i < iBarrier then
                begin
                    for i := _i + 1 to iBarrier do
                        begin
                            mymatrix[i, jBarrier] := tmp_vector[ind];
                            inc(ind)
                        end;
                    if _j < jBarrier then
                        begin
                            for j := jBarrier - 1 downto _j do
                                begin
                                    mymatrix[iBarrier, j] := tmp_vector[ind];
                                    inc(ind)
                                end;
                            if iBarrier - _i > 1 then
                                for i := iBarrier - 1 downto _i + 1 do
                                    begin
                                        mymatrix[i, _j] := tmp_vector[ind];
                                        inc(ind)
                                    end;
                        end;
                end;
            inc(_i);
            inc(_j);
            dec(iBarrier);
            dec(jBarrier);
        end;
 // вывод
     Writeln('Spiral : ');
    for i := 1 to n do
        begin
            for j := 1 to m do write(mymatrix[i, j] : 4);
          Writeln;
        end;
    readln;
end.


---------------------------------------------------------------------------------------------------

THandle
1) 3)
http://delphiprog.ucoz.ru/files/1and3second.rar

---------------------------------------------------------------------------------------------------

Qu1nt

Код

function CreateClass(Value: Integer): TDummy;
begin
  Result := TDummy(TDummy.NewInstance);
  Result.FValue := Value;
  Result.AfterConstruction;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  Dummy: TDummy;
begin
  Dummy := CreateClass(123);
  Dummy.ShowValue;
  Dummy.Free;
end;




--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
Alexeis
Дата 24.10.2008, 10:47 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459



Отдельная просьба к Sajtran, отписаться тут, поскольку поставить "+" можно только в пост.


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Общие вопросы"
SnowyMetalFan
bemsPoseidon
Rrader

Запрещается!

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делиться вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи


Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.

 
1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Общие вопросы | Следующая тема »


 




[ Время генерации скрипта: 0.1400 ]   [ Использовано запросов: 22 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.