Примечание: здесь находится описание старой версии программы True Shop 1.47 (год выпуска 2007). Программа была успешно внедрена и работала более одного года. Людям программа понравилась и было принято решение выпустить вторую версию. Первая версия программы не содержит инсталлятора, и возможностей у неё намного меньше, чем у второй версии (раз в пять). Поэтому её описание здесь выложено только для ознакомления. Описание актуальной версии программы для автоматизации торговли можно посмотреть здесь.

ФЕДЕРАЛЬНОЕ АГЕНТСТВО ПО ОБРАЗОВАНИЮ РФ

ГОСУДАРСТВЕННОЕ ОБРАЗОВАТЕЛЬНОЕ УЧРЕЖДЕНИЕ ВЫСШЕГО ПРОФЕССИОНАЛЬНОГО ОБРАЗОВАНИЯ

ВОЛОГОДСКИЙ ГОСУДАРСТВЕННЫЙ ПЕДАГОГИЧЕСКИЙ УНИВЕРСИТЕТ

ВЫПУСКНАЯ КВАЛИФИКАЦИОННАЯ РАБОТА

НА ТЕМУ:

«Автоматизация работы хозяйственного магазина»

Выполнил: студент 5 курса

факультета ПМиКТ

Горчаков Иван Михайлович

Научный руководитель:

к.т.н., профессор

Ржеуцкая Светлана Юрьевна

Вологда

2007

СОДЕРЖАНИЕ

ВВЕДЕНИЕ 4

1. АНАЛИЗ ПРЕДМЕТНОЙ ОБЛАСТИ И ОПРЕДЕЛЕНИЕ ТРЕБОВАНИЙ К СИСТЕМЕ 5

1.1. Анализ круга пользователей 5

1.3. Требования заказчика к пользовательскому интерфейсу 7

2. ПРОЕКТНАЯ ЧАСТЬ 8

2.1. Система бизнес-правил 8

2.2. Логическая схема базы данных: 10

2.2.1. Описание структуры таблиц 10

2.2.2. Нормализация базы данных 14

2.3. Архитектура системы 16

3. РЕАЛИЗАЦИЯ 17

3.1. Физическая схема БД 17

3.2. Особенности реализации приложения 19

3.3. Описание пользовательского интерфейса 20

3.4. Алгоритмы 34

4. ТЕСТИРОВАНИЕ ПРОГРАММЫ 52

4.1. Первый этап тестирования 52

4.2. Второй этап тестирования 55

4.3. Третий этап тестирования 56

4.4. Четвертый этап тестирования 56

4.5. Пятый этап тестирования 56

5. БЕЗОПАСНОСТЬ ДАННЫХ 60

ЗАКЛЮЧЕНИЕ 61

Список литературы 62

ПРИЛОЖЕНИЯ 63

1. Сценарий создания БД 63

2. Тексты запросов, хранимых процедур, триггеров 69

3. Образец программного кода 107

Процедура GetDateOfNumber 107

Процедура IsCorrectFloatString 108

Процедура NaturalNumberUp999ToString 109

Процедура DrawGraphLine 113

Процедура DrawGraphLineWithSpline 113

Функции DateDays, DateSeconds библиотеки libraryDateDaysSeconds 114

Модуль для работы со сканером 115

Модуль для работы с кассовым аппаратом 118

Модуль BGL 123

ВВЕДЕНИЕ

Цель данной работы заключается в автоматизации работы небольшого хозяйственного магазина. Данная организация занимается тем, что привозит хозтовары с оптовых баз, затем торгует ими. Данная программа позволяет оперативно фиксировать остатки товаров на складе, цены на товары, продавать товары (пробивать чеки, печатать товарные чеки, фиксировать продажи в базе данных) и делать возврат. Также программа дает статистику работы магазина (общая прибыльность магазина, зависимость числа покупателей и прибыльности от времени суток, от дня недели, от числа месяца, от месяца, от времени года и т. д.). Программа также содержит отчеты, необходимые для нормальной работы магазина. По желанию заказчика в нее могут быть добавлены новые отчеты, необходимые ему, которых нет в данной программе.

Подобные программы уже, конечно, существуют, но данная программа имеет перед ними некоторые преимущества:

1) Программа содержит только необходимые функции и ничего лишнего, также у нее простой и понятный пользовательский интерфейс. Поэтому с ней могут работать пользователи, не очень хорошо разбирающиеся в компьютерах.

2) Программа позволяет максимально легко и быстро вводить товары, привезенные с оптовых баз, а также выполнять поиск по заданным параметрам.

3) Программа может быть доработана по желанию заказчика (изменен интерфейс, добавлены новые возможности (новые виды поиска, отчетность, статистика)).

4) Если у заказчика возникнут какие-либо проблемы с программой, они могут быть решены с минимальными затратами сил и с максимальной эффективностью (так как автор сам разрабатывал программу с нуля).

1. АНАЛИЗ ПРЕДМЕТНОЙ ОБЛАСТИ И ОПРЕДЕЛЕНИЕ ТРЕБОВАНИЙ К СИСТЕМЕ

1.1. Анализ круга пользователей

Программой должны пользоваться следующие работники предприятия:

1) Кассир

2) Менеджер

3) Руководитель предприятия

Для каждого из сотрудников предприятия программа должна обеспечивать следующие возможности:

1) Кассиру – возможность быстро находить нужную информацию в базе, продавать товары и делать возврат от покупателя.

2) Менеджеру – возможность заносить товары, привезенные с оптовых баз, быстро находить нужную информацию в базе (какие товары есть на складе, по каким ценам, себестоимость товаров, статистические данные и т. д.), а также возможность печатать отчеты.

3) Руководителю предприятия – возможность быстро находить нужную информацию в базе, просматривать статистику работы предприятия, печатать отчеты, изменять цены на товары.

1.2. Требования заказчика к функциональности программы

1) Работа кассира

Процесс продажи товара должен выглядеть так:

В процессе продажи кассир должен видеть перед собой таблицу с информацией о продаваемых товарах. Программа должна предоставлять возможность кассиру добавлять записи в таблицу (с помощью ввода магазинного кода товара или с помощью сканера, а также, если сканера нет под рукой, программа должна предоставлять возможность вручную ввести скан-код), а также изменять их и удалять. Каждая строка таблицы должна соответствовать продаваемому товару.

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

Программа должна предоставлять возможность продавцу вводить скидку, а также изменять данные в поле, где отображается цена со скидкой. При этом программа должна автоматически рассчитывать скидку по исходной цене и цене со скидкой.

В самом правом столбце каждой строки должна отображаться информация о стоимости введенного количества товара данной строки.

Если все данные продавец ввел правильно, на экране должна отображаться общая стоимость всех продаваемых товаров. После этого продавец должен ввести сумму, которую он получил от покупателя, в поле «Наличные». При этом программа должна рассчитать сдачу.

Если сумма в поле «наличные» меньше общей стоимости товаров, программа не должна давать возможность пробить чек.

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

Программа должна предоставлять кассиру возможность возврата товара. Процесс возврата товара должен выглядеть так:

При продаже товара на каждом чеке должен печататься код покупки. При возврате товара продавец вводит код покупки, написанный на чеке покупателя. При этом на экране должны высветиться купленные товары. Продавец выбирает, какие товары возвращает покупатель и вводит количество. После этого программа должна пробить чек возврата.

Если покупатель принес товар для возврата, но не принес чек, программа должна предоставлять продавцу возможность найти код покупки по части названия товара, по артикулу, по части скан-кода, по дате и времени покупки, а также по цене покупки.

Кассир может только продавать товары и делать возврат от покупателя. Программа должна не позволять ему выполнять прочие действия, изменяющие данные в базе (просматривать кассир может любую информацию).

2) Работа менеджера

Менеджер отвечает за занесение информации о товарах, закупленных магазином на оптовых базах. Процесс занесения товаров выглядит следующим образом:

Менеджер вводит информацию об оптовой закупке (дата закупки, база, на которой закуплен товар);

Затем менеджер заносит товары в оптовую закупку. Пока менеджер заносит товары в оптовую закупку, они не должны быть доступны для продажи. Программа должна предоставлять возможность параллельного занесения товаров нескольким пользователям. При этом каждый пользователь должен видеть только занесенные им товары;

После того, как все товары занесены, менеджер сверяет сумму занесенных товаров с суммой, указанной в накладной. Если эти суммы совпадают, оптовая закупка закрывается, товары становятся доступными для продажи и недоступными для изменения.

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

Первый способ: занесение товара, которого еще не было в данном магазине. Менеджер заводит новый магазинный код товара, вводит название товара, артикул и единицу измерения, выбирает местоположение товара в дереве групп, затем вводит количество и стоимость (эти данные указываются в накладной). Затем менеджер может ввести скан-коды для созданного товара (вручную или с помощью сканера).

Второй способ: менеджер выбирает существующий товар с помощью навигации по дереву групп, с помощью ввода магазинного кода (если он помнит этот код) существующего товара, или с помощью сканера. Во всех этих случаях на экране должно высветиться название существующего товара, артикул, текущая цена, себестоимость, остаток и другие данные, которые должны быть недоступными для изменения.

Менеджер не всегда помнит, в какой группе дерева расположен товар, поэтому программа должна предоставлять возможность поиска по части названия, по части артикула и по части скан-кода.

3) Работа руководителя предприятия

Программа должна предоставлять возможность руководителю предприятия просматривать статистику работы магазина за любой выбранный период (какие товары были проданы, в каких случаях имела место скидка), а также выводить эти данные на печать.

Руководитель предприятия должен иметь возможность просмотреть и распечатать остатки товаров на складе (например, для проведения инвентаризации), а также также изменить цены. При этом программа должна предоставлять возможность печати измененных ценников за выбранный период (чтобы была возможность синхронизировать ценники на витрине и ценники в базе).

1.3. Требования заказчика к пользовательскому интерфейсу

1) Программа должна работать в операционной системе Windows XP. Пользовательский интерфейс должен соответствовать стандартам для приложений Windows (формы, кнопки, переключатели и т. д.).

2) Интерфейс должен быть максимально простым и понятным. Везде, где могут возникнуть трудности, должны быть написаны подсказки. Программа должна иметь только необходимые функции и ничего лишнего.

3) Пользовательский интерфейс должен быть построен так, чтобы минимизировать возможность ошибок. Если ошибочные данные все-таки занесены, должна быть возможность легко и быстро их исправить.

4) Самые часто выполняемые и рутинные операции (например, занесение привезенных товаров в базу) должны выполняться по возможности быстро и удобно.

5) Программа должна работать быстро («без тормозов»). Системные характеристики машины, на которой будет работать программа: Intel Celeron D 2400 Mhz, 256 Mb RAM, что должно быть достаточно для обеспечения деятельности небольшого магазина, с невысокой интенсивностью продаж.

6) Программа должна выдавать отчеты в формате doc (для возможности последующего форматирования в Microsoft Word).

7) Программа должна предоставлять защиту от несанкционированного доступа. Предполагается, что пользователи не очень хорошо разбираются в компьютерах, а сервер общедоступен, поэтому достаточно защиты на уровне приложения.

2. ПРОЕКТНАЯ ЧАСТЬ

2.1. Система бизнес-правил

1) Для каждого товара должен храниться магазинный код товара (число от 10000 до 999999), артикул (обычно не длиннее 10 символов), а также скан-коды. Скан-коды состоят из 13 цифр. Для каждого магазинного кода товара может быть несколько скан-кодов, а также для одного скан-кода может быть несколько магазинных кодов. Программа должна давать возможность завести для каждого кода товара до 6 скан-кодов.

2) Товары могут быть как штучными (можно продать только целое количество товара (например, коврики для ванной)), так и вещественными (можно продать часть единицы товара (например, 75 сантиметров провода, когда длина провода измеряется в метрах). Программа должна давать возможность продать не целое количество вещественного товара, и не должна давать возможности продать не целое количество штучного товара. Подавляющее большинство товаров – штучные (магазин хозяйственный). Именно на них в основном следует ориентироваться при разработке интерфейса программы.

3) Товары закупаются на оптовых базах. Программа должна хранить список оптовых баз (должно храниться название базы, адрес, ФИО менеджера, телефон менеджера и телефон главного бухгалтера). Также должна быть доступна информация о том, на какую сумму было закуплено товаров на той или иной оптовой базе.

4) Занесение товаров, привезенных с оптовой базы, производится следующим образом: сначала заводится оптовая закупка. В ней должны фиксироваться дата и время закупки, а также оптовая база. Затем в оптовой закупке создается сессия, в которую заносятся товары. Пока сессия не закрыта, занесенные товары не доступны для продажи. Как только сессия становится закрытой, занесенные товары становятся доступными для продажи. Должна быть возможность создания нескольких сессий для параллельного занесения товаров несколькими пользователями, а также для возможности закрытия сессий, когда не все товары оптовой закупки занесены (чтобы была возможность торговать). Также после закрытия сессии цены на товары, занесенные под старыми кодами, изменяются по следующему принципу: если новая цена больше старой, устанавливается новая цена, иначе остается старая цена. Должна быть возможность посмотреть изменившиеся ценники за заданное количество дней.

5) Товары заносятся в сессию одним из следующих способов:

5.1. Заводится новый код товара, которого до этого небыло в базе, и под ним заносятся название товара, артикул, местоположение, количество и стоимость данного количества товара (именно она указывается в накладной). Затем заносятся скан-коды (один или несколько). Должна быть возможность заносить скан-коды с помощью сканера или вручную. Затем заносится наценка товара, после чего должна автоматически вычисляться розничная цена, или заносится цена, тогда должна автоматически формироваться наценка. Наценка не может быть больше 1000%.

5.2. Товар заносится под старым кодом (если такой товар уже был занесен в программу). При занесении товара пользователь должен иметь возможность найти код товара в Справочнике Товаров, либо найти код по части названия, по части артикула, или по части скан-кода. При этом на экране должна отображаться старая цена товара (которая сейчас имеет место в магазине). Все остальные параметры заносятся также, как и при первом способе. При этом поля с названием товара, артикулом и местоположением блокируются от изменений.

Пользователь должен иметь возможность заносить товары любым из этих способов.

6) Программа должна автоматически округлять розничную цену товара по следующим правилам: если товар стоит менее 5 рублей, округляем цену до 10 копеек; если товар стоит от 5 до 20 рублей, округляем цену до 50 копеек; если товар стоит больше 20 рублей, округляем цену до рубля.

7) Должна быть возможность разбить все товары по группам в виде дерева с глубиной вложенности не менее 8-10.

8) Программа должна давать возможность продажи товаров покупателям. При этом продавец может сделать скидку на отдельные товары покупки (одна покупка может содержать несколько товаров). Кроме этого, продавец должен иметь возможность просто изменить цену продажи (скидка на глазок). Это бывает нужно, когда цена на витрине не совпадает с ценой в базе, а также когда нужно сделать скидку на определенную сумму, или вручную округлить копейки. При изменении цены товара должна автоматически вычисляться скидка, и наоборот, при изменении наценки должна автоматически вычисляться цена товара (округление до 1 копейки). Введение товаров для продажи может осуществляться следующими способами: вводится вручную код товара, или вводится скан-код (вручную или с помощью сканера). При этом должна быть возможность поиска кода товара по названию и артикулу (иногда бывают товары, на которые почему-то нет ни скан-кода, ни магазинного кода, ни даже цены). При этом продажи ведутся в одну смену, кассир один.

9) Программа должна давать возможность делать возврат товара от покупателя. При этом должна иметься возможность поиска покупателя, купившего данные товары. После этого на экране должна высвечиваться информация о купленных товарах. Возврат может производиться неограниченное количество раз, пока объем возврата не превышает объем покупки.

10) Программа должна хранить всю введенную информацию (какие товары с какой базы когда были привезены, даты оптовых закупок, дерево товаров, что и когда было продано, дату и время продажи, товары, имеющиеся на складе, возможность оставлять примечания для купленных товаров) для последующего анализа. Ничего не должно удаляться из базы.

11) Также нужна возможность делать примечания к оптовым базам, к продажам (например, такое: «мужчина 35 лет купил ведро с трещиной на крышке»).

12) Объемы данных будут такими: количество групп товаров – до двух тысяч. Количество наименований товаров – до двадцати тысяч. Количество продаж в день – до ста (обычно меньше). Программа должна нормально справляться с такими объемами данных «без тормозов».

2.2. Логическая схема базы данных:

Опираясь на приведенные выше бизнес-правила, разработаем логическую схему базы данных.

Логическая схема базы данных приведена на рисунке 2.1

Рисунок 2.1

2.2.1. Описание структуры таблиц

База данных содержит 16 основных таблиц. Каждая из таблиц имеет свое назначение:

1) Таблица goods (Справочник Товаров). Пожалуй, самая основная таблица. Хранит список товаров, имеющихся в данном магазине, или бывших когда-либо в данном магазине. Было принято решение не использовать код товара в качестве уникального значения ключа (так как в последующем будет добавлена возможность освобождать старые коды товаров (товары, которыми магазин уже давно не торгует), при этом сохранится информация о том, какие товары в то время продавались. При этом если CodeIsActive=1, то магазин таким товаром торгует, иначе этот код уже не используется. Таким образом, если CodeIsActive=1, то поле code_good однозначно идентифицирует товар, что и требуется. Поле number_good уникально и полностью скрыто от всех пользователей программы. Поле art содержит артикул товара. Это поле не уникально, но по нему может осуществляться поиск. Поле name_good содержит название товара. Таблица Товары также содержит поле code_ancestor (код группы) для определения группы, в которой он лежит (например, товар может лежать в группе “Стройматериалы\Дерево\Доски обрезные”). Этот код (code_ancestor) обязательно есть в таблице paths (Группы), если code_ancestor¹0 (то есть если папка не является корнем дерева), и по нему можно однозначно определить местоположение группы в дереве групп, а также ее название. Поле code_unit обозначает код единицы измерения товара, который хранится в таблице TitleUnits. Было принято решение не хранить название единицы измерения в таблице goods (Товары), так как возможен ошибочный ввод единицы измерения (например, пользователь может где-то ввести “кг”, где-то “Кг”, и т. д.), а также по той причине, что единица измерения определяет тип товара (штучный или вещественный). Этот тип может быть один раз задан для каждой единицы измерения. Он определяет, давать возможность продавцу торговать не целым количеством товара, или не давать. И наконец, поле scan_codes хранит скан-коды данного товара. Это поле денормализует структуру таблиц, но оно нужно для ускорения вывода списка товаров на форму (вообще, скан-коды для данного товара хранятся в таблице ScanCodes).

2) Таблица TitleUnits (Единицы измерения). Хранит единицы измерения товаров, используемые в программе. Поле code_unit однозначно определяет единицу измерения, и оно уникально. Поле name_unit содержит название единицы измерения (например, “м”, “шт”, “кг”). Поле IsActive определяет, доступна ли данная единица измерения для выбора из списка при занесении товаров. Поле IsMaterial хранит информацию о том, штучный товар или вещественный.

3) Таблица paths (Группы товаров). Хранит структуру дерева групп товаров. Дерево служит для удобства навигации по товарам. Поле code_path определяет группу товаров; поле code_ancestor – предка группы. Предок группы также содержится в группе paths, если он не равен нулю (в таком случае предком является корневой каталог). По коду группы можно однозначно вычислить полное имя группы. Поле name_path хранит название группы.

4) Таблица ScanCodes (Скан-коды товаров). Хранит список скан-кодов для данного номера товара. Число скан-кодов может быть не более 12. Любой из этих скан-кодов идентифицирует номер товара, а следовательно, и его код (хотя не всегда однозначно). В случае неоднозначности одному скан-коду соответствует несколько магазинных кодов, и пользователь должен выбрать нужный (программа предоставляет такую возможность).

5) Таблица StoreHouse (Склад). Хранит информацию о товарах, имеющихся в наличии, а также о том, сколько товара было продано. Поле number_good обозначает номер товара (ссылка на таблицу goods). Поле first_price обозначает себестоимость товара (вычисляется как сумма, которая потрачена на покупку данного товара, деленная на количество данного товара). Поле price обозначает текущую розничную цену товара (цену, по которой товар продается в магазине). Цена устанавливается руководителем предприятия, а также программой при занесении товаров, привезенных с оптовых баз. Поле sold хранит информацию о том, сколько товара было продано за все время существования данного number_good. Это, конечно денормализует базу, но зато ускоряет работу программы.

6) Таблица WholesaleBases (Оптовые базы). Хранит информацию об оптовых базах, на которых магазин закупал товары. Поле code_base является ключевым и однозначно идентифицирует базу. Поле name_base хранит название базы. Остальные поля (address, FIOman, PhoneMan, PhoneBK) хранят, соответственно, адрес оптовой базы, ФИО менеджера, телефон менеджера и телефон главного бухгалтера.

7) Таблица purchases (Оптовые закупки) хранит информацию о том, какие закупки и когда были сделаны. Поле code_base ссылается на таблицу WholesaleBases (ОптовыеБазы), и означает оптовую базу, где была сделана закупка. Также хранится дата данной закупки. Поле summa означает то, на какую сумму было закуплено товаров. Это денормализует базу, но зато ускоряет работу программы.

8) Таблица sessions (Сессии). Товар, который привезен с оптовой базы не обязательно заносить в одну таблицу сплошным списком. Товар можно занести в несколько сессий, чтобы таблица с занесенными товарами не была слишком большой для вывода на экран, а также для параллельного занесения товаров несколькими пользователями (чтобы они не мешали друг другу). Поле code_purchase ссылается на таблицу purchases (Оптовые закупки), означает код оптовой закупки. Поле addition позволяет задать наценку (в процентах) по умолчанию для товаров данной сессии (чтобы ее не вводить при занесении каждого товара). Поле date0 означает дату создания сессии, а поле date1 означает дату закрытия сессии (если она закрыта). Если accepted=0, то товар можно заносить в данную сессию, удалять из данной сессии (то есть сессия не закрыта). Пока товары заносятся в сессию, ими нельзя торговать. После закрытия сессии товары становятся доступными для продажи, при этом происходят изменения в таблице StoreHouse (Склад). После закрытия сессии в неё уже нельзя дозаносить товары. Поле summa означает сумму закупленных товаров для данной сессии. Оно денормализует базу, но ускоряет работу программы. Детальная информация о том, какие товары были занесены в текущей сессии хранится в таблице StructureSession.

9) Таблица StructureSession (СтруктураСессии). Это таблица, подчиненная таблице sessions, содержит детальную информацию о том, какие товары с какой наценкой были занесены в данную сессию (сессию с кодом code_session). Хранит number_good, которое ссылается на таблицу goods (Товары), и означает товар, который занесли. Поля quantity, first_price, addition означают, соответственно, количество, оптовую цену (в процентах) и магазинную наценку для данного товара (по умолчанию она равна значению, заданному в таблице sessions), но для каждого товара данной сессии наценка может быть своей. Поле scan_codes означает список скан-кодов для данного товара. Денормализует базу, но ускоряет работу программы (вообще, скан-коды для данной сессии хранятся в таблице ScanCodesForSession, так как их нельзя заносить в таблицу ScanCodes, потому что бизнес-правила запрещают торговать заносимыми товарами, пока сессия не закрыта).

10)Таблица ScanCodesForSession (Скан-коды для сессии) хранит список скан-кодов для товаров сессии (то есть пока сессия не закрыта, коды не активны).

11)Таблица ChangedPrices (Измененные цены). Хранит цены на товары, которые были изменены, и дату последнего изменения. Нужно, например, когда руководитель предприятия поменяет цены товаров на Складе, чтобы программа могла выдать информацию, какие ценники изменились за последние несколько дней (число дней задается), а также когда после закрытия сессии меняются ценники на некоторые товары.

12)Таблица sales (Продажи). Поле code_sale является ключевым и однозначно идентифицирует продажу. Поле date_sale означает дату продажи. Поле summa означает сумму данной продажи (денормализует базу, но ускоряет работу программы (например, при выводе большого списка продаж)). Поле cash означает сумму, которой расплатился покупатель (может пригодиться при поиске кода продажи, когда покупатель возвращает товар без чека). Детальная информация о том, какие товары были проданы в текущей продаже, хранится в таблице StructureSale.

13)Таблица StructureSale (Структура продажи). Хранит детальную информацию о том, какие товары были проданы в данной продаже. Поле number_good ссылается на таблицу goods и означает название товара. Поля quantity, first_price, price, discount, soldbyprice означают, соответственно, количество проданного за данную покупку товара, закупочную цену, цену, розничную цену товара на момент продажи, скидку (в процентах) и цену, по которой товар был продан. Поле summa означает сумму, на которую продан данный товар. При этом имеется некоторая избыточность, но она оправдана. summa не всегда равна произведению quantity*soldbyprice. Равенство выполняется строго, когда продается целое количество товара. При продаже вещественного количества товара может возникнуть такая ситуация: например, цена товара 1,01 руб., количество 1,5. Тогда сумма будет 1,52 руб., что не равно 1,515. Также soldbyprice не всегда равно price*(100-discount)/100. Например, товар стоит 1,90. Продавец делает скидку 15%. Товар должен стоить 1,615, но стоит 1,62. Но в базе все равно будет храниться скидка 15% (продавец именно ее делал). А поле soldbyprice нужно для поиска кода продажи по цене (при этом поле soldbyprice можно индексировать, а выражение price*(100-discount)/100 в Firebird не индексируется. В принципе, при желании можно обойтись без некоторых полей, и вычислять их, но это замедлит работу программы.

14)Таблица returns2 (возвраты). Хранит информацию о возвратах от покупателя. Возврат производится следующим образом: покупатель приносит чек, на котором написан код продажи, по нему продавец делает возврат. Поле code_sale как раз будет хранить код продажи, для которого делается возврат. Поле date_return хранит дату продажи. Поле summa хранит сумму возврата. Денормализует базу, но ускоряет работу программы. Детальная информация о том, какие товары были проданы, хранится в таблице StructureReturn.

15)Таблица StructureReturn2 (Структура возврата). Хранит детальную информацию о том, какие товары были возвращены при данном возврате. Хранится номер товара, количество и сумма возврата.

16)Таблица notes (примечания). Хранит примечания к оптовым базам, оптовым закупкам, сессиям, продажам и возвратам. Было решено не заводить для каждой таблицы подчиненную таблицу с примечаниями, а писать примечания ко всем таблицам в одну таблицу, так как предполагается, что примечаний будет немного. code_note – код примечания. number_table – номер таблицы, для которой это примечание. KeyFromTable – ключевое поле таблицы для которой сделано данное примечание (для таблицы WholesaleBases это code_base; для таблицы purchases это code_purchase; для таблицы sessions это code_session; для таблицы sales это code_sale; для таблицы returns это code_return. text – текст примечания. Названия и номера основных таблиц базы приведены в таблице 2.1.

1) TitleUnits	2) goods	Таблица 2.1
3) WholesaleBases	4) purchases
5) sessions	6) StructureSession
7) StoreHouse	8) sales
9) StructureSale	10) paths
11) notes	15) ScanCodes
16) ScanCodesForSession	18) returns2
19) StructureReturn2	22) ChangedPrices

2.2.2. Нормализация базы данных

Структура таблиц в целом приведена к третьей нормальной форме, за исключением некоторых полей, введенных в таблицу для ускорения работы программы. Итак, поля, которые мы не будем учитывать:

· goods (поле scan_codes)

· purchases (поле summa)

· sessions (поле summa)

· StructureSession (поле scan_codes)

· StoreHouse (поля quantity, sold, конечно вычисляемые но их очень долго вычислять. Для этого нужно пройтись по объемным таблицам StructureSession и StructureSale, что отнимает очень много времени, так как это самые большие таблицы. К тому же информация из них будет время от времени сливаться (иначе через несколько лет там будут миллионы записей))

· sales (поле summa)

· StructureSale (в принципе без полей soldbyprice и summa можно было бы обойтись)

· ScanCodesForSession (поле primarykey)

· returns2 (поле summa)

· StructureReturn2 (поле summa можно вычислить, заглянув в таблицу sales и посмотрев, за сколько был продан товар, затем полученное значение умножить на количество и выполнить округление. Но это недопустимо долго).

1НФ – требует, чтобы каждое поле таблицы базы данных было не делимым и не содержало повторяющихся групп. Неделимость поля означает, что содержащиеся в нем значения не должны делиться на более мелкие. Повторяющимися считаются поля, которые содержат одинаковые по смыслу значения.

В нашей структуре таблиц нет повторяющихся групп (можно легко проверить, просмотрев все таблицы). Почти все поля, кроме полей в таблице WholesaleBases являются неделимыми. Например, поле address не является неделимым, так как содержит разнородную информацию (текстовое название улицы и числовое название дома и квартиры). Также FIOman (ФИО менеджера) состоит и фамилии, имени и отчества. Но информация эта чисто справочная, поэтому разделять это нигде не потребуется, поэтому можно считать, что 1НФ имеет место.

2НФ – требует, чтобы все поля таблицы зависели от первичного ключа, т.е. чтобы первичный ключ, однозначно определял запись и не был избыточен.

Очевидно, во всех таблицах, где есть первичные ключи, они однозначно определяют запись. Первичных ключей нет только в таблице ScanCodes. Но там они и не нужны.

3НФ – требует чтобы, в таблице не имелось транзитивных зависимостей между не ключевыми полями, т.е. чтобы значение любого поля не входящего в первичный ключ не зависело от значения другого поля, так же не входящего в первичный ключ!

Проанализировав все таблицы и исключив поля которые мы договорились не учитывать, можно убедиться, что так оно и есть.

2.3. Архитектура системы

Архитектура системы приведена на рисунке 2.2.

Рисунок 2.2

Компьютер кассира, работающего в магазине, является сервером. Менеджер с главным бухгалтером подсоединены к серверу через сеть. Руководитель предприятия имеет возможность подсоединить свой ноутбук к сети и посмотреть, как идут дела, или воспользоваться для этого компьютером менеджера.

В идеальном случае в качестве сервера должен стоять отдельный компьютер с установленным сервером БД, с отсутствием несанкционированного доступа. Но на данном предприятии всего три компьютера, и фирма не может себе позволить простаивание одного из них. Поэтому на сервере будет также выполняться другая работа. Сервером является компьютер кассира. Это разумно по следующим причинам:

во-первых, данный компьютер самый мощный из всех;

во-вторых, он запитан через источник бесперебойного питания, который подсоединен не только к компьютеру, но и к кассовому аппарату (что позволяет избежать сбоев в программе в случае отключения электричества, а также нормально пробить чек);

в-третьих, кассиру не придется ежедневно с утра включать дополнительный компьютер, используемый в качестве сервера, для того, чтобы иметь возможность работать с программой;

в-четвертых, большую часть времени с программой будет работать именно кассир (отсутствие передачи данных по сети).

Недостатком такого решения является снижение безопасности. Опытный кассир легко скопирует базу себе домой, с целью внесения изменений.

3. РЕАЛИЗАЦИЯ

3.1. Физическая схема БД

Рисунок 3.1

Объясним, почему были выбраны именно такие типы данных:

1) Таблица goods (Товары). По идее, название товара (name_good) вряд ли будет размером больше 80 символов, поэтому было решено остановиться именно на этой цифре. Артикул (art) также вряд ли будет иметь длину более 20 (обычно у него длина меньше 10). А поле scan_codes хранит все скан-коды для данного товара в строковом формате с пробелами-разделителями (это поле нужно только для ускорения вывода больших объемов информации), поэтому было решено сделать его с запасом (varchar(255)).

2) Таблица TitleUnits (ЕдиницыИзмерения): code_unit – ключевое поле, при этом автоинкрементное. Для названия единицы измерения логично выбрать тип varchar длины 20, так как вряд ли могут потребоваться единицы измерения, имеющие большую длину (вообще, вряд ли их длина будет содержать более 5 символов, так как названия единиц измерения выглядят так: “шт”, “кг”, “м”). Поле IsActive обозначает, доступна ли в данный момент указанная единица измерения. Если IsActive=0, то пользователь её не сможет вносить, но она будет присутствовать в тех товарах, куда уже внесена. Если IsActive=1, то единица измерения активна. Вообще, было бы логично выбрать тип boolean, но так как Firebird его не поддерживает, был выбран тип integer. Поле IsMaterial (единица измерения является вещественной, если IsMaterial=1) тоже должно было иметь тип boolean, но по известной причине (тип boolean не поддерживается сервером Firebird), был выбран тип integer.

3) Таблица paths (Группы). Для названия группы тип varchar(80) вполне подходит.

4) В таблице ScanCodes было решено сделать scan_code строковым типом, который, однако, может содержать только 13-значные числа. Тип integer для этой цели не подходит, так как может хранить только 9-значные числа.

5) Таблица StoreHouse (Склад) хранит только то, что есть на складе. Если товар лежит на складе, то он не знает, с какой оптовой базы он был закуплен. Поэтому достаточно хранить его количество (quantity), себестоимость (first_price) (средневзвешенное значение закупочных цен, если товар был привезен неоднократно по разным ценам), цену (price) и количество проданного товара (sold). Если товар сыпучий (например, сахарный песок), то при инвентаризации будет видно, сколько данного товара было продано, и сколько осталось. Например, если было продано 500 кг сахарного песка, то недостача в 2 кг вполне допустима, но если было продано 20 кг песка, то есть повод задуматься.

6) Таблица WholesaleBases хранит список оптовых баз, на которых магазин закупал товары. Для названия оптовой базы вполне достаточно строкового поля длиной 80, а в строку длиной 40 символов можно записать несколько телефонных номеров.

7) В таблице purchases поле summa нужно только для ускорения вывода данных. Оно хранит сумму, на которую были закуплены товары данной оптовой закупки. Поэтому оно имеет тип float.

8) В таблице sessions поле accepted должно было иметь тип boolean, но за неимением данного типа используется integer. Поля addition (наценка) и summa (сумма) целесообразно сделать вещественными, так как наценка не обязана быть целым числом (может быть, например, 72,5%), а деньги было решено хранить в вещественном формате.

9) Таблица StructureSession (СтруктураСессии). Поле scan_codes хранит список скан-кодов, которые будут доступны для данного товара после занесения сессии. Оно аналогично полю scan_codes таблицы goods. Так как товар может быть штучным или вещественным, было решено хранить количество товара в вещественном формате. Поле first_price хранит закупочную цену, поэтому разумно использовать тип float. Поле addition хранит наценку, которая может быть не целым числом, поэтому тип float для него подходит.

10) Типы таблицы ScanCodesForSession аналогичны типам таблицы ScanCodes. Таблица ScanCodesForSession нужна только для временного хранения скан-кодов незакрытых сессий.

11) Таблица ChangedPrices хранит измененные ценники и дату последнего изменения. Для даты разумно использовать тип timestamp, а для хранения новой цены – тип float.

12) Таблица sales (Продажи) не требует пояснений.

13) В таблице StructureSale (СтруктураПродажи) целесообразно по известным причинам (см. пояснения для таблиц StoreHouse и StructureSession) хранить количество, закупочную цену, розничную цену, скидку для покупателя, а также цену, по которой был продан товар и стоимость товара в вещественном формате.

14) Таблица returns2 (Возвраты) не требует пояснений.

15) Таблица StructureReturn2 хранит возвращенные товары, а также их количество и сумму. Для последних разумно использовать тип float.

16) Для таблицы notes (Примечания) решено было ограничить размер примечания 80 символами (для того, чтобы не перегружать базу).

3.2. Особенности реализации приложения

Программа написана на Borland Delphi. В качестве рабочей версии была выбрана седьмая версия компилятора Delphi. В качестве СУБД выбран Firebird версии 1.53.

По сути, программа состоит из двух частей: серверная (хранимые процедуры) и клиентская (код программы).

Программа работает под операционной системой Windows XP. Для нормальной работы программы нужно разрешение экрана не менее, чем 1024x768, поддержка режима VGA (256 цветов), 64 мегабайта оперативной памяти и процессор уровня Intel Celeron 400 Mhz, хотя для нормальной работы программы на сервере лучше иметь машину помощнее.

Программа полностью соответствует стандартам для программ Windows (главные меню, контекстные меню, кнопки, переключатели и т. д.). Для работы с данной программой требуются минимальные навыки работы с компьютером (умение включить и выключить компьютер, запустить программу с рабочего стола, умение пользоваться главными и контекстными меню, кнопками и переключателями).

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

Манипуляции с данными происходят так: вызывается нужная хранимая процедура с входными параметрами, на выход процедура выдает ошибку (переменная типа integer). Если ошибка равна нулю, то действия прошли успешно, иначе в зависимости от полученного номера ошибки клиентская программа выдает соответствующее сообщение об ошибке.

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

Все запросы и вся работа с данными (например, различные сортировки) производится на сервере. Это можно себе позволить для небольшого магазина, так как число пользователей невелико (2—3). При таком подходе упрощается реализация программы, к тому же не нужны мощные клиентские машины и снижается нагрузка на сеть (по сети передается только нужная информация). Тем не менее, со временем планируется перенести часть работы на клиента (чтобы не перегружать сервер).

3.3. Описание пользовательского интерфейса

На рисунке 3.2 приведена основная форма программы. Она появляется сразу после входа в программу.

Рисунок 3.2

Для использования программы в работе магазина через нее нужно занести информацию о товарах, которыми торгует данный магазин, в базу. Программа предоставляет возможность разбить товары на группы для более удобной организации работы. Перед первым занесением информации о товарах рекомендуется продумать структуру групп. Программа позволяет создавать, переименовывать, удалять, перемещать записи (в том числе группы, а также товары, находящиеся в этих группах) в процессе занесения товаров, но для большего порядка лучше сразу определить основные группы. Форма для занесения групп товаров приведена на рисунке 3.3.

Товары поставляются в магазин с оптовых баз, поэтому перед занесением информации о товарах из очередной оптовой закупки необходимо убедиться, что оптовая база, с которой поставлены товары, имеется в списке оптовых баз программы. Если такой записи нет, ее нужно добавить. Для этого на основной форме (рисунок 3.2), появляющейся при входе в программу, следует нажать кнопку «Работа с оптовыми базами». На экране появится форма для работы с оптовыми базами (рисунок 3.4).

Рисунок 3.3

Рисунок 3.4

В данной форме с помощью команд главного или контекстного меню можно добавлять, изменять или удалять информацию об оптовых базах.

Итак, нужные оптовые базы заведены. Теперь необходимо занести информацию о товарах. Для этого выходим из формы для работы с оптовыми базами в главную форму (рисунок 3.2) (из любой формы данной программы можно выйти с помощью клавиши <Esc>). Выбираем пункт «Занесение товаров». После нажатия данной кнопки на экране появится форма «Занесение закупленных товаров в базу» (рисунок 3.5):

Рисунок 3.5

На рисунке 3.5 приведено отображение списка оптовых закупок в форме. При поставке товаров с оптовой базы, нужно завести оптовую закупку. Делается это с помощью команд главного или контекстного меню. Процесс создания оптовой закупки выглядит следующим образом (рисунок 3.6).

Нужно выбрать из списка оптовую базу, при отсутствии сведений о базе в списке (см. «Работа с оптовыми базами»). Дата оптовой закупки устанавливается автоматически как текущая, но ее можно изменить.

После создания оптовой закупки в нее можно заносить товары. Для того, чтобы начать заносить товары, в данной оптовой закупке нужно создать сессию. Сессии нужны для удобства занесения товаров. Оптовая закупка может содержать большое количество товаров, и в таком случае удобнее разбить товары по сессиям, чем заносить их большим списком. Кроме того, это очень помогает при занесении товаров оптовой закупки несколькими пользователями одновременно. В этом случае каждый пользователь будет видеть только те товары, которые он занес. При этом пока сессия не закрыта, товары недоступны для продажи в магазине. Это нужно для того, чтобы предотвратить несовпадение ценников на витрине и в базе.

Рисунок 3.6

Рисунок 3.7

После закрытия сессии ответственный за цены человек должен заменить старые ценники на витрине на новые. Список товаров, на которые нужно поменять ценники, программа выдает в виде документа Microsoft Word. Создать сессию можно с помощью команд главного или контекстного меню. Процесс создания сессии прост, и не требует иллюстраций. При создании сессии необходимо только указать магазинную наценку на товары. При занесении товаров в данную сессию розничная цена будет формироваться автоматически. Конечно, при желании ее можно будет изменить (и наценку тоже).

Итак, сессия создана. При двойном щелчке мышью по созданной сессии на экране появится форма для занесения товаров (рисунок 3.7).

Пока в сессию не занесено ни одного товара. Открыть форму для добавления товара в сессию можно с помощью команд главного или контекстного меню, или с помощью клавиши <пробел>. После данных действий на экране появится форма для занесения товара (рисунок 3.8):

Рисунок 3.8

Рисунок 3.9

Товары можно заносить несколькими способами. Рассмотрим первый способ. Он используется, когда заносятся новые товары, которых в магазине еще нет. Вводим новый магазинный код товара вручную, или с помощью кнопки «Завести новый код товара». Затем вводим название товара, артикул, количество, выбираем единицу измерения («шт», «м» или «кг»). После этого вводим стоимость данного количества товаров, указанную в накладной. После выполнения данных действий форма должна принять примерно следующий вид (цена и себестоимость сформировались автоматически) (рисунок 3.9).

После этого нужно указать местоположение товара. Делается это следующим образом: нажимаем клавишу «Задать», на экране появляется форма, приведенная на рисунке 3.3 (Справочник товаров).

Щелкнем два раза по той группе дерева, куда нужно занести товар, и данная форма закроется, и на экране отобразится предыдущая, но уже с определенной группой (рисунок 3.9):

Рисунок 3.10

Теперь с помощью сканера или вручную заведем скан-коды для данного товара. Эти скан-коды будут использоваться для распознавания товаров с помощью сканера при торговле в магазине. После этого нажимаем «Занести», и если все поля заполнены правильно, в сессию добавится товар, и на экране отобразится следующее (рисунок 3.11).

Теперь можно заносить следующий товар.

Опишем теперь второй списоб занесения товара. На форме занесения товара введем код существующего в базе товара, или просканируем его. Если товар с данным кодом уже существует, все необходимые поля будут заполнены автоматически, и их нельзя будет изменить. Форма при этом будет выглядеть следующим образом (рисунок 3.12).

Рисунок 3.11

Рисунок 3.12

После этого остается только ввести количество, сумму, исправить цену. В случае, если новая цена незначительно отличается от старой, которая также показывается на экране, цену можно оставить прежней, чтобы не менять впоследствии ценники на витрине.

Если товар не сканируется, а магазинный код товара неизвестен (невозможно физически запомнить такое количество кодов!), то товар можно выбрать из Справочника. Делается это следующим образом: нажимаем клавишу «Выбрать существующий товар из справочника», в открывшемся окне выбираем группу, где лежит товар, а в ней выбираем товар. После этого нужные поля на форме занесения товара заполнятся автоматически также, как если бы мы вручную ввели код товара.

Итак, товары в сессию занесены. Теперь нужно проверить правильность занесения. Методов проверки несколько, один из них такой:

товары нужно заносить по одной странице накладной в одну сессию (то есть заводить столько сессий, сколько страниц в накладной);

затем сверить общую стоимость товаров;

затем закрыть сессию.

Теперь товарами, занесенными в данную сессию, можно торговать, но до этого необходимо изменить некоторые ценники. Порядок извлечения из программы списка изменившихся ценников будет описан далее.

Форма для торговли товарами приведена на рисунке 3.13.

Рисунок 3.13

Данная форма предоставляет возможность осуществить следующее:

· Ввести товары для продажи с помощью кода товара или скан-кода.

· Сделать скидку с помощью ввода скидки или с помощью изменения цены.

· Подсчитать автоматически общую сумму покупки. Чтобы пробить чек, обязательно нужно ввести наличные. Это нужно, во-первых, потому что не все умеют хорошо считать в уме, и все равно нужен был бы калькулятор. Во-вторых, это дополнительная гарантия того, что продавец не забудет взять деньги от покупателя.

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

· Ввести примечание к покупке (например, «у чашки имеется скол на ручке») для последующего поиска при возможном возврате товара в магазин.

· Обслужить несколько покупателей без необходимости запускать вторую копию программы. Достигнуто это с помощью вкладок. Каждая вкладка имеет свои компоненты.

· Осуществить поиск товара по части названия, по артикулу и по части скан-кода. Если введен целый скан-код (13 цифр), то поиск ведется с вероятностью несовпадения нескольких цифр скан-кода (это может быть полезно, если при занесении товара скан-код был введен неправильно). Вид формы для поиска товара приведен на рисунке 3.14.

Рисунок 3.14

Программа позволяет осуществлять возврат товара. Процесс возврата товара выглядит следующим образом: на каждом чеке написан код покупки (рисунок 3.15).

Для возврата товара продавец должен ввести данный код покупки на форме для возврата товаров, и на экране будут отображены товары данной покупки. Вид формы приведен на рисунке 3.16.

Рисунок 3.15

Рисунок 3.16

На экране отображены товары, также прописанные в чеке покупателя. В графе «количество» записано количество товара, которое было куплено первоначально. В графе «остаток» записано количество товара данной покупки, которое еще имеется у покупателя (остальное он уже вернул в магазин). Для возврата товара нужно ввести количество возвращаемых товаров, затем нажать кнопку «Возврат товара». Программа предоставляет возможность производить возврат по чеку неограниченное количество раз, пока объем возврата не превысит объем покупки.

Рисунок 3.17

Если покупатель принес товар для возврата без чека, то следует искать код покупки по базе. Для этого имеется специальная форма (рисунок 3.17). Покупатель может помнить, за какую сумму он купил данный товар, какими купюрами расплачивался, когда он купил этот товар (дата и время), какие товары он покупал совместно с возвращаемым. Поиск также может производиться по части названия товара, по скан-коду и по части артикула.

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

Руководитель предприятия может просмотреть товары, хранящиеся на Складе. Для этого в главной форме программы (рисунок 3.2) следует нажать кнопку «Работа с товарами на Складе». Затем нужно выбрать группу, в которой нужно просмотреть товары. После двойного щелчка на экране отобразится форма, приведенная на рисунке 3.18.

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

Рисунок 3.18

На предыдущей форме (которая высвечивается после нажатия на главной форме кнопки «Работа с товарами на Складе») можно также распечатать дерево групп товаров, распечатать все товары магазина или выбранной группы в виде дерева, а также посмотреть измененные ценники.

Форма для просмотра измененных ценников приведена на рисунке 3.19.

Руководитель предприятия может просмотреть измененные ценники на товары, за любой предшествующий период.

Рисунок 3.19

Рисунок 3.20

Руководитель предприятия может просмотреть итоги любого дня. Форма для просмотра итогов дня приведена на рисунке 3.20.

Данная форма позволяет просмотреть товары, проданные за определенный период, а также различную статистику (например, зависимость оборота и прибыли от времени). Также из данной формы можно изменять ценники.

Для того, чтобы любой пользователь программы не мог делать любые действия, имеется возможность создать нескольких пользователей и наделить их различными правами. Форма для входа в программу приведена на рисунке 3.21.

Рисунок 3.21

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

Рисунок 3.22

Имеется 2 типа пользователей: простой и с правом создания других пользователей. Если в колонке «Права» написано «3», то это администратор. Если в колонке «Права» написано «2», то пользователь имеет право создавать других пользователей, наделяя их правами не большими, чем имеет сам. Если в колонке «Права» написано «1», то пользователь имеет право менять свой пароль. Если написано «0», то пользователь вообще не имеет никаких прав по работе с пользователями.

Форма для создания пользователя приведена на рисунке 3.23.

Рисунок 3.23

Для создания пользователя необходимо указать свой пароль, ввести имя пользователя и его пароль, затем наделить пользователя правами.

3.4. Алгоритмы

Данная программа производит различные манипуляции с данными в основном с помощью хранимых процедур. Но вывод данных (таблицы, деревья, графики и т. д.) в основном производится с помощью SQL-запросов. Один из самых сложных SQL-запросов выглядит так:

select

code_path, name_path, paths.code_ancestor,

count(code_good) chislo

from paths left join goods

on paths.code_path=goods.code_ancestor and CodeIsActive=1

group by code_path, name_path, paths.code_ancestor

order by name_path

Этот запрос используется для формирования дерева групп товаров. Дерево групп товаров приведено на рисунке 3.24.

Рисунок 3.24

Для каждой группы нужно определить имя (для вывода на форме), код группы, код предка группы и число товаров, лежащих в данной группе. Число товаров в группе нужно для того, чтобы определить, пустая группа .или не пустая. Для групп, содержащих хоть один товар, на форме выводится картинка рядом с названием группы. Для пустых групп такой картинки не выводится. Первоначально заполнение дерева производилось следующим образом: выполнялся запрос select * from paths. Затем для каждой из групп выполнялся запрос с целью выяснения, пустая она или нет: select count(*) from goods where code_ancestor=:code_path. Таким образом, выполнялось столько запросов, сколько групп в дереве. Но уже при ста группах программа стала «тормозить». Поэтому было принято решение придумать один сложный запрос для сервера, полученные данные обрабатывать уже на клиенте с помощью средств языка Delphi. Заполнение дерева групп производится следующим образом:

Объявляем необходимые типы для закачки данных с сервера на клиент:

const

step=50;

type

tMassiv=record

code_path: integer;

code_ancestor: integer;

chislo: integer;

name_path: string;

end;

var

massiv: array of tMassiv;

LengthMassiv: integer; RealLengthMassiv: integer;

Итак, тип данных tMassiv хранит то, что выдает тот самый сложный запрос (код группы, код предка, число товаров в группе и название группы). Массив объявлен переменного размера, так как неизвестно, какое количество записей выдаст сервер. step – шаг увеличения размера массива после добавления в него элементов. Это нужно, чтобы при каждом добавлении данных не увеличивать размер массива на единицу (что отнимает время). LengthMassiv – это логическая длина массива (сколько элементов в него закачано). RealLengthMassiv – физическая длина массива (сколько элементов в него может быть закачано). Именно это значение увеличивается шагами, имеющими размер step. Вот процедура для заполнения данного массива:

procedure FillingMassiv;

begin

with Form2 do begin

TR_SelectPaths.Active:=false; TR_SelectPaths.Active:=true;

Q_SelectPaths.Close; Q_SelectPaths.Open;

LengthMassiv:=0;

SetLength(massiv, step);

RealLengthMassiv:=step;

Q_SelectPaths.First;

while not Q_SelectPaths.Eof do begin

if LengthMassiv=RealLengthMassiv then begin

inc(RealLengthMassiv, step);

SetLength(massiv, RealLengthMassiv);

end;

massiv[LengthMassiv].code_path:=

Q_SelectPaths.FieldValues['code_path'];

massiv[LengthMassiv].code_ancestor :=

Q_SelectPaths.FieldValues['code_ancestor'];

massiv[LengthMassiv].name_path :=

Q_SelectPaths.FieldValues['name_path'];

massiv[LengthMassiv].chislo:=Q_SelectPaths.FieldValues['chislo'];

inc(LengthMassiv);

Q_SelectPaths.Next;

end;

Q_SelectPaths – это тот самый сложный запрос. Итак, массив заполнен. Теперь нужно заполнить дерево. Заполнение дерева производится рекурсивно с помощью стандартной процедуры добавления элемента в дерево AddChildObject. Выбор потомков для каждой группы производится полным перебором. Это, конечно, неоптимально, но при 2000 групп скорость вполне приемлема, а больше вряд ли понадобится (реально в магазине используется где-то 200 групп). При необходимости этот процесс можно значительно ускорить, если использовать вместо массива, например, дерево. Вот процедура для заполнения дерева:

procedure FillingTree;

var

i: integer;

procedure Add0(where: TTreeNode; what: integer);

//куда_добавляем и что_добавляем -- параметры процедуры

var

code_path: integer;

name_path: string;

p: TTreeNode;

i, j: integer;

ExistSubPaths: boolean;

begin

with Form2 do begin

for i:=0 to LengthMassiv-1 do begin

if massiv[i].code_ancestor=what then begin

//Достаем из массива код папки и название папки

code_path:=massiv[i].code_path;

name_path:=massiv[i].name_path;

//Добавляем данный элемент в дерево

p:=TreeView1.Items.AddChildObject

(where, name_path, pointer(code_path));

//Определяем, какие папки непустые и делаем рисунки

if massiv[i].chislo=0 then p.StateIndex:=0

else p.StateIndex:=1;

ExistSubPaths:=false;

for j:=0 to LengthMassiv-1 do begin

if massiv[j].code_ancestor=code_path then

ExistSubPaths:=true;

end;

if ExistSubPaths then Add0(p, code_path);

end;

begin

FormActivate0;

with Form2 do begin

//создаем корень дерева

TreeView1.Items.Clear;

TreeView1.StateImages:=ImageList1;

TreeView1.Items.Add(nil, 'Структура товаров магазина "Идеал"');

//заполняем динамический массив элементами

FillingMassiv;

//теперь заполняем дерево

Add0(Form2.TreeView1.Items.Item[0], 0);

TreeView1.Items.Item[0].Expanded:=true;

end;

FilledTree:=true;

end;

В программе (раздел статистики работы магазина) есть один интересный график – зависимость процента прибыли от процента покупателей, приведенный на рисунке 3.25.

Рисунок 3.25

Из данного графика видно, что 20% покупателей приносят 70% прибыли. 10% покупателей приносят 55% прибыли. Закон 20-80 почти работает!

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

procedure DeleteFrontZeros(var s: string);

{удаляет впередистоящие нули у натурального числа}

var

i: integer; {позиция последнего ненужного нуля}

begin

September.DoStringOnlyDigits(s);

i:=0;

while (i+1<=length(s)) and (s[i+1]='0') do inc(i);

delete(s, 1, i);

if s='' then s:='0';

end;

Эта процедура очень часто использовалась в программе для коррекции введенных пользователем целых чисел. Обычно вызов данной процедуры привязывался к событию OnExit поля ввода.

Эта процедура использует процедуру DoStringOnlyDigits. Ее цель состоит в том, чтобы убрать из строки все символы, не являющиеся цифрами. Данная процедура очень часто использовалась отдельно – для разрешения ввода пользователю только цифр. Ее вызов привязывался к событию OnChange. Текст процедуры тривиален, поэтому приводить его не будем.

В программе в нескольких местах использовался ручной ввод числа, месяца и года. Пользователь мог неверно ввести эти данные. Для того, чтобы не писать во всех необходимых местах программы код для проверки правильности ввода даты, была создана функция, проверяющая правильность ввода даты. Вот ее интерфейс:

function IsCorrectDate(day, month, year: integer): boolean;

Текст процедуры тривиален, поэтому нет необходимости его приводить.

В некоторых местах программы была необходимость вывести список товаров за последние n дней, где число n задается пользователем. Для того, чтобы посчитать дату начала периода, понадобилась функция, возвращающая абсолютный номер дня по числу, месяцу и году, а также обратная функция. За точку отсчета было решено принять 1 января 1901 года. Номер этого дня 1. От него и идет отсчет. Вот функция, которая вычисляет номер дня, начиная с 1 января 1901 года по числу, месяцу и году :

function GetNumberOfDate(day, month, year: integer): integer;

{возвращает номер дня начиная с 01.01.1901 (его номер 1)}

var

years: integer; {сколько полных лет прошло}

HighYears: integer; {сколько полных високосных лет прошло}

days: integer; {сколько дней с начала года прошло}

begin

if not September.IsCorrectDate(day, month, year) then

September.Error('September.GetNumberfDate: дата некорректна');

{начинаем все с 1 января 1901 года -- 1-й день}

years:=year-1901;

HighYears:=years div 4;

days:=0;

if month>=2 then inc(days, 31);

if month>=3 then begin

if year mod 4=0 then inc(days, 29)

else inc(days, 28);

end;

if month>=4 then inc(days, 31);

if month>=5 then inc(days, 30);

if month>=6 then inc(days, 31);

if month>=7 then inc(days, 30);

if month>=8 then inc(days, 31);

if month>=9 then inc(days, 31);

if month>=10 then inc(days, 30);

if month>=11 then inc(days, 31);

if month>=12 then inc(days, 30);

days:=days+day;

GetNumberOfDate:=365*years+HighYears+days;

end;

Вряд ли программа будет использоваться более 93 лет, поэтому то, что 2100-й год не високосный можно не учитывать. Вот интерфейс обратной процедуры, которая по номеру дня определяет дату:

procedure GetDateOfNumber(num_day: integer; var day, month, year: integer);

Текст данной процедуры приведен в Приложении.

В программе применялись знания курса «Языки программирования и методы трансляции». Например, в процедуре, которая распознает строку с записью даты (преобразует текстовую запись даты в набор из пяти переменных: число, месяц, год, часы и минуты):

procedure StringToDate

(s: string; var day, month, year, hour, minute: integer);

const

EOT=#9;

var

ch: char; {текущий символ строки}

i: integer; {номер текущего символа}

res: string;

procedure ResetText;

begin

s:=s+EOT;

i:=1;

ch:=s[1];

end;

procedure NextCh;

begin

inc(i);

ch:=s[i];

end;

procedure error(mess: string);

begin

September.Error('September.StringToDate: '+mess+' (s='+s+')');

end;

procedure procWord(var Ident: string);

begin

if ch in RussianLetters then begin

Ident:=ch;

NextCh;

end

else error('Ожидается русская буква');

while ch in RussianLetters do begin

Ident:=Ident+ch;

NextCh;

end;

procedure RecognizeDate;

var

i: integer;

name_month: string;

begin

name_month:='';

//распознаем число

while ch=' ' do NextCh; //пропускаем пробелы

if ch in ['0'..'9'] then begin

day := ord(ch) - ord('0');

NextCh;

end

else error('Число месяца должно начинаться с цифры!');

while ch in ['0'..'9'] do begin

day := 10*day + (ord(ch)-ord('0'));

NextCh;

if day>31 then error('Число месяца не может быть больше 31!');

end;

//распознаем месяц

while ch=' ' do NextCh; //пропускаем пробелы

if ch='.' then begin

NextCh;

while ch=' ' do NextCh; //пропускаем пробелы

if ch in ['0'..'9'] then begin

month := ord(ch) - ord('0');

NextCh;

while ch in ['0'..'9'] do begin

month := 10*month + (ord(ch)-ord('0'));

NextCh;

if month>12 then error('Номер месяца не может быть больше 12!');

end;

end

else if ch in RussianLetters then begin

procWord(name_month);

September.StringToLowRegister(name_month);

month:=0;

for i:=1 to 12 do begin

if (name_month=months[i]) or (name_month=months2[i]) then month:=i;

end;

if month=0 then error('некорректная запись номера месяца');

end

else error('ожидается точка в качестве разделителя между числом '+

'и номером месяца или название месяца русскими буквами!');

//распознаем год

while ch=' ' do NextCh; //пропускаем пробелы

if length(name_month)=0 then begin

if ch='.' then NextCh

else error('ожидается "."');

end;

while ch=' ' do NextCh; //пропускаем пробелы

if ch in ['1'..'2'] then begin

year := ord(ch) - ord('0');

NextCh;

end

else error('ожидается цифра "1" или "2"');

while ch in ['0'..'9'] do begin

year := 10*year + (ord(ch)-ord('0'));

NextCh;

if year>2100 then error('Номер года не может быть больше 2100');

end;

if year<1900 then error('Номер года не может быть меньше 1900');

while ch=' ' do NextCh; //пропускаем пробелы

if ch in ['г','Г'] then begin

NextCh;

while ch=' ' do NextCh; //пропускаем пробелы

if ch='.' then NextCh;

end;

//распознаем часы

while ch=' ' do NextCh; //пропускаем пробелы

if ch in ['0'..'9'] then begin

hour := ord(ch) - ord('0');

NextCh;

end

else error('ожидается цифра в часе');

while ch in ['0'..'9'] do begin

hour := 10*hour + (ord(ch)-ord('0'));

NextCh;

end;

//распознаем минуты

while ch=' ' do NextCh; //пропускаем пробелы

if ch=':' then NextCh

else error('ожидается двоеточие');

while ch=' ' do NextCh; //пропускаем пробелы

if ch in ['0'..'9'] then begin

minute := ord(ch) - ord('0');

NextCh;

end

else error('ожидается цифра в минуте');

while ch in ['0'..'9'] do begin

minute := 10*minute + (ord(ch)-ord('0'));

NextCh;

end;

while ch=' ' do NextCh; //пропускаем пробелы

if ch=':' then NextCh;

while ch=' ' do NextCh; //пропускаем пробелы

while ch in ['0'..'9'] do NextCh;

while ch=' ' do NextCh; //пропускаем пробелы

end;

begin

ResetText;

RecognizeDate;

if ch<>EOT then error('ожидается конец текста');

if not September.IsCorrectDate(day, month, year) then

September.Error

('September.StringToDate: дата является некорректной: '+s);

end;

При разработке программы часто возникала необходимость проверить, является ли строка корректным вещественным числом (без символов e, E). Для этих целей была написана специальная функция. Вот ее интерфейс:

function IsCorrectFloatString(s: string): boolean;

При написании функции использовались тривиальные знания курса «Языки программирования и методы трансляции». Ее текст приведен в Приложении.

В программе при отображении денежных сумм (особенно, больших) нужна наглядность. То есть, число не должно выводиться в стандартной форме (без пробелов, с точкой для разделения рублей и копеек). Было принято решение разделять рубли и копейки запятой, а разряды числа – пробелом. Например, число 19888283.25 будет записано как «19 188 283,25». Приведенная ниже процедура преобразует числа, по модулю не большие триллиона триллионов, в строку (с точностью до 15 разрядов, больше тип double не дает):

procedure FloatToMoneyString(x: float; var s: string);

const

exact=24; {число может быть до 1e24}

var

minus: boolean; {является ли число отрицательным}

{разряды числа (первый -- копейки и т. д.)}

digits: array [1..26] of integer;

LastDigit: float; {последняя цифра числа}

digit: integer; {последняя цифра числа (округленная)}

LengthNumber: integer; {длина числа (учитывая копейки)}

NumberTriads: integer; {число триад в числе}

ostatok: integer; {сколько цифр осталось записать}

i: integer;

begin

if x>=0.0 then minus:=false

else begin minus:=true; x:=-x; end;

if x>1.0e24 then September.Error

('September.FloatToMoneyString: Слишком большое число!');

x:=100.0*x+0.5; {число копеек, округленное до копейки}

{преобразуем число в массив цифр}

LengthNumber:=0; {общая длина числа (с копейками)}

for i:=1 to 26 do begin

LastDigit := 10.0*frac(x/10.0);

digit := trunc(LastDigit);

digits[i] := digit;

if digit<>0 then LengthNumber:=i;

x := (x - LastDigit)/10.0 + 0.1;

end;

{убираем все цифры, кроме 15 значащих цифр}

for i:=LengthNumber-15 downto 1 do digits[i]:=0;

{преобразуем массив цифр в денежное число}

if LengthNumber=0 then s:='0,00'

else if LengthNumber=1 then s:='0,0'+inttostr(digits[1])

else if LengthNumber=2 then

s:='0,'+inttostr(digits[2])+inttostr(digits[1])

else begin

s:=','+inttostr(digits[2])+inttostr(digits[1]);

NumberTriads := (LengthNumber-3) div 3;

{триады нужны для правильной расстановки пробелов в числе}

for i:=1 to NumberTriads do begin

s:=inttostr(digits[3*i+2])+inttostr(digits[3*i+1])+

inttostr(digits[3*i])+s;

s:=' '+s;

end;

ostatok := (LengthNumber-2)-3*NumberTriads;

for i:=ostatok downto 1 do

s:=inttostr(digits[LengthNumber-i+1])+s;

end;

if minus then s:='-'+s;

end;

Для того, чтобы корректно выводить в программе данные типа «2 рубля», «5 рублей», нужно определить тип числа. Если тип числа 1, то окончание будет «рубль». Если тип числа 2, то окончание будет «рубля». Иначе окончание будет «рублей». Ниже приведена процедура для определения типа натурального числа:

function TypeOfNumber(x: integer): integer;

{1-год 2-года 3-лет}

var

tip: integer;

begin

tip:=3;

if x div 10<>1 then begin

case x mod 10 of

1: tip:=1;

2,3,4: tip:=2;

end;

TypeOfNumber:=tip;

end;

В программе встречаются места, где нужно словами написать денежную сумму (например, в товарном чеке).

Для этого была написана специальная функция. Для написания данной функции потребовалось написать несколько дополнительных функций.

Функция, приведенная ниже, выдает текстовую запись натурального числа от 0 до 99. Входными параметрами функции являются данное число и тип результата. Если tip=1, то процедура выдаст результат в виде «двадцать два», иначе в виде «двадцать две»:

function NaturalNumberUp99ToString(x, tip: integer): string;

var

digits: array[0..9] of string;

var

s: string; {строка результата}

tens, units: integer; {десятки и единицы}

begin

if not ((x>=0) and (x<=99)) then

September.Error

('September.NaturalNumberUp99ToString: x must between 0 and 99');

if tip=1 then begin

digits[0]:='ноль'; digits[1]:='один';

digits[2]:='два'; digits[3]:='три';

digits[4]:='четыре'; digits[5]:='пять';

digits[6]:='шесть'; digits[7]:='семь';

digits[8]:='восемь'; digits[9]:='девять';

end

else if tip=2 then begin

digits[0]:='ноль'; digits[1]:='одна';

digits[2]:='две'; digits[3]:='три';

digits[4]:='четыре'; digits[5]:='пять';

digits[6]:='шесть'; digits[7]:='семь';

digits[8]:='восемь'; digits[9]:='девять';

end;

tens:=x div 10;

units:=x mod 10;

if tens=0 then begin

s:=digits[units];

end

else if tens=1 then begin

case units of

0: s:='десять';

1: s:='одиннадцать';

2: s:='двенадцать';

3: s:='тринадцать';

4: s:='четырнадцать';

5: s:='пятнадцать';

6: s:='шестнадцать';

7: s:='семнадцать';

8: s:='восемнадцать';

9: s:='девятнадцать';

end;

end

else begin

case tens of

2: s:='двадцать';

3: s:='тридцать';

4: s:='сорок';

5: s:='пятьдесят';

6: s:='шестьдесят';

7: s:='семьдесят';

8: s:='восемьдесят';

9: s:='девяносто';

end;

if units<>0 then s:=s+' '+digits[units];

end;

NaturalNumberUp99ToString:=s;

end;

Функция для преобразования числа от 0 до 999 в текстовую запись выглядит аналогично, вот ее интерфейс:

function NaturalNumberUp999ToString(x, tip: integer): string;

Текст данной функции приведен в Приложении. С помощью двух вышеприведенных функций была написана функция для текстовой записи денежных сумм, по модулю не превышающих 999 квадриллионов (примерно ). Вот ее интерфейс:

function FloatToLettersMoneyString(x: float): string;

Ее код не очень сложный, но довольно объемный, поэтому было принято решение также вынести его в Приложение.

При разработке программы также применялись знания из курса «Компьютерная графика». При написании программы возникла необходимость отображать графики (подобно Microsoft Excel). Было принято решение разработать собственный компонент. Для рисования графиков нужны элементарные процедуры (рисование точек, линий, очистка экрана, вывод текста, и т. д.). Было принято решение разместить их в отдельном модуле BGL.

Вот основные параметры модуля BGL:

const

SizeX=1024; SizeY=768; {размер экрана}

getmaxx=SizeX-1; getmaxy=SizeY-1;

type

tBuf=array [0..getmaxy, 0..getmaxx] of integer;

cc, bc: integer; {основной цвет и цвет фона}

var

Buf: tBuf; {буфер, где строится изображение}

Рисование производится в буфере, из которого с помощью несложных процедур затем можно будет скопировать построенное изображение куда нужно. SizeX, SizeY – размеры области вывода. getmaxx и getmaxy – максимальные координаты по осям x и y соответственно. Buf – буфер, в котором строится изображение. cc – основной цвет (используется для рисования точек, линий, окружностей и т. д.), а bc – цвет фона (используется процедурой ClearDevice, которая очищает экран). Вот процедура для вывода изображения (здесь используется алгоритм Брезенхема):

procedure DrawLine(x1, y1, x2, y2: integer);

var

dx, dy, d, inc1, inc2, s: integer;

a, a2: integer;

buf0: array [0..SizeX*SizeY-1] of integer absolute buf;

begin

dx:=abs(x2-x1); dy:=abs(y2-y1);

if dx>dy then begin

inc1:=2*dy; inc2:=2*(dy-dx);

d:=2*dy-dx;

if x1<x2 then begin

a:=SizeX*y1+x1;

a2:=SizeX*y2+x2;

if y1<y2 then s:=SizeX+1

else s:=-SizeX+1;

end

else begin

a:=SizeX*y2+x2; a2:=SizeX*y1+x1;

if y1>y2 then s:=SizeX+1

else s:=-SizeX+1;

end;

buf0[a]:=cc;

while a<>a2 do begin

if d>0 then begin

a:=a+s;

d:=d+inc2;

end

else begin

a:=a+1;

d:=d+inc1;

end;

buf0[a]:=cc;

end;

end {dx>dy}

else begin

inc1:=2*dx; inc2:=2*(dx-dy);

d:=2*dx-dy;

if y1<y2 then begin

a:=SizeX*y1+x1;

a2:=SizeX*y2+x2;

if x1<x2 then s:=SizeX+1

else s:=SizeX-1;

end

else begin

a:=SizeX*y2+x2; a2:=SizeX*y1+x1;

if x1>x2 then s:=SizeX+1

else s:=SizeX-1;

end;

buf0[a]:=cc;

while a<>a2 do begin

if d>0 then begin

a:=a+s;

d:=d+inc2;

end

else begin

a:=a+SizeX;

d:=d+inc1;

end;

buf0[a]:=cc;

end;

Так как процедура для вывода линий используется довольно часто, было принято решение ее оптимизировать. Для оптимизации применялся язык ассемблера (применялись знания курса «Архитектура ЭВМ и язык Ассемблера»). Оптимизировался только внутренний цикл, так как именно он больше всего влияет на время выполнения процедуры.

Оптимизированная процедура работает значительно быстрее (в 23 раза при выводе длинных линий). Текст процедуры довольно длинный, поэтому он приведен в Приложении.

Процедура DrawLine рисует, не используя отсечение. Если координаты линии выйдут за пределы экрана, произойдет ошибка и программа аварийно завершит работу. Чтобы такого не происходило, используем процедуру для отсечения линий (алгоритм Ивана Сазерленда). хleft, ytop, xright, ybottom – окно, по которому производится отсечение. (xleft, ytop) – левый верхний угол; (xright, ybottom) – правый нижний угол. Вот текст процедуры:

procedure line(x1, y1, x2, y2: longint);

type

tCode=set of 0..3;

procedure Coding(x, y: integer; var code: tCode);

begin

code:=[];

if x<xleft then code:=code+[0]

else if x>xright then code:=code+[1];

if y<ytop then code:=code+[2]

else if y>ybottom then code:=code+[3];

end;

var

code1, code2: tCode;

inside: boolean;

x, y: integer;

code: tCode;

reg1, reg2, reg3, reg4: integer;

begin

x1:=x1+xleft; x2:=x2+xleft;

y1:=y1+ytop; y2:=y2+ytop;

Coding(x1, y1, code1);

Coding(x2, y2, code2);

inside:=code1+code2=[];

while not inside and (code1*code2=[]) do begin

if code1=[] then begin

reg1:=x1; reg3:=y1;

reg2:=x2; reg4:=y2;

x1:=reg2; y1:=reg4;

x2:=reg1; y2:=reg3;

code:=code1; code1:=code2; code2:=code;

end;

if x1<xleft then begin {отсечение слева}

y1:=y1+round((y2-y1)/(x2-x1)*(xleft-x1));

x1:=xleft;

end

else if x1>xright then begin {отсечение справа}

y1:=y1+round((y2-y1)/(x2-x1)*(xright-x1));

x1:=xright;

end

else if y1<ytop then begin {отсечение сверху}

x1:=x1+round((x2-x1)/(y2-y1)*(ytop-y1));

y1:=ytop;

end

else if y1>ybottom then begin {отсечение снизу}

x1:=x1+round((x2-x1)/(y2-y1)*(ybottom-y1));

y1:=ybottom;

end;

Coding(x1, y1, code1);

inside:=(code1+code2)=[];

end;

if inside then DrawLine(x1, y1, x2, y2);

end;

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

В программе есть компонент для вывода графиков. График строится в виде ломаных линий (рисунок 3.26).

Рисунок 3.26

Неплохо было бы провести сглаживание. Для сглаживания применим сплайн-интерполяцию. Метод выглядит так: отрезок по оси аргумента функции разбивается на несколько частей. Для каждой части строится кубическое уравнение. При этом у итоговой линии убираются резкие углы ломаной за счет равенства производных соседних сплайнов в общих точках. Пусть у нас есть отрезок. Разобъем его на частей . В данных точках функция (ее мы и собираемся сглаживать) принимает значения . Для каждого из отрезков нужно определить функцию, которая определяется четырьмя коэффициентами (как многочлен третьей степени: . То есть нужно определить коэффициентов: (эти коэффициенты определяют функции). Для этого нужно составить уравнений:

1) Очевидно, все функции отрезков на левом конце отрезка должны принимать значения такие же, как итоговая функция:

………………………………...

2) Очевидно, все функции отрезков на правом конце отрезка должны принимать значения такие же, как итоговая функция:

………………………………...

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

……………………………………………………………….

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

………………………………………….

Получилось уравнений. Нужно еще два, поэтому приравняем к нулю вторую производную первой функции в точке , а также вторую производную -й функции в точке :

……………………..

Итак, получилось уравнений первой степени. Проще всего такую систему решить, «забив» коэффициенты в матрицу, а затем найти решение методом Гаусса. Именно так и поступим.

На рисунке 3.27 приведен тот же самый график, но уже с применением сглаживания.

Рисунок 3.27

Правда, на некоторых графиках сглаживание применять нельзя, так как это затрудняет восприятие истинных значений. Поэтому в компонент встроена возможность ручного включения/выключения сглаживания.

Конечно, существуют более оптимальные алгоритмы для построения сплайнов, но в данной программе при сотне точек в графике проблема быстродействия не стоит (сглаживание происходит без задержек даже на слабых машинах (например, Intel Celeron 400 Mhz, 64 Mb RAM)).

Текст процедуры тривиален, поэтому приведен в Приложении. В данной процедуре использовался метод Гаусса. Ниже приведены структуры данных для реализации метода Гаусса:

type

tMatrix=array [1..l0, 1..l0] of float;

tMatrix0=array [1..l0] of float;

Нижеприведенная процедура решает систему линейных уравнений методом Гаусса. Для использования данной процедуры необходимо «забить» матрицу коэффициентов при неизвестных в матрицу M, и матрицу свободных коэффициентов в матрицу M0. Процедура выдаст матрицу решений системы S.

procedure GaussSolve(M: tMatrix; M0: tMatrix0; l: integer; var S: tMatrix0);

procedure ExchangeFloat(var f1, f2: float);

var

buf: float;

begin

buf:=f1;

f1:=f2;

f2:=buf;

end;

var

ValueMaxModule: float;

StringMaxModule: integer;

i, j, CS{CurrentString}: integer;

know: integer;

begin

for CS:=1 to l-1 do begin

StringMaxModule:=CS;

ValueMaxModule:=M[CS, CS];

for j:=CS+1 to l do

if abs(M[j, CS])>ValueMaxModule then begin

ValueMaxModule:=abs(M[j, CS]);

StringMaxModule:=j;

end;

for i:=CS to l do ExchangeFloat(M[CS, i], M[StringMaxModule, i]);

ExchangeFloat(M0[CS], M0[StringMaxModule]);

M0[CS]:=M0[CS]/M[CS, CS];

for i:=l downto CS do M[CS, i]:=M[CS, i]/M[CS, CS];

for j:=CS+1 to l do begin

M0[j]:=M0[j]-M0[CS]*M[j, CS];

for i:=l downto CS do M[j, i]:=M[j, i]-M[CS, i]*M[j, CS];

end;

for know:=l downto 1 do begin

S[know]:=M0[know]/M[know, know];

for i:=l downto know+1 do

S[know]:=S[know]-(M[know, i]/M[know, know])*S[i];

end;

В программе есть дерево групп для удобства навигации по товарам. Иногда требуется определить полное имя группы, известен код группы. Можно, конечно, это сделать с помощью нескольких вызовов запроса определения имени папки по коду, но гораздо эффективнее создать для того хранимую процедуру на сервере. Ниже приведена данная процедура:

create procedure procDoFullNamePathFromCodePath(code_path integer)

returns(name_path varchar(1000), error integer) as

declare variable vrem integer;

error=1 -- this code_path is not exist

begin

error=0;

if (code_path=0) then begin name_path=''; exit; end

select count(*) from paths where code_path=:code_path into vrem;

if (vrem=0) then begin error=1; exit; end

execute procedure procDoFullNamePathFromCodePath0(code_path, '')

returning_values(name_path);

end

Данная процедура проверяет, существует ли код указанной группы, и если не существует, выдает ошибку. Затем вызывается рекурсивная процедура для определения названия группы по ее коду:

create procedure procDoFullNamePathFRomCodePath0(

code_path integer,

name_path0 varchar(1000))

returns(name_path varchar(1000)) as

declare variable code_ancestor integer;

begin

select name_path from paths where code_path=:code_path into :name_path;

if (name_path0<>'') then name_path=name_path||'\'||name_path0;

select code_ancestor from paths

where code_path=:code_path

into :code_ancestor;

if (code_ancestor<>0) then begin

execute procedure procDoFullNamePathFromCodePath0

(code_ancestor, name_path)

returning_values(name_path);

end

Иногда требуется получить случайное число на сервере. Сервер Firebird не содержит функций наподобие random, но зато поддерживает UDF – User Defined Functions. С помощью этого средства программист может сам написать нужные ему функции, которые не являются стандартными для сервера Firebird. Эти функции должны быть скопированы на сервер в виде dll-библиотек, которые можно написать на большинстве из серьезных языков программирования. Вот текст библиотеки для определения функции random (написан на Delphi):

library libraryRandom;

uses

SysUtils;

var

pred: longint;

function random(var x: integer): integer; cdecl; export;

const

a1=635786523; a2=634789253;

b1=945362785; b2=328498355;

var

next: int64;

reg1, reg2, reg3, reg4: longint;

begin

next:=pred;

reg1:=0; reg2:=0; reg3:=0; reg4:=0;

asm

push ebx; push eax; push ecx; push edx; push edi; push esi;

mov esi, dword ptr next; {esi=0}

mov edi, dword ptr next+4; {edi=0}

{edi:esi=next}

mov eax, a2; mul esi; mov reg4, eax; mov reg3, edx; {reg4:reg3=0}

mov eax, a2; mul edi; add reg3, eax; adc reg2, edx; adc reg1, 0;

mov eax, a1; mul esi; add reg3, eax; adc reg2, edx; adc reg1, 0;

mov eax, a1; mul edi; add reg2, eax; adc reg1, edx; {reg1:reg2=0}

mov eax, reg1; mov ebx, reg2; mov ecx, reg3; mov edx, reg4;

{eax:ebx:ecx:edx -- chislo}

add edx, b2; adc ecx, b1; and ecx, 1073741823;

mov dword ptr next+4, ecx;

mov dword ptr next, edx;

pop esi; pop edi; pop edx; pop ecx; pop eax; pop ebx;

end;

pred:=next;

Result:=next mod x;

end;

exports random;

begin

pred:=0;

end.

Данная функция генерирует последовательность случайный чисел по следующему алгоритму: , где – положительное число, делящееся на 4 с остатком 1, – нечетное число, а – степень двойки (2, 4, 8, 16, 32, 64,…). В качестве периода была взята тридцатая степень двойки (около миллиарда). Чтобы функция заработала, недостаточно просто скопировать ее на сервер. Нужно ее еще прописать в базе:

declare external function random integer

returns integer by value

entry_point 'random' module_name 'libraryRandom.dll';

Данная запись означает следующее: определить функцию random (под таким именем она будет иметь место на сервере), возвращающую целочисленное значение по значению (бывает еще по ссылке). module_name 'libraryRandom.dll' – имя библиотеки, откуда экспортируем функцию; entry_point 'random' – экспортируемая функция.

В серверной части программы также используются функции DateDays и DateSeconds (работают с датой и временем). Они определяют, соответственно, число дней, прошедших с 1 января 1901 года (этот день идет под номером 1), и число секунд, прошедших с начала суток. Текст процедур тривиален и приведен в Приложении.

4. ТЕСТИРОВАНИЕ ПРОГРАММЫ

Перед внедрением программы, естественно, проводилось тестирование. Это нужно для предотвращения ввода в базу ошибочных данных. Особо пристальное внимание уделялось тестированию хранимых процедур, так как в основном от них зависит непротиворечивость и правильность данных на сервере. Но правильность работы клиентского приложения тоже тестировалась. Тестирование проводилось в несколько этапов:

4.1. Первый этап тестирования

После окончания написания предварительной версии программы, готовой к внедрению, были извлечены из базы и напечатаны тексты всех хранимых процедур. Первоочередной целью была проверка правильности работы всех хранимых процедур при различных входных данных. Сначала проводилась визуальная проверка правильности написания процедуры, затем тестирование путем внесения в процедуру различных данных, вызывающих исключительные ситуации.

Вот, к примеру, процедура для добавления товара в Справочник Товаров:

create procedure procAddGood(

code_good integer, art varchar(20),

code_ancestor integer,

name_good varchar(80),

code_unit integer)

returns(error integer, new_number_good integer) as

declare variable vrem integer;

declare variable scan_code varchar(20);

error=1 -- this code_good already exists

error=2 -- articul must not be empty

error=3 -- incorrect code_ancestor (path not exists)

error=4 -- name_good must not be empty

error=5 -- this code_unit is not exist

error=6 -- good with this name_good already exists

error=7 -- code_good must not be less than 10000

error=8 -- the good cannot have more than 12 scan_codes

error=9 -- length(name_good) must not be less than 3

begin

error=0;

select count(*) from goods

where CodeIsActive=1 and code_good=:code_good

into vrem;

if (vrem<>0) then begin error=1; exit; end

if (art='') then begin error=2; exit; end

select count(*) from paths where code_path=:code_ancestor into vrem;

if (vrem=0) then begin error=3; exit; end

if (name_good='') then begin error=4; exit; end

if (LengthString(name_good)<3) then begin error=9; exit; end

select count(*) from TitleUnits where code_unit=:code_unit into vrem;

if (vrem=0) then begin error=5; exit; end

select count(*) from goods

where

code_ancestor=:code_ancestor and

name_good=:name_good and CodeIsActive=1

into vrem;

if (vrem<>0) then begin error=6; exit; end

if (code_good<10000) then begin error=7; exit; end

/*write data to database*/

new_number_good=gen_id(genGoods, 1);

insert into goods

values(:new_number_good, :code_good, 1, :art,

:code_ancestor, :name_good, :code_unit,'');

vrem=0;

for select scan_code from ScanCodes2

into :scan_code as cursor cur1 do begin

vrem=vrem+1;

if (vrem=13) then begin

error=1/0;

when any do begin error=8; exit; end

end

insert into ScanCodes

values(:new_number_good, :scan_code);

update goods

set scan_codes=scan_codes||:scan_code||' '

where number_good=:new_number_good;

end

Проанализируем входные и выходные данные, и подумаем, какие могут быть ошибочные ситуации. На входе процедура имеет код товара, артикул, код группы, название товара и код единицы измерения. Возвращает она номер ошибки и новый код товара в случае удачи (error=0).

Возможны следующие ошибочные ситуации:

1. Такой код товара как code_good может уже существовать.

2. Вводимый код товара может быть меньше 10000.

3. Артикул может быть пустым.

4. Группы с кодом code_ancestor может не существовать.

5. Название товара может быть пустым.

6. Название товара может быть короче трех символов (было принято решение не допускать названия товаров короче трех символов).

7. Единица измерения с кодом code_unit может не существовать в таблице TitleUnits.

8. В данной группе может существовать товар с данным названием.

9. Товар может иметь более 12 скан-кодов (программа заносит товар следующим образом: сначала во временные таблицы заносятся скан-коды, затем заносится сам товар, затем переносятся скан-коды из временной таблицы, поэтому данная процедура «знает» про скан-коды, хотя она не получает их в виде входных параметров).

Теперь, когда мы определились, какие исключительные ситуации могут существовать, рассмотрим, какие исключительные ситуации уже были предусмотрены до этапа тестирования (то есть на этапе написания программы). Вот они:

1) error=1 -- this code_good already exists

2) error=2 -- articul must not be empty

3) error=3 -- incorrect code_ancestor (path not exists)

4) error=4 -- name_good must not be empty

5) error=5 -- this code_unit is not exist

6) error=6 -- good with this name_good already exists

7) error=7 -- code_good must not be less than 10000

8) error=8 -- the good cannot have more than 12 scan_codes

9) error=9 -- length(name_good) must not be less than 3

Их тоже оказалось девять, при этом тех же самых. Скорее всего, других исключительных ситуаций не может быть. Теперь проверим процедуру путем внесения в нее различных данных, приводящих к ошибкам (с помощью IBExpert):

1) Попытаемся вызвать ошибку 1: внести в базу товар с уже имеющимся кодом. Для этого напишем (товар с кодом 10000 имеется в базе):

execute procedure procAddGood(10000, 'art', 1, 'name_good', 1);

Получили: error=1; new_number_good=null. В принципе, так и должно быть.

2) Попытаемся вызвать ошибку 2, то есть внести в базу товар с пустым артикулом. Для этого напишем следующее:

execute procedure procAddGood(50000, '', 1, 'name_good', 1);

Получили: error=2; new_number_good=null. Все нормально.

3) Попытаемся вызвать ошибку 3, то есть внести некорректный код группы для товара. Для этого напишем следующее:

execute procedure procAddGood(50000, 'art', 10000, 'name_good', 1);

Получили: error=3; new_number_good=null. В принципе, нормально.

4) Попытаемся вызвать ошибку 4, то есть внести в базу товар с пустым именем. Для этого напишем следующее:

execute procedure procAddGood(50000, 'art', 1, '', 1);

Получили: error=4; new_number_good=null. Так и должно быть.

5) Попытаемся вызвать ошибку 5, то есть внести в базу товар с единицей измерения, неопределенной в таблице TitleUnits. Для этого напишем следующее:

execute procedure procAddGood(50000, 'art', 1, 'name_good', 10000);

Получили: error=5; new_name_good=null. Нормально.

6) Попытаемся вызвать ошибку 6, то есть внести в базу товар с уже существующим именем. Для этого напишем следующее (в группе с кодом 1 имеется товар, который называется «Штора для ванной»):

execute procedure procAddGood(50000, 'art', 1, 'Штора для ванной', 1);

Получили: error=6; new_name_good=null. Так и должно быть.

7) Попытаемся вызвать ошибку 7, то есть внести в базу товар с кодом, меньшим 10000. Для этого напишем следующее:

execute procedure procAddGood(9999, 'art', 1, 'name_good', 1);

Получили: error=7; new_name_good=null. Все нормально.

8) Попытаемся вызвать ошибку 8, то есть внести в базу товар с числом скан-кодов, большим 12. Для этого выполним такую последовательность действий:

delete from ScanCodes2;

insert into ScanCodes2 values('0000000000000');

insert into ScanCodes2 values('0000000000001');

insert into ScanCodes2 values('0000000000002');

insert into ScanCodes2 values('0000000000003');

insert into ScanCodes2 values('0000000000004');

insert into ScanCodes2 values('0000000000005');

insert into ScanCodes2 values('0000000000006');

insert into ScanCodes2 values('0000000000007');

insert into ScanCodes2 values('0000000000008');

insert into ScanCodes2 values('0000000000009');

insert into ScanCodes2 values('0000000000010');

insert into ScanCodes2 values('0000000000011');

insert into ScanCodes2 values('0000000000012');

insert into ScanCodes2 values('0000000000013');

execute procedure procAddGood(50000, 'art', 1, 'name_good', 1);

Получили: error=8; new_name_good=8099. Все правильно. new_number_good ¹ null, так как ошибка возникла уже после определения кода товара. Но товар не занесен в базу. В этом можно убедиться, открыв таблицу goods, или выполнить запрос: select * from goods where number_good=8099.

9) Попытаемся внести товар с названием короче трех символов (но не пустым). Для этого напишем следующее:

execute procedure procAddGood(50000, 'art', 1, 'na', 1);

Получили: error=9; new_name_good=null. Все нормально.

Итак, процедура протестирована с помощью IBExpert. Теперь протестируем процедуру с помощью программы. Для этого запустим форму для занесения товаров и попытаемся внести в базу товар с неверными данными. Убедимся, что это невозможно, иначе исправим найденные ошибки.

В результате тестирования всех процедур найдено следующие три ошибки, которые в дальнейшем устранены:

при изменении себестоимости товара сессии сумма себестоимостей товаров сессии не обновлялась;

при закрытии сессии когда в сессии имеются товары с нулевым количеством происходит ошибка division by zero;

процедура Возврат Товара не работала должным образом.

На этом первый этап тестирования закончен.

4.2. Второй этап тестирования

Проверим код программы во всех местах, где она работает с базой на правильность введенных данных. Программа должна реагировать на все ошибки, которые выдают хранимые процедуры.

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

В результате найдено семь ошибок, причем не все из них связаны с некорректной работой с базой. Ниже приведены некоторые из ошибок, устраненных в дальнейшем:

на форме для занесения товаров в сессию не проверялась правильность ввода наценки;

на форме для занесения товара в сессию при вводе количества товара, равного нулю, происходило деление на ноль;

поле для ручного ввода скан-кода (который состоит из цифр) на форме для изменения товара сессии допускало ввод любых символов (конечно, в базу этот скан-код все равно не попадал, так как существует еще проверка не сервере, но это приводило к непонятным «глюкам»).

4.3. Третий этап тестирования

Третий этап тестирования. Проверяем Firebird Server. Для этого запустим длинную транзакцию (из миллиона операторов insert и update). В середине транзакции выдернем шнур питания из розетки. Результаты данного действия следующие:

при числе записей до 1000 база данных нормально откатывалась к предыдущему состоянию;

при числе записей 50000 некоторые таблицы стали читаться с ошибками;

при числе записей 500000 база стала занимать на момент выключения питания около 700 мегабайт, и после включения питания оказалась нечитаемой.

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

4.4. Четвертый этап тестирования

Четвертый этап тестирования силами стороннего программиста. В результате найдена одна ошибка: при вводе скидки в поле со скидкой в форме с продажами скидка производится на все товары, а не только на ту строку, где была введена скидка. Ошибка исправлена.

4.5. Пятый этап тестирования

Пятый этап тестирования: пишем процедуру для ввода большого количества товаров в базу. С помощью этой процедуры заносим в базу около 5000 наименований товаров в 100 сессий оптовой закупки номер три. При этом создается 100 групп товаров. Процедура эмулирует реальное занесение товаров, поэтому отсутствие ошибок может быть подтверждением корректной работы программы. При этом имена товаров и групп формируем случайным образом, и делаем длинными (чтобы программа «тормозила»). Выполним данную процедуру 10 раз, и в базе будет находиться около 50000 товаров в 1000 групп, занесенных с помощью 1000 сессий.

Теперь откроем дерево групп товаров. На это уходит около 10 секунд, что слишком долго. Ищем причины такого поведения программы. При формировании дерева групп определяется также заполненность групп товарами (если в группе есть товары, то группа с картинкой, иначе без картинки). Для формирования дерева групп используется следующий запрос:

select

code_path, name_path, paths.code_ancestor,

count(code_good) chislo

from paths left join goods

on paths.code_path=goods.code_ancestor and CodeIsActive=1

group by code_path, name_path, paths.code_ancestor

order by name_path

Здесь, возможно, поможет индекс для таблицы goods по полю code_ancestor. Создаем индекс для таблицы goods:

create index IndexGoods4 on goods(code_ancestor)

Теперь дерево формируется около 1 секунды. Это уже приемлемо. Итак, можно считать, что вывод дерева оптимизирован.

Теперь пробуем открыть какую-либо группу с товарами. Группа открывается неоправданно долго. Смотрим на текст запроса для заполнения списка товаров:

select * from goods join TitleUnits on

goods.code_unit=TitleUnits.code_unit

where code_ancestor=:code_ancestor and CodeIsActive=1

order by name_good

Вроде, ничего особенного. Таблица TitleUnits маленькая (три записи, так как в ней хранятся единицы измерения). Таблица goods содержит 50000 записей, но ведь это немного! Все должно работать быстро! Выполняем данный запрос в IBExpert, и получаем время работы 0,00 секунд! Значит, не в этом дело. При открытии формы выполняется следующая процедура (она нужна для заполнения сетки и установки курсора в нужное место):

procedure RefreshDataAndSetCursor(name_good: string);

{устанавливает курсор куда нужно}

var

ExistNumberGood: integer; {0 – нет; 1 -- есть}

name_good0: string;

begin

with Form3 do begin

TR_SelectGoodsOfPath.Active:=false; TR_SelectGoodsOfPath.Active:=true;

Q_ExistNumberGood.Close;

Q_ExistNumberGood.ParamByName('name_good').Value:=name_good;

Q_ExistNumberGood.ParamByName('code_ancestor').Value := code_path;

Q_ExistNumberGood.Open;

ExistNumberGood:=Q_ExistNumberGood.RecordCount;

Q_SelectGoodsOfPath.Close;

Q_SelectGoodsOfPath.ParamByName('code_ancestor').Value := code_path;

Q_SelectGoodsOfPath.Open; Q_SelectGoodsOfPath.First;

if ExistNumberGood<>0 then begin

name_good0:=Q_SelectGoodsOfPath.FieldValues['name_good'];

while not Q_SelectGoodsOfPath.Eof and (name_good0<>name_good)

do begin

Q_SelectGoodsOfPath.Next;

name_good0:=Q_SelectGoodsOfPath.FieldValues['name_good'];

end;

end

else begin

if not Q_SelectGoodsOfPath.Eof then begin

name_good0:=Q_SelectGoodsOfPath.FieldValues['name_good'];

while not Q_SelectGoodsOfPath.Eof do begin

if name_good0<name_good then Q_SelectGoodsOfPath.Next

else Break;

name_good0:=Q_SelectGoodsOfPath.FieldValues['name_good'];

end;

RefreshTree(code_path);

CodeCutForAdd:=0;

end;

Думаем, какие действия могут вызывать «тормоза». Во-первых, это запрос Q_ExistNumberGood. Вот его текст:

select * from goods

where name_good=:name_good and CodeIsActive=1 and

code_ancestor=:code_ancestor

Этот запрос должен выполняться быстро, так как используется только одна таблица из 50000 записей, и даже полный перебор не должен вызывать проблем. Тем более, поле code_ancestor таблицы goods индексировано. Тем не менее, проверим его в IBExpert и убедимся, что его выполнение занимает 0,00 секунд.

Q_SelectGoodsOfPath как раз занимается заполнением списка товаров. Его уже проверили ранее, он выполняется 0,00 секунд. Цикл из 50 итераций (именно столько товаров в проверяемой группе) не может занимать много времени, поэтому причина может быть только в процедуре RefreshTree, которая занимается обновлением картинок дерева на форме с группами товаров (чтобы не перерисовывать каждый раз дерево при открытии формы). Убираем вызов этой процедуры. Теперь открытие группы с товарами происходит очень быстро. Поэтому в дальнейшем будем выполнять вызов процедуры RefreshTree только после операций добавления, или удаления товара (тогда действительно есть что обновлять), а не после каждого действия. Затем попытаемся оптимизировать и эту процедуру. Ниже приведен текст данной процедуры:

procedure RefreshTree(code_path: integer);

var

i, j: integer;

code_path0: integer;

chislo: integer;

p: TTreeNode;

begin

with Form3 do begin

for i:=0 to Form2.TreeView1.Items.Count-1 do begin

p := Form2.TreeView1.Items.Item[i];

code_path0 := integer(p.Data);

TR_CountGoodsInPath.Active:=false; TR_CountGoodsInPath.Active:=true;

Q_CountGoodsInPath.Close;

Q_CountGoodsInPath.ParamByName('code_path').Value:=code_path;

Q_CountGoodsInPath.Open;

chislo:=Q_CountGoodsInPath.RecordCount;

for j:=0 to LengthMassiv-1 do begin

if massiv[j].code_path=code_path then massiv[j].chislo:=chislo;

end;

if code_path0=code_path then begin

p.StateIndex:=0;

if chislo=0 then p.StateIndex:=0

else p.StateIndex:=1;

end;

end;

Наверное, проблема в запросе Q_CountGoodsInPath. Вот текст данного запроса:

select * from goods

where code_ancestor=:code_path and CodeIsActive=1

В данном запросе нет соединений таблиц, а таблица goods содержит 50000 записей. «Тормозить» не должно. В IBExpert данный запрос выполняется 0,00 секунд. Наверное, вся проблема в том, что запрос выполняется в цикле. Причем число итераций равно числу групп дерева. А число групп дерева больше тысячи, поэтому выполняется около тысячи запросов. Хотя время выполнения каждого в отдельности 0,00 секунд, в сумме это дает как раз те самые три секунды ожидания. Но данную процедуру легко можно оптимизировать, так как она пересчитывает число товаров в каждой из групп дерева. Будем пересчитывать только количество товаров текущей группы (группы с кодом code_path). Текст оптимизированной процедуры будет таким:

procedure RefreshTree(code_path: integer);

var

i, j: integer;

code_path0: integer;

chislo: integer;

p: TTreeNode;

begin

with Form3 do begin

for i:=0 to Form2.TreeView1.Items.Count-1 do begin

p := Form2.TreeView1.Items.Item[i];

code_path0 := integer(p.Data);

if code_path=code_path0 then begin

TR_CountGoodsInPath.Active:=false;

TR_CountGoodsInPath.Active:=true;

Q_CountGoodsInPath.Close;

Q_CountGoodsInPath.ParamByName('code_path').Value:=code_path;

Q_CountGoodsInPath.Open;

chislo:=Q_CountGoodsInPath.RecordCount;

for j:=0 to LengthMassiv-1 do begin

if massiv[j].code_path=code_path then

massiv[j].chislo:=chislo;

end;

if code_path0=code_path then begin

p.StateIndex:=0;

if chislo=0 then p.StateIndex:=0

else p.StateIndex:=1;

end;

end;

Конечно, эту процедуру можно «причесать» (убрать лишние переменные, и т. д.), но для наглядности в данной работе лучше подходит «сырой» вид. Теперь потестируем программу. Процессы открытия формы, добавления, удаления и изменения товаров стали почти мгновенными.

Аналогичным образом оптимизируем другие места программы. После данного этапа программа стала пригодной к внедрению.

Шестой этап тестирования проходил уже после внедрения программы на реальных пользователях. Серьезных ошибок на данном этапе не обнаружено, но исправлено несколько мелких недочетов.

5. БЕЗОПАСНОСТЬ ДАННЫХ

Архитектура сети на предприятии продублирована на рисунке 32.

Рисунок 32

Все компьютеры используются, фирма не может себе позволить выделить один для сервера и не пользоваться им. Поэтому базу данных практически невозможно защитить от несанкционированного копирования.

Как известно, пароли сервера Firebird хранятся на сервере (а не в базе данных). Поэтому любой человек, который хорошо разбирается в компьютерах, может скопировать базу на флешку, унести ее домой, там поставить Firebird Server и получить к ней доступ под именем пользователя sysdba и паролем masterkey. Он может поменять в базе все, что захочет, и затем ее подменить.

Пользователя sysdba из базы никак не удалить. Поэтому было принято решение не делать защиту от людей, хорошо разбирающихся в компьютере, а сделать защиту от обычных пользователей на уровне программы. Доступ к серверу все пользователи получают через учетную запись sysdba, с измененным паролем.

Все пароли хранятся в базе данных в зашифрованном с помощью алгоритма MD5 виде. Это нужно, чтобы разбирающиеся в компьютерах люди не могли узнать пароль.

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

ЗАКЛЮЧЕНИЕ

Представленная программа уже на данном этапе может применяться для работы в небольших магазинах. Но в настоящее время она не является полностью завершенным продуктом. В дальнейшем планируется усовершенствовать данную программу и сделать ее пригодной для массового внедрения. Основные планы по модернизации программы таковы:

1) Оптимизация некоторых SQL-запросов и хранимых процедур.

2) Перенесение части работы с сервера на клиентские машины (чтобы не перегружать сервер).

3) Доработка системы безопасности (создание защиты на уровне сервера, доработка защиты на уровне программы).

4) Доработка программы для реализации возможности параллельной работы нескольких кассиров в несколько смен.

5) Создание пакета автоматической инсталляции.

6) Добавление функций, отчетов, изменение интерфейса программы в соответствии с требованиями потенциальных заказчиков

Список литературы

1) Зубков С. В. Ассемблер для DOS, Windows и UNIX. – М.: ДМК Пресс, 2000

2) Юров В. И. Assembler: Специальный справочник. 2-е изд. – СПб.: Питер, 2004. – 412 с.: ил.

3) О. Л. Голицына, Н. В. Максимов, И. И. Попов Базы данных: Учебное пособие. – М.: ФОРУМ: ИНФРА-М, 2006. – 352 с.: ил. – (Профессиональное образование).

4) Фаронов В. В. Программирование баз данных в Delphi 7. Учебный курс. – СПб.: Питер, 2006. – 459 с.: ил.

5) Корняков В. Н. Программирование документов и приложений MS Office в Delphi. – СПб.: БХВ-Петербург, 2006. – 496 с.: ил.

6) Свердлов С. З. Языки программирования и методы трансляции: учеб. пособие для вузов по направлению “Прикладная математика и информатика”/С. З. Свердлов.-М. [и др.]:Питер,2007.-638 с.:ил.

7) Биллиг Владимир Арнольдович Основы офисного программирования и документы Word. Электронный ресурс: http://www.intuit.ru/department/office/vbaword/

8) Биллиг Владимир Арнольдович Основы офисного программирования и документы Excel. Электронный ресурс: http://www.intuit.ru/department/office/vbaexcel/

9) Олег Кукарцев Как научиться писать UDF для IB Database за 21 мин. Электронный ресурс: http://www.lcard.ru/~nail/database/ib_udf.html

10)Антон Григорьев Неочевидные особенности вещественных чисел. Электронный ресурс: http://www.www.delphikingdom.ru/asp/viewitem.asp?catalogid=374

11)alglib.ru Интерполяция функции кубическими сплайнами. Электронный ресурс: http://alglib.sources.ru/interpolation/spline3.php

12)Кузьменко Дмитрий Частые вопросы и ответы по InterBase / Firebird / Yaffil. Электронный ресурс: http://www.ibase.ru/ibfaq.htm

13)Королевство Delphi. Электронный ресурс: http://www.delphikingdom.com/

14)Игорь Алексеев Delphi. Создание компонентов. Электронный ресурс: http://progs.biz/delphi/components/components01.aspx

15)Игорь Алексеев Delphi. VCL. Электронный ресурс: http://progs.biz/delphi/vcl/vcl01.aspx

16)sedinko.ru Документация. Delphi. Электронный ресурс: http://www.sedinko.ru/delphi/

17)Matthias Fichtner Реализация алгоритма MD5. Электронный ресурс: http://files.myref.ru/10/myref-1092629683.zip

ПРИЛОЖЕНИЯ

1. Сценарий создания БД

CREATE GENERATOR GENTITLEUNITS ;

CREATE GENERATOR GENGOODS ;

CREATE GENERATOR GENWHOLESALEBASES ;

CREATE GENERATOR GENPURCHASES ;

CREATE GENERATOR GENSESSIONS ;

CREATE GENERATOR GENSTRUCTURESESSION ;

CREATE GENERATOR GENSALES ;

CREATE GENERATOR GENSTRUCTURESALE ;

CREATE GENERATOR GENPATHS ;

CREATE GENERATOR GENNOTES ;

CREATE GENERATOR GENACTIONS ;

CREATE GENERATOR GENSAVES ;

CREATE GENERATOR GENRETURNS ;

CREATE GENERATOR GENSTRUCTURERETURN ;

CREATE GENERATOR GENGOODSFORCUT ;

CREATE GENERATOR GENNUMBERGOODSFORSELECT ;

CREATE GENERATOR GENSEARCHCODESALENUMBERGOOD ;

CREATE GENERATOR GENPROGRAMUSERS ;

CREATE TABLE TITLEUNITS (

CODE_UNIT INTEGER NOT NULL,

NAME_UNIT VARCHAR(20) NOT NULL,

ISACTIVE INTEGER NOT NULL,

ISMATERIAL INTEGER NOT NULL);

/* Primary Key */

ALTER TABLE TITLEUNITS ADD CONSTRAINT INTEG_5 PRIMARY KEY (CODE_UNIT);

CREATE TABLE GOODS (

NUMBER_GOOD INTEGER NOT NULL,

CODE_GOOD INTEGER NOT NULL,

CODEISACTIVE INTEGER NOT NULL,

ART VARCHAR(20) NOT NULL,

CODE_ANCESTOR INTEGER NOT NULL,

NAME_GOOD VARCHAR(80) NOT NULL,

CODE_UNIT INTEGER NOT NULL,

SCAN_CODES VARCHAR(255));

/* Primary Key */

ALTER TABLE GOODS ADD CONSTRAINT INTEG_13 PRIMARY KEY (NUMBER_GOOD);

CREATE TABLE DATE1 (

DATE0 TIMESTAMP);

CREATE TABLE WHOLESALEBASES (

CODE_BASE INTEGER NOT NULL,

NAME_BASE VARCHAR(80) NOT NULL,

ADDRESS VARCHAR(80) NOT NULL,

FIOMAN VARCHAR(80) NOT NULL,

PHONEMAN VARCHAR(40) NOT NULL,

PHONEBK VARCHAR(40) NOT NULL);

/* Primary Key */

ALTER TABLE WHOLESALEBASES ADD CONSTRAINT INTEG_20 PRIMARY KEY (CODE_BASE);

CREATE TABLE PURCHASES (

CODE_PURCHASE INTEGER NOT NULL,

CODE_BASE INTEGER NOT NULL,

DATE_PURCHASE TIMESTAMP NOT NULL,

SUMMA DOUBLE PRECISION NOT NULL);

/* Primary Key */

ALTER TABLE PURCHASES ADD CONSTRAINT INTEG_25 PRIMARY KEY (CODE_PURCHASE);

CREATE TABLE SESSIONS (

CODE_SESSION INTEGER NOT NULL,

CODE_PURCHASE INTEGER NOT NULL,

ACCEPTED INTEGER NOT NULL,

ADDITION DOUBLE PRECISION NOT NULL,

DATE0 TIMESTAMP NOT NULL,

DATE1 TIMESTAMP NOT NULL,

SUMMA DOUBLE PRECISION);

/* Primary Key */

ALTER TABLE SESSIONS ADD CONSTRAINT INTEG_32 PRIMARY KEY (CODE_SESSION);

CREATE TABLE STRUCTURESESSION (

PRIMARYKEY INTEGER NOT NULL,

CODE_SESSION INTEGER NOT NULL,

NUMBER_GOOD INTEGER NOT NULL,

QUANTITY DOUBLE PRECISION NOT NULL,

FIRST_PRICE DOUBLE PRECISION NOT NULL,

ADDITION DOUBLE PRECISION NOT NULL,

SCAN_CODES VARCHAR(255));

/* Primary Key */

ALTER TABLE STRUCTURESESSION ADD CONSTRAINT INTEG_39 PRIMARY KEY (PRIMARYKEY);

CREATE TABLE STOREHOUSE (

NUMBER_GOOD INTEGER NOT NULL,

QUANTITY DOUBLE PRECISION NOT NULL,

FIRST_PRICE DOUBLE PRECISION NOT NULL,

PRICE DOUBLE PRECISION NOT NULL,

SOLD DOUBLE PRECISION NOT NULL);

/* Primary Key */

ALTER TABLE STOREHOUSE ADD CONSTRAINT INTEG_45 PRIMARY KEY (NUMBER_GOOD);

CREATE TABLE SALES (

CODE_SALE INTEGER NOT NULL,

TYPE_SALE INTEGER NOT NULL,

DATE_SALE TIMESTAMP NOT NULL,

SUMMA DOUBLE PRECISION NOT NULL,

CASH DOUBLE PRECISION NOT NULL);

/* Primary Key */

ALTER TABLE SALES ADD CONSTRAINT INTEG_51 PRIMARY KEY (CODE_SALE);

CREATE TABLE STRUCTURESALE (

PRIMARYKEY INTEGER NOT NULL,

CODE_SALE INTEGER NOT NULL,

NUMBER_GOOD INTEGER NOT NULL,

QUANTITY DOUBLE PRECISION NOT NULL,

FIRST_PRICE DOUBLE PRECISION NOT NULL,

PRICE DOUBLE PRECISION NOT NULL,

DISCOUNT DOUBLE PRECISION NOT NULL,

SUMMA DOUBLE PRECISION NOT NULL,

SOLDBYPRICE DOUBLE PRECISION NOT NULL);

/* Primary Key */

ALTER TABLE STRUCTURESALE ADD CONSTRAINT INTEG_60 PRIMARY KEY (PRIMARYKEY);

CREATE TABLE PATHS (

CODE_PATH INTEGER NOT NULL,

CODE_ANCESTOR INTEGER NOT NULL,

NAME_PATH VARCHAR(80) NOT NULL);

/* Primary Key */

ALTER TABLE PATHS ADD CONSTRAINT INTEG_64 PRIMARY KEY (CODE_PATH);

CREATE TABLE NOTES (

CODE_NOTE INTEGER NOT NULL,

NUMBER_TABLE INTEGER NOT NULL,

KEYFROMTABLE INTEGER NOT NULL,

TEXT VARCHAR(80) NOT NULL);

/* Primary Key */

ALTER TABLE NOTES ADD CONSTRAINT INTEG_69 PRIMARY KEY (CODE_NOTE);

CREATE TABLE ACTIONS (

CODE_ACTION INTEGER NOT NULL,

DATE_ACTION TIMESTAMP NOT NULL,

TEXT VARCHAR(160) NOT NULL);

/* Primary Key */

ALTER TABLE ACTIONS ADD CONSTRAINT INTEG_148 PRIMARY KEY (CODE_ACTION);

CREATE TABLE SAVES (

CODE_SAVE INTEGER NOT NULL,

WAY VARCHAR(1000) NOT NULL,

DATE_SAVE TIMESTAMP NOT NULL);

/* Primary Key */

ALTER TABLE SAVES ADD CONSTRAINT INTEG_77 PRIMARY KEY (CODE_SAVE);

CREATE TABLE PROPERTIES (

CODE_PROPERTY INTEGER NOT NULL,

NAME_PROPERTY VARCHAR(255) NOT NULL,

VAL INTEGER NOT NULL);

/* Primary Key */

ALTER TABLE PROPERTIES ADD CONSTRAINT INTEG_81 PRIMARY KEY (CODE_PROPERTY);

CREATE TABLE SCANCODES (

NUMBER_GOOD INTEGER NOT NULL,

SCAN_CODE VARCHAR(20) NOT NULL);

CREATE TABLE SCANCODESFORSESSION (

PRIMARYKEY INTEGER NOT NULL,

CODE_SESSION INTEGER NOT NULL,

NUMBER_GOOD INTEGER NOT NULL,

SCAN_CODE VARCHAR(20) NOT NULL);

CREATE TABLE SESSIONSCLOSED (

CODE_SESSION INTEGER NOT NULL,

NUMBER_GOOD INTEGER NOT NULL,

OLD_PRICE DOUBLE PRECISION NOT NULL,

NEW_PRICE DOUBLE PRECISION NOT NULL);

CREATE TABLE SCANCODES2 (

SCAN_CODE VARCHAR(20) NOT NULL);

CREATE TABLE RETURNS2 (

CODE_RETURN INTEGER NOT NULL,

CODE_SALE INTEGER NOT NULL,

DATE_RETURN TIMESTAMP NOT NULL,

SUMMA DOUBLE PRECISION NOT NULL,

CASH DOUBLE PRECISION NOT NULL);

/* Primary Key */

ALTER TABLE RETURNS2 ADD CONSTRAINT INTEG_126 PRIMARY KEY (CODE_RETURN);

CREATE TABLE STRUCTURERETURN2 (

PRIMARYKEY INTEGER NOT NULL,

CODE_RETURN INTEGER NOT NULL,

CODE_STRUCTURESALE INTEGER NOT NULL,

NUMBER_GOOD INTEGER NOT NULL,

PRICE DOUBLE PRECISION NOT NULL,

QUANTITY DOUBLE PRECISION NOT NULL,

SUMMA DOUBLE PRECISION NOT NULL);

/* Primary Key */

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT INTEG_134 PRIMARY KEY (PRIMARYKEY);

CREATE TABLE GOODSFORRETURN (

NUMBER_GOOD INTEGER NOT NULL,

CODE_GOOD INTEGER NOT NULL,

NAME_GOOD VARCHAR(80) NOT NULL,

QUANTITY DOUBLE PRECISION NOT NULL,

REMAINDER DOUBLE PRECISION NOT NULL,

ISMATERIAL INTEGER NOT NULL,

CODE_UNIT INTEGER NOT NULL,

NAME_UNIT VARCHAR(20) NOT NULL,

PRICE DOUBLE PRECISION NOT NULL,

CODESTRUCTURESALE INTEGER NOT NULL,

DAY0 INTEGER NOT NULL,

MONTH0 INTEGER NOT NULL,

YEAR0 INTEGER NOT NULL,

HOUR0 INTEGER NOT NULL,

MINUTE0 INTEGER NOT NULL);

CREATE TABLE NUMBERGOODSFORSELECT (

CODE_SEARCH INTEGER NOT NULL,

NUMBER_GOOD INTEGER NOT NULL);

CREATE TABLE GOODSFORCUT (

CODE_CUT INTEGER NOT NULL,

NUMBER_GOOD INTEGER NOT NULL);

CREATE TABLE SEARCHCODESALES (

CODE_SEANCE INTEGER NOT NULL,

CODE_SALE INTEGER NOT NULL);

CREATE TABLE SCANCODESFORSESSION2 (

SCAN_CODE VARCHAR(20) NOT NULL);

CREATE TABLE CHANGEDPRICES (

NUMBER_GOOD INTEGER NOT NULL,

NEW_PRICE DOUBLE PRECISION,

DATE_CHANGE TIMESTAMP);

CREATE TABLE CHANGEDPRICESFORPERIOD (

NUMBER_GOOD INTEGER,

CODE_SEANCE INTEGER NOT NULL);

CREATE TABLE RESUMEOFDAY (

NUMBER_GOOD INTEGER NOT NULL,

FIRST_PRICE DOUBLE PRECISION NOT NULL,

PRICE DOUBLE PRECISION NOT NULL,

SOLDBYPRICE DOUBLE PRECISION NOT NULL,

QUANTITY DOUBLE PRECISION NOT NULL,

DATE_SALE TIMESTAMP NOT NULL,

CODE_SEANCE INTEGER NOT NULL,

HOUR0 INTEGER NOT NULL);

CREATE TABLE SALES0 (

CODE_SALE INTEGER NOT NULL,

TYPE_SALE INTEGER NOT NULL,

DATE_SALE TIMESTAMP NOT NULL,

SUMMA DOUBLE PRECISION NOT NULL,

CASH DOUBLE PRECISION NOT NULL);

/* Primary Key */

ALTER TABLE SALES0 ADD CONSTRAINT INTEG_219 PRIMARY KEY (CODE_SALE);

CREATE TABLE USERS (

CODE_SEANCE INTEGER NOT NULL,

DATE_SEANCE TIMESTAMP NOT NULL);

CREATE TABLE RETURNS20 (

CODE_RETURN INTEGER NOT NULL,

CODE_SALE INTEGER NOT NULL,

DATE_RETURN TIMESTAMP NOT NULL,

SUMMA DOUBLE PRECISION NOT NULL,

CASH DOUBLE PRECISION NOT NULL);

/* Primary Key */

ALTER TABLE RETURNS20 ADD CONSTRAINT INTEG_240 PRIMARY KEY (CODE_RETURN);

CREATE TABLE STRUCTURESALE0 (

PRIMARYKEY INTEGER NOT NULL,

CODE_SALE INTEGER NOT NULL,

NUMBER_GOOD INTEGER NOT NULL,

QUANTITY DOUBLE PRECISION NOT NULL,

FIRST_PRICE DOUBLE PRECISION NOT NULL,

PRICE DOUBLE PRECISION NOT NULL,

DISCOUNT DOUBLE PRECISION NOT NULL,

SUMMA DOUBLE PRECISION NOT NULL,

SOLDBYPRICE DOUBLE PRECISION NOT NULL);

/* Primary Key */

ALTER TABLE STRUCTURESALE0 ADD CONSTRAINT INTEG_228 PRIMARY KEY (PRIMARYKEY);

CREATE TABLE STRUCTURERETURN20 (

PRIMARYKEY INTEGER NOT NULL,

CODE_RETURN INTEGER NOT NULL,

CODE_STRUCTURESALE INTEGER NOT NULL,

NUMBER_GOOD INTEGER NOT NULL,

PRICE DOUBLE PRECISION NOT NULL,

QUANTITY DOUBLE PRECISION NOT NULL,

SUMMA DOUBLE PRECISION NOT NULL);

/* Primary Key */

ALTER TABLE STRUCTURERETURN20 ADD CONSTRAINT INTEG_247 PRIMARY KEY (PRIMARYKEY);

CREATE TABLE SEARCHNUMBERGOODS (

CODE_SEANCE INTEGER NOT NULL,

NUMBER_GOOD INTEGER NOT NULL,

EXACTLY INTEGER NOT NULL);

CREATE TABLE SCANCODES3 (

NUMBER_GOOD INTEGER NOT NULL,

SCAN_CODE VARCHAR(20) NOT NULL);

CREATE TABLE GRAFIKWEEK (

CODE_SEANCE INTEGER,

DAY_OF_WEEK INTEGER,

SUMMA DOUBLE PRECISION,

PRIBIL DOUBLE PRECISION);

CREATE TABLE GRAFIKHOURBUYERS (

CODE_SEANCE INTEGER NOT NULL,

HOUR0 INTEGER NOT NULL,

NUM_BUYERS INTEGER NOT NULL);

CREATE TABLE GRAFIKPERCENTBUYERSPRIBIL (

CODE_SEANCE INTEGER,

NUM_BUYERS INTEGER NOT NULL,

PRIBIL DOUBLE PRECISION NOT NULL);

CREATE TABLE PROGRAMUSERS (

CODE_USER INTEGER NOT NULL,

NAME_USER VARCHAR(80) NOT NULL,

PSSWD VARCHAR(80),

RIGHTS INTEGER NOT NULL);

ALTER TABLE GOODS ADD CONSTRAINT INTEG_92 FOREIGN KEY (CODE_UNIT)

REFERENCES TITLEUNITS(CODE_UNIT)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE PURCHASES ADD CONSTRAINT INTEG_93 FOREIGN KEY (CODE_BASE)

REFERENCES WHOLESALEBASES(CODE_BASE)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE SESSIONS ADD CONSTRAINT INTEG_94 FOREIGN KEY (CODE_PURCHASE)

REFERENCES PURCHASES(CODE_PURCHASE)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STRUCTURESESSION ADD CONSTRAINT INTEG_95 FOREIGN KEY (CODE_SESSION)

REFERENCES SESSIONS(CODE_SESSION)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STRUCTURESESSION ADD CONSTRAINT INTEG_96 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STOREHOUSE ADD CONSTRAINT INTEG_97 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STRUCTURESALE ADD CONSTRAINT INTEG_98 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STRUCTURESALE ADD CONSTRAINT INTEG_99 FOREIGN KEY (CODE_SALE)

REFERENCES SALES(CODE_SALE)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE SCANCODES ADD CONSTRAINT INTEG_100 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE SCANCODESFORSESSION ADD CONSTRAINT INTEG_101 FOREIGN KEY (CODE_SESSION)

REFERENCES SESSIONS(CODE_SESSION)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE SCANCODESFORSESSION ADD CONSTRAINT INTEG_102 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE SCANCODESFORSESSION ADD CONSTRAINT INTEG_103 FOREIGN KEY (PRIMARYKEY)

REFERENCES STRUCTURESESSION(PRIMARYKEY)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE SESSIONSCLOSED ADD CONSTRAINT INTEG_104 FOREIGN KEY (CODE_SESSION)

REFERENCES SESSIONS(CODE_SESSION)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE SESSIONSCLOSED ADD CONSTRAINT INTEG_105 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE RETURNS2 ADD CONSTRAINT INTEG_127 FOREIGN KEY (CODE_SALE)

REFERENCES SALES(CODE_SALE)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT INTEG_137 FOREIGN KEY (CODE_RETURN)

REFERENCES RETURNS2(CODE_RETURN)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT INTEG_139 FOREIGN KEY (CODE_STRUCTURESALE)

REFERENCES STRUCTURESALE(PRIMARYKEY)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT INTEG_140 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE NUMBERGOODSFORSELECT ADD CONSTRAINT INTEG_200 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE GOODSFORCUT ADD CONSTRAINT INTEG_166 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE CHANGEDPRICES ADD CONSTRAINT INTEG_183 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE CHANGEDPRICESFORPERIOD ADD CONSTRAINT INTEG_206 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE RESUMEOFDAY ADD CONSTRAINT INTEG_213 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STRUCTURESALE0 ADD CONSTRAINT INTEG_231 FOREIGN KEY (NUMBER_GOOD)

REFERENCES GOODS(NUMBER_GOOD)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STRUCTURESALE0 ADD CONSTRAINT INTEG_235 FOREIGN KEY (CODE_SALE)

REFERENCES SALES0(CODE_SALE)

ON UPDATE RESTRICT ON DELETE CASCADE;

ALTER TABLE STRUCTURERETURN20 ADD CONSTRAINT INTEG_257 FOREIGN KEY (CODE_RETURN)

REFERENCES RETURNS20(CODE_RETURN)

ON UPDATE RESTRICT ON DELETE CASCADE;

/* Check Constraints */

ALTER TABLE TITLEUNITS ADD CONSTRAINT C1_001 check (code_unit>=0);

ALTER TABLE TITLEUNITS ADD CONSTRAINT C1_002 check ((IsActive=0) or (IsActive=1));

ALTER TABLE TITLEUNITS ADD CONSTRAINT C1_003 check (name_unit<>'');

ALTER TABLE TITLEUNITS ADD CONSTRAINT C1_004 check ((IsMaterial=0) or (IsMaterial=1));

ALTER TABLE GOODS ADD CONSTRAINT C2_001 check (number_good>=0);

ALTER TABLE GOODS ADD CONSTRAINT C2_002 check ((code_good>=10000) and (code_good<=999999));

ALTER TABLE GOODS ADD CONSTRAINT C2_003 check ((CodeIsActive=0) or (CodeIsActive=1));

ALTER TABLE GOODS ADD CONSTRAINT C2_004 check (code_ancestor>=0);

ALTER TABLE GOODS ADD CONSTRAINT C2_005 check (code_unit>=1);

ALTER TABLE WHOLESALEBASES ADD CONSTRAINT C3_001 check (code_base>=0);

ALTER TABLE PURCHASES ADD CONSTRAINT C4_001 check (code_purchase>=0);

ALTER TABLE PURCHASES ADD CONSTRAINT C4_002 check (code_base>=1);

ALTER TABLE PURCHASES ADD CONSTRAINT C4_003 check (summa>=0.0);

ALTER TABLE SESSIONS ADD CONSTRAINT C5_001 check (code_session>=0);

ALTER TABLE SESSIONS ADD CONSTRAINT C5_002 check (code_purchase>=1);

ALTER TABLE SESSIONS ADD CONSTRAINT C5_003 check ((accepted=0) or (accepted=1));

ALTER TABLE SESSIONS ADD CONSTRAINT C5_004 check (summa>=0.0);

ALTER TABLE STRUCTURESESSION ADD CONSTRAINT C6_001 check (primarykey>=0);

ALTER TABLE STRUCTURESESSION ADD CONSTRAINT C6_002 check (code_session>=1);

ALTER TABLE STRUCTURESESSION ADD CONSTRAINT C6_003 check (number_good>=1);

ALTER TABLE STRUCTURESESSION ADD CONSTRAINT C6_005 check (first_price>=0.0);

ALTER TABLE STRUCTURESESSION ADD CONSTRAINT C6_004 check (quantity>=0.0);

ALTER TABLE STOREHOUSE ADD CONSTRAINT C7_001 check (number_good>=0);

ALTER TABLE STOREHOUSE ADD CONSTRAINT C7_002 check (quantity>=-0.0001);

ALTER TABLE STOREHOUSE ADD CONSTRAINT C7_003 check (first_price>=0.0);

ALTER TABLE STOREHOUSE ADD CONSTRAINT C7_004 check (price>=0.0);

ALTER TABLE SALES ADD CONSTRAINT C8_001 check (code_sale>=0);

ALTER TABLE SALES ADD CONSTRAINT C8_002 check ((type_sale=0) or (type_sale=1));

ALTER TABLE SALES ADD CONSTRAINT C8_003 check (summa>=0.0);

ALTER TABLE SALES ADD CONSTRAINT C8_004 check (cash>=0.0);

ALTER TABLE STRUCTURESALE ADD CONSTRAINT C9_001 check (primarykey>=0);

ALTER TABLE STRUCTURESALE ADD CONSTRAINT C9_002 check (code_sale>=0.0);

ALTER TABLE STRUCTURESALE ADD CONSTRAINT C9_003 check (number_good>=1);

ALTER TABLE STRUCTURESALE ADD CONSTRAINT C9_004 check (quantity>=0.0);

ALTER TABLE STRUCTURESALE ADD CONSTRAINT C9_005 check (first_price>=0.0);

ALTER TABLE STRUCTURESALE ADD CONSTRAINT C9_006 check (price>=0.0);

ALTER TABLE PATHS ADD CONSTRAINT C10_001 check (code_path>=1);

ALTER TABLE PATHS ADD CONSTRAINT C10_002 check (code_ancestor>=0);

ALTER TABLE NOTES ADD CONSTRAINT C11_001 check (code_note>=0);

ALTER TABLE NOTES ADD CONSTRAINT C11_003 check (KeyFromTable>=1);

ALTER TABLE NOTES ADD CONSTRAINT C11_002 check ((number_table>=1) and (number_table<=80));

ALTER TABLE ACTIONS ADD CONSTRAINT C12_001 check (code_action>=0);

ALTER TABLE SAVES ADD CONSTRAINT C13_001 check (code_save>=0);

ALTER TABLE PROPERTIES ADD CONSTRAINT C14_001 check (code_property>=0);

ALTER TABLE SCANCODES ADD CONSTRAINT C15_001 check (number_good>=1);

ALTER TABLE SCANCODESFORSESSION ADD CONSTRAINT C16_001 check (code_session>=1);

ALTER TABLE SCANCODESFORSESSION ADD CONSTRAINT C16_002 check (number_good>=1);

ALTER TABLE SCANCODESFORSESSION ADD CONSTRAINT C16_003 check (primarykey>=1);

ALTER TABLE SCANCODESFORSESSION ADD CONSTRAINT C23_001 check (code_session>=1);

ALTER TABLE SCANCODESFORSESSION ADD CONSTRAINT C23_002 check (number_good>=1);

ALTER TABLE SCANCODESFORSESSION ADD CONSTRAINT C23_003 check (primarykey>=1);

ALTER TABLE SESSIONSCLOSED ADD CONSTRAINT C17_001 check (code_session>=1);

ALTER TABLE SESSIONSCLOSED ADD CONSTRAINT C17_002 check (number_good>=1);

ALTER TABLE SESSIONSCLOSED ADD CONSTRAINT C17_003 check (old_price>=0.0);

ALTER TABLE SESSIONSCLOSED ADD CONSTRAINT C17_004 check (new_price>=0.0);

ALTER TABLE RETURNS2 ADD CONSTRAINT C18_001 check (code_return>=1);

ALTER TABLE RETURNS2 ADD CONSTRAINT C18_002 check (code_sale>=1);

ALTER TABLE RETURNS2 ADD CONSTRAINT C18_003 check (summa>=0.0);

ALTER TABLE RETURNS2 ADD CONSTRAINT C18_004 check (cash>=0.0);

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT C19_001 check (primarykey>=1);

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT C19_002 check (code_return>=1);

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT C19_003 check (code_StructureSale>=1);

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT C19_004 check (number_good>=1);

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT C19_005 check (price>=0.0);

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT C19_006 check (quantity>=0.0);

ALTER TABLE STRUCTURERETURN2 ADD CONSTRAINT C19_007 check (summa>=0.0);

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_001 check (number_good>=1);

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_002 check (name_good<>'');

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_003 check (quantity>=0.0);

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_004 check (remainder>=-0.0001);

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_005 check ((IsMaterial=0) or (IsMaterial=1));

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_006 check (code_unit>=1);

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_007 check (name_unit<>'');

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_008 check (price>=0.0);

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_009 check (CodeStructureSale>=1);

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_010 check ((day0>=1) and (day0<=31));

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_011 check ((month0>=1) and (month0<=12));

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_012 check ((year0>=2000) and (year0<=2020));

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_013 check ((hour0>=0) and (hour0<=23));

ALTER TABLE GOODSFORRETURN ADD CONSTRAINT C20_014 check ((minute0>=0) and (minute0<=59));

ALTER TABLE NUMBERGOODSFORSELECT ADD CONSTRAINT C24_001 check (code_search>=1);

ALTER TABLE NUMBERGOODSFORSELECT ADD CONSTRAINT C24_002 check (number_good>=1);

ALTER TABLE GOODSFORCUT ADD CONSTRAINT C21_001 check (code_cut>=1);

ALTER TABLE GOODSFORCUT ADD CONSTRAINT C21_002 check (number_good>=1);

ALTER TABLE GOODSFORCUT ADD CONSTRAINT C21_004 check (code_cut>=1);

ALTER TABLE GOODSFORCUT ADD CONSTRAINT C21_005 check (number_good>=1);

ALTER TABLE SEARCHCODESALES ADD CONSTRAINT C32_001 check (code_seance>=1);

ALTER TABLE SEARCHCODESALES ADD CONSTRAINT C32_002 check (code_sale>=1);

ALTER TABLE CHANGEDPRICES ADD CONSTRAINT C22_001 check (number_good>=1);

ALTER TABLE CHANGEDPRICES ADD CONSTRAINT C22_002 check (new_price>=0.0);

ALTER TABLE CHANGEDPRICESFORPERIOD ADD CONSTRAINT C26_001 check(number_good>=1);

ALTER TABLE RESUMEOFDAY ADD CONSTRAINT C27_001 check (number_good>=1);

ALTER TABLE RESUMEOFDAY ADD CONSTRAINT C27_002 check (first_price>=0.0);

ALTER TABLE RESUMEOFDAY ADD CONSTRAINT C27_003 check (price>=0.0);

ALTER TABLE RESUMEOFDAY ADD CONSTRAINT C27_004 check (soldbyprice>=0.0);

ALTER TABLE SALES0 ADD CONSTRAINT C28_001 check (code_sale>=0);

ALTER TABLE SALES0 ADD CONSTRAINT C28_002 check ((type_sale=0) or (type_sale=1));

ALTER TABLE SALES0 ADD CONSTRAINT C28_003 check (summa>=0.0);

ALTER TABLE SALES0 ADD CONSTRAINT C28_004 check (cash>=0.0);

ALTER TABLE RETURNS20 ADD CONSTRAINT C30_001 check (code_return>=1);

ALTER TABLE RETURNS20 ADD CONSTRAINT C30_002 check (code_sale>=1);

ALTER TABLE RETURNS20 ADD CONSTRAINT C30_003 check (summa>=0.0);

ALTER TABLE RETURNS20 ADD CONSTRAINT C30_004 check (cash>=0.0);

ALTER TABLE STRUCTURESALE0 ADD CONSTRAINT C29_001 check (primarykey>=0);

ALTER TABLE STRUCTURESALE0 ADD CONSTRAINT C29_002 check (code_sale>=0.0);

ALTER TABLE STRUCTURESALE0 ADD CONSTRAINT C29_003 check (number_good>=1);

ALTER TABLE STRUCTURESALE0 ADD CONSTRAINT C29_004 check (quantity>=0.0);

ALTER TABLE STRUCTURESALE0 ADD CONSTRAINT C29_005 check (first_price>=0.0);

ALTER TABLE STRUCTURESALE0 ADD CONSTRAINT C29_006 check (price>=0.0);

ALTER TABLE STRUCTURERETURN20 ADD CONSTRAINT C31_001 check (primarykey>=1);

ALTER TABLE STRUCTURERETURN20 ADD CONSTRAINT C31_002 check (code_return>=1);

ALTER TABLE STRUCTURERETURN20 ADD CONSTRAINT C31_003 check (code_StructureSale>=1);

ALTER TABLE STRUCTURERETURN20 ADD CONSTRAINT C31_004 check (number_good>=1);

ALTER TABLE STRUCTURERETURN20 ADD CONSTRAINT C31_005 check (price>=0.0);

ALTER TABLE STRUCTURERETURN20 ADD CONSTRAINT C31_006 check (quantity>=0.0);

ALTER TABLE STRUCTURERETURN20 ADD CONSTRAINT C31_007 check (summa>=0.0);

ALTER TABLE SEARCHNUMBERGOODS ADD CONSTRAINT C33_001 check (code_seance>=1);

ALTER TABLE SEARCHNUMBERGOODS ADD CONSTRAINT C33_002 check (number_good>=1);

/* Unique Constraints */

ALTER TABLE WHOLESALEBASES ADD CONSTRAINT C3_002 UNIQUE (NAME_BASE);

ALTER TABLE PATHS ADD CONSTRAINT C10_003 UNIQUE (CODE_ANCESTOR,NAME_PATH);

ALTER TABLE NOTES ADD CONSTRAINT C11_004 UNIQUE (NUMBER_TABLE,KEYFROMTABLE);

ALTER TABLE GOODSFORCUT ADD CONSTRAINT C21_003 UNIQUE (CODE_CUT,NUMBER_GOOD);

2. Тексты запросов, хранимых процедур, триггеров

SET TERM ^ ;

CREATE PROCEDURE GETDATE

RETURNS (

DAY0 INTEGER,

MONTH0 INTEGER,

YEAR0 INTEGER,

HOUR0 INTEGER,

MINUTE0 INTEGER)

declare variable date0 timestamp;

begin

date0=current_timestamp;

delete from date1;

insert into date1(date0) values (:date0);

select extract(day from date0) from date1 into day0;

select extract(month from date0) from date1 into month0;

select extract(year from date0) from date1 into year0;

select extract(hour from date0) from date1 into hour0;

select extract(minute from date0) from date1 into minute0;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE LEN(

STR VARCHAR(1000) )

RETURNS (

LEN INTEGER)

declare variable pat varchar(1000);

begin

len = null;

if (str is null) then exit;

pat = '';

len = 0;

while (not str like pat) do begin

pat = pat || '_';

len = len + 1;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE THISSYMBOLISDIGIT(

S VARCHAR(1000),

NUM INTEGER,

LEN INTEGER )

RETURNS (

ANSWER INTEGER)

declare variable vrem varchar(1000);

declare variable len_vrem integer;

declare variable cycle integer;

declare variable i integer;

begin

answer=0;

cycle=0;

while (cycle<=9) do begin

vrem=''; i=1;

while (i<num) do begin

vrem=vrem||'_';

i=i+1;

end

vrem = vrem||cycle;

i=i+1;

while (i<=len) do begin

vrem=vrem||'_';

i=i+1;

end

if (s like vrem) then begin answer=1; exit; end

cycle=cycle+1;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE STRINGHASONLYDIGITS(

S VARCHAR(1000) )

RETURNS (

ANSWER INTEGER)

declare variable len integer;

declare variable i integer;

declare variable vrem integer;

begin

answer=1;

execute procedure len(s) returning_values len;

if (len=0) then exit;

i=1;

while (i<=len) do begin

execute procedure ThisSymbolIsDigit(s, i, len) returning_values(vrem);

if (vrem=0) then begin answer=0; exit; end

i=i+1;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE TRUNC(

CHISLO DOUBLE PRECISION )

RETURNS (

CHISLO2 DOUBLE PRECISION)

declare variable milliards integer;

declare variable x integer;

begin

chislo2=0;

if (chislo<1e9) then begin

x=chislo-0.49999999999999;

chislo2=x;

end

else if (chislo<1e18) then begin

milliards=(chislo/1e9)-0.5;

chislo=chislo-1e9*milliards;

x=chislo-0.49999999999999;

chislo2=1e9*milliards+x;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE CHISLOISFLOAT(

CHISLO DOUBLE PRECISION )

RETURNS (

ANSWER INTEGER)

declare variable trunc_chislo double precision;

declare variable razn double precision;

begin

if (chislo<0.0) then chislo=-chislo;

execute procedure trunc(chislo) returning_values(trunc_chislo);

razn=chislo-trunc_chislo;

if (((razn>=0.000) and (razn<=0.0001)) or ((razn>=0.9999) and (razn<=1.0000))) then answer=0;

else answer=1;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDTITLEUNIT(

NAME_UNIT VARCHAR(20),

ISMATERIAL INTEGER )

RETURNS (

NEW_CODE_UNIT INTEGER,

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this name_unit already exists

error=2 -- name_unit cannot be empty

error=3 -- IsMaterial must be 0 or 1

begin

error=0;

if (name_unit='') then begin

error=2;

exit;

end

if ((IsMaterial<>0) and (IsMaterial<>1)) then begin error=3; exit; end

select count(*) from TitleUnits

where name_unit=:name_unit and IsActive=1 into vrem;

if (vrem<>0) then error=1;

else begin

new_code_unit = gen_id(genTitleUnits, 1);

insert into TitleUnits values (:new_code_unit, :name_unit, 1, :IsMaterial);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE ROUND(

CHISLO DOUBLE PRECISION )

RETURNS (

CHISLO2 DOUBLE PRECISION)

begin

chislo=chislo+0.5;

execute procedure trunc(chislo) returning_values(chislo2);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDOWHOLEPRICE(

P1 DOUBLE PRECISION )

RETURNS (

P2 DOUBLE PRECISION)

begin

p1=p1+0.001;

if (p1<=1.00) then begin

p1=100.0*p1;

execute procedure round(p1) returning_values(p2);

p2=p2/100.0;

end

else if (p1<=5.00) then begin

p1=10.0*(p1+0.029);

execute procedure round(p1) returning_values(p2);

p2=p2/10.0;

end

else if (p1<=20.00) then begin

p1=2.0*(p1+0.145);

execute procedure round(p1) returning_values(p2);

p2=p2/2.0;

end

else begin

p1=1.0*(p1+0.29);

execute procedure round(p1) returning_values(p2);

p2=p2/1.0;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCRENAMEPATH(

CODE_PATH INTEGER,

NEW_NAME_PATH VARCHAR(80) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable code_ancestor integer;

error=1 -- name_path must not be empty

error=2 -- this code_path is not exist

error=3 -- this name_path is already exists

error=4 -- length(name_path) must more than 3

begin

error=0;

if (new_name_path='') then begin error=1; exit; end

if (LengthString(new_name_path)<3) then begin error=4; exit; end

select count(*) from paths where code_path=:code_path into vrem;

if (vrem=0) then begin error=2; exit; end

select code_ancestor from paths where code_path=:code_path into code_ancestor;

select count(*) from paths

where (code_ancestor=:code_ancestor) and (code_path<>:code_path) and

(name_path=:new_name_path) into vrem;

if (vrem<>0) then begin error=3; exit; end

update paths set name_path=:new_name_path where code_path=:code_path;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDWHOLESALEBASE(

NAME_BASE VARCHAR(80),

ADDRESS VARCHAR(80),

FIOMAN VARCHAR(80),

PHONEMAN VARCHAR(40),

PHONEBK VARCHAR(40),

NOTE VARCHAR(80) )

RETURNS (

NEW_CODE_BASE INTEGER,

ERROR INTEGER)

declare variable vrem integer;

declare variable new_code_note integer;

error=1 -- name_base is empty

error=2 -- address is empty

error=3 -- FIOman is empty

error=4 -- PhoneMan is empty

error=5 -- PhoneBK is empty

error=6 -- this name_base already exists

begin

error=0;

if (name_base='') then begin error=1; exit; end

if (address='') then begin error=2; exit; end

if (FIOman='') then begin error=3; exit; end

if (PhoneMan='') then begin error=4; exit; end

if (PhoneBK='') then begin error=5; exit; end

select count(*) from WholesaleBases where name_base=:name_base into vrem;

if (vrem<>0) then begin error=6; exit; end

new_code_base=gen_id(genWholesaleBases, 1);

insert into WholesaleBases

values (:new_code_base, :name_base, :address, :FIOman, :PhoneMan, :PhoneBK);

if (note<>'') then begin

new_code_note=gen_id(genNotes, 1);

insert into notes values(:new_code_note, 3, :new_code_base, :note);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDELWHOLESALEBASE(

CODE_BASE INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this wholesale base is not exist

error=2 -- this base use in table purchases

begin

error=0;

select count(*) from WholesaleBases where code_base=:code_base into vrem;

if (vrem=0) then begin error=1; exit; end

select count(*) from purchases where code_base=:code_base into vrem;

if (vrem<>0) then begin error=2; exit; end

delete from WholesaleBases where code_base=:code_base;

delete from notes where number_table=3 and KeyFromTable=:code_base;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGEWHOLESALEBASE(

CODE_BASE INTEGER,

NAME_BASE VARCHAR(80),

ADDRESS VARCHAR(80),

FIOMAN VARCHAR(80),

PHONEMAN VARCHAR(40),

PHONEBK VARCHAR(40),

NOTE VARCHAR(80) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable new_code_note integer;

error=1 -- name_base is empty

error=2 -- address is empty

error=3 -- FIOman is empty

error=4 -- PhoneMan is empty

error=5 -- PhoneBK is empty

error=6 -- this name_base already exists

error=7 -- this code_base is not exist

begin

error=0;

if (name_base='') then begin error=1; exit; end

if (address='') then begin error=2; exit; end

if (FIOman='') then begin error=3; exit; end

if (PhoneMan='') then begin error=4; exit; end

if (PhoneBK='') then begin error=5; exit; end

select count(*) from WholesaleBases where code_base=:code_base into vrem;

if (vrem=0) then begin error=7; exit; end

select count(*) from WholesaleBases

where (code_base<>:code_base) and (name_base=:name_base) into vrem;

if (vrem<>0) then begin error=6; exit; end

/*write data to database*/

update WholesaleBases set

name_base=:name_base, address=:address,

FIOman=:FIOman, PhoneMan=:PhoneMan, PhoneBK=:PhoneBK

where code_base=:code_base;

/*write note*/

select count(*) from notes

where (number_table=3) and (KeyFromTable=:code_base) into vrem;

if (vrem=0) then begin

if (note<>'') then begin

new_code_note=gen_id(genNotes, 1);

insert into notes values (:new_code_note, 3, :code_base, :note);

end

else begin

if (note<>'') then begin

update notes set text=:note where (number_table=3) and (KeyFromTable=:code_base);

end

else begin

delete from notes where (number_table=3) and (KeyFromTable=:code_base);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGECODEGOOD(

OLD_CODE_GOOD INTEGER,

NEW_CODE_GOOD INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable number_good integer;

error=1 -- this old_code_good is not exist

error=2 -- this old_code_good exist more than once

error=3 -- this new_code_good already exists

error=4 -- this good already exists on StoreHouse. Impossible to change code.

begin

error=0;

select count(*) from goods

where code_good=:old_code_good and CodeIsActive=1

into vrem;

if (vrem=0) then begin error=1; exit; end

if (vrem>1) then begin error=2; exit; end

select number_good from goods

where code_good=:old_code_good and CodeIsActive=1

into :number_good;

select count(*) from goods where

code_good=:new_code_good and CodeIsActive=1

into vrem;

if (vrem<>0) then begin error=3; exit; end

select count(*) from StoreHouse where number_good=:number_good into vrem;

if (vrem<>0) then begin error=4; exit; end

update goods set code_good=:new_code_good where number_good=:number_good;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGEPURCHASENOTE(

CODE_PURCHASE INTEGER,

NOTE VARCHAR(80) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable new_code_note integer;

error=1 -- this code_purchase is not exist

begin

error=0;

select count(*) from purchases where code_purchase=:code_purchase into vrem;

if (vrem=0) then begin error=1; exit; end

select count(*) from notes

where (number_table=4) and (KeyFromTable=:code_purchase) into vrem;

if (vrem=0) then begin

if (note<>'') then begin

new_code_note=gen_id(genNotes, 1);

insert into notes values(:new_code_note, 4, :code_purchase, :note);

end

else begin

if (note='') then begin

delete from notes where number_table=4 and KeyFromTable=:code_purchase;

end

else begin

update notes set text=:note where number_table=4 and KeyFromTable=:code_purchase;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDSESSION(

CODE_PURCHASE INTEGER,

ADDITION DOUBLE PRECISION,

NOTE VARCHAR(80) )

RETURNS (

ERROR INTEGER)

declare variable new_code_session integer;

declare variable new_code_note integer;

declare variable vrem integer;

declare variable date0 timestamp;

error=1 -- this code_purchase is not exist

error=2 -- addition bust between -100% and 10000%

begin

error=0;

select count(*) from purchases where code_purchase=:code_purchase into vrem;

if (vrem=0) then begin error=1; exit; end

if ((addition<-100.0) or (addition>10000.0)) then begin error=2; exit; end

date0 = current_timestamp;

new_code_session=gen_id(genSessions, 1);

insert into sessions values (:new_code_session, :code_purchase, 0, :addition,

:date0, :date0, 0.0);

if (note<>'') then begin

new_code_note=gen_id(genNotes, 1);

insert into notes values (:new_code_note, 5, :new_code_session, :note);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGESESSIONNOTE(

CODE_SESSION INTEGER,

NOTE VARCHAR(80) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable new_code_note integer;

error=1 -- this code_session is not exist

begin

error=0;

select count(*) from sessions where code_session=:code_session into vrem;

if (vrem=0) then begin error=1; exit; end

select count(*) from notes where (number_table=5) and (KeyFromTable=:code_session)

into vrem;

if (vrem=0) then begin

if (note<>'') then begin

new_code_note=gen_id(genNotes, 1);

insert into notes values(:new_code_note, 5, :code_session, :note);

end

else begin

if (note='') then begin

delete from notes where number_table=5 and KeyFromTable=:code_session;

end

else begin

update notes set text=:note where number_table=5 and KeyFromtable=:code_session;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGEADDITIONOFSESSION(

CODE_SESSION INTEGER,

ADDITION DOUBLE PRECISION )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this code_session is not exist

error=2 -- addition bust between -100% and 10000%

begin

error=0;

select count(*) from sessions where code_session=:code_session into vrem;

if (vrem=0) then begin error=1; exit; end

if ((addition<-100.0) or (addition>10000.0)) then begin error=2; exit; end

update sessions set addition=:addition where code_session=:code_session;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDPATH(

CODE_ANCESTOR INTEGER,

NAME_PATH VARCHAR(80) )

RETURNS (

ERROR INTEGER,

NEW_CODE_PATH INTEGER)

declare variable vrem integer;

error=1 -- name_path is empty

error=2 -- this code_ancestor is not exist

error=3 -- this name_path already exists

begin

error=0;

if (name_path='') then begin error=1; exit; end

if (code_ancestor<>0) then begin

select count(*) from paths where code_path=:code_ancestor into vrem;

if (vrem=0) then begin error=2; exit; end

end

select count(*) from paths

where code_ancestor=:code_ancestor and name_path=:name_path

into vrem;

if (vrem<>0) then begin error=3; exit; end

new_code_path=gen_id(genPaths, 1);

insert into paths values(:new_code_path, :code_ancestor, :name_path);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDSCANCODE(

SCAN_CODE VARCHAR(20) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable scan_code0 varchar(20);

declare variable scan_codes varchar(255);

error=2 -- length of scan_code must be 13

error=3 -- scan_code must have only digits

begin

error=0;

/*checkings*/

if (LengthString(scan_code)<>13) then begin error=2; exit; end

execute procedure StringHasOnlyDigits(scan_code) returning_values(vrem);

if (vrem=0) then begin error=3; exit; end

/*write data to database*/

insert into ScanCodes2 values (:scan_code);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDOFULLNAMEPATHFROMCODEPATH0(

CODE_PATH INTEGER,

NAME_PATH0 VARCHAR(1000) )

RETURNS (

NAME_PATH VARCHAR(1000))

declare variable code_ancestor integer;

begin

select name_path from paths where code_path=:code_path into :name_path;

if (name_path0<>'') then name_path = name_path||'\'||name_path0;

select code_ancestor from paths where code_path=:code_path into :code_ancestor;

if (code_ancestor<>0) then begin

execute procedure procDoFullNamePathFromCodePath0(code_ancestor, name_path)

returning_values(name_path);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDOFULLNAMEPATHFROMCODEPATH(

CODE_PATH INTEGER )

RETURNS (

NAME_PATH VARCHAR(1000),

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this code_path is not exist

begin

error=0;

if (code_path=0) then begin name_path=''; exit; end

select count(*) from paths where code_path=:code_path into vrem;

if (vrem=0) then begin error=1; exit; end

execute procedure procDoFullNamePathFromCodePath0(code_path, '')

returning_values(name_path);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDELGOOD(

NUMBER_GOOD INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this number_good is not exist

error=2 -- this good exist on StoreHouse

error=3 -- this good exist on unaccepted session

begin

error=0;

/*checking that good exists*/

select count(*) from goods where number_good=:number_good and CodeIsActive=1 into vrem;

if (vrem=0) then begin error=1; exit; end

/*checking that good(number_good) is not exist on StoreHouse*/

select count(*) from StoreHouse where number_good=:number_good into vrem;

if (vrem<>0) then begin error=2; exit; end

/*checking that good(number_good) is not exist on unaccepted session*/

select count(*) from sessions join StructureSession

on sessions.code_session=StructureSession.code_session

where sessions.accepted=0 and StructureSession.number_good=:number_good

into vrem;

if (vrem<>0) then begin error=3; exit; end

/*other actions*/

update goods set CodeIsActive=0, scan_codes='' where number_good=:number_good;

delete from ScanCodes where number_good=:number_good;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDGOOD(

CODE_GOOD INTEGER,

ART VARCHAR(20),

CODE_ANCESTOR INTEGER,

NAME_GOOD VARCHAR(80),

CODE_UNIT INTEGER )

RETURNS (

ERROR INTEGER,

NEW_NUMBER_GOOD INTEGER)

declare variable vrem integer;

declare variable scan_code varchar(20);

error=1 -- this code_good already exists

error=2 -- articul must not be empty

error=3 -- incorrect code_ancestor (path not exists)

error=4 -- name_good must not be empty

error=5 -- this code_unit is not exist

error=6 -- good with this name_good already exists

error=7 -- code_good must not be less than 10000

error=8 -- the good cannot have more than 12 sacn_codes

error=9 -- length(name_good) must not be less than 3

begin

error=0;

select count(*) from goods where CodeIsActive=1 and code_good=:code_good into vrem;

if (vrem<>0) then begin error=1; exit; end

if (art='') then begin error=2; exit; end

select count(*) from paths where code_path=:code_ancestor into vrem;

if (vrem=0) then begin error=3; exit; end

if (name_good='') then begin error=4; exit; end

if (LengthString(name_good)<3) then begin error=9; exit; end

select count(*) from TitleUnits where code_unit=:code_unit into vrem;

if (vrem=0) then begin error=5; exit; end

select count(*) from goods

where code_ancestor=:code_ancestor and name_good=:name_good and CodeIsActive=1

into vrem;

if (vrem<>0) then begin error=6; exit; end

if (code_good<10000) then begin error=7; exit; end

/*write data to database*/

new_number_good=gen_id(genGoods, 1);

insert into goods

values(:new_number_good, :code_good, 1, :art, :code_ancestor, :name_good, :code_unit,'');

vrem=0;

for select scan_code from ScanCodes2

into :scan_code as cursor cur1 do begin

vrem=vrem+1;

if (vrem=13) then begin error=1/0; when any do begin error=8; exit; end end

insert into ScanCodes

values(:new_number_good, :scan_code);

update goods

set scan_codes=scan_codes||:scan_code||' '

where number_good=:new_number_good;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE CLEARDATABASE

declare variable vrem integer;

begin

vrem=gen_id(genActions, 0); vrem=gen_id(genActions, -vrem);

vrem=gen_id(genGoods, 0); vrem=gen_id(genGoods, -vrem);

vrem=gen_id(genGoodsForCut, 0); vrem=gen_id(genGoodsForCut, -vrem);

vrem=gen_id(genNotes, 0); vrem=gen_id(genNotes, -vrem);

vrem=gen_id(genNumberGoodsForSelect, 0); vrem=gen_id(genNumberGoodsForSelect, -vrem);

vrem=gen_id(genPaths, 0); vrem=gen_id(genPaths, -vrem);

vrem=gen_id(genPurchases, 0); vrem=gen_id(genPurchases, -vrem);

vrem=gen_id(genReturns, 0); vrem=gen_id(genReturns, -vrem);

vrem=gen_id(genSales, 0); vrem=gen_id(genSales, -vrem);

vrem=gen_id(genSaves, 0); vrem=gen_id(genSaves, -vrem);

vrem=gen_id(genSearchCodeSaleNumberGood, 0); vrem=gen_id(genSearchCodeSaleNumberGood, -vrem);

vrem=gen_id(genSessions, 0); vrem=gen_id(genSessions, -vrem);

vrem=gen_id(genStructureReturn, 0); vrem=gen_id(genStructureReturn, -vrem);

vrem=gen_id(genStructureSale, 0); vrem=gen_id(genStructureSale, -vrem);

vrem=gen_id(genStructureSession, 0); vrem=gen_id(genStructureSession, -vrem);

vrem=gen_id(genTitleUnits, 0); vrem=gen_id(genTitleUnits, -vrem);

vrem=gen_id(genWholesaleBases, 0); vrem=gen_id(genWholesaleBases, -vrem);

delete from actions;

delete from ChangedPrices;

delete from ChangedPricesForPeriod;

delete from date1;

delete from goods;

delete from GoodsForCut;

delete from GoodsForReturn;

delete from notes;

delete from NumberGoodsForSelect;

delete from paths;

delete from properties;

delete from purchases;

delete from ResumeOfDay;

delete from returns2;

delete from returns20;

delete from sales;

delete from sales0;

delete from saves;

delete from ScanCodes;

delete from ScanCodes2;

delete from ScanCodesForSession;

delete from ScanCodesForSession2;

delete from SearchCodeSales;

delete from SearchNumberGoods;

delete from sessions;

delete from SessionsClosed;

delete from StoreHouse;

delete from StructureReturn2;

delete from StructureReturn20;

delete from StructureSale;

delete from StructureSale0;

delete from StructureSession;

delete from TitleUnits;

delete from users;

delete from WholesaleBases;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDELETEEMPTYSESSION(

CODE_SESSION INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this code_session is not exist

error=2 -- impossible delete session which not empty

begin

error=0;

select count(*) from sessions where code_session=:code_session into vrem;

if (vrem=0) then begin error=1; exit; end

select count(*) from StructureSession where code_session=:code_session into vrem;

if (vrem<>0) then begin error=2; exit; end

delete from sessions where code_session=:code_session;

delete from notes where number_table=5 and KeyFromTable=:code_session;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDELUSELESSNOTES

declare variable number_table integer;

declare variable KeyFromTable integer;

declare variable vrem integer;

begin

/*WholesaleBases purchases sessions sales returns2*/

for select number_table, KeyFromTable from notes

into :number_table, :KeyFromTable as cursor cur1 do begin

if (number_table=3) then begin /*WholesaleBases*/

select count(*) from WholesaleBases where code_base=:KeyFromTable

into vrem;

end

if (number_table=4) then begin /*purchases*/

select count(*) from purchases where code_purchase=:KeyFromTable

into vrem;

end

if (number_table=5) then begin /*sessions*/

select count(*) from sessions where code_session=:KeyFromTable

into vrem;

end

if (number_table=8) then begin /*sales*/

select count(*) from sales where code_sale=:KeyFromTable

into vrem;

end

if (number_table=18) then begin /*returns2*/

select count(*) from returns2 where code_return=:KeyFromTable

into vrem;

end

if (vrem=0) then begin

delete from notes

where number_table=:number_table and KeyFromTable=:KeyFromTable;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCMINNEWCODERETURN(

CODE_SALE INTEGER )

RETURNS (

CODE_RETURN INTEGER)

declare variable date_return timestamp;

begin

code_return=gen_id(genReturns, 1);

date_return=current_timestamp;

insert into returns20 values(:code_return, :code_sale, :date_return, 0.0, 0.0);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCNEWCODENUMBERGOODSFORSELECT

RETURNS (

CODE_SEARCH INTEGER)

begin

code_search=gen_id(genNumberGoodsForSelect, 1);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDGOODTONGFORSELECT(

CODE_SEARCH INTEGER,

NUMBER_GOOD INTEGER )

begin

insert into NumberGoodsForSelect values(:code_search, :number_good);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE SUPERKA

declare variable number_good integer;

declare variable first_price double precision;

declare variable price double precision;

declare variable addition double precision;

begin

delete from StoreHouse;

update sessions set accepted=0 where code_session=1;

for select number_good, first_price from StructureSession

where code_session=1

into :number_good, :price as cursor cur1 do begin

if (price<>0.0) then begin

first_price=0.625*price;

first_price=100.0*first_price;

execute procedure round(first_price)

returning_values(first_price);

first_price=0.01*first_price;

addition=100.0*(price-first_price)/first_price;

end

else begin

first_price=0.0;

addition=0.0;

end

update StructureSession

set first_price=:first_price, addition=:addition

where code_session=1 and number_good=:number_good;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCNEWNAMEPATH(

CODE_ANCESTOR INTEGER )

RETURNS (

ERROR INTEGER,

NEW_NAME_PATH VARCHAR(80))

declare variable vrem integer;

declare variable base_name_path varchar(80);

declare variable number integer;

error=1 -- this code_ancestor is not exist

begin

error=0;

select count(*) from paths where code_path=:code_ancestor into vrem;

if (code_ancestor=0) then vrem=1;

if (vrem=0) then begin error=1; exit; end

base_name_path='Íîâàÿ ïàïêà';

select count(*) from paths

where name_path=:base_name_path and code_ancestor=:code_ancestor

into vrem;

new_name_path=base_name_path;

number=0;

while (vrem<>0) do begin

number=number+1;

new_name_path=base_name_path||' ('||number||')';

select count(*) from paths

where name_path=:new_name_path and code_ancestor=:code_ancestor

into vrem;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCREHSUMMSOFSESSANDPURCH

declare variable vrem integer;

declare variable code_purchase integer;

declare variable code_session integer;

declare variable summa0 double precision;

begin

for select code_purchase from purchases

into :code_purchase as cursor cur1 do begin

for select code_session from sessions

where code_purchase=:code_purchase

into :code_session as cursor cur2 do begin

select count(*), sum(quantity*first_price) from StructureSession

where code_session=:code_session

into vrem, summa0;

if (vrem=0) then summa0=0.0;

update sessions set summa=:summa0 where code_session=:code_session;

end

select count(*), sum(summa) from sessions

where code_purchase=:code_purchase

into vrem, summa0;

if (vrem=0) then summa0=0.0;

update purchases set summa=:summa0 where code_purchase=:code_purchase;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE SUPERKA2

declare variable number_good integer;

declare variable scan_code varchar(20);

declare variable vrem integer;

begin

for select number_good, scan_code from ScanCodes

into :number_good, :scan_code as cursor cur1 do begin

select count(*) from ScanCodes3 where number_good=:number_good and scan_code=:scan_code

into vrem;

if (vrem=0) then begin

insert into ScanCodes3 values(:number_good, :scan_code);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCENDRETURN(

CODE_RETURN INTEGER,

COMMONSUMMA DOUBLE PRECISION,

CASH DOUBLE PRECISION,

NOTE VARCHAR(80) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable code_sale integer;

declare variable CommonSumma2 double precision;

declare variable diff double precision;

declare variable date_return timestamp;

declare variable new_code_note integer;

/*variables for main cycle (cursor cur1)*/

declare variable number_good integer;

declare variable code_StructureSale integer;

declare variable first_price double precision;

declare variable price double precision;

declare variable quantity double precision;

declare variable summa double precision;

/*variables for forming new first_price and quantity on StoreHouse*/

declare variable first_price2 double precision;

declare variable quantity2 double precision;

declare variable sold2 double precision;

declare variable first_price3 double precision;

declare variable quantity3 double precision;

/*other variables*/

declare variable x1 double precision;

declare variable x2 double precision;

declare variable x3 double precision;

declare variable x4 double precision;

declare variable x5 double precision;

declare variable x6 double precision;

declare variable x7 double precision;

error=1 -- this code_return is not exist

error=2 -- the same goods must not be exist in StructureReturn

error=3 -- the summa incorrect calculated in program

error=4 -- error StoreHouse: sold<quantity...

error=5 -- cash<CommonSumma

begin

error=0;

select count(*) from returns20 where code_return=:code_return into vrem;

if (vrem=0) then begin error=1; exit; end

select code_sale from returns20 where code_return=:code_return into code_sale;

if (cash+0.001<CommonSumma) then begin error=5; exit; end

CommonSumma2=0.0;

for select

StructureSale.number_good,

StructureReturn20.code_StructureSale,

StructureSale.first_price,

StructureReturn20.price,

StructureReturn20.quantity,

StructureReturn20.summa

from StructureReturn20 join StructureSale

on StructureReturn20.code_StructureSale=StructureSale.primarykey

where StructureReturn20.code_return=:code_return

into number_good, code_StructureSale, first_price, price, quantity, summa

as cursor cur1 do begin

select count(*) from StructureReturn20

where code_return=:code_return and code_StructureSale=:code_StructureSale

into vrem;

if (vrem>1) then begin error=1/0; when any do begin error=2; exit; end end

CommonSumma2=CommonSumma2+summa;

select first_price, quantity, sold from StoreHouse

where number_good=:number_good

into first_price2, quantity2, sold2;

if (sold2+0.0001<quantity) then begin

error=1/0; when any do begin error=4; exit; end

end

if (quantity<0.0) then quantity=0.0;

if (quantity2<0.0) then quantity2=0.0;

quantity3=quantity+quantity2;

if (quantity3<>0.0) then

first_price3=(first_price*quantity+first_price2*quantity2)/quantity3;

else first_price=0.0;

update StoreHouse

set quantity=:quantity3, sold=sold-:quantity, first_price=:first_price3

where number_good=:number_good;

end

diff=abs(CommonSumma-CommonSumma2);

if (diff>0.001) then begin error=1/0; when any do begin error=3; exit; end end

select date_return from returns20 where code_return=:code_return into date_return;

/*write data to main tables*/

select count(*) from StructureReturn20 where code_return=:code_return into vrem;

if ((vrem<>0) or (note<>'')) then begin

insert into returns2

values(:code_return, :code_sale, :date_return, :CommonSumma, :cash);

for select primarykey, code_return, code_StructureSale, number_good,

price, quantity, summa from StructureReturn20

where code_return=:code_return

into x1, x2, x3, x4, x5, x6, x7

do begin

insert into StructureReturn2 values(:x1, :x2, :x3, :x4, :x5, :x6, :x7);

end

if (note<>'') then begin

new_code_note=gen_id(genNotes, 1);

insert into notes (code_note, number_table, KeyFromTable, text) values

(:new_code_note, 18, :code_return, :note);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCALLOWADDSCANCODE(

CODE_SESSION INTEGER,

NUMBER_GOOD INTEGER,

SCAN_CODE VARCHAR(20) )

RETURNS (

W1 INTEGER,

W2 INTEGER)

declare variable vrem integer;

w1 -- this scan_code exist in table ScanCodes for goods

w2 -- this scan_code exist in table ScanCodesForSession

begin

w1=0; w2=0;

/*warning1*/

select count(*) from goods join ScanCodes

on goods.number_good=ScanCodes.number_good

where number_good<>:number_good and CodeIsActive=1 and scan_code=:scan_code

into vrem;

if (vrem<>0) then w1=1;

/*warning2*/

select count(*) from StructureSession join ScanCodesForSession

on StructureSession.primarykey=ScanCodesForSession.primarykey join sessions

on StructureSession.code_session=sessions.code_session join goods

on StructureSession.number_good=goods.number_good

where goods.CodeIsActive=1 and sessions.accepted=0 and

(StructureSession.code_session<>:code_session or

StructureSession.number_good<>:number_good) and

ScanCodesForSession.scan_code=:scan_code into vrem;

if (vrem<>0) then vrem=1;

w2=vrem;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE SUPERKA3

declare variable number_good integer;

declare variable scan_code varchar(20);

declare variable vrem integer;

begin

delete from ScanCodes;

for select number_good, scan_code from ScanCodes3

into :number_good, :scan_code as cursor cur1 do begin

insert into ScanCodes values(:number_good, :scan_code);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCMINNEWCODESALE

RETURNS (

CODE_SALE INTEGER)

declare variable date0 timestamp;

begin

code_sale=gen_id(genSales, 1);

date0=current_timestamp;

insert into sales0 values (:code_sale, 0, :date0, 0.0, 0.0);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCMOVEPATH(

WHAT_MOVE INTEGER,

WHERE_MOVE INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable code_path integer;

declare variable name_path varchar(80);

error=1 -- path, where we move what_move must not be equal what_move

error=2 -- path, where we move what_move, found in path what_move

error=3 -- in path, where we move what_path already exist path with this name_path

begin

error=0;

if (what_move=where_move) then begin error=1; exit; end

code_path=where_move;

while (code_path<>0) do begin

select code_ancestor from paths where code_path=:code_path into code_path;

if (code_path=what_move) then begin error=2; exit; end

end

select name_path from paths where code_path=:what_move into name_path;

select count(*) from paths

where code_ancestor=:where_move and name_path=:name_path

into vrem;

if (vrem<>0) then begin error=3; exit; end

update paths set code_ancestor=:where_move where code_path=:what_move;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDGOODTOCUT(

CODE_CUT INTEGER,

NUMBER_GOOD INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this number_good is not exist

begin

error=0;

select count(*) from goods where number_good=:number_good into vrem;

if (vrem=0) then begin error=1; exit; end

insert into GoodsForCut values(:code_cut, :number_good);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDELGOODFROMCUT(

CODE_CUT INTEGER,

NUMBER_GOOD INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this number_good is not exist

begin

error=0;

select count(*) from goods where number_good=:number_good into vrem;

if (vrem=0) then begin error=1; exit; end

delete from GoodsForCut where code_cut=:code_cut and number_good=:number_good;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCGETNEWCODECUT

RETURNS (

CODE_CUT INTEGER)

begin

code_cut=gen_id(genGoodsForCut, 1);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCLEARUSERS(

CODE_SEANCE INTEGER )

declare variable vrem integer;

declare variable date_seance timestamp;

declare variable days integer;

declare variable seconds integer;

declare variable code_seance0 integer;

declare variable date_seance0 timestamp;

declare variable days0 integer;

declare variable seconds0 integer;

declare variable diff integer;

begin

select count(*) from users where code_seance=:code_seance into vrem;

if (vrem=0) then begin

insert into users values(:code_seance, current_timestamp);

end

else begin

update users set date_seance=current_timestamp

where code_seance=:code_seance;

end

date_seance=current_timestamp;

days=DateDays(date_seance);

seconds=DateSeconds(date_seance);

for select code_seance, date_seance from users

into :code_seance0, :date_seance0 as cursor cur1 do begin

days0=DateDays(date_seance0);

seconds0=DateSeconds(date_seance0);

diff=0;

diff=86400*(days-days0);

diff=diff+(seconds-seconds0);

if (diff>=60) then begin

delete from users where code_seance=:code_seance0;

delete from ResumeOfDay where code_seance=:code_seance0;

delete from ChangedPricesForPeriod where code_seance=:code_seance0;

delete from SearchCodeSales where code_seance=:code_seance0;

delete from SearchNumberGoods where code_seance=:code_seance0;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDELTITLEUNIT(

CODE_UNIT INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

begin

error=0;

select count(*) from TitleUnits

where code_unit=:code_unit

into vrem;

if (vrem=0) then begin error=1; exit; end

update TitleUnits set IsActive=0 where code_unit=:code_unit;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGETITLEUNIT(

CODE_UNIT INTEGER,

NAME_UNIT VARCHAR(20) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this name_unit already exists

error=2 -- name_unit cannot be empty

error=3 -- this code_unit is not exist

begin

error=0;

select count(*) from TitleUnits where code_unit=:code_unit into vrem;

if (vrem=0) then begin error=3; exit; end

if (name_unit='') then begin error=2; exit; end

select count(*) from TitleUnits

where (code_unit<>:code_unit) and (name_unit=:name_unit) and (IsActive=1)

into vrem;

if (vrem=0) then begin

update TitleUnits set name_unit=:name_unit where code_unit=:code_unit;

end

else begin

error=1;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCMINNEWCODEGOOD(

MIN_CODE INTEGER )

RETURNS (

CODE_GOOD INTEGER)

declare variable vrem integer;

declare variable first integer; /*boolean*/

declare variable x integer;

declare variable y integer;

begin

first=1;

y=0;

for select code_good from goods where CodeIsActive=1 and code_good>=:min_code

order by code_good

into :vrem as cursor cur do begin

if (first=1) then begin

y=vrem; x=y;

first=0;

if (y>min_code) then begin code_good=min_code; exit; end

end

else begin

x=vrem;

if (x=y+1) then y=x;

else begin

code_good=y+1;

exit;

end

if (y=0) then code_good=min_code;

else code_good=y+1;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE SUPERKA4

declare variable number_good integer;

declare variable scan_code varchar(255);

declare variable scan_codes varchar(255);

begin

for select number_good from goods

into :number_good as cursor cur1 do begin

scan_codes='';

for select scan_code from ScanCodes where number_good=:number_good

into :scan_code as cursor cur2 do begin

scan_codes=scan_codes||scan_code||' ';

end

update goods set scan_codes=:scan_codes

where number_good=:number_good;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCBRINGGOODTOSTRUCTURESALE(

CODE_SALE INTEGER,

CODE_GOOD INTEGER,

QUANTITY DOUBLE PRECISION,

PRICE DOUBLE PRECISION,

DISCOUNT DOUBLE PRECISION,

SUMMA DOUBLE PRECISION )

RETURNS (

ERROR INTEGER)

declare variable primarykey integer; /*for StructureSale*/

declare variable number_good integer; /*for this good*/

declare variable code_unit integer; /*for this good*/

declare variable IsMaterial integer; /*for this good*/

/*real first_price, price and quantity on StoreHouse*/

declare variable first_price2 double precision;

declare variable price2 double precision;

declare variable quantity2 double precision;

declare variable soldbyprice double precision;

/*other variables*/

declare variable vrem integer;

declare variable x double precision;

error=1 -- this code_sale is not exist

error=2 -- this code_good is not exist

error=3 -- error in table goods (this code_good exist more than ones)

error=4 -- quantity must be more or equal zero

error=5 -- quantity must be whole number (good is whole)

error=6 -- good with this number_good is not exist on StoreHouse

error=7 -- price must not be less than zero

error=8 -- discount must not be more than 100%

error=9 -- price on screen and on StoreHouse must be equal

error=10 -- error summa

error=11 -- this quantity of good is not exist on StoreHouse

begin

error=0;

/*checking code_sale, code_good*/

select count(*) from sales0 where code_sale=:code_sale into vrem;

if (vrem=0) then begin error=1; exit; end

select count(*) from goods where code_good=:code_good and CodeIsActive=1 into vrem;

if (vrem=0) then begin error=2; exit; end

if (vrem>1) then begin error=3; exit; end

/*define number_good, code_unit, IsMaterial*/

select number_good, code_unit from goods

where code_good=:code_good and CodeIsActive=1

into number_good, code_unit;

select IsMaterial from TitleUnits where code_unit=:code_unit into IsMaterial;

/*checking quantity*/

if (quantity<0.0) then begin error=4; exit; end

if (IsMaterial=0) then begin

execute procedure ChisloIsFloat(quantity) returning_values (vrem);

if (vrem=1) then begin error=5; exit; end

end

/*checking that number_good exist on StoreHouse*/

select count(*) from StoreHouse where number_good=:number_good into vrem;

if (vrem=0) then begin error=6; exit; end

/*checking price, discount*/

if (price<0.0) then begin error=7; exit; end

if (discount>100.0) then begin error=8; exit; end

/*more difficult errors*/

select first_price, price, quantity from StoreHouse

where number_good=:number_good

into first_price2, price2, quantity2;

/*checking difference of price on screen and in database*/

if (abs(price2-price)>0.001) then begin error=9; exit; end /*error price*/

/*checking that summa is right calculated*/

x = abs(quantity*price*(100.0-discount)/100.0 - summa);

if (x>0.011) then begin error=10; exit; end

/*checking that this quantity of good exist on StoreHouse*/

if (quantity2+0.0001<quantity) then begin error=11; exit; end

/*write data to database*/

primarykey=gen_id(genStructureSale, 1);

if (quantity<>0.0) then begin

soldbyprice=price*(100.0-discount)/100.0;

insert into StructureSale0(primarykey, code_sale, number_good, quantity,

first_price, price, discount, summa, soldbyprice)

values (:primarykey, :code_sale, :number_good, :quantity,

:first_price2, :price, :discount, :summa, :soldbyprice);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGEGOOD(

NUMBER_GOOD INTEGER,

ART VARCHAR(20),

NAME_GOOD VARCHAR(80),

CODE_UNIT INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable code_ancestor integer;

declare variable fl double precision;

declare variable fl2 double precision;

declare variable vrem2 integer;

declare variable scan_code varchar(20);

error=1 -- this number_good is not exist

error=2 -- art must not be empty

error=3 -- name_good must not be empty

error=4 -- this code_unit is not exist

error=5 -- this name_good already exists

error=6 -- name_good must have length not less than 3

error=7 -- impossible change material good to whole good (StoreHouse)

error=8 -- impossible change material good to whole good (StructureSale)

error=9 -- impossible change material good to whole good (StructureSession)

error=10 -- the good cannot have more than 12 scan_codes

begin

error=0;

/*first five errors*/

select count(*) from goods where number_good=:number_good into vrem;

if (vrem=0) then begin error=1; exit; end

if (art='') then begin error=2; exit; end

if (name_good='') then begin error=3; exit; end

select count(*) from TitleUnits where code_unit=:code_unit into vrem;

if (vrem=0) then begin error=4; exit; end

select code_ancestor from goods where number_good=:number_good into code_ancestor;

select count(*) from goods where code_ancestor=:code_ancestor and

number_good<>:number_good and name_good=:name_good and CodeIsActive=1 into vrem;

if (vrem<>0) then begin error=5; exit; end

/*next errors (after five)*/

if (LengthString(name_good)<3) then begin error=6; exit; end

/*errors with change code_unit*/

select IsMaterial from TitleUnits where code_unit=:code_unit into vrem;

select IsMaterial from goods join TitleUnits

on goods.code_unit=TitleUnits.code_unit

where goods.number_good=:number_good

into vrem2;

if ((vrem2=1) and (vrem=0)) then begin /*change material unit to whole unit*/

/*StoreHouse*/

select count(*) from StoreHouse where number_good=:number_good into vrem;

if (vrem<>0) then begin

for select sold, quantity from StoreHouse where number_good=:number_good

into fl, fl2 as cursor cur do begin

execute procedure ChisloIsFloat(fl) returning_values(vrem);

if (vrem=1) then begin error=7; exit; end

execute procedure ChisloIsFloat(fl2) returning_values(vrem);

if (vrem=1) then begin error=7; exit; end

end

/*StructureSale*/

select count(*) from StructureSale where number_good=:number_good into vrem;

if (vrem<>0) then begin

for select quantity from StructureSale where number_good=:number_good

into fl as cursor cur do begin

execute procedure ChisloIsFloat(fl) returning_values(vrem);

if (vrem=1) then begin error=8; exit; end

end

/*StructureSession*/

select count(*) from StructureSession where number_good=:number_good into vrem;

if (vrem<>0) then begin

for select quantity from StructureSession where number_good=:number_good

into fl as cursor cur do begin

execute procedure ChisloIsFloat(fl) returning_values(vrem);

if (vrem=1) then begin error=9; exit; end

end

/*ChangeGood*/

delete from ScanCodes where number_good=:number_good;

update goods set art=:art, name_good=:name_good, code_unit=:code_unit, scan_codes=''

where number_good=:number_good;

vrem=0;

for select scan_code from ScanCodes2

into :scan_code as cursor cur1 do begin

vrem=vrem+1;

if (vrem=13) then begin error=1/0; when any do begin error=10; exit; end end

insert into ScanCodes

values(:number_good, :scan_code);

update goods

set scan_codes=scan_codes||:scan_code||' '

where number_good=:number_good;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDELETEEMPTYPURCHASE(

CODE_PURCHASE INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable code_session integer;

error=1 -- this code_purchase is not exist

error=2 -- this purchase have sessions, which not empty. delete impossible

begin

error=0;

select count(*) from purchases where code_purchase=:code_purchase into vrem;

if (vrem=0) then begin error=1; exit; end

for select code_session from sessions

where code_purchase=:code_purchase

into :code_session as cursor cur1 do begin

select count(*) from StructureSession where code_session=:code_session into vrem;

if (vrem<>0) then begin error=1/0; when any do begin error=2; exit; end end

delete from sessions where code_session=:code_session;

delete from notes where number_table=5 and KeyFromTable=:code_session;

end

delete from purchases where code_purchase=:code_purchase;

delete from notes where number_table=4 and KeyFromTable=:code_purchase;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDEXISTGOODTOSTRUCTSESSION(

CODE_SESSION INTEGER,

CODE_GOOD INTEGER,

QUANTITY DOUBLE PRECISION,

FIRST_PRICE DOUBLE PRECISION,

ADDITION DOUBLE PRECISION )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable number_good integer;

declare variable code_unit integer;

declare variable StructureSessionHasGood integer;

declare variable IsMaterial integer;

declare variable new_primarykey integer;

declare variable scan_code varchar(20); /*for cursor cur1*/

declare variable summa0 double precision; /*for update summa of session*/

declare variable code_purchase integer;

error=1 -- this code_session is not exist

error=2 -- this code_good is not exist

error=3 -- quantity<0

error=4 -- first_price<0

error=5 -- quantity is float but good is not float

error=6 -- old_first_price<>first_price

error=7 -- old_addition<>addition

error=8 -- good already exist in this session

error=9 -- addition must between -100% an 10000%

error=10 -- number of scan_codes must not be more than 12

error=11 -- impossimble add good to closed session

begin

error=0;

/*checking that code_session is exist*/

select count(*) from sessions where code_session=:code_session into vrem;

if (vrem=0) then begin error=1; exit; end

select accepted from sessions where code_session=:code_session into vrem;

if (vrem=1) then begin error=11; exit; end

/*checking that code_good is exist*/

select count(*) from goods where code_good=:code_good and CodeIsActive=1 into vrem;

if (vrem=0) then begin error=2; exit; end

/*define number_good and code_unit*/

select number_good, code_unit from goods

where code_good=:code_good and CodeIsActive=1

into number_good, code_unit;

/*define StructureSessionHasGood*/

select count(*) from StructureSession

where (code_session=:code_session) and (number_good=:number_good)

into StructureSessionHasGood;

/*checking that quantity>=0 and first_price>=0*/

if (quantity<0.0) then begin error=3; exit; end

if (first_price<0.0) then begin error=4; exit; end

/*checking addition*/

if ((addition<-100.0) or (addition>10000.00)) then begin error=9; exit; end

/*checking floating of good*/

select IsMaterial from TitleUnits where code_unit=:code_unit into IsMaterial;

if (IsMaterial=0) then begin

execute procedure ChisloIsFloat(quantity) returning_values(vrem);

if (vrem=1) then begin error=5; exit; end

end

/*insert or update StructureSession*/

if (StructureSessionHasGood=0) then begin /*good is not exist in StructureSession*/

new_primarykey=gen_id(genStructureSession, 1);

delete from ScanCodesForSession where

code_session=:code_session and number_good=:number_good;

insert into StructureSession

values(:new_primarykey, :code_session, :number_good, :quantity, :first_price, :addition,

'');

select count(*) from ScanCodes where number_good=:number_good into vrem;

for select scan_code from ScanCodesForSession2

into :scan_code as cursor cur1 do begin

vrem=vrem+1;

if (vrem=13) then begin error=1/0; when any do begin error=10; exit; end end

insert into ScanCodesForSession

values(:new_primarykey, :code_session, :number_good, :scan_code);

update StructureSession

set scan_codes=scan_codes||:scan_code||' '

where primarykey=:new_primarykey;

end

summa0=quantity*first_price;

update sessions set summa=summa+:summa0 where code_session=:code_session;

select code_purchase from sessions where code_session=:code_session into code_purchase;

update purchases set summa=summa+:summa0 where code_purchase=:code_purchase;

end

else begin /*good exists in StructureSession*/

error=8; exit;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCFILLINGGOODSFORRETURN(

CODE_SALE INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable x double precision;

/*variables for main cycle (cursor cur1)*/

declare variable number_good integer;

declare variable code_good integer;

declare variable name_good varchar(80);

declare variable quantity double precision;

declare variable remainder double precision;

declare variable IsMaterial integer;

declare variable code_unit integer;

declare variable name_unit varchar(20);

declare variable price double precision;

declare variable discount double precision;

declare variable CodeStructureSale integer;

declare variable day0 integer;

declare variable month0 integer;

declare variable year0 integer;

declare variable hour0 integer;

declare variable minute0 integer;

begin

error=0;

delete from GoodsForReturn;

for select number_good, code_good, name_good, quantity,

IsMaterial, code_unit, name_unit, price, discount, primarykey,

extract(day from date_sale), extract(month from date_sale), extract(year from date_sale),

extract(hour from date_sale), extract(minute from date_sale)

from sales join StructureSale

on sales.code_sale=StructureSale.code_sale join goods

on StructureSale.number_good=goods.number_good join TitleUnits

on goods.code_unit=TitleUnits.code_unit

where sales.code_sale=:code_sale

into number_good, code_good, name_good, quantity,

IsMaterial, code_unit, name_unit, price, discount, CodeStructureSale,

day0, month0, year0, hour0, minute0

as cursor cur1 do begin

price=price*(100.0-discount)/100.0;

select count(*) from returns2 join StructureReturn2

on returns2.code_return=StructureReturn2.code_return

where StructureReturn2.code_StructureSale=:CodeStructureSale

into vrem;

remainder=quantity;

if (vrem<>0) then begin

select sum(quantity) from StructureReturn2

where StructureReturn2.code_StructureSale=:CodeStructureSale

into x;

end

else x=0.0;

remainder=remainder-x;

insert into GoodsForReturn

values(:number_good, :code_good, :name_good, :quantity, :remainder,

:IsMaterial, :code_unit, :name_unit, :price, :CodeStructureSale,

:day0, :month0, :year0, :hour0, :minute0);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCPASTECUTGOODS(

CODE_CUT INTEGER,

CODE_PATH INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable number_good integer;

declare variable name_good varchar(80);

error=1 -- this code_cut is not exist

error=2 -- this code_path is not exist

error=3 -- some goods what we want to paste is not exist

error=4 -- in path, where we want to paste, exist goods with names like pasted goods

begin

error=0;

select count(*) from GoodsForCut where code_cut=:code_cut into vrem;

if (vrem=0) then begin error=1; exit; end

select count(*) from paths where code_path=:code_path into vrem;

if (vrem=0) then begin error=2; exit; end

for select number_good from GoodsForCut

where code_cut=:code_cut

into :number_good as cursor cur1 do begin

/*checking that good with number_good is exist*/

select count(*) from goods where number_good=:number_good and CodeIsActive=1 into vrem;

if (vrem=0) then begin error=1/0; when any do begin error=3; exit; end end

/*define name_good*/

select name_good from goods where number_good=:number_good into name_good;

/*move good with number_good to path with code_path*/

select count(*) from goods

where code_ancestor=:code_path and CodeIsActive=1 and name_good=:name_good

into vrem;

if (vrem<>0) then begin error=1/0; when any do begin error=4; exit; end end

/*move good with number_good*/

update goods set code_ancestor=:code_path where number_good=:number_good;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCENDSALE(

CODE_SALE INTEGER,

SUMMA DOUBLE PRECISION,

CASH DOUBLE PRECISION,

NOTE VARCHAR(80) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable summa2 double precision; /*calculate summa*/

declare variable difference double precision;

declare variable date_sale timestamp;

/*variables of main cycle (cursor cur1)*/

declare variable number_good integer;

declare variable addon double precision;

declare variable quantity double precision;

declare variable new_code_note integer;

/*variables of main cycle (cursor cur2)*/

declare variable primarykey integer;

declare variable first_price double precision;

declare variable price double precision;

declare variable discount double precision;

declare variable summa0 double precision;

declare variable soldbyprice double precision;

error=1 -- this code_sale is not exist

error=2 -- the same goods must not be exist in StructureSale

error=3 -- error summa

error=4 -- cash<summa

begin

error=0;

select count(*) from sales0 where code_sale=:code_sale into vrem;

if (vrem=0) then begin error=1; exit; end

summa2=0.0;

for select number_good, summa, quantity from StructureSale0

where code_sale=:code_sale into :number_good, :addon, :quantity

as cursor cur1 do begin

error=0;

select count(*) from StructureSale0

where code_sale=:code_sale and number_good=:number_good

into vrem;

if (vrem>1) then begin error=1/0; when any do begin error=2; exit; end end

summa2=summa2+addon;

/*change data*/

update StoreHouse

set quantity=quantity-:quantity, sold=sold+:quantity

where number_good=:number_good;

end

difference=abs(summa2-summa);

if (difference>0.001) then begin error=1/0; when any do begin error=3; exit; end end

if (cash+0.001<summa) then begin error=1/0; when any do begin error=4; exit; end end

/*change data*/

select date_sale from sales0 where code_sale=:code_sale into date_sale;

select count(*) from StructureSale0

where code_sale=:code_sale

into vrem;

if ((vrem<>0) or (note<>'')) then begin

insert into sales values(:code_sale, 0, :date_sale, :summa, :cash);

for select primarykey, number_good, quantity, first_price, price, discount, summa,

soldbyprice

from StructureSale0

where code_sale=:code_sale

into primarykey, number_good, quantity, first_price, price, discount, summa0,

soldbyprice

as cursor cur2 do begin

insert into StructureSale

values(:primarykey, :code_sale, :number_good, :quantity,

:first_price, :price, :discount, :summa0, :soldbyprice);

end

if (note<>'') then begin

new_code_note=gen_id(genNotes, 1);

insert into notes (code_note, number_table, KeyFromTable, text) values

(:new_code_note, 8, :code_sale, :note);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGEPURCHASE(

CODE_PURCHASE INTEGER,

CODE_BASE INTEGER,

DAY0 INTEGER,

MONTH0 INTEGER,

YEAR0 INTEGER,

HOUR0 INTEGER,

MINUTE0 INTEGER,

NOTE VARCHAR(80) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable s varchar(80);

declare variable old_note varchar(80);

declare variable new_code_note integer;

declare variable code_session integer;

declare variable date_session timestamp;

declare variable date0 timestamp;

declare variable date1 timestamp;

error=1 -- this code_base is not exist

error=2 -- incorrect day

error=3 -- incorrect month

error=4 -- year must be between 2000 and 2020

error=5 -- incorrect hour

error=6 -- incorrect minute

error=7 -- incorrect date

begin

error=0;

/*checking code_base*/

select count(*) from WholesaleBases where code_base=:code_base into vrem;

if (vrem=0) then begin error=1; exit; end

/*checking date*/

if ((day0<0) or (day0>31)) then begin error=2; exit; end

if ((month0<0) or (month0>12)) then begin error=3; exit; end

if ((year0<2000) or (year0>2020)) then begin error=4; exit; end

if ((hour0<0) or (hour0>23)) then begin error=5; exit; end

if ((minute0<0) or (minute0>59)) then begin error=6; exit; end

if (((month0=4) or (month0=6) or (month0=9) or (month0=11)) and (day0=31)) then begin

error=7; exit;

end

if ((month0=2) and (day0>29)) then begin error=7; exit; end

vrem=year0-4*(year0/4); /*vrem=year0 mod 4*/

if ((vrem<>0) and (month0=2) and (day0=29)) then begin error=7; exit; end

s = day0||'.'||month0||'.'||year0||' '||hour0||':'||minute0;

/*write data to database*/

update purchases set date_purchase=:s, code_base=:code_base

where code_purchase=:code_purchase;

select count(*) from notes

where number_table=4 and KeyFromTable=:code_purchase

into vrem;

if (vrem=0) then begin

if (note<>'') then begin

new_code_note=gen_id(genNotes, 1);

insert into notes values(:new_code_note, 4, :code_purchase, :note);

end

else begin

if (note='') then begin

delete from notes where number_table=4 and KeyFromTable=:code_purchase;

end

else begin

update notes set text=:note

where number_table=4 and KeyFromTable=:code_purchase;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDSCANCODEFORSESSION(

SCAN_CODE VARCHAR(20) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=3 -- scan_code must have 13 symbols

error=4 -- scan_code must have only digits

begin

error=0;

if (LengthString(scan_code)<>13) then begin error=3; exit; end

execute procedure StringHasOnlyDigits(scan_code) returning_values(vrem);

if (vrem=0) then begin error=4; exit; end

insert into ScanCodesForSession2 values (:scan_code);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCSHOWCHANGEDPRICESFORPERIOD(

CODE_SEANCE INTEGER,

DAYS INTEGER,

HOURS INTEGER )

/*days must equal 0 or hours must equal 0*/

/*if days<>0 then hours ignore*/

declare variable date0 timestamp;

declare variable NowDays integer;

declare variable NowSeconds integer;

declare variable ChangeDays integer;

declare variable ChangeSeconds integer;

/*variables for main cycle (cursor cur1)*/

declare variable number_good integer;

declare variable date_change timestamp;

begin

date0=current_timestamp;

NowDays=DateDays(date0);

NowSeconds=DateSeconds(date0);

delete from ChangedPricesForPeriod where code_seance=:code_seance;

if ((days=0) and (hours=0)) then exit;

for select number_good, date_change from ChangedPrices

into :number_good, :date_change as cursor cur1 do begin

ChangeDays=DateDays(date_change);

ChangeSeconds=DateSeconds(date_change);

if (days<>0) then begin

if (NowDays-days+1<=ChangeDays) then begin

insert into ChangedPricesForPeriod values(:number_good, :code_seance);

end

else begin

if (24*3600*(NowDays-ChangeDays)+(NowSeconds-ChangeSeconds)<=3600*hours) then begin

insert into ChangedPricesForPeriod values(:number_good, :code_seance);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDPURCHASE(

DAY0 INTEGER,

MONTH0 INTEGER,

YEAR0 INTEGER,

HOUR0 INTEGER,

MINUTE0 INTEGER,

CODE_BASE INTEGER,

NOTE VARCHAR(80) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable s varchar(100);

declare variable new_code_purchase integer;

declare variable new_code_note integer;

error=1 -- this code_base is not exist

error=2 -- incorrect day

error=3 -- incorrect month

error=4 -- year must be between 2000 and 2020

error=5 -- incorrect hour

error=6 -- incorrect minute

error=7 -- incorrect date

begin

error=0;

select count(*) from WholesaleBases where code_base=:code_base into vrem;

if (vrem=0) then begin error=1; exit; end

/*checking date*/

if ((day0<0) or (day0>31)) then begin error=2; exit; end

if ((month0<0) or (month0>12)) then begin error=3; exit; end

if ((year0<2000) or (year0>2020)) then begin error=4; exit; end

if ((hour0<0) or (hour0>23)) then begin error=5; exit; end

if ((minute0<0) or (minute0>59)) then begin error=6; exit; end

if (((month0=4) or (month0=6) or (month0=9) or (month0=11)) and (day0=31)) then begin

error=7;

exit;

end

if ((month0=2) and (day0>29)) then begin error=7; exit; end

vrem=year0-4*(year0/4); /*vrem=year0 mod 4*/

if ((vrem<>0) and (month0=2) and (day0=29)) then begin error=7; exit; end

/*write data to database*/

s = day0||'.'||month0||'.'||year0||' '||hour0||':'||minute0;

new_code_purchase = gen_id(genPurchases, 1);

insert into purchases values (:new_code_purchase, :code_base, :s, 0.0);

if (note<>'') then begin

new_code_note=gen_id(genNotes, 1);

insert into notes values (:new_code_note, 4, :new_code_purchase, :note);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDELGOODFROMSTRUCTSESSION(

CODE_SESSION INTEGER,

NUMBER_GOOD INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable quantity double precision;

declare variable first_price double precision;

declare variable summa0 double precision;

declare variable code_purchase integer;

error=1 -- this code_session is not exist

error=2 -- this session is closed; deleting impossible

begin

error=0;

select count(*) from sessions where code_session=:code_session into vrem;

if (vrem=0) then begin error=1; exit; end

select accepted from sessions where code_session=:code_session into vrem;

if (vrem=1) then begin error=2; exit; end

select quantity, first_price from StructureSession

where code_session=:code_session and number_good=:number_good

into :quantity, :first_price;

delete from StructureSession

where code_session=:code_session and number_good=:number_good;

delete from ScanCodesForSession

where code_session=:code_session and number_good=:number_good;

summa0=quantity*first_price;

update sessions set summa=summa-:summa0 where code_session=:code_session;

select code_purchase from sessions where code_session=:code_session into code_purchase;

update purchases set summa=summa-:summa0 where code_purchase=:code_purchase;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDELEMPTYPATH(

CODE_PATH INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this code_path is not exist

error=2 -- this path includes other paths

error=3 -- this path includes some goods

begin

error=0;

select count(*) from paths where code_path=:code_path into vrem;

if (vrem=0) then begin error=1; exit; end

select count(*) from paths where code_ancestor=:code_path into vrem;

if (vrem<>0) then begin error=2; exit; end

select count(*) from goods

where code_ancestor=:code_path and CodeIsActive=1

into vrem;

if (vrem<>0) then begin error=3; exit; end

delete from paths where code_path=:code_path;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDNEWGOODTOSTRUCTSESSION(

CODE_SESSION INTEGER,

CODE_GOOD INTEGER,

ART VARCHAR(20),

CODE_ANCESTOR INTEGER,

NAME_GOOD VARCHAR(80),

CODE_UNIT INTEGER,

QUANTITY DOUBLE PRECISION,

FIRST_PRICE DOUBLE PRECISION,

ADDITION DOUBLE PRECISION )

RETURNS (

ERROR INTEGER,

NEW_NUMBER_GOOD INTEGER)

declare variable vrem integer;

declare variable IsMaterial integer;

declare variable new_primarykey integer;

declare variable scan_code varchar(20); /*for cursor cur1*/

declare variable summa0 double precision;

declare variable code_purchase integer;

error=1 -- this code_session is not exist

error=2 -- this code_good already exist

error=3 -- code_good<10000

error=4 -- art must not be empty

error=5 -- name_good must not be empty

error=6 -- this code_ancestor is not exist

error=7 -- this code_unit is not exist

error=8 -- quantity<0

error=9 -- first_price<0

error=10 -- the good is not float but quantity is float

error=11 -- the good with this name_good already exist

error=12 -- addition must between -100% and 10000%

error=13 -- number of scan_codes must not be more than 12

error=14 -- impossimble add good to closed session

error=15 -- length(name_good) must not be less than 3

begin

error=0;

/*checking code_session*/

select count(*) from sessions where code_session=:code_session into vrem;

if (vrem=0) then begin error=1; exit; end

select accepted from sessions where code_session=:code_session into vrem;

if (vrem=1) then begin error=14; exit; end

/*checking code_good*/

select count(*) from goods where code_good=:code_good and CodeIsActive=1 into vrem;

if (vrem<>0) then begin error=2; exit; end

if (code_good<10000) then begin error=3; exit; end

/*checking art and name_good*/

if (art='') then begin error=4; exit; end

if (name_good='') then begin error=5; exit; end

if (LengthString(name_good)<3) then begin error=15; exit; end

/*checking code_ancestor*/

select count(*) from paths where code_path=:code_ancestor into vrem;

if (vrem=0) then begin error=6; exit; end

/*checking code_unit*/

select count(*) from TitleUnits where code_unit=:code_unit into vrem;

if (vrem=0) then begin error=7; exit; end

/*checking quantity and first_price*/

if (quantity<0.0) then begin error=8; exit; end

if (first_price<0.0) then begin error=9; exit; end

/*checking floating of good and quantity*/

select IsMaterial from TitleUnits where code_unit=:code_unit into IsMaterial;

if (IsMaterial=0) then begin

execute procedure ChisloIsFloat(quantity) returning_values(vrem);

if (vrem=1) then begin error=10; exit; end

end

/*checking that not the same name_good*/

select count(*) from goods

where name_good=:name_good and code_ancestor=:code_ancestor and CodeIsActive=1

into vrem;

if (vrem<>0) then begin error=11; exit; end

/*checking addition*/

if ((addition<-100.0) or (addition>10000.00)) then begin error=12; exit; end

/*record data to database*/

new_number_good=gen_id(genGoods, 1);

insert into goods

values(:new_number_good, :code_good, 1, :art, :code_ancestor, :name_good, :code_unit,'');

new_primarykey=gen_id(genStructureSession, 1);

insert into StructureSession

values(:new_primarykey, :code_session, :new_number_good, :quantity, :first_price, :addition,'');

vrem=0;

for select scan_code from ScanCodesForSession2

into :scan_code as cursor cur1 do begin

vrem=vrem+1;

if (vrem=13) then begin error=1/0; when any do begin error=13; exit; end end

insert into ScanCodesForSession

values(:new_primarykey, :code_session, :new_number_good, :scan_code);

update StructureSession

set scan_codes=scan_codes||:scan_code||' '

where primarykey=:new_primarykey;

end

summa0=quantity*first_price;

update sessions set summa=summa+:summa0 where code_session=:code_session;

select code_purchase from sessions where code_session=:code_session into code_purchase;

update purchases set summa=summa+:summa0 where code_purchase=:code_purchase;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCNEWCODESEANCE

RETURNS (

CODE_SEANCE INTEGER)

begin

code_seance=gen_id(genSearchCodeSaleNumberGood, 1);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGESESSIONGOOD(

CODE_SESSION INTEGER,

NUMBER_GOOD INTEGER,

QUANTITY DOUBLE PRECISION,

ADDITION DOUBLE PRECISION,

FIRST_PRICE DOUBLE PRECISION )

RETURNS (

ERROR INTEGER)

declare variable primarykey integer;

declare variable vrem integer;

declare variable IsMaterial integer;

declare variable scan_code varchar(20);

declare variable delta_summa double precision;

declare variable old_first_price double precision;

declare variable old_quantity double precision;

declare variable code_purchase integer;

error=1 -- this code_session is not exist

error=2 -- this number_good is not exist

error=3 -- quantity must not be less than zero

error=4 -- addition must be between -100 and 10000

error=5 -- first_price must not be less than zero

error=6 -- if good is whole then quantity must be whole number

error=7 -- the good cannot have more than 12 scan-codes

error=8 -- session is accepted!

begin

error=0;

select count(*) from sessions where code_session=:code_session into vrem;

if (vrem=0) then begin error=1; exit; end

select accepted from sessions where code_session=:code_session into vrem;

if (vrem=1) then begin error=8; exit; end

select count(*) from goods where number_good=:number_good into vrem;

if (vrem=0) then begin error=2; exit; end

if (quantity<0.0) then begin error=3; exit; end

if ((addition<-100.0) or (addition>10000.0)) then begin error=4; exit; end

if (first_price<0.0) then begin error=5; exit; end

/*checking that if good is whole then quantity is whole*/

select IsMaterial from goods join TitleUnits

on goods.code_unit=TitleUnits.code_unit

where goods.number_good=:number_good

into IsMaterial;

if (IsMaterial=0) then begin

execute procedure ChisloIsFloat(quantity) returning_values(vrem);

if (vrem=1) then begin error=6; exit; end

end

delete from ScanCodesForSession

where code_session=:code_session and number_good=:number_good;

update StructureSession set scan_codes=''

where code_session=:code_session and number_good=:number_good;

select count(*) from ScanCodes where number_good=:number_good into vrem;

select primarykey from StructureSession

where code_session=:code_session and number_good=:number_good

into :primarykey;

for select scan_code from ScanCodesForSession2

into :scan_code as cursor cur1 do begin

vrem=vrem+1;

if (vrem=13) then begin error=1/0; when any do begin error=7; exit; end end

insert into ScanCodesForSession

values(:primarykey, :code_session, :number_good, :scan_code);

update StructureSession

set scan_codes=scan_codes||:scan_code||' '

where code_session=:code_session and number_good=:number_good;

end

/*write data to database*/

select first_price, quantity from StructureSession

where code_session=:code_session and number_good=:number_good

into :old_first_price, :old_quantity;

update StructureSession

set quantity=:quantity, addition=:addition, first_price=:first_price

where code_session=:code_session and number_good=:number_good;

delta_summa=quantity*first_price-old_quantity*old_first_price;

update sessions set summa=summa+:delta_summa where code_session=:code_session;

select code_purchase from sessions where code_session=:code_session into :code_purchase;

update purchases set summa=summa+:delta_summa where code_purchase=:code_purchase;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCBRINGGOODTOSTRUCTURERETURN(

CODE_RETURN INTEGER,

CODE_STRUCTURESALE INTEGER,

NUMBER_GOOD INTEGER,

PRICE DOUBLE PRECISION,

QUANTITY DOUBLE PRECISION,

SUMMA DOUBLE PRECISION )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable code_sale integer;

declare variable IsMaterial integer;

declare variable returned_quantity double precision;

declare variable diff double precision;

declare variable primarykey integer; /*for write data to database*/

declare variable quantity2 double precision;

declare variable price2 double precision; /*real price of sale*/

declare variable discount2 double precision;

error=1 -- this code_return is not exist

error=2 -- this code_StructureSale incorrect

error=3 -- this number_good incorrect

error=4 -- the good is whole therefore quantity must be whole number

error=5 -- the quantity of whole good is too many

error=6 -- the real good already returned

error=7 -- summa incorrect calculated in program

error=8 -- the quantity of real good is too many

error=9 -- incorrect price (it must be equal sale_price

error=10 -- code_StructureSale is incorrect

begin

error=0;

/*checking code_return, code_StructureSale, number_good*/

select count(*) from returns20 where code_return=:code_return into vrem;

if (vrem=0) then begin error=1; exit; end

select code_sale from returns20 where code_return=:code_return into code_sale;

select primarykey from StructureSale

where code_sale=:code_sale and number_good=:number_good

into vrem;

if (vrem<>code_StructureSale) then begin error=10; exit; end

select count(*) from StructureSale

where code_sale=:code_sale and primarykey=:code_StructureSale

into vrem;

if (vrem=0) then begin error=2; exit; end

select count(*) from goods where number_good=:number_good into vrem;

if (vrem=0) then begin error=3; exit; end

/*checking that quantity is whole*/

select IsMaterial from goods join TitleUnits

on goods.code_unit=TitleUnits.code_unit

where number_good=:number_good

into IsMaterial;

if (IsMaterial=0) then begin

execute procedure ChisloIsFloat(quantity) returning_values (vrem);

if (vrem=1) then begin error=4; exit; end

end

/*checking that qunatity is not more than allow return*/

select quantity from StructureSale

where primarykey=:code_StructureSale

into :quantity2;

select sum(quantity), count(*) from returns2 join StructureReturn2

on returns2.code_return=StructureReturn2.code_return

where code_StructureSale=:code_StructureSale

into returned_quantity, vrem;

if (vrem=0) then returned_quantity=0.0;

if (IsMaterial=0) then begin /*quantity is whole number*/

if (quantity>quantity2-returned_quantity+0.0001) then begin

error=5; exit;

end

else begin

if (quantity>quantity2-returned_quantity+0.0001) then begin

error=8; exit;

end

/*checking price*/

select price, discount from StructureSale

where StructureSale.primarykey=:code_StructureSale

into price2, discount2;

if (abs(price-price2*(100.0-discount2)/100.0)>=0.001) then begin error=9; exit; end

/*checking summa*/

if (abs(summa-price*quantity)>0.011) then begin error=11; exit; end

/*write data to database*/

primarykey=gen_id(genStructureReturn, 1);

if (quantity<>0.0) then begin

insert into StructureReturn20

values (:primarykey, :code_return, :code_StructureSale, :number_good,

:price, :quantity, :summa);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGEPRICEONSTOREHOUSE(

NUMBER_GOOD INTEGER,

NEW_PRICE DOUBLE PRECISION )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- this number_good is not exist

error=2 -- price must not be less than zero

begin

error=0;

select count(*) from StoreHouse where number_good=:number_good into vrem;

if (vrem=0) then begin error=1; exit; end

if (new_price<0.0) then begin error=2; exit; end

update StoreHouse set price=:new_price where number_good=:number_good;

delete from ChangedPrices where number_good=:number_good;

insert into ChangedPrices values(:number_good, :new_price, current_timestamp);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCLEARHARDTABLES

begin

delete from ResumeOfDay;

delete from ChangedPricesForPeriod;

delete from SearchCodeSales;

delete from SearchNumberGoods;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCSEARCHSTOREHOUSEGOODS(

CODE_SEANCE INTEGER,

NAME_GOOD VARCHAR(80),

ART VARCHAR(20),

SCAN_CODE VARCHAR(20),

EXACTLY INTEGER )

declare variable number_good integer;

declare variable exactly0 integer;

declare variable scan_code0 varchar(20);

declare variable vrem integer;

begin

name_good='%'||ToUpperCase(name_good)||'%';

art='%'||art||'%';

delete from SearchNumberGoods where code_seance=:code_seance;

if (scan_code='') then begin

for select goods.number_good from StoreHouse join goods on

StoreHouse.number_good=goods.number_good

where

ToUpperCase(name_good) like :name_good and

art like :art

into number_good as cursor cur1 do begin

insert into SearchNumberGoods

values(:code_seance, :number_good, 0);

end

else if (LengthString(scan_code)<>13) then begin

scan_code='%'||scan_code||'%';

for select goods.number_good from StoreHouse join goods on

StoreHouse.number_good=goods.number_good join ScanCodes

on goods.number_good=ScanCodes.number_good

where

ToUpperCase(name_good) like :name_good and

art like :art and

scan_code like :scan_code

into number_good as cursor cur1 do begin

select count(*) from SearchNumberGoods

where code_seance=:code_seance and number_good=:number_good

into vrem;

if (vrem=0) then begin

insert into SearchNumberGoods

values(:code_seance, :number_good, 0);

end

else begin

for select goods.number_good, ScanCodes.scan_code

from StoreHouse join goods on

StoreHouse.number_good=goods.number_good join ScanCodes

on goods.number_good=ScanCodes.number_good

where

ToUpperCase(name_good) like :name_good and

art like :art

into number_good, scan_code0 as cursor cur1 do begin

/*exactly0=SameScanCodes(scan_code, scan_code0, :exactly)=1;*/

exactly0=SameScanCodes(scan_code, scan_code0);

if (exactly0<=exactly) then begin

select count(*) from SearchNumberGoods

where code_seance=:code_seance and number_good=:number_good

into vrem;

if (vrem=0) then begin

insert into SearchNumberGoods

values(:code_seance, :number_good, :exactly0);

end

else begin

select exactly from SearchNumberGoods

where code_seance=:code_seance and number_good=:number_good

into vrem;

if (exactly0<vrem) then begin

update SearchNumberGoods set exactly=:exactly0

where code_seance=:code_seance and number_good=:number_good;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCADDUSER(

NAME_USER VARCHAR(80),

PSSWD VARCHAR(80),

RIGHTS INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable code_user integer;

error=1 -- this name_user already exists

error=2 -- name_user must not be empty

begin

error=0;

select count(*) from ProgramUsers where name_user=:name_user into vrem;

if (vrem<>0) then begin error=1; exit; end

if (name_user='') then begin error=2; exit; end

code_user=gen_id(genProgramUsers, 1);

insert into ProgramUsers values(:code_user, :name_user, :psswd, :rights);

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCDELUSER(

CODE_USER INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- impossible drop Administrator

error=2 -- deleting user not exist

begin

error=0;

if (code_user=0) then begin error=1; exit; end

select count(*) from ProgramUsers where code_user=:code_user into vrem;

if (vrem=0) then begin error=2; exit; end

delete from ProgramUsers where code_user=:code_user;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGESCANCODESINSESSION(

CODE_SESSION INTEGER,

NUMBER_GOOD INTEGER )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

declare variable primarykey integer;

declare variable scan_code varchar(20);

declare variable scan_codes varchar(255);

error=1 -- this code_session is not exist in sessions

error=2 -- this number_good is not exist in goods

error=3 -- this (code_session, number_good) are not exist in StructureSession

error=4 -- the good cannot has more than 12 scan_codes

begin

error=0;

select count(*) from sessions where code_session=:code_session into vrem;

if (vrem=0) then begin error=1; exit; end

select count(*) from goods where number_good=:number_good into vrem;

if (vrem=0) then begin error=2; exit; end

select count(*) from StructureSession

where code_session=:code_session and number_good=:number_good

into vrem;

if (vrem=0) then begin error=3; exit; end

select primarykey from StructureSession

where code_session=:code_session and number_good=:number_good

into :primarykey;

delete from ScanCodesForSession

where code_session=:code_session and number_good=:number_good;

scan_codes='';

vrem=0;

for select scan_code from ScanCodes2 into :scan_code as cursor cur1 do begin

if (vrem=12) then begin error=1/0; when any do begin error=4; exit; end end

insert into ScanCodesForSession

values(:primarykey, :code_session, :number_good, :scan_code);

vrem=vrem+1;

scan_codes=scan_codes||scan_code||' ';

end

update StructureSession set scan_codes=:scan_codes

where code_session=:code_session and number_good=:number_good;

/*bring new scan_codes into table GOODS*/

for select scan_code from ScanCodesForSession

where code_session=:code_session and number_good=:number_good

into :scan_code as cursor cur2 do begin

select count(*) from ScanCodes

where number_good=:number_good and scan_code=:scan_code

into vrem;

if (vrem=0) then begin

select count(*) from ScanCodes where number_good=:number_good into vrem;

if (vrem=12) then begin error=1/0; when any do begin error=2; exit; end end

insert into ScanCodes values(:number_good, :scan_code);

end

scan_codes='';

for select scan_code from ScanCodes where number_good=:number_good

into :scan_code as cursor cur3 do begin

scan_codes=scan_codes||scan_code||' ';

end

update goods set scan_codes=:scan_codes where number_good=:number_good;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCLOSESESSION(

CODE_SESSION INTEGER,

CLOSESESSION INTEGER )

RETURNS (

ERROR INTEGER,

CHISLO INTEGER)

CloseSession=0 -- show changed prices only after close session

CloseSession=1 -- we want to close session

declare variable vrem integer;

/*variables of main cycle (cursor cur1)*/

declare variable number_good integer;

declare variable quantity double precision;

declare variable first_price double precision;

declare variable addition double precision;

/*variables of inside cycle (cursor cur2)*/

declare variable scan_code varchar(20);

/*variables for do new_price*/

declare variable q1 double precision;

declare variable p01 double precision;

declare variable p1 double precision;

declare variable q2 double precision;

declare variable p02 double precision;

declare variable a2 double precision;

declare variable p2 double precision;

declare variable q3 double precision;

declare variable p03 double precision;

declare variable p3 double precision;

/*other variables*/

declare variable code_good integer;

declare variable date1 timestamp;

declare variable GoodExistOnStoreHouse integer;

declare variable PriceChanged integer;

declare variable date_change timestamp;

error=1 -- this code_session is not exist

error=2 -- for this code_good(chislo) too many scan_codes

error=3 -- quantity of bringing good must be more than zero (code_good in chislo)

begin

error=0; chislo=0; /*returning values*/

date_change=current_timestamp;

select count(*) from sessions where code_session=:code_session into vrem;

if (vrem=0) then begin error=1; exit; end

select accepted from sessions where code_session=:code_session into vrem;

if (vrem=1) then exit;

/*CloseSession=0 or CloseSession=1*/

delete from SessionsClosed where code_session=:code_session;

/*main cycle*/

for select number_good, quantity, first_price, addition

from StructureSession where code_session=:code_session

into number_good, quantity, first_price, addition

as cursor cur1 do begin

/*define code_good, NumScanCodes1, NumScanCodes2*/

select code_good from goods where number_good=:number_good into code_good;

/*bringing scan_codes*/

for select scan_code from ScanCodesForSession

where code_session=:code_session and number_good=:number_good

into scan_code as cursor cur2 do begin

if (CloseSession=1) then begin

select count(*) from ScanCodes

where number_good=:number_good and scan_code=:scan_code

into vrem;

if (vrem=0) then begin

select count(*) from ScanCodes where number_good=:number_good into vrem;

if (vrem=12) then begin

error=1/0; when any do begin error=2; exit; end

end

insert into ScanCodes values (:number_good, :scan_code);

update goods set scan_codes=scan_codes||:scan_code||' '

where number_good=:number_good;

end

/*move goods from session to StoreHouse*/

/*define q1, p01, p1, q2, p02, p2*/

select count(*) from StoreHouse

where number_good=:number_good

into GoodExistOnStoreHouse;

if (GoodExistOnStoreHouse<>0) then begin

select quantity, first_price, price from StoreHouse

where number_good=:number_good

into q1, p01, p1;

end

else begin q1=0.0; p01=0.0; p1=0.0; end

q2=quantity; p02=first_price; a2=addition;

p2=p02*(1.0+a2/100.0);

execute procedure procDoWholePrice(p2) returning_values (p2);

/*define q3, p03*/

if (q2<0.0) then begin

error=1/0; when any do begin error=3; chislo=code_good; exit; end

end

if (q1<0.0) then begin

update StoreHouse set quantity=0.0 where quantity<0.0;

q1=0.0;

end

q3=q1+q2;

if (q3<>0.0) then p03=(q1*p01+q2*p02)/q3;

else p03=0.0;

/*define p3, PriceChanged*/

if (GoodExistOnStoreHouse=0) then p3=p2;

else begin

if (p1>=p2) then p3=p1; else p3=p2;

if (p1>=1.00) then begin

if ((p3/p1)<=1.01) then begin p3=p1; PriceChanged=0; end

else PriceChanged=1;

end

else PriceChanged=1;

end

/*bringing goods to StoreHouse*/

if (GoodExistOnStoreHouse<>0) then begin

if (PriceChanged=1) then begin

insert into SessionsClosed values (:code_session, :number_good, :p1, :p3);

end

if (CloseSession=1) then begin

update StoreHouse set quantity=:q3, first_price=:p03, price=:p3

where number_good=:number_good;

end

if ((CloseSession=1) and (PriceChanged=1)) then begin

delete from ChangedPrices where number_good=:number_good;

insert into ChangedPrices values(:number_good, :p3, :date_change);

end

else begin

insert into SessionsClosed values (:code_session, :number_good, 0.0, :p3);

if (CloseSession=1) then begin

insert into StoreHouse (number_good, quantity, first_price, price, sold)

values (:number_good, :q3, :p03, :p3, 0.0);

delete from ChangedPrices where number_good=:number_good;

insert into ChangedPrices values(:number_good, :p3, :date_change);

end

/*close session and set date of closing*/

if (CloseSession=1) then begin

date1 = current_timestamp;

update sessions set accepted=1, date1=:date1 where code_session=:code_session;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCFORMRESUMEOFDAY(

CODE_SEANCE INTEGER,

DAY_BEGIN INTEGER,

DAY_END INTEGER )

declare variable date0 timestamp;

declare variable number_good integer;

declare variable first_price double precision;

declare variable price double precision;

declare variable soldbyprice double precision;

declare variable quantity double precision;

declare variable summa double precision;

declare variable x integer;

begin

delete from ResumeOfDay where code_seance=:code_seance;

for select number_good, quantity, first_price, price,

StructureSale.summa, date_sale

from sales join StructureSale

on sales.code_sale=StructureSale.code_sale join goods

on StructureSale.number_good=goods.number_good

into :number_good, :quantity, :first_price, :price, :summa, :date0

as cursor cur1 do begin

if (quantity<>0.0) then soldbyprice=summa/quantity;

else soldbyprice=0.0;

if (((DateDays(date0)>=day_begin) and (DateDays(date0)<=day_end)) and (summa<>0.0))

then begin

x=(DateSeconds(:date0)+1800)/3600;

insert into ResumeOfDay

values(:number_good, :first_price, :price, :soldbyprice, :quantity, :date0,

:code_seance, :x);

end

for select

goods.number_good as number_good,

StructureReturn2.quantity as quantity,

StructureSale.first_price as first_price,

StructureSale.price as price,

StructureSale.soldbyprice as soldbyprice,

returns2.date_return as date0

from returns2 join StructureReturn2

on returns2.code_return=StructureReturn2.code_return join StructureSale

on StructureReturn2.code_StructureSale=StructureSale.primarykey join goods

on StructureSale.number_good=goods.number_good

into :number_good, :quantity, :first_price, :price, :soldbyprice, :date0

as cursor cur2 do begin

if (((DateDays(date0)>=day_begin) and (DateDays(date0)<=day_end)) and (summa<>0.0))

then begin

x=(DateSeconds(:date0)+1800)/3600;

quantity=-quantity;

insert into ResumeOfDay

values(:number_good, :first_price, :price, :soldbyprice, :quantity, :date0,

:code_seance, :x);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE SUPERKA5(

CODE_GOOD INTEGER,

NEW_PRICE DOUBLE PRECISION )

declare variable number_good integer;

begin

select number_good from goods where code_good=:code_good into number_good;

update StoreHouse set first_price=:new_price, price=:new_price

where number_good=:number_good;

update StructureSession set first_price=:new_price, addition=0.0

where code_session=1 and number_good=:number_good;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCFORMGRAFIKWEEK(

CODE_SEANCE INTEGER,

DAY_BEGIN INTEGER,

DAY_END INTEGER )

declare variable day_of_week integer;

declare variable summa double precision;

declare variable pribil double precision;

begin

execute procedure procFormResumeOfDay(:code_seance, :day_begin, :day_end);

delete from GrafikWeek where code_seance=:code_seance;

day_of_week=1;

while (day_of_week<=7) do begin

insert into GrafikWeek values(:code_seance, :day_of_week, 0.0, 0.0);

day_of_week=day_of_week+1;

end

for select

DateDays(date_sale),

sum(quantity*soldbyprice),

sum(quantity*(soldbyprice-first_price))

from ResumeOfDay

where code_seance=:code_seance

group by DateDays(date_sale)

into :day_of_week, summa, pribil as cursor cur1 do begin

day_of_week=(day_of_week-2)-7*((day_of_week-2)/7)+1;

update GrafikWeek

set summa=summa+:summa, pribil=pribil+:pribil

where code_seance=:code_seance and day_of_week=:day_of_week;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCFORMGRAFIKHOURBUYERS(

CODE_SEANCE INTEGER,

DAY_BEGIN INTEGER,

DAY_END INTEGER )

declare variable i integer;

declare variable x integer;

begin

execute procedure procFormResumeOfDay

(code_seance, day_begin, day_end);

delete from GrafikHourBuyers where code_seance=:code_seance;

i=0;

while (i<>25) do begin

insert into GrafikHourBuyers

values(:code_seance, :i, 0);

i=i+1;

end

for select DateSeconds(date_sale) from sales

where DateDays(date_sale)>=:day_begin and

DateDays(date_sale)<=:day_end

into :x as cursor cur1 do begin

x=(x+1800)/3600;

update GrafikHourBuyers

set num_buyers=num_buyers+1

where code_seance=:code_seance and hour0=:x;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCGRAFIKPERCENTBUYERSPRIBIL(

CODE_SEANCE INTEGER,

DAY_BEGIN INTEGER,

DAY_END INTEGER )

RETURNS (

NUM INTEGER,

SUMMA DOUBLE PRECISION)

declare variable pribil double precision;

begin

delete from GrafikPercentBuyersPribil

where code_seance=:code_seance;

num=0; summa=0.0;

for select

sum(quantity*(soldbyprice-first_price))

from sales join StructureSale

on sales.code_sale=StructureSale.code_sale

where soldbyprice>=first_price and

DateDays(date_sale)>=:day_begin and DateDays(date_sale)<=:day_end

group by sales.code_sale

order by -sum(quantity*(soldbyprice-first_price))

into :pribil as cursor cur1 do begin

num=num+1; summa=summa+pribil;

insert into GrafikPercentBuyersPribil

values(:code_seance, :num, :summa);

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCHANGEUSERPASSWORD(

CODE_USER INTEGER,

PSSWD VARCHAR(80) )

RETURNS (

ERROR INTEGER)

declare variable vrem integer;

error=1 -- changed user not exist

begin

error=0;

select count(*) from ProgramUsers where code_user=:code_user into vrem;

if (vrem=0) then begin error=1; exit; end

update ProgramUsers set psswd=:psswd where code_user=:code_user;

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCCLOSESESSION3(

CODE_SESSION INTEGER )

RETURNS (

ERROR INTEGER)

declare variable number_good integer;

declare variable vrem integer;

declare variable scan_code varchar(20);

declare variable scan_codes varchar(255);

error=1 -- this code_session is not exist

error=2 -- the good cannot has more than 12 scan_codes

begin

error=0;

select count(*) from sessions where code_session=:code_session into vrem;

if (vrem=0) then begin error=1; exit; end

for select number_good from StructureSession where code_session=:code_session

into :number_good as cursor cur1 do begin

for select scan_code from ScanCodesForSession

where code_session=:code_session and number_good=:number_good

into :scan_code as cursor cur2 do begin

select count(*) from ScanCodes

where number_good=:number_good and scan_code=:scan_code

into vrem;

if (vrem=0) then begin

select count(*) from ScanCodes where number_good=:number_good into vrem;

if (vrem=12) then begin error=1/0; when any do begin error=2; exit; end end

insert into ScanCodes values(:number_good, :scan_code);

end

scan_codes='';

for select scan_code from ScanCodes where number_good=:number_good

into :scan_code as cursor cur3 do begin

scan_codes=scan_codes||scan_code||' ';

end

update goods set scan_codes=:scan_codes where number_good=:number_good;

end

end^

SET TERM ;^

SET TERM ^ ;

CREATE PROCEDURE PROCSTARTSEARCH(

CODE_SEANCE INTEGER,

DAY0 INTEGER,

DAY1 INTEGER,

SECOND0 INTEGER,

SECOND1 INTEGER,

PRICE0 DOUBLE PRECISION,

PRICE1 DOUBLE PRECISION,

PRICE2 DOUBLE PRECISION,

SCAN_CODE VARCHAR(20),

ART VARCHAR(20),

NAME_GOOD VARCHAR(80) )

declare variable vrem integer;

declare variable code_sale integer;

declare variable number_good2 integer;

declare variable soldbyprice double precision;

declare variable art2 varchar(20);

declare variable price3 double precision;

declare variable price4 double precision;

declare variable million integer;

declare variable CodeSeancePlusMillion integer;

begin

million=1000000;

CodeSeancePlusMillion=code_seance+million;

delete from SearchCodeSales where code_seance=:code_seance;

delete from SearchNumberGoods where code_seance=:code_seance;

if (price0<-0.5) then price0=0.0;

price0=price0-0.001;

price2=price2+0.001;

if (price1>-0.5) then begin

price3=price1-0.001;

price4=price1+0.001;

end

for select

sales.code_sale as code_sale,

StructureSale.soldbyprice as soldbyprice

from sales join StructureSale

on sales.code_sale=StructureSale.code_sale

where (DateDays(date_sale)>=:day0) and (DateDays(date_sale)<=:day1) and

(DateSeconds(date_sale)>=:second0) and (DateSeconds(date_sale)<=:second1)

into :code_sale, :soldbyprice

as cursor cur1 do begin

if (price1>-0.5) then begin /*limited by price*/

if (price2>-0.5) then begin /*limited by maximum*/

if ((soldbyprice>=price3) and (soldbyprice<=price4) and

(soldbyprice>=price0) and (soldbyprice<=price2))

then begin

select count(*) from SearchCodeSales

where code_seance=:code_seance and code_sale=:code_sale

into vrem;

if (vrem=0) then begin

insert into SearchCodeSales values(:CodeSeancePlusMillion, :code_sale);

end

else begin

if ((soldbyprice>=price3) and (soldbyprice<=price4) and

(soldbyprice>=price0))

then begin

select count(*) from SearchCodeSales

where code_seance=:code_seance and code_sale=:code_sale

into vrem;

if (vrem=0) then begin

insert into SearchCodeSales values(:CodeSeancePlusMillion, :code_sale);

end

else begin

if (price2>-0.5) then begin

if ((soldbyprice<=price2) and (soldbyprice>=price0)) then begin

select count(*) from SearchCodeSales

where code_seance=:code_seance and code_sale=:code_sale

into vrem;

if (vrem=0) then begin

insert into SearchCodeSales values(:CodeSeancePlusMillion, :code_sale);

end

else if (soldbyprice>=price0) then begin

select count(*) from SearchCodeSales

where code_seance=:code_seance and code_sale=:code_sale

into vrem;

if (vrem=0) then begin

insert into SearchCodeSales values(:CodeSeancePlusMillion, :code_sale);

end

name_good=ToUpperCase(name_good);

name_good='%'||name_good||'%';

art=ToUpperCase(art);

art='%'||art||'%';

if (scan_code='') then begin

for select distinct(goods.number_good) from StructureSale join SearchCodeSales

on StructureSale.code_sale=SearchCodeSales.code_sale join goods

on StructureSale.number_good=goods.number_good

where ToUpperCase(goods.name_good) like :name_good and

ToUpperCase(goods.art) like :art and

SearchCodeSales.code_seance=:CodeSeancePlusMillion

into :number_good2 as cursor cur2 do begin

insert into SearchNumberGoods values(:code_seance, :number_good2, 0);

end

else if (LengthString(scan_code)<>13) then begin

scan_code='%'||scan_code||'%';

for select distinct(goods.number_good) from goods join ScanCodes

on goods.number_good=ScanCodes.number_good join StructureSale

on goods.number_good=StructureSale.number_good join SearchCodeSales

on StructureSale.code_sale=SearchCodeSales.code_sale

where ScanCodes.scan_code like :scan_code and

ToUpperCase(goods.name_good) like :name_good and

ToUpperCase(goods.art) like :art and

SearchCodeSales.code_seance=:CodeSeancePlusMillion

into :number_good2 as cursor cur3 do begin

insert into SearchNumberGoods values(:code_seance, :number_good2, 0);

end

else begin

for select distinct(goods.number_good) from goods join ScanCodes

on goods.number_good=ScanCodes.number_good join StructureSale

on goods.number_good=StructureSale.number_good join SearchCodeSales

on StructureSale.code_sale=SearchCodeSales.code_sale

where ScanCodes.scan_code=:scan_code and

ToUpperCase(goods.name_good) like :name_good and

ToUpperCase(goods.art) like :art and

SearchCodeSales.code_seance=:CodeSeancePlusMillion

into :number_good2 as cursor cur4 do begin

insert into SearchNumberGoods values(:code_seance, :number_good2, 0);

end

/*delete useless code_sales*/

for select

StructureSale.code_sale

from sales join StructureSale

on sales.code_sale=StructureSale.code_sale join SearchCodeSales

on sales.code_sale=SearchCodeSales.code_sale join SearchNumberGoods

on SearchNumberGoods.number_good=StructureSale.number_good

where

SearchNumberGoods.code_seance=:code_seance and

SearchCodeSales.code_seance=:CodeSeancePlusMillion

into :code_sale as cursor cur5 do begin

select count(*) from SearchCodeSales

where code_seance=:code_seance and code_sale=:code_sale

into vrem;

if (vrem=0) then begin

insert into SearchCodeSales

values(:code_seance, :code_sale);

end

delete from SearchCodeSales where code_seance=:CodeSeancePlusMillion;

end^

SET TERM ;^

/* UDFs */

DECLARE EXTERNAL FUNCTION LENGTHSTRING

CSTRING(254)

RESULTS INTEGER BY VALUE

ENTRY_POINT 'LengthString' MODULE_NAME 'libraryLengthString.dll';

DECLARE EXTERNAL FUNCTION SUBSTRING

CSTRING(256),INTEGER,INTEGER

RESULTS CSTRING(256)

ENTRY_POINT 'SubString' MODULE_NAME 'librarySubString.dll';

DECLARE EXTERNAL FUNCTION RANDOM

INTEGER

RESULTS INTEGER BY VALUE

ENTRY_POINT 'random' MODULE_NAME 'libraryRandom.dll';

DECLARE EXTERNAL FUNCTION DATEDAYS

TIMESTAMP

RESULTS INTEGER BY VALUE

ENTRY_POINT 'DateDays' MODULE_NAME 'librarydateDaysSeconds.dll';

DECLARE EXTERNAL FUNCTION DATESECONDS

TIMESTAMP

RESULTS INTEGER BY VALUE

ENTRY_POINT 'DateSeconds' MODULE_NAME 'librarydateDaysSeconds.dll';

DECLARE EXTERNAL FUNCTION ROUNDCOPECKS

DOUBLE PRECISION

RESULTS DOUBLE PRECISION BY VALUE

ENTRY_POINT 'RoundCopecks' MODULE_NAME 'libraryRoundCopecks.dll';

DECLARE EXTERNAL FUNCTION TOUPPERCASE

CSTRING(254)

RESULTS CSTRING(254) FREE_IT

ENTRY_POINT 'ToUpperCase' MODULE_NAME 'libraryToUpperCase.dll';

DECLARE EXTERNAL FUNCTION ABS

DOUBLE PRECISION

RESULTS DOUBLE PRECISION BY VALUE

ENTRY_POINT 'abs' MODULE_NAME 'libraryAbs.dll';

DECLARE EXTERNAL FUNCTION SAMESCANCODES

CSTRING(20),CSTRING(20)

RESULTS INTEGER BY VALUE

ENTRY_POINT 'SameScanCodes' MODULE_NAME 'librarySameScanCodes';

3. Образец программного кода

Процедура GetDateOfNumber

procedure GetDateOfNumber(num_day: integer; var day, month, year: integer);

{начинаем все с 1 января 1901 года -- 1-й день}

var

Blocks4years: integer;

begin

if num_day<1 then

September.Error

('September.GetDateOfNumber: num_day must be not be less than 1');

day:=1; month:=1; year:=1901;

num_day:=num_day-1; {сколько дней еще нужно прибавить}

Blocks4years:=num_day div 1461;

year:=year+4*Blocks4years;

num_day:=num_day-1461*Blocks4years;

while num_day<>0 do begin

case month of

1: if day<>31 then inc(day) else begin month:=2; day:=1; end;

2: if year mod 4<>0 then begin {год не високосный}

if day<>28 then inc(day) else begin month:=3; day:=1; end;

end

else begin {год високосный}

if day<>29 then inc(day) else begin month:=3; day:=1; end;

end;

3: if day<>31 then inc(day) else begin month:=4; day:=1; end;

4: if day<>30 then inc(day) else begin month:=5; day:=1; end;

5: if day<>31 then inc(day) else begin month:=6; day:=1; end;

6: if day<>30 then inc(day) else begin month:=7; day:=1; end;

7: if day<>31 then inc(day) else begin month:=8; day:=1; end;

8: if day<>31 then inc(day) else begin month:=9; day:=1; end;

9: if day<>30 then inc(day) else begin month:=10; day:=1; end;

10: if day<>31 then inc(day) else begin month:=11; day:=1; end;

11: if day<>30 then inc(day) else begin month:=12; day:=1; end;

12: if day<>31 then inc(day) else begin

inc(year); month:=1; day:=1;

end;

dec(num_day);

end;

Процедура IsCorrectFloatString

function IsCorrectFloatString(s: string): boolean;

{проверяет, является ли строка корректным вещественным числом

(без символов e, E)}

const

EOT=#9;

var

ch: char; {текущий символ строки}

i: integer; {номер текущего символа}

err: boolean; {была ли ошибка}

procedure ResetText;

begin

s:=s+EOT;

i:=1;

ch:=s[1];

end;

procedure NextCh;

begin

inc(i);

ch:=s[i];

end;

procedure error; {синтаксическая ошибка}

begin

i:=length(s);

ch:=s[i];

err:=true;

end;

procedure NaturalNumber;

begin

if ch in ['0'..'9'] then NextCh

else error;

while ch in ['0'..'9'] do NextCh;

end;

procedure FloatNumber;

begin

if ch in ['+','-'] then NextCh;

NaturalNumber;

if (ch='.') or (ch=',') then begin

NextCh;

NaturalNumber;

end;

begin

err:=false;

ResetText;

FloatNumber;

if ch<>EOT then err:=true;

IsCorrectFloatString:=not err;

end;

Процедура NaturalNumberUp999ToString

function NaturalNumberUp999ToString(x, tip: integer): string;

var

hundreds, units: integer; {сотни и единицы}

s1, s2: string;

s: string; {строка результата}

begin

if not ((x>=0) and (x<=999)) then

September.Error

('September.NaturalNumberUp999ToString: x must between 0 and 999');

hundreds:=x div 100;

units:=x mod 100;

if hundreds=0 then

s:=NaturalNumberUp99ToString(units, tip)

else begin

case hundreds of

1: s:='сто';

2: s:='двести';

3: s:='триста';

4: s:='четыреста';

5: s:='пятьсот';

6: s:='шестьсот';

7: s:='семьсот';

8: s:='восемьсот';

9: s:='девятьсот';

end;

if units<>0 then s:=s+' '+NaturalNumberUp99ToString(units, tip);

end;

NaturalNumberUp999ToString:=s;

end;

Процедура FloatToLettersMoneyString

function FloatToLettersMoneyString(x: float): string;

{число может быть максимум 18-значным}

var

{массив цифр числа (вместе с копейками)}

digits: array [1..80] of integer; NumDigits: integer;

function func(i: integer): integer;

{i=0 -- возвращает рубли i=1 -- тысяси i=2 -- миллионы

i=3 -- миллиарды i=4 -- триллионы i=5 -- квадриллионы}

var

d1, d2, d3: integer;

f: integer;

begin

d1:=NumDigits-4-3*i;

d2:=NumDigits-3-3*i;

d3:=NumDigits-2-3*i;

f:=0;

if d1>=1 then f:=f+100*digits[d1];

if d2>=1 then f:=f+10*digits[d2];

if d3>=1 then f:=f+digits[d3];

func:=f;

end;

var

copecks, roubles, thousands, millions, milliards,

trillions, kvadrillions: string;

{тип записи слова "рублей" (0 -- ''; 1 -- рубль; 2 -- рубля; 3 -- рублей}

TypeRoubles: integer;

s: string; {результат}

y: integer;

i: integer;

begin

{извлекаем из числа массив цифр}

September.FloatToMoneyString(x, s);

NumDigits:=0;

for i:=1 to length(s) do begin

if (s[i]>='0') and (s[i]<='9') then begin

inc(NumDigits);

digits[NumDigits]:=ord(s[i])-ord('0');

end;

if NumDigits>20 then

September.Error('Error September.FloatToLettersMoneyString: '+

+'chislo is too long');

TypeRoubles:=0; {изначально слово пустое}

{определяем квадриллионы}

y:=func(5);

if y<>0 then begin

if y<>0 then kvadrillions:=NaturalNumberUp999ToString(y, 1)+' '

else kvadrillions:='';

TypeRoubles:=3; {теперь надо писать "рублей"}

case TypeOfNumber(y) of

1: kvadrillions:=kvadrillions+'квадриллион ';

2: kvadrillions:=kvadrillions+'квадриллиона ';

3: kvadrillions:=kvadrillions+'квадриллионов ';

end;

end

else kvadrillions:='';

{определяем триллионы}

y:=func(4);

if y<>0 then begin

if y<>0 then trillions:=NaturalNumberUp999ToString(y, 1)+' '

else trillions:='';

TypeRoubles:=3; {теперь надо писать "рублей"}

case TypeOfNumber(y) of

1: trillions:=trillions+'триллион ';

2: trillions:=trillions+'триллиона ';

3: trillions:=trillions+'триллионов ';

end;

end

else trillions:='';

{определяем миллиарды}

y:=func(3);

if y<>0 then begin

if y<>0 then milliards:=NaturalNumberUp999ToString(y, 1)+' '

else milliards:='';

TypeRoubles:=3; {теперь надо писать "рублей"}

case TypeOfNumber(y) of

1: milliards:=milliards+'миллиард ';

2: milliards:=milliards+'миллиарда ';

3: milliards:=milliards+'миллиардов ';

end;

end

else milliards:='';

{определяем миллионы}

y:=func(2);

if y<>0 then begin

if y<>0 then millions:=NaturalNumberUp999ToString(y, 1)+' '

else millions:='';

TypeRoubles:=3; {теперь надо писать "рублей"}

case TypeOfNumber(y) of

1: millions:=millions+'миллион ';

2: millions:=millions+'миллиона ';

3: millions:=millions+'миллионов ';

end;

end

else millions:='';

{определяем тысячи}

y:=func(1);

if y<>0 then begin

if y<>0 then thousands:=NaturalNumberUp999ToString(y, 2)+' '

else thousands:='';

TypeRoubles:=3; {теперь надо писать "рублей"}

case TypeOfNumber(y) of

1: thousands:=thousands+'тысяча ';

2: thousands:=thousands+'тысячи ';

3: thousands:=thousands+'тысяч ';

end;

end

else thousands:='';

{определяем рубли}

y:=func(0);

if y<>0 then begin

roubles:=NaturalNumberUp999ToString(y, 1)+' ';

{теперь тип слова определяется числом рублей}

TypeRoubles:=TypeOfNumber(y);

end

else roubles:='';

{определяяем копейки}

y:=10*digits[NumDigits-1]+digits[NumDigits];

copecks:=inttostr(y);

if y<10 then copecks:='0'+copecks;

case TypeOfNumber(y) of

1: copecks:=copecks+' копейка';

2: copecks:=copecks+' копейки';

3: copecks:=copecks+' копеек';

end;

{собираем число}

s:=kvadrillions+trillions+milliards+millions+thousands+roubles;

case TypeRoubles of

0: s:=s+'';

1: s:=s+'рубль ';

2: s:=s+'рубля ';

3: s:=s+'рублей ';

end;

s:=s+copecks;

FloatToLettersMoneyString:=s;

end;

Процедура DrawLine

procedure DrawLine(x1, y1, x2, y2: integer);

var

dx, dy, d, inc1, inc2, s: integer;

a, a2: integer;

buf0: array [0..SizeX*SizeY-1] of integer absolute buf;

begin

dx:=abs(x2-x1); dy:=abs(y2-y1);

if dx>dy then begin

inc1:=2*dy; inc2:=2*(dy-dx);

d:=2*dy-dx;

if x1<x2 then begin

a:=SizeX*y1+x1;

a2:=SizeX*y2+x2;

if y1<y2 then s:=SizeX+1

else s:=-SizeX+1;

end

else begin

a:=SizeX*y2+x2; a2:=SizeX*y1+x1;

if y1>y2 then s:=SizeX+1

else s:=-SizeX+1;

end;

asm

lea ebx, buf0;

mov edx, dword ptr cc; {dx -- CurrentColor}

shl a, 2; shl a2, 2;

add a, ebx; add a2, ebx;

mov ebx, a; {ebx -- CurrentAddr}

mov ecx, a2; {ecx -- MaxAddr}

mov edi, d; {edi -- d}

mov esi, s; shl esi, 2; {esi -- s*4}

mov eax, inc2; {eax -- inc2}

mov dword ptr [ebx], edx;

@BeginWhile:

cmp ebx, ecx; je @EndWhile;

cmp edi, 0; jle @ElseIf;

add ebx, esi;

add edi, eax;

jmp @EndIf;

@ElseIf:

add ebx, 4;

add edi, inc1;

@EndIf:

mov dword ptr [ebx], edx;

jmp @BeginWhile;

@EndWhile:

end;

end {dx>dy}

else begin

inc1:=2*dx; inc2:=2*(dx-dy);

d:=2*dx-dy;

if y1<y2 then begin

a:=SizeX*y1+x1;

a2:=SizeX*y2+x2;

if x1<x2 then s:=SizeX+1

else s:=SizeX-1;

end

else begin

a:=SizeX*y2+x2; a2:=SizeX*y1+x1;

if x1>x2 then s:=SizeX+1

else s:=SizeX-1;

end;

asm

lea ebx, buf0;

mov edx, dword ptr cc; {dx -- CurrentColor}

shl a, 2; shl a2, 2;

add a, ebx; add a2, ebx;

mov ebx, a; {ebx -- CurrentAddr}

mov ecx, a2; {ecx -- MaxAddr}

mov edi, d; {edi -- d}

mov esi, s; shl esi, 2; {esi -- s*4}

mov eax, inc2; {eax -- inc2}

mov dword ptr [ebx], edx;

@BeginWhile:

cmp ebx, ecx; je @EndWhile;

cmp edi, 0; jle @ElseIf;

add ebx, esi;

add edi, eax;

jmp @EndIf;

@ElseIf:

add ebx, 4*SizeX;

add edi, inc1;

@EndIf:

mov dword ptr [ebx], edx;

jmp @BeginWhile;

@EndWhile:

end;

end;

Процедура DrawGraphLine

procedure DrawGraphLine(NumGrafik: integer);

{рисуем линию графика без сплайна}

var

i, j: integer;

x1, y1, x2, y2: float;

start, stop: integer;

begin

for i:=0 to GraphLines[NumGrafik].NumberPoints-2 do begin

x1:=GraphLines[NumGrafik].Points[i].x;

y1:=GraphLines[NumGrafik].Points[i].y;

x2:=GraphLines[NumGrafik].Points[i+1].x;

y2:=GraphLines[NumGrafik].Points[i+1].y;

cc:=GraphLines[NumGrafik].ColorLine;

stop:=GraphLines[NumGrafik].WidthLine div 2;

start:=stop-GraphLines[NumGrafik].WidthLine+1;

for j:=start to stop do

GraphLine0(x1, y1+j/ScaleY, x2, y2+j/ScaleY);

end;

Процедура DrawGraphLineWithSpline

procedure DrawGraphLineWithSpline(NumGrafik: integer);

var

n: integer; {число точек на очередной линии для графика}

M: TMatrix; M0: TMatrix0; {матрицы для метода Гаусса}

x, y: array [0..MaxN] of float; {точки линии графика}

{коэффициенты для кубических уравнений сплайнов}

a, b, c, d: array [1..MaxN] of float;

x1, y1, x2, y2: float; {координаты для рисования линий}

u, v: float; {временные переменные}

k, MaxK: integer; {переменные, задают количество линий на участок сплайна}

i, line, j: integer;

start, stop: integer; {для рисования толстых линий}

begin

{число точек на очередной линии графика}

n:=GraphLines[NumGrafik].NumberPoints;

{очищаем матрицы для последующего заполнения}

MultScalarMatrix(M, 0.0); {обнуление матрицы}

MultScalarMatrix0(M0, 0.0); {обнуление вектора решений}

{переносим массив с точками из структуры линии в x[] и y[] (для удобства)}

for i:=0 to n-1 do begin

x[i]:=GraphLines[NumGrafik].Points[i].x;

y[i]:=GraphLines[NumGrafik].Points[i].y;

end;

{заполняем матрицы Гаусса иксами и игреками в нужных местах}

for i:=0 to n-1 do begin

line:=i+1;

M[line,4*i+1]:=x[i]*x[i]*x[i];

M[line,4*i+2]:=x[i]*x[i];

M[line,4*i+3]:=x[i];

M[line,4*i+4]:=1.0;

M0[line]:=y[i];

end;

for i:=1 to n do begin

line:=i+n;

M[line,4*(i-1)+1]:=x[i]*x[i]*x[i];

M[line,4*(i-1)+2]:=x[i]*x[i];

M[line,4*(i-1)+3]:=x[i];

M[line,4*(i-1)+4]:=1.0;

M0[line]:=y[i];

end;

for i:=1 to n-1 do begin

line:=i+2*n;

M[line,4*(i-1)+1]:=3.0*x[i]*x[i];

M[line,4*(i-1)+2]:=2.0*x[i];

M[line,4*(i-1)+3]:=1.0;

M[line,4*i+1]:=-3.0*x[i]*x[i];

M[line,4*i+2]:=-2.0*x[i];

M[line,4*i+3]:=-1.0;

end;

for i:=1 to n-1 do begin

line:=i+3*n-1;

M[line,4*(i-1)+1]:=6.0*x[i];

M[line,4*(i-1)+2]:=2.0;

M[line,4*i+1]:=-6.0*x[i];

M[line,4*i+2]:=-2.0;

end;

line:=4*n-1;

M[line,1]:=6.0*x[0];

M[line,2]:=2.0;

line:=4*n;

M[line,4*(n-1)+1]:=6.0*x[n];

M[line,4*(n-1)+1]:=2.0;

{находим решение методом Гаусса}

GaussSolve(M, M0, 4*n, M0);

{переносим данные из матрицы с решением M0 в массивы a[],b[],c[],d[]}

for i:=1 to n do begin

a[i]:=M0[4*(i-1)+1];

b[i]:=M0[4*(i-1)+2];

c[i]:=M0[4*(i-1)+3];

d[i]:=M0[4*(i-1)+4];

end;

{теперь рисуем график исходя из кубических уравнений сплайнов с

полученными коэффициентами}

for i:=1 to n-1 do begin

MaxK:=round((x[i]-x[i-1])*ScaleX);

for k:=0 to MaxK-1 do begin

u:=x[i-1]+(x[i]-x[i-1])/MaxK*k;

v:=x[i-1]+(x[i]-x[i-1])/MaxK*(k+1);

x1:=u; y1:=a[i]*u*u*u+b[i]*u*u+c[i]*u+d[i];

x2:=v; y2:=a[i]*v*v*v+b[i]*v*v+c[i]*v+d[i];

cc:=GraphLines[NumGrafik].ColorLine;

stop:=GraphLines[NumGrafik].WidthLine div 2;

start:=stop-GraphLines[NumGrafik].WidthLine+1;

for j:=start to stop do

GraphLine0(x1, y1+j/ScaleY, x2, y2+j/ScaleY);

end;

Функции DateDays, DateSeconds библиотеки libraryDateDaysSeconds

library libraryDateDaysSeconds;

uses SysUtils;

const //константы трансляции даты:

MSecsPerDay10=MSecsPerDay*10; //миллисекунд в сутках * 10

IBDateDelta=15384; //разница в днях между датами Delphi и InterBase

type

PIBDateTime=^TIBDateTime;

TIBDateTime=record

Days, //Date: Days since 17 November 1858

MSec10: Integer; //Time: Millisecond * 10 since midnigth

end;

function DateDays(var date: TIBDateTime): integer; cdecl; export;

//номер дня начиная с 1 января 1901 года

var

date0: TDateTime;

y: double absolute date0;

begin

with date do date0:=Days-IBDateDelta+MSec10/MSecsPerDay10;

Result:=trunc(y);

end;

function DateSeconds(var date: TIBDateTime): integer; cdecl; export;
//сколько целых секунд прошло с начала суток

var

date0: TDateTime;

y: double absolute date0;

begin

with date do date0:=Days-IBDateDelta+MSec10/MSecsPerDay10;

Result:=trunc(86400.0*(y-trunc(y)));

end;

exports DateSeconds;

exports DateDays;

begin

end.

Модуль для работы со сканером

UNIT Skaner;

INTERFACE

USES

SysUtils, Windows, Messages, Variants, Classes, Graphics, Controls, Forms,

Dialogs, Menus, ToolWin, ActnMan, ActnCtrls, ActnMenus, ExtCtrls,

Math, StdCtrls, Buttons, IniFiles, StrUtils, September;

procedure ReadFromPort(var s: TEdit);

procedure TerminateReadFromPort;

procedure AddKeyToVirtualPort(Key: integer);

IMPLEMENTATION

type

TThread2 = class(TThread)

private

protected

public

Keys: array [0..63] of integer;

Len: integer;

procedure Execute; override;

end;

var

f: array[1..9] of THandle;

Thread: TThread2;

NumPort: integer; //номер открытого порта

Edit: {^}TEdit; //поле ввода для изменения

{AllowTerminate0, }SkanerOpened01: boolean;

function OpenPort: boolean;

var

DCB: tDCB;

TimeOut: COMMTimeOuts;

begin

OpenPort:=true;

f[NumPort] := Windows.CreateFile(PChar('COM'+inttostr(NumPort)), GENERIC_READ or

GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE,

nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);

if f[NumPort]=INVALID_HANDLE_VALUE then begin

OpenPort:=false;

end;

if not Windows.GetCommState(f[NumPort], DCB) then begin

OpenPort:=false;

end;

DCB.BaudRate := CBR_9600;

DCB.Parity := NOPARITY;

DCB.ByteSize := 8;

DCB.StopBits := ONESTOPBIT;

DCB.Flags := 20625;

DCB.DCBlength := 256;

DCB.EofChar := chr(10);

if not SetCommState(f[NumPort], DCB) then begin

//raise Exception.Create('Error setting port state');

OpenPort:=false;

end;

if not PurgeComm(f[NumPort], PURGE_TXCLEAR or PURGE_RXCLEAR) then begin

//raise Exception.Create('Error purging port');

OpenPort:=false;

end;

if not SetCommMask(f[NumPort], EV_RXCHAR) then begin

//raise Exception.Create('Error setting port mask');

OpenPort:=false;

end;

if not SetupComm(f[NumPort], 256, 256) then begin

OpenPort:=false;

end;

if PurgeComm(f[NumPort], PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR) then begin

end

else OpenPort:=false;

Windows.GetCommTimeouts(f[NumPort], TimeOut);

TimeOut.ReadIntervalTimeout:=10;

TimeOut.ReadTotalTimeoutMultiplier:=10;

TimeOut.ReadTotalTimeoutConstant:=100;

Windows.SetCommTimeouts(f[NumPort], TimeOut);

end;

procedure ClosePort;

begin

{ September.Message('Закрываем порт'+inttostr(NumPort));}

Windows.CloseHandle(f[NumPort]);

end;

var

second: boolean;

procedure ReadFromPort0(var s: TEdit);

label

label1;

var

bytes: array [0..14] of byte;

readed0: cardinal;

readed: integer;

Buf: array [0..14] of byte;

i: integer;

s0: string;

x: Cardinal;

OK: boolean;

begin

if NumPort<>0 then begin {ExistSkaner}

label1:

readed:=0;

for i:=0 to 14 do bytes[i]:=48;

repeat

ReadFile(f[NumPort], Buf, 15, readed0, nil);

for i:=readed to readed+readed0-1 do begin

if i<=14 then bytes[i]:=Buf[i-readed];

end;

readed:=readed+readed0;

{ if second then readed:=15;}

until readed>=15;

s0:='';

if not ((bytes[12]>=ord('0')) and (bytes[12]<=ord('9'))) then begin

for i:=11 downto 0 do bytes[i+1]:=bytes[i];

bytes[0]:=ord('0');

end;

for i:=0 to 12 do s0:=s0+chr(bytes[i]);

for i:=13 to 20 do s0:=s0+chr(ord('a')+random(26));

{ repeat

OK:=false;

try }

s.Text := s0;

{ OK:=true;

except

end;

until OK;}

PurgeComm(f[NumPort], PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);

sleep(100);

goto label1;

end

else begin

Thread.Len:=0;

for i:=0 to 63 do Thread.Keys[i]:=48;

repeat

s0:='';

for i:=0 to Thread.Len-1 do begin

if Thread.Keys[i]=17 then s0:=s0+'C'

else s0:=s0+chr(Thread.Keys[i]);

end;

if Length(s0)=14 then begin

delete(s0, 1, 1);

for i:=13 to 20 do s0:=s0+chr(ord('a')+random(26));

s.Text:=s0;

Thread.Len:=0;

end;

sleep(100);

until false;

end;

procedure TThread2.Execute;

begin

ReadFromPort0(Edit{^});

end;

procedure ReadFromPort(var s: TEdit);

var

fl: text;

OK: boolean;

iter: integer;

begin

if not SkanerOpened01 then begin

assign(fl, 'PortSkaner.txt'); reset(fl);

readln(fl, NumPort);

close(fl);

iter:=0;

repeat

if iter<>0 then ClosePort;

if NumPort<>0 then OK:=OpenPort {ExistSkaner}

else OK:=true;

if not OK then NumPort:=0;

inc(iter);

until (NumPort<>0) or (iter=10);

{ September.Message(inttostr(NumPort));}

{ Thread := TThread2.Create(true);

Thread.FreeOnTerminate := true;

Thread.Priority := tpLower;

Thread.Resume;}

Thread.FreeOnTerminate := true;

Thread.Priority := tpLower;

Thread.Resume;

end;

SkanerOpened01:=true;

Edit := {Addr(}s{)};

{ Thread.Suspend;}

{second:=not second;}

end;

procedure TerminateReadFromPort;

begin

{ if NumPort<>0 then ClosePort;

Thread.Suspend;

Thread.Terminate;

Thread.DoTerminate;}

end;

procedure AddKeyToVirtualPort(Key: integer);

var

i: integer;

sdvig: integer;

begin

if (Key>=96) and (Key<=105) then Key:=Key-48;

if Key=September.klCtrl then begin

if Thread.Len=0 then begin

Thread.Len := 1;

Thread.Keys[0] := klCtrl;

end

else if Thread.Len<14 then begin

sdvig:=14-Thread.Len;

for i:=Thread.Len-1 downto 1 do

Thread.Keys[i+sdvig]:=Thread.Keys[i];

for i:=1 to sdvig do Thread.Keys[i]:=48;

Thread.Len:=14;

end

else if Thread.Len=14 then begin

//ничего не делаем

end

else September.Error('Skaner.AddKeyToVirtualPort');

end

else if (Key>=48) and (Key<=57) then begin

if (Thread.Len<>0) and (Thread.Len<14) then begin

Thread.Keys[Thread.Len]:=Key;

inc(Thread.Len);

end;

end

else if (Key<>0) then begin

Thread.Len:=0;

end;

BEGIN

{second:=false;}

Thread := TThread2.Create(true);

SkanerOpened01:=false;

{AllowTerminate0:=false;}

{ Thread := TThread2.Create(true);}

END.

Модуль для работы с кассовым аппаратом

UNIT KKM;

INTERFACE

uses ComObj, September;

var

ExistKKM: boolean=true;

function Connect(Password, ComNumber, BaudRateNumber, Timeout: integer): boolean;

function Connect3: integer;

function CheckKKM: boolean; {проверяем соединение с кассовым аппаратом}

function PrintFiveEmptyStrings: boolean; {напечатать пять пустых строк}

function PrintString(s: string): boolean; {напечатать строку}

function PrintWideString(s: string): boolean; {напечатать жирную строку}

function CutCheck: boolean; {отрезать чек}

function CancelCheck: boolean; {аннулировать чек}{не надо резать}

function PrintReportWithoutCleaning: boolean; {снять отчет без гашения}{не надо резать}

function PrintReportWithCleaning: boolean; {снять отчет с гашением}{не надо резать}

function CashIncome(n: float): boolean; {внесение денег в кассу}

function CashOutcome(n: float): boolean; {забор денег из кассы}

function DefineSummInKass(var summ: float): boolean; {узнать, сколько денег в кассе}

function Sale(good: string; price, quantity: float): boolean; {продажа товара}

function ReturnSale(good: string; price, quantity: float): boolean; {возврат товара}

function CloseCheck(summ: float): boolean;{не надо резать}

function Beep: boolean; {пипикнуть}

function OpenDrawer: boolean; {открыть денежный ящик}

function PrintBarCode(BK: string): boolean; {печать штрих-кода}

IMPLEMENTATION

uses UnitPrintCheque;

const

namef='cheque.txt';

var

FileOpened: boolean=false;

Driver: OLEVariant;

f: text;

saled: float;

WasSaled: boolean;

function Connect(Password, ComNumber, BaudRateNumber, Timeout: integer): boolean;

var

x: integer;

begin

Driver := CreateOleObject('Addin.DrvFR');

try

Driver.Password := Password;

Driver.ComNumber := ComNumber;

Driver.BaudRate := BaudRateNumber; {6: 115200}

Driver.Timeout := Timeout;

x:=Driver.Connect;

finally

end;

Connect:=x=0;

end;

function Connect3: integer;

var

i: integer; {номер COM-порта}

begin

saled:=0.0;

if not ExistKKM then begin

if FileOpened then begin

FileOpened:=false;

close(f);

end;

assign(f, namef);

Connect3:=1; {подсоединились!}

Exit;

end;

Connect3:=0;

for i:=1 to 8 do begin {i -- номер com-порта}

if Connect(30, i, 6, 100) then begin

Connect3:=i;

exit;

end;

function CheckKKM: boolean; {проверяем соединение с кассовым аппаратом}

var

Connected: integer;

begin

Connected:=KKM.Connect3;

CheckKKM:=Connected<>0;

end;

procedure OpenFile;

begin

if not FileOpened then begin assign(f, namef); rewrite(f); FileOpened:=true; end;

end;

procedure CloseFile;

begin

if FileOpened then close(f);

FileOpened:=false;

end;

function PrintFiveEmptyStrings: boolean;

var

i: integer;

begin

if not ExistKKM then begin

OpenFile;

for i:=1 to 5 do writeln(f);

PrintFiveEmptyStrings:=true;

end

else begin

Driver.StringForPrinting := ' ';

for i:=1 to 5 do Driver.PrintString;

PrintFiveEmptyStrings:=Driver.ResultCode=0;

end;

function PrintString(s: string): boolean;

begin

if not ExistKKM then begin

OpenFile;

writeln(f, s);

PrintString:=true;

end

else begin

if s<>'' then begin

Driver.StringForPrinting := s;

Driver.PrintString;

PrintString:=Driver.ResultCode=0;

end

else PrintString:=true;

end;

function PrintWideString(s: string): boolean;

begin

if not ExistKKM then begin

OpenFile;

writeln(f, s);

PrintWideString:=true;

end

else begin

if s<>'' then begin

Driver.StringForPrinting := s;

Driver.PrintWideString;

PrintWideString:=Driver.ResultCode=0;

end

else PrintWideString:=true;

end;

function CutCheck: boolean;

begin

if not ExistKKM then begin

OpenFile;

writeln(f, '!!! -- ЧЕК ОБРЕЗАН -- !!!');

CutCheck:=true;

CloseFile; FormPrintCheque.ShowModal;

end

else begin

Driver.CutCheck;

CutCheck:=Driver.ResultCode=0;

end;

function CancelCheck: boolean;

begin

if not ExistKKM then begin

OpenFile;

writeln(f, '!!! -- ЧЕК ОТМЕНЕН -- !!!');

CancelCheck:=true;

CloseFile; FormPrintCheque.ShowModal;

end

else begin

Driver.CancelCheck;

CancelCheck:=Driver.ResultCode=0;

end;

function PrintReportWithoutCleaning: boolean;

begin

if not ExistKKM then begin

OpenFile;

writeln(f, 'Не могу напечатать отчет без гашения без кассового аппарата!');

PrintReportWithoutCleaning:=true;

CloseFile; FormPrintCheque.ShowModal;

end

else begin

Driver.PrintReportWithoutCleaning;

PrintReportWithoutCleaning:=Driver.ResultCode=0;

end;

function PrintReportWithCleaning: boolean;

begin

if not ExistKKM then begin

OpenFile;

writeln(f, 'Не могу напечатать отчет с гашением без кассового аппарата!');

PrintReportWithCleaning:=true;

CloseFile; FormPrintCheque.ShowModal;

end

else begin

Driver.PrintReportWithCleaning;

PrintReportWithCleaning:=Driver.ResultCode=0;

end;

function CashIncome(n: float): boolean;

var

s: string;

begin

if not ExistKKM then begin

OpenFile;

writeln(f, 'В кассу внесены деньги!');

September.FloatToMoneyString(n, s);

writeln(f, '('+s+' рублей)');

CashIncome:=true;

end

else begin

Driver.Summ1 := n;

Driver.CashIncome;

CashIncome:=Driver.ResultCode=0;

end;

function CashOutcome(n: float): boolean;

var

s: string;

begin

if not ExistKKM then begin

OpenFile;

writeln(f, 'Из кассы забраны деньги!');

September.FloatToMoneyString(n, s);

writeln(f, '('+s+' рублей)');

CashOutcome:=true;

end

else begin

Driver.Summ1 := n;

Driver.CashOutcome;

CashOutcome:=Driver.ResultCode=0;

end;

function DefineSummInKass(var summ: float): boolean;

begin

if not ExistKKM then begin

summ:=5000.00;

DefineSummInKass:=true;

end

else begin

Driver.RegisterNumber := 241;

Driver.GetCashReg;

if Driver.ResultCode=0 then begin

summ:=Driver.ContentsOfCashRegister;

DefineSummInKass:=true;

end

else DefineSummInKass:=false;

end;

function Sale(good: string; price, quantity: float): boolean;

var

s: string;

s0: string;

summa: float;

begin

WasSaled:=true;

if not ExistKKM then begin

OpenFile;

if length(good)>36 then SetLength(good, 36);

writeln(f, good);

summa:=September.CalculateSumma(price, quantity);

if (quantity>=0.9999) and (quantity<=1.0001) then begin

September.FloatToMoneyString(price, s);

s:='='+s;

while length(s)<>36 do s:=' '+s;

writeln(f, s);

end

else begin

str(quantity:0:3, s);

September.FloatToMoneyString(price, s0);

s:=s+' X '+s0;

while length(s)<>36 do s:=' '+s;

September.DotsToCommas(s);

writeln(f, s);

September.FloatToMoneyString(summa, s);

s:='='+s;

while length(s)<>36 do s:=' '+s;

writeln(f, s);

end;

saled:=saled+summa;

Sale:=true;

end

else begin

if length(good)>36 then SetLength(good, 36);

Driver.StringForPrinting := good;

Driver.Quantity := quantity; {количество}

Driver.Price := price; {цена}

Driver.Sale;

Sale:=Driver.ResultCode=0;

{ September.Message(Driver.ResultCode);}

end;

function ReturnSale(good: string; price, quantity: float): boolean;

var

s: string;

s0: string;

summa: float;

begin

WasSaled:=false;

if not ExistKKM then begin

OpenFile;

if length(good)>36 then SetLength(good, 36);

writeln(f, good);

summa:=September.CalculateSumma(price, quantity);

if (quantity>=0.9999) and (quantity<=1.0001) then begin

September.FloatToMoneyString(price, s);

s:='='+s;

while length(s)<>36 do s:=' '+s;

writeln(f, s);

end

else begin

str(quantity:0:3, s);

September.FloatToMoneyString(price, s0);

s:=s+' X '+s0;

while length(s)<>36 do s:=' '+s;

September.DotsToCommas(s);

writeln(f, s);

September.FloatToMoneyString(summa, s);

s:='='+s;

while length(s)<>36 do s:=' '+s;

writeln(f, s);

end;

saled:=saled+summa;

ReturnSale:=true;

end

else begin

if length(good)>36 then SetLength(good, 36);

Driver.StringForPrinting := good;

Driver.Quantity := quantity; {количество}

Driver.Price := price; {цена}

Driver.ReturnSale;

ReturnSale:=Driver.ResultCode=0;

end;

function CloseCheck(summ: float): boolean;

var

s: string;

begin

if not ExistKKM then begin

{ str(saled:0:3, s);

September.Message(s);}

if (WasSaled and (abs(saled-summ)>=0.001)) or (not WasSaled and (abs(saled-summ)>=0.001)) then begin

CloseCheck:=false;

end

else begin

OpenFile;

writeln(f, '====================================');

September.FloatToMoneyString(summ, s);

while length(s)<32 do s:=' '+s;

s:='ИТОГ'+s;

writeln(f, s);

if WasSaled then writeln(f, '!!! --- ЧЕК ПОКУПКИ ЗАКРЫТ --- !!!')

else writeln(f, '!!! --- ЧЕК ВОЗВРАТА ЗАКРЫТ --- !!!');

CloseCheck:=true;

CloseFile; FormPrintCheque.ShowModal;

end;

end

else begin

if WasSaled then Driver.StringForPrinting:=' СПАСИБО ЗА ПОКУПКУ! '

else Driver.StringForPrinting:='';

Driver.Summ1:=summ;

Driver.CloseCheck;

CloseCheck:=Driver.ResultCode=0;

end;

function Beep: boolean;

begin

if not ExistKKM then begin

OpenFile;

writeln(f, '!!! -- ПИПИКНУЛИ -- !!!');

Beep:=true;

end

else begin

Driver.Beep;

Beep:=Driver.ResultCode=0;

end;

function OpenDrawer: boolean;

begin

if not ExistKKM then begin

OpenFile;

writeln(f, '!!! ДЕНЕЖНЫЙ ЯЩИК ОТКРЫЛИ !!!');

OpenDrawer:=true;

end

else begin

Driver.OpenDrawer;

OpenDrawer:=Driver.ResultCode=0;

end;

function PrintBarCode(BK: string): boolean;

begin

delete(BK, 13, 1);

Driver.BarCode:=BK;

Driver.PrintBarCode;

end;

END.

Модуль BGL

UNIT BGL;

INTERFACE

USES

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, IBStoredProc, StdCtrls, DB, IBDatabase, IBCustomDataSet,

IBQuery, Grids, DBGrids, September, Menus, ExtCtrls, TeeProcs, TeEngine, Chart;

const

SizeX=1024; SizeY=768;

getmaxx=SizeX-1; getmaxy=SizeY-1;

red=65536; green=256; blue=1;

white=red+green+blue;

type

tBuf=array [0..getmaxy, 0..getmaxx] of integer;

tFont=record

width, height: integer;

TextMassiv: array [0..255, 0..63, 0..31] of boolean;

end;

var

Buf: TBuf;

fonts: array[8..20] of tFont;

cc, bc: integer;

ColorText, ColorBGText: integer;

xleft, xright, ytop, ybottom: integer;

wherex, wherey: longint;

FontSize: integer;

TransparentText: boolean;

procedure BufToBitMap(var BitMap: TBitMap);

procedure BitMapToBuf(var BitMap: TBitMap);

procedure ClearDevice;

procedure DrawLine(x1, y1, x2, y2: longint);

procedure SetColor(r, g, b: integer);

procedure SetBgColor(r, g, b: integer);

procedure line(x1, y1, x2, y2: longint);

procedure SetViewPort(xl, yt, xr, yb: longint);

procedure putpixel(x, y: longint);

procedure InitText;

procedure gotoxy(x, y: longint);

procedure textbackground(r, g, b: longint);

procedure textcolor(r, g, b: longint);

procedure putchar(ch: char);

procedure writes(s: string);

procedure DoFontFromBMPFile(FontSize: integer);

IMPLEMENTATION

var

x, y: integer;

procedure BufToBitMap(var BitMap: TBitMap);

var

r, g, b: integer;

color: integer;

begin

for x:=0 to BitMap.Width-1 do begin

for y:=0 to BitMap.Height-1 do begin

color:=Buf[y,x];

b:=color and 255;

g:=(color and (255*green)) div green;

r:=(color and (255*red)) div red;

color:=r*blue+g*green+b*red;

BitMap.Canvas.Pixels[x,y]:=color;

end;

procedure BitMapToBuf(var BitMap: TBitMap);

var

r, g, b: integer;

color: integer;

begin

for x:=0 to BitMap.Width-1 do begin

for y:=0 to BitMap.Height-1 do begin

color:=BitMap.Canvas.Pixels[x,y];

b:=color and 255;

g:=(color and (255*green)) div green;

r:=(color and (255*red)) div red;

color:=r*blue+g*green+b*red;

Buf[y,x]:=color;

end;

procedure ClearDevice;

begin

for y:=0 to getmaxy do

for x:=0 to getmaxx do

Buf[y,x]:=bc;

end;

procedure DoBWColor(var x: integer);

var

c: integer;

b: array[0..3] of byte absolute x;

begin

c:=x;

x:=(65536+256+1)*((3*b[2]+6*b[1]+b[0]) div 10);

end;

procedure DrawLine(x1, y1, x2, y2: integer);

var

dx, dy, d, inc1, inc2, s: integer;

a, a2: integer;

buf0: array [0..SizeX*SizeY-1] of integer absolute buf;

begin

dx:=abs(x2-x1); dy:=abs(y2-y1);

if dx>dy then begin

inc1:=2*dy; inc2:=2*(dy-dx);

d:=2*dy-dx;

if x1<x2 then begin

a:=SizeX*y1+x1;

a2:=SizeX*y2+x2;

if y1<y2 then s:=SizeX+1

else s:=-SizeX+1;

end

else begin

a:=SizeX*y2+x2; a2:=SizeX*y1+x1;

if y1>y2 then s:=SizeX+1

else s:=-SizeX+1;

end;

asm

lea ebx, buf0;

mov edx, dword ptr cc; {dx -- CurrentColor}

shl a, 2; shl a2, 2;

add a, ebx; add a2, ebx;

mov ebx, a; {ebx -- CurrentAddr}

mov ecx, a2; {ecx -- MaxAddr}

mov edi, d; {edi -- d}

mov esi, s; shl esi, 2; {esi -- s*4}

mov eax, inc2; {eax -- inc2}

mov dword ptr [ebx], edx;

@BeginWhile:

cmp ebx, ecx; je @EndWhile;

cmp edi, 0; jle @ElseIf;

add ebx, esi;

add edi, eax;

jmp @EndIf;

@ElseIf:

add ebx, 4;

add edi, inc1;

@EndIf:

mov dword ptr [ebx], edx;

jmp @BeginWhile;

@EndWhile:

end;

end {dx>dy}

else begin

inc1:=2*dx; inc2:=2*(dx-dy);

d:=2*dx-dy;

if y1<y2 then begin

a:=SizeX*y1+x1;

a2:=SizeX*y2+x2;

if x1<x2 then s:=SizeX+1

else s:=SizeX-1;

end

else begin

a:=SizeX*y2+x2; a2:=SizeX*y1+x1;

if x1>x2 then s:=SizeX+1

else s:=SizeX-1;

end;

asm

lea ebx, buf0;

mov edx, dword ptr cc; {dx -- CurrentColor}

shl a, 2; shl a2, 2;

add a, ebx; add a2, ebx;

mov ebx, a; {ebx -- CurrentAddr}

mov ecx, a2; {ecx -- MaxAddr}

mov edi, d; {edi -- d}

mov esi, s; shl esi, 2; {esi -- s*4}

mov eax, inc2; {eax -- inc2}

mov dword ptr [ebx], edx;

@BeginWhile:

cmp ebx, ecx; je @EndWhile;

cmp edi, 0; jle @ElseIf;

add ebx, esi;

add edi, eax;

jmp @EndIf;

@ElseIf:

add ebx, 4*SizeX;

add edi, inc1;

@EndIf:

mov dword ptr [ebx], edx;

jmp @BeginWhile;

@EndWhile:

end;

procedure DrawLine(x1, y1, x2, y2: integer);

var

dx, dy, d, inc1, inc2, s: integer;

a, a2: integer;

buf0: array [0..SizeX*SizeY-1] of integer absolute buf;

begin

dx:=abs(x2-x1); dy:=abs(y2-y1);

if dx>dy then begin

inc1:=2*dy; inc2:=2*(dy-dx);

d:=2*dy-dx;

if x1<x2 then begin

a:=SizeX*y1+x1;

a2:=SizeX*y2+x2;

if y1<y2 then s:=SizeX+1

else s:=-SizeX+1;

end

else begin

a:=SizeX*y2+x2; a2:=SizeX*y1+x1;

if y1>y2 then s:=SizeX+1

else s:=-SizeX+1;

end;

buf0[a]:=cc;

while a<>a2 do begin

if d>0 then begin

a:=a+s;

d:=d+inc2;

end

else begin

a:=a+1;

d:=d+inc1;

end;

buf0[a]:=cc;

end;

end {dx>dy}

else begin

inc1:=2*dx; inc2:=2*(dx-dy);

d:=2*dx-dy;

if y1<y2 then begin

a:=SizeX*y1+x1;

a2:=SizeX*y2+x2;

if x1<x2 then s:=SizeX+1 {!!!}

else s:=SizeX-1;

end

else begin

a:=SizeX*y2+x2; a2:=SizeX*y1+x1;

if x1>x2 then s:=SizeX+1 {!!!}

else s:=SizeX-1;

end;

buf0[a]:=cc;

while a<>a2 do begin

if d>0 then begin

a:=a+s;

d:=d+inc2;

end

else begin

a:=a+SizeX;

d:=d+inc1;

end;

buf0[a]:=cc;

end;

procedure SetColor(r, g, b: integer);

begin

cc:=r*red+g*green+b*blue;

end;

procedure SetBgColor(r, g, b: integer);

begin

bc:=r*red+g*green+b*blue;

end;

procedure line(x1, y1, x2, y2: longint);

type

tCode=set of 0..3;

procedure Coding(x, y: integer; var code: tCode);

begin

code:=[];

if x<xleft then code:=code+[0]

else if x>xright then code:=code+[1];

if y<ytop then code:=code+[2]

else if y>ybottom then code:=code+[3];

end;

var

code1, code2: tCode;

inside: boolean;

x, y: integer;

code: tCode;

reg1, reg2, reg3, reg4: integer;

begin

x1:=x1+xleft; x2:=x2+xleft;

y1:=y1+ytop; y2:=y2+ytop;

Coding(x1, y1, code1);

Coding(x2, y2, code2);

inside:=code1+code2=[];

while not inside and (code1*code2=[]) do begin

if code1=[] then begin

reg1:=x1; reg3:=y1; reg2:=x2; reg4:=y2;

x1:=reg2; y1:=reg4; x2:=reg1; y2:=reg3;

code:=code1; code1:=code2; code2:=code;

end;

if x1<xleft then begin {отсечение слева}

y1:=y1+round((y2-y1)/(x2-x1)*(xleft-x1));

x1:=xleft;

end

else if x1>xright then begin {отсечение справа}

y1:=y1+round((y2-y1)/(x2-x1)*(xright-x1));

x1:=xright;

end

else if y1<ytop then begin {отсечение сверху}

x1:=x1+round((x2-x1)/(y2-y1)*(ytop-y1));

y1:=ytop;

end

else if y1>ybottom then begin {отсечение снизу}

x1:=x1+round((x2-x1)/(y2-y1)*(ybottom-y1));

y1:=ybottom;

end;

Coding(x1, y1, code1);

inside:=(code1+code2)=[];

end;

if inside then DrawLine(x1, y1, x2, y2);

end;

procedure SetViewPort(xl, yt, xr, yb: longint);

begin

if (xl>=0) and (xr<=getmaxx) and (xl<xr) and

(yt>=0) and (yb<=getmaxy) and (yt<yb)

then begin

xleft:=xl;

xright:=xr;

ytop:=yt;

ybottom:=yb;

end

else begin

if xl<0 then September.error('Error SetViewPort (xleft<0)');

if yt<0 then September.error('Error SetViewPort (ytop<0)');

if xr>getmaxx then September.error('Error SetViewPort (xright>getmaxx)');

if yb>getmaxy then September.error('Error SetViewPort (ybottom>getmaxy)');

if xl>=xr then September.error('Error SetViewPort (xleft>=xright)');

if yt>=yb then September.error('Error SetViewPort (ytop>=ybottom)');

end;

procedure putpixel(x, y: longint);

begin

line(x, y, x, y);

end;

procedure InitText;

var

f: text;

size: integer;

symbol: integer;

ch: char;

x, y: integer;

namef: string;

begin

for size:=8 to 8 do begin

namef:='font'+inttostr(size)+'_'+inttostr(fonts[size].width)+'_'+inttostr(fonts[size].height);

assign(f, 'myfonts\'+namef+'.gaz'); reset(f);

for symbol:=0 to 255 do

for y:=0 to 63 do

for x:=0 to 31 do

fonts[size].TextMassiv[symbol,y,x]:=false;

for symbol:=32 to 255 do begin

for y:=0 to fonts[size].height-1 do begin

for x:=0 to fonts[size].width-1 do begin

read(f, ch);

if ch='W' then fonts[size].TextMassiv[symbol,y,x]:=true;

end;

readln(f);

end;

readln(f);

end;

close(f);

end;

procedure gotoxy(x, y: longint);

begin

wherex:=x;

wherey:=y;

end;

procedure textbackground(r, g, b: longint);

begin

ColorBGText:=r*red+g*green+b*blue;

end;

procedure textcolor(r, g, b: longint);

begin

ColorText:=r*red+g*green+b*blue;

end;

procedure putchar(ch: char);

var

x, y: longint;

OldBC, OldCC: longint;

begin

OldBC:=bc; OldCC:=cc;

for x:=0 to Fonts[FontSize].width-1 do begin

for y:=0 to Fonts[FontSize].height-1 do begin

if (x>=0) and (x<=getmaxx) and (y>=0) and (y<=getmaxy) then begin

if fonts[FontSize].TextMassiv[ord(ch), y, x] then begin

cc:=ColorText;

putpixel(WhereX+x+xleft, WhereY+y+ytop);

end

else if not TransparentText then begin

cc:=ColorBGText;

putpixel(WhereX+x+xleft, WhereY+y+ytop);

end;

bc:=OldBC; cc:=OldCC;

end;

procedure writes(s: string);

var

i: longint;

begin

i:=length(s);

for i:=1 to length(s) do begin

putchar(s[i]);

inc(wherex, fonts[FontSize].width);

end;

procedure DoFontFromBMPFile(FontSize: integer);

var

f: text;

namef: string;

BitMap: TBitMap;

x, y: integer;

StartX, StartY: integer;

symbol: integer;

w, h: integer;

begin

w:=fonts[FontSize].width;

h:=fonts[FontSize].height;

namef:='font'+inttostr(FontSize)+'_'+inttostr(w)+'_'+inttostr(h);

BitMap:=TBitmap.Create;

BitMap.LoadFromFile('myfonts\'+namef+'.bmp');

assign(f, 'myfonts\'+namef+'.gaz');

rewrite(f);

for symbol:=32 to 255 do begin

StartX:=w*((symbol-32) mod 16);

StartY:=h*((symbol-32) div 16);

for y:=StartY to StartY+h-1 do begin

for x:=StartX to StartX+w-1 do begin

if BitMap.Canvas.Pixels[x,y]=0 then write(f, 'W')

else write(f, ' ');

end;

writeln(f);

end;

writeln(f);

end;

close(f);

end;

BEGIN

cc:=0; bc:=255*(red+green+blue);

ColorText:=cc; ColorBgText:=bc;

SetViewPort(0, 0, getmaxx, getmaxy);

TransparentText:=false; FontSize:=8;

fonts[8].width:=7; fonts[8].height:=14;

InitText;

for y:=0 to getmaxy do

for x:=0 to getmaxx do

Buf[y,x]:=random(255);

END.