Модуль uMain.

unit uMain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Buttons, ExtCtrls, jpeg, StdCtrls, Db, ADODB, Grids, DBGrids, DBCtrls,comobj;

type

TfoMain = class(TForm)

SpeedButton1: TSpeedButton;

SpeedButton2: TSpeedButton;

SpeedButton3: TSpeedButton;

SpeedButton4: TSpeedButton;

SpeedButton5: TSpeedButton;

Image1: TImage;

SpeedButton6: TSpeedButton;

Memo1: TMemo;

SpeedButton7: TSpeedButton;

ADOConnection1: TADOConnection;

procedure SpeedButton4Click(Sender: TObject);

procedure SpeedButton7Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure SpeedButton1Click(Sender: TObject);

procedure SpeedButton2Click(Sender: TObject);

procedure SpeedButton3Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

procedure RunSQL(q:TADOquery;close:boolean);

var

foMain: TfoMain;

ts:tstrings;

implementation

uses uConfig, uNewUser, UCompare, USound;

{$R *.DFM}

procedure RunSQL(q:TADOquery;close:boolean);

begin

try

q.Open;

except

on EOleException do q.Active:=false;

on EDatabaseError do q.Active:=false;

end;

if close then q.Active:=false;

// q.SQL.SaveToFile('db\1.sql');

end;

procedure TfoMain.SpeedButton4Click(Sender: TObject);

begin

if not assigned(foconfig) then

begin

Application.CreateForm ( Tfoconfig, foconfig );

end;

foconfig.show;

end;

procedure TfoMain.SpeedButton7Click(Sender: TObject);

begin

halt;

end;

procedure stringtobyte(s:string;var b:array of integer);

var x:integer;

begin

for x:=0 to 127 do b[x]:=ord(s[x+1]);

end;

procedure TfoMain.FormCreate(Sender: TObject);

var f:file;

Energ1:array[1..128]of integer;

Energ2,Energ3 : array[1..128]of byte;

x:integer;

v:array [0..127]of integer;

s:string;

begin

fomain.DoubleBuffered:=true;

end;

procedure TfoMain.SpeedButton1Click(Sender: TObject);

begin

if not assigned(fonewuser) then

begin

Application.CreateForm ( Tfonewuser, fonewuser );

end;

fonewuser.show;

end;

procedure TfoMain.SpeedButton2Click(Sender: TObject);

begin

if not assigned(form2) then

begin

Application.CreateForm ( Tform2, form2 );

end;

form2.show;

end;

procedure TfoMain.SpeedButton3Click(Sender: TObject);

begin

if not assigned(analizeform) then

begin

Application.CreateForm ( Tanalizeform, analizeform );

end;

analizeform.show;

end;

end.

Модуль Spectr

unit uSpectr;

interface

uses Sysutils,graphics,extctrls,windows;

procedure GetSpectr(filename:string;var spectr:array of integer);

function calc_fxy(energ11,energ21:array of integer):real;

implementation

type arr=array[0..10000]of byte;

sampl=array[0..1024]of real;

samplr=array[0..1024]of real;

comp=record re,im:real;end;

procedure FFTR(buf:array of comp);stdcall; external 'fftc.dll';

const k=0.5;

type pikrec=record

pos:integer;

lpc:integer;

l:integer;

end;

var left:array[0..200000]of smallint;

buf:array[0..200000]of byte;

procedure savevsd(s:string;energ:array of integer);

var f:file;

x:integer;

begin

assignfile(f,s);

rewrite(f,1);

blockwrite(f,energ,sizeof(energ),x);

closefile(f);

end;

function calc_fxy(energ11,energ21:array of integer):real;

var mx,my,s1,s2,s3:real;

i:integer;

begin

mx:=0;my:=0;

for i:=0 to 127 do

begin

mx:=mx+energ11[i];

my:=my+energ21[i];

end;

mx:=mx/128;

my:=my/128;

s1:=0;s2:=0;s3:=0;

for i:=0 to 127 do s1:=s1+((energ11[i]-mx)*(energ21[i]-my));

for i:=0 to 127 do s2:=s2+(sqr(energ11[i]-mx));

for i:=0 to 127 do s3:=s3+(sqr(energ21[i]-my));

s2:=sqrt(s2);

s3:=sqrt(s3)*s2;

if s3<>0 then result:=abs(s1/s3) else result:=0;

end;

function I0(X:real):real;

var Y, T, E, DE, SDE:real;

i:integer;

begin

Y := X/2;

T := 0.0000000001;

de:= 1;

E :=DE;

for i:=1 to 50 do

begin

DE := de*Y / i;

SDE := DE * DE;

E := e+SDE;

if (E*T-SDE>0) then break;

end;

result:= E;

end;

procedure KaiserWindow(source:sampl; length,b:integer;var result:sampl);

var i, k:integer;

iI0b:real;

h:real;

begin

iI0b:=1.0 / I0(b);

k := -(Length shr 2);

for i:=1 to Length shr 2 do

begin

inc(k);

h := I0(b*sqrt(1-sqr(2.0*k/(Length-1)))) * iI0b;

source[i]:=source[i] *h;

source[Length-1-i] := source[Length-1-i]*h;

end;

for i:=1 to length do result[i]:=source[i];

end;

procedure Liftering(source:sampl; length,b:integer;var result:sampl);

var i:integer;

w,xout:real;

begin

for i:=1 to Length do

begin

xout:=source[i]-0.9*w;

w:=0.54-0.46*cos(2*pi*(i-6)/179);

source[i]:=xout*w;

end;

for i:=1 to length do result[i]:=source[i];

end;

procedure Fft(source:sampl; length,step:integer;var result:sampl);forward;

procedure Fft(source:sampl; length,step:integer;var result:sampl);

var f,t:integer;

begin

for f:=1 to Length do

begin

Result[f]:=0.0;

for t:=1 to Length do

Result[f]:=Result[f]+ Source[t]*(-cos(PI*f*t/Length/2));

end;

end;

procedure GetSpectr(filename:string;var spectr:array of integer);

var step :integer;

sImage :array[1..500,1..128]of smallint;

x,y,n :integer;

energ :array[0..128]of integer;

bufc :array [0..512]of comp;

f :file;

chastota :sampl;

l :integer;

begin_crop,end_crop :integer;

max,min :integer;

xout,dz :real;

I :Integer;

xx :integer;

begin

assignfile(f,filename);

reset(f,1);

for n:=1 to 200000 do buf[n]:=0;

for n:=1 to 200000 do left[n]:=0;

seek(f,58);

BlockRead(F, buf, filesize(f), x);

end_crop:=x-100;

closefile(f);

for x:=1 to 128 do energ[x]:=0;

x:=1;

begin_crop:=200;

max:=0;

min:=255;

for l:=begin_crop to end_crop do if buf[l]<>0 then break;

begin_crop:=l;

for l:=begin_crop to end_crop do if buf[l]<min then min:=buf[l];

for l:=begin_crop to end_crop do

left[l]:=round((buf[l]+buf[l-1]+buf[l+1])/3)-128;

for l:=begin_crop to end_crop do

begin

xout:=LEFT[l]-0.90*dz;

dz:=left[l];

LEFT[l]:=round(xout*(0.54-0.46*cos((l-6)*6.2832/179)));

end;

repeat

inc(begin_crop);

until abs(left[begin_crop]-left[begin_crop+1])>4;

repeat

dec(end_crop);

until abs(left[end_crop]-left[end_crop-1])>4;

begin_crop:=begin_crop+512;

end_crop:=end_crop-512;

for l:=begin_crop to end_crop do

begin

if left[l]>max then max:=left[l];

end;

step:=round((end_crop-begin_crop)/500);

for x:=1 to 500 do for y:=1 to 128 do

begin

sImage[x,y]:=0;

end;

step:=64;

for y:=1 to 128 do energ[y]:=0;

//-=-=-=-=-= Analize

for x:=1 to 500 do

begin

if x*step+begin_crop< end_crop then begin

for i:=0 to 511 do

begin

bufc[I].Re:= left[i+x*step+begin_crop];

bufc[I].Im:=0;

end;

FFTR(bufc);//----

for i:=128 to 256 do chastota[i-128]:=(sqrt(sqr(bufc[I].Im)+sqr(bufc[I].re)));

Liftering(chastota,128,5,chastota);

KaiserWindow(chastota,128,10,chastota);

//////////////////////

for y:=1 to 125 do

begin

l:=abs(round(chastota[y]));

energ[y]:=energ[y]+l;

if l>255 then l:=255;

if l<0 then l:=0;

end;

end;

end;

//-=-=-=-=-=-=- end analize

energ[126]:=0;

for x:=1 to 125 do

begin

if energ[x]>y then y:=energ[x];

end;

y:=round(y/128);

xx:=1;

if y>0 then

begin

for xx:=1 to 128 do ;//spectr[xx]:=round(energ[xx]/y);

for xx:=0 to 127 do spectr[xx]:=round(energ[xx+1]/y);

for xx:=1 to 128 do energ[xx]:=round(energ[xx]/y);

end;

SaveVSD(ChangeFileExt(filename,'.vsd'),energ);

end;

end.

Модуль LoginSecure

unit uInMain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, DXClass, DXSounds, extCtrls, Buttons, Wave, uSpectr, uSpectrImage,Registry, Geometry, jpeg, DB, ADODB, Menus, comobj, opengl, bmp, cPanel;

type

TfoInMain = class(TForm)

Panel2: TPanel;

SpeedButton7: TSpeedButton;

Panel3: TPanel;

Label1: TLabel;

Label2: TLabel;

Image2: TImage;

Image5: TImage;

Edit2: TEdit;

Label7: TLabel;

Label9: TLabel;

Panel1: TPanel;

Image1: TImage;

Label3: TLabel;

Label4: TLabel;

Label5: TLabel;

Label6: TLabel;

ADOConnection1: TADOConnection;

ADOQuery1: TADOQuery;

Edit1: TEdit;

Image3: TImage;

Timer1: TTimer;

procedure SpeedButton7Click(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure FormCreate(Sender: TObject);

procedure Image5MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure Image5MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure SpeedButton7MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure Timer1Timer(Sender: TObject);

private

FCapture: TSoundCaptureStream;

FWaveStream: TWaveStream;

procedure CaptureFilledBuffer(Sender: TObject);

public

{ Public declarations }

end;

type

comp=record re,im:real;end;

const

GridSize = 63;

type TGLCoord = Record

X, Y, Z : glFloat;

end;

var

h_Wnd : HWND; // Global window handle

h_DC : HDC; // Global device context

h_RC : HGLRC; // OpenGL rendering context

keys : Array[0..255] of Boolean; // Holds keystrokes

FPSCount : Integer = 0; // Counter for FPS

ElapsedTime : Integer; // Elapsed time between frames

// Textures

WaterTexture : glUint;

// User vaiables

RainInterval : Integer;

Viscosity : glFloat;

Position : Array[0..GridSize, 0..GridSize] of glFloat;

Velocity : Array[0..GridSize, 0..GridSize] of glFloat;

Vertex : Array[0..GridSize, 0..GridSize] of TglCoord;

Normals:array [0..GridSize, 0..GridSize] of TglCoord;

xAngle, yAngle : glFloat;

var

foInMain : TfoInMain;

Needformat,i,x,y : integer;

bufc : array [1..512]of comp;

energ,Energ1,Energ2,Energ3 : array[1..128]of integer;

CurSampl : integer=0;

k1,k2,l3,max:integer;

wndClass : TWndClass; // Window class

dwStyle : DWORD; // Window styles

dwExStyle : DWORD; // Extended window styles

dmScreenSettings : DEVMODE; // Screen settings (fullscreen, etc...)

PixelFormat : GLuint; // Settings for the OpenGL rendering

h_Instance : HINST; // Current instance

pfd : TPIXELFORMATDESCRIPTOR; // Settings for the OpenGL window

DC:hdc;

procedure FFTR(buf:array of comp);stdcall; external 'fftc.dll';

implementation

{$R *.DFM}

procedure glBindTexture(target: GLenum; texture: GLuint); stdcall; external opengl32;

{------------------------------------------------------------------}

{ Function to convert int to string. (No sysutils = smaller EXE) }

{------------------------------------------------------------------}

function IntToStr(Num : Integer) : String; // using SysUtils increase file size by 100K

begin

Str(Num, result);

end;

procedure DrawWater;

var I, J : Integer;

VectLength : glFloat;

begin

// Calculate new velocity

For I :=2 to GridSize-2 do

For J :=2 to GridSize-2 do

Velocity[I, J] := Velocity[I, J] + (Position[I, J] -

(4*(Position[I-1,J] + Position[I+1,J] + Position[I,J-1] + Position[I,J+1]) + // left, right, above, below

Position[I-1,J-1] + Position[I+1,J-1] + Position[I-1,J+1] + Position[I+1,J+1])/25) / 7; // diagonally across

// Calculate the new ripple positions

For I:=2 to GridSize-2 do

For J:=2 to GridSize-2 do

Begin

Position[I, J] :=

foInMain.image1.Picture.Bitmap.Canvas.Pixels[round(i*(500/GridSize)),

round(j*(128/GridSize))]/800;

// Velocity[I, J] := Velocity[I, J] * Viscosity;

End;

// Calculate the new vertex coordinates

For I :=0 to GridSize do

For J :=0 to GridSize do

begin

Vertex[I, J].X :=(I - GridSize/2)/GridSize*5;

Vertex[I, J].Y :=(Position[I, J] / 1024)/GridSize*3;

Vertex[I, J].Z :=(J - GridSize/2)/GridSize*5;

end;

// Calculate the new vertex normals.

// Do this by using the points to each side to get the right angle

For I :=0 to GridSize do

begin

For J :=0 to GridSize do

begin

If (I > 0) and (J > 0) and (I < GridSize) and (J < GridSize) then

begin

with Normals[I, J] do

begin

X := Position[I+1, J] - Position[I-1,J];

Y := -2048;

Z := Position[I, J+1] - Position[I, J-1];

VectLength :=sqrt(x*x + y*y + z*z);

if VectLength <> 0 then

begin

X :=X/VectLength;

Y :=Y/VectLength;

Z :=Z/VectLength;

end;

end;

end

else

begin

Normals[I, J].X :=0;

Normals[I, J].Y :=1;

Normals[I, J].Z :=0;

end;

end;

end;

// Draw the water texture

glBindTexture(GL_TEXTURE_2D, WaterTexture);

For J :=0 to GridSize-1 do

begin

glBegin(GL_QUAD_STRIP);

for I :=0 to GridSize do

begin

glNormal3fv(@Normals[I, J+1]);

glTexCoord2f(I/GridSize, (J+1)/GridSize);

glVertex3fv(@Vertex[I, J+1]);

glNormal3fv(@Normals[I, J]);

glTexCoord2f(I/GridSize, J/GridSize);

glVertex3fv(@Vertex[I, J]);

end;

glEnd;

end;

end;

procedure glDraw();

VAR ps : TPaintStruct;

begin

// BeginPaint(h_wnd, ps);

glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); // Clear The Screen And The Depth Buffer

glLoadIdentity();// Reset The View

glTranslatef(0.0,0.2,-4.5);

glRotatef(xAngle, 1, 0, 0);

glRotatef(yAngle, 0, 1, 0);

glColor3f(0.85, 1, 0.85);

DrawWater;

// endPaint(h_wnd, ps);

SwapBuffers(DC);

end;

{ Initialise OpenGL }

procedure glInit();

var I, J : Integer;

begin

glClearColor(0.9, 0.9, 0.9, 0.0); //Background

glShadeModel(GL_SMOOTH);

glClearDepth(1.0);

glEnable(GL_DEPTH_TEST);

glDepthFunc(GL_LESS);

glBlendFunc(GL_SRC_COLOR, GL_ONE);

glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST);

glEnable(GL_TEXTURE_2D);

LoadTexture('reflection.bmp', WaterTexture);

// enable spherical environment maping

// glEnable(GL_BLEND);

glTexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP);

glTexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP);

glEnable(GL_TEXTURE_GEN_S);

glEnable(GL_TEXTURE_GEN_T);

Viscosity :=0.96;

For I :=0 to GridSize do

begin

For J :=0 to GridSize do

begin

Position[I, J] :=0;

Velocity[I, J] :=0;

end;

end;

xAngle :=15;

yAngle :=60;

end;

function calc_fxy(energ11,energ21:array of integer):real;

var mx,my,s1,s2,s3:real;

i:integer;

begin

mx:=0;my:=0;

for i:=0 to 127 do

begin

mx:=mx+energ11[i];

my:=my+energ21[i];

end;

mx:=mx/128;

my:=my/128;

s1:=0;s2:=0;s3:=0;

for i:=0 to 127 do s1:=s1+((energ11[i]-mx)*(energ21[i]-my));

for i:=0 to 127 do s2:=s2+(sqr(energ11[i]-mx));

for i:=0 to 127 do s3:=s3+(sqr(energ21[i]-my));

s2:=sqrt(s2);

s3:=sqrt(s3)*s2;

if s3<>0 then result:=abs(s1/s3) else result:=0;

end;

procedure TfoInMain.SpeedButton7Click(Sender: TObject);

begin

close;

end;

procedure TfoInMain.CaptureFilledBuffer(Sender: TObject);

var buf:array[0..512]of byte;

bufI:array[0..512]of integer;

i,x,max:integer;

Image:timage;

begin

FWaveStream.CopyFrom(FCapture, FCapture.FilledSize);

FWaveStream.Seek(FWaveStream.Size-512,0);

FWaveStream.read(buf,512);

for i:=1 to 512 do

begin

bufc[I].Re:= buf[i]-128;

bufc[I].Im:=0//left[i+x*step+begin_crop];

end;

fftr(bufc);

if cursampl=1 then image:=image2;

Image.Canvas.Brush.Color:=clwhite;

Image.Canvas.Rectangle(0,0,Image.width,Image.Height);

for i:=128 to 256 do bufi[i-128]:=round((sqrt(sqr(bufc[I].Im)+sqr(bufc[I].re)))/3);

for i:=1 to 128 do if bufi[i]>255 then bufi[i]:=255;

for x:=1 to 4 do for y:=2 to 127 do

bufi[y]:=round((bufi[y-1]+bufi[y]+bufi[y+1])/3);

Image.Canvas.Brush.Color:=clblack;

for i:=1 to 16 do

begin

max:=0;

if (i-1)*8+x<126 then

for x:=1 to 8 do if bufi[(i-1)*8+x]>max then max:=bufi[(i-1)*8+x];

Image.Canvas.Rectangle((i-1)*8,128,i*8-1,128-max);

end;//

end;

procedure TfoInMain.FormClose(Sender: TObject; var Action: TCloseAction);

begin

foInMain.Release;

foInMain := nil;

end;

procedure RunSQL(q:TADOquery;close:boolean);

begin

try

q.Open;

except

on EOleException do q.Active:=false;

on EDatabaseError do q.Active:=false;

end;

if close then q.Active:=false;

q.SQL.SaveToFile('db\1.sql');

end;

procedure bytetostring(b:array of integer;var s:string);

begin

s:='';

for x:=0 to 127 do

s:=s+chr(b[x]+1);

end;

procedure stringtobyte(s:string;var b:array of integer);

begin

for x:=0 to 127 do b[x]:=ord(s[x+1]);

end;

procedure glResizeWnd(Width, Height : Integer);

begin

if (Height = 0) then // prevent divide by zero exception

Height := 1;

glViewport(0, 0, Width, Height); // Set the viewport for the OpenGL window

glMatrixMode(GL_PROJECTION); // Change Matrix Mode to Projection

glLoadIdentity(); // Reset View

gluPerspective(45.0, Width/Height, 1.0, 100.0); // Do the perspective calculations. Last value = max clipping depth

glMatrixMode(GL_MODELVIEW); // Return to the modelview matrix

glLoadIdentity(); // Reset View

end;

Procedure SetDCPixelFormat;

var

nPixelFormat: Integer;

pfd: TPixelFormatDescriptor;

begin

FillChar(pfd, SizeOf(pfd),0);

with pfd do begin

nSize := sizeof(pfd); // Size of this structure

nVersion := 1; // Version number

dwFlags := PFD_DRAW_TO_WINDOW or

PFD_SUPPORT_OPENGL or

PFD_DOUBLEBUFFER; // Flags

iPixelType:= PFD_TYPE_RGBA; // RGBA pixel values

cColorBits:= 24; // 24-bit color

cDepthBits:= 32; // 32-bit depth buffer

iLayerType:= PFD_MAIN_PLANE; // Layer type

end;

nPixelFormat := ChoosePixelFormat(DC, @pfd);

SetPixelFormat(DC, nPixelFormat, @pfd);

DescribePixelFormat(DC, nPixelFormat, sizeof(TPixelFormatDescriptor), pfd);

end;

procedure TfoInMain.FormCreate(Sender: TObject);

var Reg: TRegistry;

s:string;

us_id:string;

begin

Reg := TRegistry.Create;

try

Reg.RootKey := HKEY_CURRENT_USER;

if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Explorer', false)

then s:=Reg.REadString('Logon User Name');

finally

Reg.CloseKey;

Reg.Free;

inherited;

end;

edit2.Text:=s;

edit1.Text:=s;

left:=0;

top:=0;

height:=screen.height;

width:=screen.width;

speedbutton7.left:=width-speedbutton7.Width-5;

Image1.Canvas.Brush.Color:=clwhite;

Image1.Canvas.Rectangle(0,0,Image1.width,Image1.Height);

GetSpectrPicture('test1.wav',image1,3);

ADOquery1.Active:=false;

ADOquery1.SQL.Clear;

ADOquery1.SQL.add('select * from userinfo where (deleted=0) and (login='+chr(39)+edit2.Text+chr(39)+')');

RunSQL(ADOquery1,false);

us_id:=ADOquery1.FieldByName('user_id').asstring;

ADOquery1.Active:=false;

ADOquery1.SQL.Clear;

ADOquery1.SQL.add('select * from reg where (deleted=0) and (user_id='+us_id+')');

RunSQL(ADOquery1,false);

ADOquery1.First;

while not ADOquery1.eof do

with ADOquery1 do

begin

if ADOquery1.FieldByName('number').asinteger=1 then

begin

s:=ADOquery1.FieldByName('spectr').AsString;

stringtobyte(s,energ1);

end;

if ADOquery1.FieldByName('number').asinteger=2 then

begin

s:=ADOquery1.FieldByName('spectr').AsString;

stringtobyte(s,energ2);

end;

if ADOquery1.FieldByName('number').asinteger=3 then

begin

s:=ADOquery1.FieldByName('spectr').AsString;

stringtobyte(s,energ3);

end;

ADOquery1.Next;

end;

h_wnd:=panel1.Handle;

DC := GetDC(h_wnd);

SetDCPixelFormat;

H_RC := wglCreateContext(DC);

wglMakeCurrent(DC, H_RC);

// gluPerspective(45.0, panel1.Width/panel1.Height, 1.0, 100.0); // Do the perspective calculations. Last value = max clipping depth

// glViewport(0, 0, panel1.Width, panel1.Height); // Set the viewport for the OpenGL window

glMatrixMode(GL_PROJECTION); // Change Matrix Mode to Projection

glLoadIdentity(); // Reset View

glMatrixMode(GL_MODELVIEW); // Return to the modelview matrix

glLoadIdentity(); // Reset View

glResizeWnd(panel1.Width, panel1.Height);

glinit;

end;

procedure TfoInMain.Image5MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if sender = image5 then cursampl:=1;

if cursampl<>0 then begin

deletefile('test.wav');

//--------

FCapture.Free;

FCapture := TSoundCaptureStream.Create(nil);

FWaveStream := TWaveFileStream.Create('test.wav', fmCreate);

with FCapture.SupportedFormats[8] do

FWaveStream.SetPCMFormat(22050, 8, 1);

FWaveStream.Open(True);

FCapture.OnFilledBuffer := CaptureFilledBuffer;

FCapture.CaptureFormat := 8;

FCapture.Start;

end;

end;

procedure TfoInMain.Image5MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var spectr:array[1..128]of integer;

i1,i2,i3,max:real;

i:integer;

image:timage;

f:file;

begin

if FCapture<>nil then

FCapture.Stop;

FWaveStream.Free; FWaveStream := nil;

if cursampl=1 then begin image:=image2;end;

getspectr('test.wav',spectr);

Image.Canvas.Brush.Color:=clwhite;

Image.Canvas.Rectangle(0,0,Image.width,Image.Height);

Image.Canvas.MoveTo(0,128);

for i:=1 to 128 do

begin

Image.Canvas.LineTo(i,128-spectr[i]);

energ[i]:=spectr[i];

end;

cursampl:=0;

Image1.Canvas.Brush.Color:=clwhite;

Image1.Canvas.Rectangle(0,0,Image1.width,Image1.Height);

GetSpectrPicture('test.wav',image1,6);

max:=0;

i1:=calc_fxy(energ1,energ);

if i1>max then max:=i1;

i2:=calc_fxy(energ2,energ);

if i2>max then max:=i2;

i3:=calc_fxy(energ3,energ);

if i3>max then max:=i3;

label4.caption:=inttostr(round(i1*100));

label5.caption:=inttostr(round(i2*100));

label6.caption:=inttostr(round(i3*100));

end;

procedure TfoInMain.SpeedButton7MouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

close;

end;

procedure TfoInMain.Timer1Timer(Sender: TObject);

begin

// Velocity[random(GridSize-3)+2, random(GridSize-3)+2] :=1060;

yAngle :=yangle+0.5;

glDraw();

end;

end.

Модуль FFTC.CPP

//---------------------------------------------------------------------------

// VoiceSec module. FFT transform.

// 10.2002

//

// author email viman@pisem.net

//

//---------------------------------------------------------------------------

#include <vcl.h>

#include "fft.h"

#pragma hdrstop

#define WINDOW_RECTANGLE 0

#define WINDOW_HAMMING 1

#define WINDOW_BLACKMAN 2

#define WINDOW_BARTLETT 3

#define WINDOW_TRIANGLE 3

#define WINDOW_HANNING 4

#define MATH_PI 3.141592653589793

inline int Round(double x) { return (int)(x+0.5); }

inline long double sqr(long double x) { return x*x; }

int FFTSize;

#ifdef __cplusplus

extern "C" {

#endif

__declspec( dllexport )

void FFTC(Cmplx *X,int FFTSize)

{

int N, M, i, j, L, LE, LE2, ip, k, s;

Cmplx t,z;

RealData UR, UI, SR, SI, TR, TI;

N = FFTSize;

M = Round(log(N)/log(2));

// Bit-reverse

i = 0;

for (s=0;s<N-1;s++) {

if (s<i) {

t = *(X+i); *(X+i) = *(X+s); *(X+s) = t;

}

k = N >> 1;

while (i&k) k >>= 1;

i += k;

k <<= 1;

while (k<N) {

i -= k;

k <<= 1;

}

}

// First pass

for (i=0;i<N;i+=2) {

t = *(X+i);

(X+i)->Re = t.Re + (X+i+1)->Re;

(X+i)->Im = t.Im + (X+i+1)->Im;

(X+i+1)->Re = t.Re - (X+i+1)->Re;

(X+i+1)->Im = t.Im - (X+i+1)->Im;

}

// Second pass

for (i=0;i<N;i+=4) {

t = *(X+i);

(X+i)->Re = t.Re + (X+i+2)->Re;

(X+i)->Im = t.Im + (X+i+2)->Im;

(X+i+2)->Re = t.Re - (X+i+2)->Re;

(X+i+2)->Im = t.Im - (X+i+2)->Im;

t = *(X+i+1);

z = *(X+i+3);

(X+i+1)->Re = t.Re + z.Im;

(X+i+1)->Im = t.Im - z.Re;

(X+i+3)->Re = t.Re - z.Im;

(X+i+3)->Im = t.Im + z.Re;

}

// Last passes

for (L=3;L<=M;L++) {

LE = 1 << L;

LE2 = LE >> 1;

UR = 1; UI = 0;

SR = cos(MATH_PI/LE2);

SI = -sin(MATH_PI/LE2);

for (j=0;j<LE2;j++) {

for (i=j;i<N;i+=LE) {

ip = i + LE2;

TR = (X+ip)->Re*UR - (X+ip)->Im*UI;

TI = (X+ip)->Re*UI + (X+ip)->Im*UR;

(X+ip)->Re = (X+i)->Re - TR;

(X+ip)->Im = (X+i)->Im - TI;

(X+i)->Re = (X+i)->Re + TR;

(X+i)->Im = (X+i)->Im + TI;

}

TR = UR;

UR = TR*SR - UI*SI;

UI = TR*SI + UI*SR;

}

}

}

}

#ifdef __cplusplus

#endif

#ifdef __cplusplus

extern "C" {

#endif

__declspec( dllexport )void

FFTR(Cmplx *X) {

int N, ND2, ND4;

int i, im, ip2, ipm, ip;

RealData UR, UI, SR, SI, TR, TI;

FFTSize=256;

// Separate even and odd points

N = FFTSize;

ND2 = N>>1;

ND4 = ND2>>1;

for (i=0;i<ND2;i++) {

(X+i)->Re = (X+(i<<1))->Re;

(X+i)->Im = (X+(i<<1)+1)->Re;

}

// Calculate N/2 point FFT

FFTSize = ND2;

FFTC(X,FFTSize);

FFTSize = N;

// Even/odd frequency domain decomposition

for (i=1;i<ND4;i++) {

im = ND2 - i;

ip2 = i + ND2;

ipm = im + ND2;

(X+ipm)->Re = (X+ip2)->Re = ((X+i)->Im + (X+im)->Im)*0.5;

(X+ip2)->Im = ((X+i)->Re - (X+im)->Re)*(-0.5);

(X+ipm)->Im = - (X+ip2)->Im;

(X+im)->Re = (X+i)->Re = ((X+i)->Re + (X+im)->Re)*0.5;

(X+i)->Im = ((X+i)->Im - (X+im)->Im)*0.5;

(X+im)->Im = - (X+i)->Im;}

(X+N*3/4)->Re = (X+ND4)->Im;

(X+ND2)->Re = X->Im;

(X+ND2+ND4)->Im = (X+ND2)->Im = (X+ND4)->Im = X->Im = 0;

// Complete the last FFT stage

// First step: calculate X[0] and X[N/2]

TR = (X+ND2)->Re;

TI = (X+ND2)->Im;

(X+ND2)->Re = X->Re - TR;

(X+ND2)->Im = X->Im - TI;

X->Re = X->Re + TR;

X->Im = X->Im + TI;

// Other steps

UR = SR = cos(MATH_PI/ND2);

UI = SI = -sin(MATH_PI/ND2);

ip = ND2+1;

for (i=1;i<ND2;i++,ip++) {

TR = (X+ip)->Re*UR - (X+ip)->Im*UI;

TI = (X+ip)->Re*UI + (X+ip)->Im*UR;

(X+ip)->Re = (X+i)->Re - TR;

(X+ip)->Im = (X+i)->Im - TI;

(X+i)->Re = (X+i)->Re + TR;

(X+i)->Im = (X+i)->Im + TI;

(X+i)->Re = (X+i)->Re + (X+ip)->Re*UR - (X+ip)->Im*UI;

(X+i)->Im = (X+i)->Im + (X+ip)->Re*UI + (X+ip)->Im*UR;

TR = UR;

UR = TR*SR - UI*SI;

UI = TR*SI + UI*SR;

}

}}

#ifdef __cplusplus

#endif

int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*)

{

return 1;

}

Размещено на Allbest.ru