Форум: "Media";
Текущий архив: 2004.05.02;
Скачать: [xml.tar.bz2];

Вниз

Оцифровка гафиков   Найти похожие ветки 

← →
Галинка ©   (2004-02-03 12:29) [0]

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

Значит теперь задача такая... Имеется файл (*.jpg) с изображением исходной сейсмограммы. Его нада загрузить в TImage и оцифровать. Т.е. раскрасить трассы разными цветами, а потом через определенный шаг по Х поднять перепендикуляры, до точек нужных цветов.

Раскрашивать кривые думаю, апроксиммируя их ломанной заданного цвета.
Цвета всех ломанных буду запоминать, наверное, в массив - TColorArray = array of TColor;

Вот вкраце суть новой заморочки... Только громко не смейтесь и сильно не плюйтесь... Мониторы всетаки ваши... :)

Заранее спасибо всем кто ответит. Если что не понятно спрашивайте.

---

← →
Галинка ©   (2004-02-03 12:56) [1]

Для Ромкина:
Так и не так...
1) Вывести изображение;
2) Зарегистрировать его в нужной системе отсчета, типа апмлитуда - время (y-x);
3) Обвести трассы нужными цветами, запомнив цвета в какой-то структуре, ну типа массива;
4) Задать шаг оцифровки в реальных (времени) единицах, оттранслировать его в единицы изображения;
5) "Просканировать" изображение по вертикалям через deltax с целью выявления точек заданного цвета (цвета беруться из заранее сохраненной стурктуры);
6) Как только нашли точку, заносим её в динамический массив "на свое место".

Пока все.

---

← →
Romkin ©   (2004-02-03 13:11) [2]

Мдя... Поясняю...
0. Имеется изображение в формате jpg, содержащее группу кривых, по всей видимости, представляющих собой затухающие колебания с относительно большой амплитудой, что позволяет применить к ним кусочно-линейную интерполяцию.
1. вывести изображение на экран (форму)
2. Пользователь определяет ширину и высоту изображения соответственно в единицах времени и амплитуды
3. Пользователь производит обводку каждой кривой на изображении своим цветом, пользуясь манипулятором типа "мышь" или аналогичным
4. Пользователь задает желаемый шаг оцифровки в единицах времени
5. Программа должна для каждой кривой сформировать свой массив отсчетов амплитуды через указанный шаг оцифровки. Этот массив является результатом.
Уф... Вроде все...
Теперь можно думать, обсуждать...

---

← →
Romkin ©   (2004-02-03 13:54) [3]

Общие соображения:
1. - 2. Технически решаемо через TImage, и тд...
3. Цвета можно выбрать заранее, я думаю, это непринципиально и касается интерфейса. Обводка, думаю, должна производиться кликами мышкой по узловым точкам. Для первого приближения достаточно не делать исправления неправильного указания, это второй этап. В результате клика организуется массив TPoint, содержащий список точек в координатах изображения. Поскольку количество точек для данной кривой заранее не определено, первоначальная записть производится в односвязный список. Далее данный список переводится в массив с координатами, заданными в п.2
4. Результатом п.3 является массив множеств точек, заданных координатами (время, амплитуда). Количество данных множеств соответствует количеству кривых. Требуется сформировать для каждой кривой массив отсчетов с фиксированным шагом, вычислив значение амплитуды. Типичная задача интерполяции.
5. Итак, для каждой кривой: имеется упорядоченный массив из N элементов (время, амплитуда), причем составляющая "время" каждого последующего элемента строго больше данной составляющей предыдущего. Формируем второй массив, размером N-1, содержащий коэффициенты (a,b) аппроксимирующей прямой A = a*T + b. Далее, начав с левого отсчета, наращивая время на шаг дискретизации, для каждого отсчета по первому массиву определяется отрезок, в котороый попал отсчет, и значение амплитуды вычисляется по приведенной формуле на основе данных второго массива. В случае, если отсчет попадает точно в точку оцифровки, второй массив не используется, берется точный отсчет.
Все вроде ;)

---

← →
Галинка ©   (2004-02-03 15:10) [4]

Для Ромкина.

А можно по-конкретнее пункт 3 из Romkin ©   (03.02.04 13:11) [2].
Потомучто как раз это пока и не получается.

Заранее спасибо.

---

← →
xn0bys ©   (2004-02-03 16:07) [5]

Берем Image (в памяти! или лучше bitmap) запихиваем в него твой график маштабируем его как хочем, запоминаем mx, my.
Имеем 2-й image уже на форме (ВСЕГДА В МАСШТАБЕ 1:1) и копируем в него твой УЖЕ ПРОМАШТАБИРОВАННЫЙ ГРАФИК, потом уже кликаем мышкой по нашему (видимому) имиджу.

---

← →
Romkin ©   (2004-02-03 18:17) [6]

По-конкретнее это как? :))
Вот, правда, с прорисовкой подладить надо, я целую вечность такого не делал...
Итак, кривые:
unit Curves;

interface

uses Classes, types, Graphics;

type
 PCurve = ^TCurve;
 TCurve = record
   X, Y: LongInt;
   Next: PCurve;
 end;

 PCurveHead = ^TCurveHead;
 TCurveHead = record
   Color: TColor;
   Curve: PCurve;
 end;

 TCurveArray = array of TPoint;

 TCurves = class
 private
   FCurves: TList;
   function GetCurve(Index: integer): PCurve;
   procedure FreeCurve(Index: integer);
   function GetColor(Index: integer): TColor;
   function GetCount: integer;
   procedure CheckExists(Index: integer);
   function GetLastPoint(Index: integer): TPoint;
   procedure SetColor(Index: integer; const Value: TColor);
 public
   constructor Create;
   destructor Destroy; override;
   function NewCurve: integer; //return new curve index
   //all Index is the index of curve
   procedure AddPoint(Index: integer; Point: TPoint);
   procedure DelCurve(Index: integer);
   function PointArray(Index: integer): TCurveArray;
   property Curve[Index: integer]: PCurve read GetCurve;
   property Color[Index: integer]: TColor read GetColor write SetColor;
   property LastPoint[Index: integer]: TPoint read GetLastPoint;
   property Count: integer read GetCount;
 end;

implementation

uses SysUtils;

{ TCurves }

procedure TCurves.AddPoint(Index: integer; Point: TPoint);
var
 Curve: PCurve;
begin
 CheckExists(Index);
 new(Curve);
 Curve.Next := PCurveHead(FCurves[Index])^.Curve;
 PCurveHead(FCurves[Index])^.Curve := Curve;
 Curve^.X := Point.X;
 Curve^.Y := Point.Y;
end;

constructor TCurves.Create;
begin
 inherited;
 FCurves := TList.Create;
end;

function TCurves.PointArray(Index: integer): TCurveArray;
var
 Curr: PCurve;
 i, len: integer;
begin
 Result := nil;
 Curr := GetCurve(Index);
 len := 0;
 while assigned(Curr) do
 begin
   inc(len);
   Curr := Curr^.Next;
 end;
 if len = 0 then exit;
 SetLength(Result, len);
 Curr := GetCurve(Index);
 for i := High(Result) downto Low(Result) do
   with Result[i] do
   begin
     X := Curr^.X;
     Y := Curr^.Y;
     Curr := Curr^.Next;
   end;
end;

procedure TCurves.DelCurve(Index: integer);
begin
 FreeCurve(Index);
 FCurves.Delete(Index);
end;

destructor TCurves.Destroy;
var
 i: integer;
begin
 if assigned(FCurves) then
 begin
   for i := 0 to FCurves.Count - 1 do
     FreeCurve(i);
   FCurves.Clear;
   FCurves.Free;
 end;
 inherited;
end;

procedure TCurves.FreeCurve(Index: integer);
var
 Curve, tmp: PCurve;
 CurveHead: PCurveHead;
begin
 Curve := GetCurve(Index);
 while assigned(Curve) do
 begin
   tmp := Curve;
   Curve := tmp^.Next;
   Dispose(tmp);
 end;
 CurveHead := PCurveHead(FCurves[Index]);
 if assigned(CurveHead) then
   Dispose(CurveHead);
end;

function TCurves.GetCurve(Index: integer): PCurve;
begin
 CheckExists(Index);
 Result := PCurveHead(FCurves[Index])^.Curve;
end;

function TCurves.NewCurve: integer;
var
 CurveHead: PCurveHead;
begin
 New(CurveHead);
 CurveHead^.Curve := nil;
 Result := FCurves.Add(CurveHead);
end;

function TCurves.GetColor(Index: integer): TColor;
var
 CurveHead: PCurveHead;
begin
 CheckExists(Index);
 CurveHead := PCurveHead(FCurves[Index]);
 Result := CurveHead^.Color;
end;

function TCurves.GetCount: integer;
begin
 Result := FCurves.Count;
end;

procedure TCurves.CheckExists(Index: integer);
begin
 if not assigned(FCurves[Index]) then
   raise Exception.CreateFmt("Curve with index %d not found", [Index]);
end;

function TCurves.GetLastPoint(Index: integer): TPoint;
var
 Curve: PCurve;
begin
 Result.X := 0;
 Result.Y := 0;
 Curve := GetCurve(Index);
 if assigned(Curve) then
 begin
   Result.X := Curve^.X;
   Result.Y := Curve^.Y;
 end;
end;

procedure TCurves.SetColor(Index: integer; const Value: TColor);
var
 CurveHead: PCurveHead;
begin
 CheckExists(Index);
 CurveHead := PCurveHead(FCurves[Index]);
 CurveHead^.Color := Value;
end;

end.

---

← →
Romkin ©   (2004-02-03 18:18) [7]

Можно, конечно, все через объекты, но мне понравилось именно так :))
Теперь применение:
unit Unit2;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, ExtCtrls, jpeg, Buttons, StdCtrls, Curves;

type
 TForm2 = class(TForm)
   sbImg: TScrollBox;
   img: TImage;
   pbCurve: TPaintBox;
   SpeedButton1: TSpeedButton;
   SpeedButton2: TSpeedButton;
   Shape1: TShape;
   Shape2: TShape;
   Shape3: TShape;
   stX: TStaticText;
   stY: TStaticText;
   Label1: TLabel;
   Label2: TLabel;
   memPoints: TMemo;
   procedure FormShow(Sender: TObject);
   procedure pbCurveMouseMove(Sender: TObject; Shift: TShiftState; X,
     Y: Integer);
   procedure Shape1MouseUp(Sender: TObject; Button: TMouseButton;
     Shift: TShiftState; X, Y: Integer);
   procedure SpeedButton1Click(Sender: TObject);
   procedure pbCurvePaint(Sender: TObject);
   procedure FormCreate(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
   procedure SpeedButton2Click(Sender: TObject);
   procedure pbCurveMouseUp(Sender: TObject; Button: TMouseButton;
     Shift: TShiftState; X, Y: Integer);
 private
   FCurves: TCurves;
   FDrawing: boolean;
   FCurveIndex: integer;
   FColor: TColor;
   FLastX: Longint;
   FLastY: Longint;
   procedure SetColor(const Value: TColor);
   procedure RepaintCurve;
   function GetCurveIndex: integer;
   procedure SetCurveIndex(const Value: integer);
   procedure ShowCurves;
   { Private declarations }
 public
   property CurveColor: TColor read FColor write SetColor;
   property CurveIndex: integer read GetCurveIndex write SetCurveIndex;
   { Public declarations }
 end;

var
 Form2: TForm2;

implementation

{$R *.dfm}

procedure TForm2.FormShow(Sender: TObject);
begin
 img.Top := 0;
 img.Left := 0;
 pbCurve.Top := 0;
 pbCurve.Left := 0;
 pbCurve.Width := img.Width;
 pbCurve.Height := img.Height;
end;

procedure TForm2.SetColor(const Value: TColor);
begin
 FCurves.Color[FCurveIndex] := Value;
 RepaintCurve;
end;

procedure TForm2.RepaintCurve;
var
 CurveArray: TCurveArray;
 CurveIndex: integer;
 Rect: TRect;
begin
 Rect.Left := 0;
 Rect.Top := 0;
 Rect.Right := pbCurve.Width ;
 Rect.Bottom := pbCurve.Height;
 //pbCurve.Canvas.FillRect(Rect);
 pbCurve.canvas.Pen.Mode := pmCopy;
 for CurveIndex := 0 to FCurves.Count - 1 do
 with pbCurve.Canvas do
 begin
   Pen.Color := FCurves.Color[CurveIndex];
   CurveArray := FCurves.PointArray(CurveIndex);
   Polyline(CurveArray);
   CurveArray := nil;
 end;
end;

procedure TForm2.pbCurveMouseMove(Sender: TObject; Shift: TShiftState; X,
 Y: Integer);
var
 LastPoint: TPoint;
begin
 stX.Caption := IntToStr(X);
 stY.Caption := IntToStr(Y);
 if not FDrawing then exit;
 if FCurveIndex < 0 then exit;
 with pbCurve.Canvas do
 begin
   LastPoint := FCurves.LastPoint[FCurveIndex];
   moveTo(LastPoint.X, LastPoint.Y);
   Pen.Mode := pmXor;
   LineTo(FLastX, FLastY);
   moveTo(LastPoint.X, LastPoint.Y);
   LineTo(X, Y);
   FLastX := X;
   FLastY := Y;
 end;
end;

procedure TForm2.Shape1MouseUp(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 if FCurveIndex < 0 then exit;
 FCurves.Color[FCurveIndex] := (Sender as TShape).Brush.Color;
end;

procedure TForm2.SpeedButton1Click(Sender: TObject);
begin
 pbCurve.Cursor := crCross;
 FDrawing := True;
end;

procedure TForm2.pbCurvePaint(Sender: TObject);
begin
 RepaintCurve;
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
 FCurveIndex := -1;
 FCurves := TCurves.Create;
end;

procedure TForm2.FormDestroy(Sender: TObject);
begin
 FCurves.Free;
end;

function TForm2.GetCurveIndex: integer;
begin
 Result := FCurveIndex;
end;

procedure TForm2.SetCurveIndex(const Value: integer);
begin
 FCurveIndex := Value;
end;

procedure TForm2.SpeedButton2Click(Sender: TObject);
begin
 FDrawing := false;
 FCurveIndex := -1;
 ShowCurves;
end;

procedure TForm2.pbCurveMouseUp(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
var
 Point: TPoint;
begin
 if not FDrawing then exit;
 Point.X := X;
 Point.Y := Y;
 if FCurveIndex >= 0 then
 begin
   FCurves.AddPoint(FCurveIndex, Point);
   RepaintCurve;
 end
 else
 begin
   FCurveIndex := FCurves.NewCurve;
   FLastX := X;
   FLastY := Y;
   FCurves.AddPoint(FCurveIndex, Point);
 end;
end;

procedure TForm2.ShowCurves;
var
 CurveIndex, i: integer;
 CurveString: string;
 CurveArray: TCurveArray;
begin
 memPoints.Lines.Clear;
 for CurveIndex := 0 to FCurves.Count - 1 do
 with memPoints.Lines do
 begin
   CurveString := "";
   CurveArray := FCurves.PointArray(CurveIndex);
   for i := Low(CurveArray) to High(CurveArray) do
     CurveString := CurveString + "(" + IntToStr(CurveArray[i].X) + ", " +
                          IntToStr(CurveArray[i].Y) + ") ";
   memPoints.Lines.Add(CurveString);
   CurveArray := nil;
 end;
end;

end.

---

← →
Romkin ©   (2004-02-03 18:22) [8]

Изображение я сразу загрузил, в дизайне, но dfm не помещается, так что без него :))) на OnShow строки надо выполнять после его загрузки, как раз все устанавливается. Думаю, вопросов, как грузить, не будет?

object Form2: TForm2
 Left = 330
 Top = 191
 Width = 540
 Height = 469
 Caption = "Form2"
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = "MS Sans Serif"
 Font.Style = []
 OldCreateOrder = False
 OnCreate = FormCreate
 OnDestroy = FormDestroy
 OnShow = FormShow
 DesignSize = (
   532
   442)
 PixelsPerInch = 96
 TextHeight = 13
 object SpeedButton1: TSpeedButton
   Left = 476
   Top = 16
   Width = 23
   Height = 22
   Caption = "X"
   OnClick = SpeedButton1Click
 end
 object SpeedButton2: TSpeedButton
   Left = 476
   Top = 44
   Width = 23
   Height = 22
   Caption = "end"
   OnClick = SpeedButton2Click
 end
 object Shape1: TShape
   Left = 468
   Top = 80
   Width = 50
   Height = 25
   Brush.Color = clRed
   OnMouseUp = Shape1MouseUp
 end
 object Shape2: TShape
   Left = 468
   Top = 112
   Width = 50
   Height = 25
   Brush.Color = clBlue
   OnMouseUp = Shape1MouseUp
 end
 object Shape3: TShape
   Left = 468
   Top = 144
   Width = 50
   Height = 25
   Brush.Color = clGreen
   OnMouseUp = Shape1MouseUp
 end
 object Label1: TLabel
   Left = 8
   Top = 276
   Width = 10
   Height = 13
   Anchors = [akLeft, akBottom]
   Caption = "X:"
 end
 object Label2: TLabel
   Left = 60
   Top = 276
   Width = 10
   Height = 13
   Anchors = [akLeft, akBottom]
   Caption = "Y:"
 end
 object sbImg: TScrollBox
   Left = 4
   Top = 4
   Width = 448
   Height = 268
   Anchors = [akLeft, akTop, akRight, akBottom]
   TabOrder = 0
   object img: TImage
     Left = 0
     Top = -4
     Width = 450
     Height = 314
     AutoSize = True
   end
   object pbCurve: TPaintBox
     Left = 0
     Top = 66
     Width = 105
     Height = 105
     OnMouseMove = pbCurveMouseMove
     OnMouseUp = pbCurveMouseUp
     OnPaint = pbCurvePaint
   end
 end
 object stX: TStaticText
   Left = 20
   Top = 276
   Width = 7
   Height = 17
   Anchors = [akLeft, akBottom]
   BorderStyle = sbsSunken
   Caption = " "
   TabOrder = 1
 end
 object stY: TStaticText
   Left = 72
   Top = 276
   Width = 7
   Height = 17
   Anchors = [akLeft, akBottom]
   BorderStyle = sbsSunken
   Caption = " "
   TabOrder = 2
 end
 object memPoints: TMemo
   Left = 4
   Top = 296
   Width = 521
   Height = 129
   Anchors = [akLeft, akTop, akRight, akBottom]
   ScrollBars = ssBoth
   TabOrder = 3
   WordWrap = False
 end
end

---

← →
Romkin ©   (2004-02-03 18:22) [9]

Вот, собственно, и весь третий пункт...

---

← →
Галинка ©   (2004-02-04 07:17) [10]

ОГРОМНОЕ СПАСИБО

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

---

Страницы: 1 вся ветка

Форум: "Media";
Текущий архив: 2004.05.02;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.51 MB
Время: 0.037 c