мой единственынй совет - создать проект на любом хостинге проектов.
Там и доступ будет публичный всем в любой момент суток, ну и документацию с баг трекером можнно вести.
Модератор: Модераторы
// не помню точно в каком модуле нужные типы
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
ExtCtrls, Buttons, StdCtrls, Process, lazregions,
LCLIntf, LCLType, IntfGraphics,Math;
...
{SMARTLINK ON}
const
{ Graphics Modes }
GM_COMPATIBLE = 1;
GM_ADVANCED = 2;
GM_LAST = 2;
{ xform stuff }
MWT_IDENTITY = 1;
MWT_LEFTMULTIPLY = 2;
MWT_RIGHTMULTIPLY = 3;
MWT_MIN = MWT_IDENTITY;
MWT_MAX = MWT_RIGHTMULTIPLY;
msimg32lib = 'msimg32.dll';
user32lib = 'user32.dll';
shell32lib = 'shell32.dll';
gdi32lib = 'gdi32.dll';
comctl32lib = 'comctl32.dll';
type
PXForm = ^TXForm;
tagXFORM = packed record
eM11: Single;
eM12: Single;
eM21: Single;
eM22: Single;
eDx: Single;
eDy: Single;
end;
TXForm = tagXFORM;
XFORM = tagXFORM;
function SetGraphicsMode(hdc: HDC; iMode: Integer): Integer;stdcall;
external gdi32lib name 'SetGraphicsMode';
//function GetWorldTransform(DC: HDC; var p2: TXForm): BOOL; stdcall;
// external gdi32lib name 'GetWorldTransform';
function SetWorldTransform(DC: HDC; const p2: TXForm): BOOL; stdcall;
external gdi32lib name 'SetWorldTransform';
function ModifyWorldTransform(DC: HDC; const p2: TXForm; p3: DWORD): BOOL; stdcall;
external gdi32lib name 'ModifyWorldTransform';
// Пересчет размера
// входящие ---------------------
// degree угол
// W,H ширина исходной картинки
/ /исходящие -------------------
// topoverh, leftoverh точка оси поворота ?(Не уверен в "физическом смысле" этих координат)
// X,Y - Ширина и высота "повернутой" картинки
Procedure GetRSize (degree,W,H: integer; Var topoverh, leftoverh,X,Y: integer);
Var
cosA, sinA: real;
Begin
cosA := cos(degree*Pi/180);
sinA := sin(degree*Pi/180);
while degree >= 360 do degree := degree - 360;
while degree < 0 do degree := degree + 360;
if (degree <= 90) then
begin
topoverh := 0;
y := Round(W * sinA + H * cosA);
leftoverh := Round(- H * sinA);
x := Round(W * cosA) + Abs(leftoverh);
end
else if (degree <= 180) then
begin
topoverh := Round(H * cosA);
y := Round(W * sinA) + Abs(topoverh);
leftoverh := Round(W * cosA - H * sinA);
x := Abs(leftoverh);
end
else if (degree <= 270) then
begin
topoverh := Round(W * sinA + H * cosA);
y := Abs(topoverh);
leftoverh := Round(W * cosA);
x := Round(- H * sinA) + Abs(leftoverh);
end
else
begin
topoverh := Round(W * sinA);
y := Round(H * cosA) + Abs(topoverh);
leftoverh := 0;
x := Round(W * cosA - H * sinA) + Abs(leftoverh);
end;
end;
//Поворот картинки
procedure DrawRotatedBitmap(Bitmap: TBitmap; Dest: TCanvas; X_, Y_: Integer;
degree,topoverh, leftoverh: Integer);
var
Matrix: TXForm;
Angle: Double;
x, y, H, W: integer;
begin
H := Bitmap.Height;
W := Bitmap.Width;
Angle:= degree*Pi/180;
while degree >= 360 do degree := degree - 360;
while degree < 0 do degree := degree + 360;
// Разрешаем афинные преобразования
SetGraphicsMode(Dest.Handle, GM_ADVANCED);
// Устанавливаем матрицу для смещения на (X, Y)
Matrix.eM11 := 1;
Matrix.eM12 := 0;
Matrix.eM21 := 0;
Matrix.eM22 := 1;
Matrix.eDx := X_;
Matrix.eDy := Y_;
SetWorldTransform(Dest.Handle, Matrix);
// Устанавливаем матрицу поворота
Matrix.eM11 := Cos(Angle);
Matrix.eM12 := Sin(Angle);
Matrix.eM21 := -Sin(Angle);
Matrix.eM22 := Cos(Angle);
Matrix.eDx := -leftoverh;
Matrix.eDy := -topoverh;;
ModifyWorldTransform(Dest.Handle, Matrix, MWT_LEFTMULTIPLY);
// Выводим изображение
Dest.Draw(0, 0, Bitmap);
// Восстанавливаем систему координат
ModifyWorldTransform(Dest.Handle, Matrix, MWT_IDENTITY);
end;
GetRSize(i*10,40,40,tv,lv,wr,hr);
Br:=Tbitmap.Create; Br.SetSize(wr,hr);
With BR.Canvas do begin brush.Color:=clWhite;FillRect(ClipRect);end;
DrawRotatedBitmap(B0,BR.Canvas,0,0,i*10,tv,lv);
Image2.Picture.Bitmap.Assign(BR);
Br.free;
Инструкция
1 Нажать "START"
Если все в порядке сразу увидите изображение веб-камеры подключенной по умолчанию (Иначе выведет диалог выбора камеры)
Если в системе не все так хорошо как хочется фон окна просто изменится и все.
НО ЭТО НЕ ОБЯЗАТЕЛЬНО ПОМЕШАЕТ ...
2 Жмем >>BUF и BUF >> Если все ок сможете увидеть кадр в окошке превъю
3 Auto Start шевелим камеру видим изменения в "Риал Тайм"
4 Нажимаем ZOOM открывается окно "безграничного преувеличения"
6 + - регулируют увеличение галка Обновить включает "РТ-Режим"
7 Скролы позволяют работать в режиме "глаза воблы"
8 Если камера не обнаружена для проверки можно использовать DScaler
(http://deinterlace.sourceforge.net/russian/FAQ.htm )
9 Функция "супер зум" (в этой версии в отдельном модуле) включаете галку "ОБНОВЛЕНИЕ" отмечаете часть изображения мышкой нажимаете соответствующею кнопку..
10 Функция "Слежения" включается ответствующей галкой открывается чб визир можно повозится с настройкой ( Чувствительность , шаг сканера , сглаживание ) движение показывает зелеными точками ...
Да не забывайте включать галку "Обновление"
(Интересно отслеживать прохожих и машины на улице и по идее можно сделать например офисную охранную сигнализацию с отсылкой кадров по е-майлу или следилку за машиной под окнами ..)
[MAIN]
// Шаг поворота
StepR=10
// Максимально допустимый шум %
MaxTresh=35
// Минимальное совпадение %
MinEQ=75
//Начальный угол
BeginAngle=0
//Конечный угол
EndAngle=360
// Минимальная демонстратция
MinView=1
// Выход после завершения сравнеиня
AutoExit=0
RG 4_2
Подключил выделенные в отдельный модуль этапы с 5-го по 7-мой .
(То есть собственно распознавание образов )
В исходных данных передается название файла образца(маски) и список контуров для распознавания. +
Обработка результатов распознавания (Не в полном объеме). +
Настройка параметров из основной программы. +
// Гистерезисный порог
procedure HysteresisThreshold_approximate_Base(var r:TByteMap; bm:TByteMap; Tmin,TMax:Integer); Overload;
{14-20 тик на пиксель 1 канал}
var i,j:Integer;
LL:Integer;
p,p1,p2:PAByte;
// Реализация в 4 прохода с частичной потерью точности.
begin
p:=R.ScanLine[0];
p1:=bm.ScanLine[0];
for i:=1 to bm.Width-1 do
begin
if p1[i]> Tmin then p[i]:=80;
if (p1[i]> Tmax) or (p[i-1]=255) then p[i]:=255;
end;
for j:=1 to bm.Height-1 do
begin
p:=R.ScanLine[j];
p2:=R.ScanLine[j-1];
p1:=bm.ScanLine[j];
for i:=1 to bm.Width-1 do
begin
p[i]:=0;
if (p1[i]> Tmin) then
begin
p[i]:=$80;
if (p[i-1]=255) or (p2[i]=255) then p[i]:=255;
end;
if (p1[i]> Tmax) then p[i]:=255;
end;
end;
// Обратный проход
p:=R.ScanLine[bm.Height-1];
p1:=bm.ScanLine[bm.Height-1];
for i:=bm.Width-2 downto 0 do
begin
if (p[i]= $80) and (p[i+1]=255) then p[i]:=255;
end;
for j:=bm.Height-2 downto 0 do
begin
p:=R.ScanLine[j];
p2:=R.ScanLine[j+1];
p1:=bm.ScanLine[j];
for i:=bm.Width-2 downto 0 do
begin
if (p[i]= $80) and ((p[i+1]=255) or (p2[i]=255)) then p[i]:=255;
// if (p[i]= $80) then p[i]:=0;
end;
end;
// 3 проход
p:=R.ScanLine[0];
p1:=bm.ScanLine[0];
for i:=1 to bm.Width-1 do
begin
if (p[i]=$80) and (p[i-1]=255) then p[i]:=255;
end;
for j:=1 to bm.Height-1 do
begin
p:=R.ScanLine[j];
p2:=R.ScanLine[j-1];
p1:=bm.ScanLine[j];
for i:=1 to bm.Width-1 do
begin
if (p[i]=$80) and ((p[i-1]=255) or (p2[i]=255)) then p[i]:=255;
end;
end;
// 4 проход
// Обратный проход 2
p:=R.ScanLine[bm.Height-1];
p1:=bm.ScanLine[bm.Height-1];
for i:=bm.Width-2 downto 0 do
begin
if (p[i]= $80) and (p[i+1]=255) then p[i]:=255;
end;
for j:=bm.Height-2 downto 0 do
begin
p:=R.ScanLine[j];
p2:=R.ScanLine[j+1];
p1:=bm.ScanLine[j];
for i:=bm.Width-2 downto 0 do
begin
if (p[i]= $80) and ((p[i+1]=255) or (p2[i]=255)) then p[i]:=255;
if (p[i]= $80) then p[i]:=0;
end;
end;
end;
ПРИЛОЖЕНИЕ 1 Внешние Функции доступные из скрипта .
------------------------------------------------------
/// Основной набор
//Установить параметр или создать новый
Procedure SetParam(Name,Param:String);
//Получить параметр по имени
Function GetParam(Name:String):String;
//Получить ширину обрабатываемого изображения (пока одного из трех)
Function GetWidth(N:Integer):Integer;
// Получить высоту обрабатываемого изображения (пока одного из трех)
Function GetHeight(N:Integer):Integer;
// Изменить цвет точки (N(0..2) – номер изображения X Y Координаты точки )
Procedure SetPixel(N,X,Y,C:LongInt);
// Получить цвет точки (N(0..2) – номер изображения X Y Координаты точки)
Function GetPixel(N,X,Y:LongInt):LongInt);
// Записать строку для лога
Procedure SResult(S:String);
// Выдать сообщение
Procedure MSG (S:String);
// Выдать расширенное сообщение
Procedure WForm(M:String);
//Изменить состояние «полосы прогресса»
Procedure RunTime (M,T:Integer);
// Функции работы с цветом
function Red(rgb: LongInt): BYTE;
function Green(rgb: LongInt): BYTE;
function Blue(rgb: LongInt): BYTE;
function RGB(R, G, B: Byte):Longint;
// Яркость точки
// function BWColor(C: LongInt): BYTE;
// Функция копирования изображения
//(N1 -> N2)
// 0- Исходный кадр
// 1- Рабочий кадр (Обновляется после каждого этапа )
// 2- Запасной буфер
Procedure CopyImage(N1,N2:Integer);
// Функции работы со списком маркеров
function GetCountMarkerList:Longint;
Function MarkerWidth(N:Integer):Integer;
Function MarkerHeight(N:Integer):Integer;
Function GetMarkerPixel(N,X,Y:Integer):Integer;
Procedure SetMarkerPixel(N,X,Y,C:Integer);
//ДОПОЛНЕНИЕ Функции работы с рабочим списком
//1 Копировать область из осиновых изображений
//и добавить ее в рабочий список …
// (N 0-2 номер основного изображения )
Function ACopyIRToWork(N,X,Y,W,H:integer):integer;
//2 Добавить в рабочий список эталон маркера с масштабированием
// (N номер в списке маркеров )
Function MaskToWork(N,W,H:integer):integer;
//3 Изменить размер изображения в рабочем списке
// (N номер в списке маркеров )
Procedure WReSize(N,W,H:integer);
//4 Наложение изображения с логической операцией
// N1->N2 Mode – режим наложения
// Обычно нужно mode = cmSrcPaint = $00EE0086;
Procedure WLogicCopy(N1,N2,Mode:integer);
---------------- Полный список режимов ------------------
const
cmBlackness = BLACKNESS;
cmDstInvert = DSTINVERT;
cmMergeCopy = MERGECOPY;
cmMergePaint = MERGEPAINT;
cmNotSrcCopy = NOTSRCCOPY;
cmNotSrcErase = NOTSRCERASE;
cmPatCopy = PATCOPY;
cmPatInvert = PATINVERT;
cmPatPaint = PATPAINT;
cmSrcAnd = SRCAND;
cmSrcCopy = SRCCOPY;
cmSrcErase = SRCERASE;
cmSrcInvert = SRCINVERT;
cmSrcPaint = SRCPAINT;
cmWhiteness = WHITENESS;
SRCCOPY = $00CC0020; { dest = source }
SRCPAINT = $00EE0086; { dest = source OR dest }
SRCAND = $008800C6; { dest = source AND dest }
SRCINVERT = $00660046; { dest = source XOR dest }
SRCERASE = $00440328; { dest = source AND (NOT dest ) }
NOTSRCCOPY = $00330008; { dest = (NOT source) }
NOTSRCERASE = $001100A6; { dest = (NOT src) AND (NOT dest) }
MERGECOPY = $00C000CA; { dest = (source AND pattern) }
MERGEPAINT = $00BB0226; { dest = (NOT source) OR dest }
PATCOPY = $00F00021; { dest = pattern }
PATPAINT = $00FB0A09; { dest = DPSnoo }
PATINVERT = $005A0049; { dest = pattern XOR dest }
DSTINVERT = $00550009; { dest = (NOT dest) }
BLACKNESS = $00000042; { dest = BLACK }
WHITENESS = $00FF0062; { dest = WHITE }
//5 Количество изображений в рабочем списке
Function WCount:integer;
//6 Повернуть изображение (А -угол в градусах)
// N-номер изображения в рабочем списке
Procedure WRotate(N,A:integer);
//7 Получить цвет точки N-номер номер в рабочем списке X Y Координаты точки
Function WGetPixel(N,X,Y:Integer):Integer;
//8 Изменить цвет точки N-номер в рабочем списке X Y Координаты точки
Procedure WSetPixel(N,X,Y,C:Integer);
//9 Очистить рабочий список
Procedure WClear;
//10 Получить ширину изображения в рабочем списке
Function WWidth(N:Integer):Integer;
//11 Получить высоту изображения в рабочем списке
Function WHeight(N:Integer):Integer;
Будут вопросы пишите постараюсь ответить. Сейчас скорее всего вас тормозят скрипты. Если у вас есть Delphi XE то неплохо прогнать код через него. И посмотреть какие ошибки и предупреждения он пишет. Статический анализ вещь хорошая читаешь и видишь ошибки. Но скорее всего у вас ошибки стандартного плана выход за границы массива."синдрома вертикального прогресса " (Это когда сложность программы скачком уходит за пределы моего скромного понимания ) ..
For Y:=0 to H do begin
For X:=0 to W do begin
Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 116