1 unit ogMotGraf2D;
2 {
3 ogMotGraf2D
4 ===========
5 Por Tito Hinostroza 24/09/2014
6
7 Descripción
8 ===========
9 Unidad que define a un motor gráfico, para realizar dibujos en pantalla.
10 Contiene funciones de dibujo para las principales formas.
11 Maneja desplazamientos y Zoom. Incluye definiciones y funciones para dibujo de controles
12 simples.
13 Maneja 2 tipos de coordenadas:
14 * Coordenadas de pantalla -> Se refieren comunmente como "xp" e "yp". Se usan para representar
15 posiciones en la pantalla. Se amneja en pixeles.
16 * Coordenadas virtuales -> Se refieren a las coordenadas virtuales internas con que trabajan
17 los objetos gráficos. Es variable de acuerdo al desplazamientos o pantallas. Son números en
18 coma flotante de tipo "single".
19
20 Las coordenadas de pantalla, trabajan en pixeles para acelerar los cálculos con gráficos.
21 Usa el objeto canvas para la salida gráfica. No se usan las opciones de cambio de coordenadas
22 y desplazamientos del Canvas, para tener mayor libertad de cambiar las transformaciones
23 gráficas. Basado en la clase equivalente CV2D desarrollada en VB.
24
25 }
26 {$mode objfpc}{$H+}
27 interface
28 uses Classes, Controls, SysUtils, Graphics, FPCanvas, Types, FPimage;
29 const
30 COL_GRIS = $808080; //gris
31
32 Type
33
34 //Define el Tipo de dato perspectiva
35 Tperspectiva = record
36 zoom : Real; //zoom de la perspectiva
37 x_cam : Single; //parámetro de desplazamiento x_cam
38 y_cam : Single; //parámetro de desplazamiento y_cam
39 end;
40 //Par ordenado de Reales.
41 TFPoint = record
42 x: single;
43 y: single;
44 end;
45
46 { TMotGraf }
47 TMotGraf = class
48 //Parámetros de la cámara (perspectiva)
49 x_cam : Single; //Coordenadas de la camara
50 y_cam : Single;
51 Zoom : Single; //Factor de ampliación
52 //Coordenadas de desplazamiento para ubicar el centro de la pantalla
53 x_des : integer;
54 y_des : Integer;
55
56 ImageList : TImageList;
57 constructor IniMotGraf(canvas0: Tcanvas);
58 procedure SetPenMode(modo:TFPPenMode);
59 procedure SetPen(estilo:TFPPenStyle; ancho:Integer; color:Tcolor);
60 procedure SetBrush(ColorR:TColor);
61 procedure SetColor(colLin,colRel:TColor; ancho: Integer = 1); //Fija colorde línea y relleno
62 procedure SetLine(colLin:TColor; width: Integer = 1); //Fija características de línea
63
64 procedure Line(x1, y1, x2, y2:Single);
65 procedure Line0(x1, y1, x2, y2: Integer);
66 procedure Rectang(x1, y1, x2, y2: Single);
67 procedure Rectang0(x1, y1, x2, y2: Integer);
68 procedure RectangR(x1, y1, x2, y2: Single);
69 procedure RectangR0(x1, y1, x2, y2: Integer);
70 procedure RectRedonR(x1, y1, x2, y2: Single);
71 procedure Barra(x1, y1, x2, y2: Single; colFon: TColor=-1);
72 procedure Barra0(x1, y1, x2, y2: Integer; colFon: TColor);
73 procedure Arc(x1, y1, x2, y2: Single; Angle16Deg, Angle16DegLength: Integer);
74 procedure Ellipse(x1, y1, x2, y2: Single);
75 procedure RadialPie(x1, y1, x2, y2: Single; StartAngle16Deg,
76 Angle16DegLength: integer);
77 procedure Polygon(x1, y1, x2, y2, x3, y3: Single; x4: Single=-10000;
78 y4: Single=-10000; x5: Single=-10000; y5: Single=-10000; x6: Single=-10000;
79 y6: Single=-10000);
80 procedure Polygon(const Points: array of TFPoint);
81 //funciones para texto
82 procedure SetFont(Letra: string);
83 procedure SetText(color: TColor);
84 procedure SetText(color: TColor; tam: single);
85 procedure SetText(bold: Boolean=False; italic: Boolean=False;
86 underline: Boolean=False);
87 procedure SetText(color: TColor; tam: single; font: String;
88 bold: Boolean=False; italic: Boolean=False; underline: Boolean=False);
89 procedure Texto(x1, y1: Single; txt: String);
90 procedure TextRect(x1, y1, x2, y2: Single; x0, y0: Single; const Text: string;
91 const Style: TTextStyle);
92 procedure TextoR(x1, y1, ancho, alto: Single; txt: String);
TextWidthnull93 function TextWidth(const txt: string): single; //ancho del texto
94
95 procedure SavePerspectiveIn(var p: TPerspectiva);
96 procedure ReadPerspectiveFrom(p: TPerspectiva);
97
98 procedure SetWindow(ScaleWidth, ScaleHeight: Real; xMin, xMax, yMin, yMax: Real);
99 procedure Scroll(dx, dy: Integer);
100 procedure ObtenerDesplaz2(xr, yr: Integer; Xant, Yant: Integer; out dx,
101 dy: Single);
102 procedure DrawIcon(x1, y1: Single; idx: integer);
103 procedure DrawImage(im: TGraphic; x1, y1, dx, dy: Single);
104 procedure DrawImageN(im: TGraphic; x1, y1: Single);
105 procedure DrawImage0(im: TGraphic; x1, y1, dx, dy: Integer);
106 public //Funciones de transformación
XPantnull107 function XPant(x: Single): Integer; //INLINE Para acelerar las llamadas
YPantnull108 function YPant(y: Single): Integer; //INLINE Para acelerar las llamadas
109 procedure XYpant(xv, yv: Single; out xp, yp: Integer);
110 procedure XYvirt(xp, yp: Integer; out xv, yv: Single);
Xvirtnull111 function Xvirt(xr, {%H-}yr: Integer): Single; //INLINE Para acelerar las llamadas
Yvirtnull112 function Yvirt(xr, yr: Integer): Single; //INLINE Para acelerar las llamadas
113 public //funciones básicas para dibujo de Controles
114 procedure DrawButtonBord(x1,y1:Single; ancho,alto: Single);
115 procedure DrawButtonBack(x1, y1: Single; ancho, alto: Single);
116 procedure DrawCheck(px, py: Single; ancho, alto: Single);
117 procedure DibVnormal(x1, y1: Single; ancho, alto: Single);
118 procedure DrawTrianUp(x1,y1:Single; ancho,alto: Single);
119 procedure DrawTrianDown(x1,y1:Single; ancho,alto: Single);
120 public
121 Canvas : Tcanvas; //referencia al lienzo
122 end;
123
124 implementation
125
126 //////////////////////////////// Funciones públicas //////////////////////////////
127 constructor TMotGraf.IniMotGraf(canvas0: Tcanvas);
128 begin
129 Canvas := canvas0;
130 //GetClientRect frmS.hwnd, tCR
131 x_des := 0;
132 y_des := 0;
133 //posición de cámara
134 x_cam := 0;
135 y_cam := 0;
136 //ampliación inicial
137 Zoom := 1;
138 End;
139 procedure TMotGraf.SetPenMode(modo: TFPPenMode);
140 begin
141 Canvas.Pen.Mode := modo;
142 End;
143 procedure TMotGraf.SetPen(estilo:TFPPenStyle; ancho:Integer; color:Tcolor);
144 //Establece el lápiz actual de dibujo
145 begin
146 Canvas.Pen.Style := estilo;
147 Canvas.pen.Width := ancho;
148 Canvas.pen.Color := color;
149 End;
150 procedure TMotGraf.SetBrush(ColorR:TColor);
151 //Establece el relleno actual
152 begin
153 Canvas.Brush.Style := bsSolid; //estilo sólido
154 Canvas.Brush.Color:=ColorR;
155 End;
156
157 procedure TMotGraf.SetColor(colLin, colRel: TColor; ancho: Integer = 1);
158 //Fija un color de línea y un color de relleno. La línea se fija a estilo sólido
159 //y el relleno también
160 begin
161 Canvas.Pen.Style := psSolid;
162 Canvas.pen.Width := ancho;
163 Canvas.pen.Color := colLin;
164
165 Canvas.Brush.Style:=bsSolid;
166 Canvas.Brush.Color:=colRel;
167 end;
168 procedure TMotGraf.SetLine(colLin: TColor; width: Integer);
169 begin
170 Canvas.Pen.Style := psSolid;
171 Canvas.pen.Width := width;
172 Canvas.pen.Color := colLin;
173 end;
174 //funciones para texto
175 procedure TMotGraf.SetFont(Letra: string);
176 //Permite definir el tipo de letra actual
177 begin
178 if Letra = '' then Canvas.Font.Name:= 'MS Sans Serif';
179 //'Times New Roman'
180 end;
181 procedure TMotGraf.SetText(color: TColor);
182 begin
183 Canvas.Font.Color := color;
184 end;
185 procedure TMotGraf.SetText(color: TColor; tam: single);
186 //método sencillo para cambiar propiedades del texto
187 begin
188 Canvas.Font.Color := color;
189 Canvas.Font.Size := round(tam * Zoom);
190 end;
191 procedure TMotGraf.SetText(bold:Boolean = False; italic: Boolean = False;
192 underline: Boolean = False);
193 //Establece las características completas del texto
194 begin
195 Canvas.Font.Bold := bold;
196 Canvas.Font.Italic := italic;
197 Canvas.Font.Underline := underline;
198 End;
199 procedure TMotGraf.SetText(color: TColor; tam: single; //; nDegrees As Single, _
200 font: String;
201 bold:Boolean = False;
202 italic: Boolean = False;
203 underline: Boolean = False);
204 //Establece las características completas del texto
205 begin
206 Canvas.Font.Color := color;
207 Canvas.Font.Size := round(tam * Zoom);
208 if font <> '' then Canvas.Font.Name:=font;
209 Canvas.Font.Bold := bold;
210 Canvas.Font.Italic := italic;
211 Canvas.Font.Underline := underline;
212 End;
213 procedure TMotGraf.Texto(x1, y1: Single; txt: String);
214 //Escribe un texto
215 begin
216 Canvas.Brush.Style := bsClear; //Fondo transparente
217 // tmp := Canvas.Font.Size; //guarda tamaño actual
218 // Canvas.Font.Size := round(Canvas.Font.Size * Zoom);
219 Canvas.TextOut(XPant(x1), YPant(y1), txt);
220 // Canvas.Font.Size := tmp; //restaura
221 Canvas.Brush.Style := bsSolid; //devuelve estilo de fondo
222 End;
223 procedure TMotGraf.TextRect(x1,y1,x2,y2: Single; x0, y0: Single; const Text: string;
224 const Style: TTextStyle);
225 //Escribe un texto
226 var
227 Arect: TRect;
228 begin
229 Canvas.Brush.Style := bsClear; //Fondo transparente
230 // tmp := Canvas.Font.Size; //guarda tamaño actual
231 // Canvas.Font.Size := round(Canvas.Font.Size * Zoom);
232 ARect.Left := XPant(x1);
233 ARect.Top := YPant(y1);
234 ARect.Right := XPant(x2);
235 ARect.Bottom := YPant(y2);
236 Canvas.TextRect(Arect, XPant(x0), YPant(y0), Text, Style);
237 // Canvas.Font.Size := tmp; //restaura
238 Canvas.Brush.Style := bsSolid; //devuelve estilo de fondo
239 End;
240 procedure TMotGraf.TextoR(x1, y1, ancho, alto: Single; txt: String);
241 //Escribe un texto
242 var r:TRect;
243 //s:TTextStyle;
244 begin
245 // Canvas.Font.Color:=clred;
246 Canvas.Brush.Style := bsClear; //Fondo transparente
247 Canvas.Font.Size := round(11 * Zoom);
248 r.Left := XPant(x1);
249 r.Top := YPant(y1);
250 r.Right := XPant(x1+ancho); { TODO : Ver como dibujar texto no limitado }
251 r.Bottom:= YPant(y1+alto);
252 // s.Alignment:=taRightJustify; //alineado a la derecha
253 // Canvas.TextRect(r,r.Left,r.Top,txt,s);//No permite cambia el tamaño de letra!!!!
254 Canvas.TextRect(r,r.Left,r.Top,txt);
255 Canvas.Brush.Style := bsSolid; //devuelve estilo de fondo
256 End;
TMotGraf.TextWidthnull257 function TMotGraf.TextWidth(const txt: string): single;
258 begin
259 Result := Canvas.TextWidth(txt) * Zoom;
260 end;
261
262 (*
263 Sub FijaTextoF(l As CFLetra)
264 //Establece las características de texto, por medio de una clase "CFLetra"
265 Dim grosor As Long
266 Dim nHeight As Long
267 SetTextColor hdc, l.col
268 If hFont <> 0 Then DeleteObject hFont
269 If l.negrita Then grosor = FW_BOLD Else grosor = FW_NORMAL
270 nHeight = -MulDiv(l.tam, GetDeviceCaps(hdc, LOGPIXELSY) * mZoom, 72)
271 If nHeight = 0 Then nHeight = -1 //limita tamaño a un mínimo
272 hFont = CreateFont(nHeight, _
273 0, l.inclinacion * 10, 0, grosor, l.cursiva, l.subrayado, False, DEFAULT_CHARSET, _
274 OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, l.tipo)
275 SelectObject hdc, hFont //queda pendiente eliminarlo
276 End;
277
278 Public Sub FijaAlineamiento(Optional alineac As Long = TA_LEFT)
279 SetTextAlign hdc, alineac
280 End;
281
282 Public Sub ftexto(ByVal x1 As Single, ByVal y1 As Single, _
283 txt As String, Optional alineac As Long = MVW_CEN_CEN, _
284 Optional ByVal Ang As Single = 0)
285 //Escribe un texto, con opciones completas de alineamiento, 4 cuadrantes y 4 ejes
286 //Es más lenta que texto() para los casos de texto centrado
287 //Permite centrar con ángulo. "ang" es el ángulo de inclinación en grados
288 Dim x1c As Single, y1c As Single //coordenadas corregidas
289 Dim ancho_txt As Single
290 Dim alto_txt As Single
291
292 Dim rc As RECT
293 Select Case alineac
294 Case MVW_SUP_DER
295 x1c = (x1 - x_cam) * mZoom + x_des
296 y1c = (y1 - y_cam) * mZoom + y_des
297 SetTextAlign hdc, TA_RIGHT + TA_TOP
298 TextOut hdc, x1c, y1c, txt, Len(txt)
299 Case MVW_SUP_IZQ
300 x1c = (x1 - x_cam) * mZoom + x_des
301 y1c = (y1 - y_cam) * mZoom + y_des
302 SetTextAlign hdc, TA_LEFT + TA_TOP
303 TextOut hdc, x1c, y1c, txt, Len(txt)
304 Case MVW_SUP_CEN
305 x1c = (x1 - x_cam) * mZoom + x_des
306 y1c = (y1 - y_cam) * mZoom + y_des
307 SetTextAlign hdc, TA_CENTER + TA_TOP
308 TextOut hdc, x1c, y1c, txt, Len(txt)
309 Case MVW_CEN_DER
310 Call LeeGeomTextoZ(txt, ancho_txt, alto_txt)
311 If Ang = 0 Then
312 x1 = x1
313 y1 = y1 - alto_txt / 2
314 Else
315 Ang = Ang / 180 * PI
316 x1 = x1 - alto_txt / 2 * Sin(Ang)
317 y1 = y1 - alto_txt / 2 * Cos(Ang)
318 End If
319 x1c = (x1 - x_cam) * mZoom + x_des
320 y1c = (y1 - y_cam) * mZoom + y_des
321 SetTextAlign hdc, TA_RIGHT + TA_TOP
322 TextOut hdc, x1c, y1c, txt, Len(txt)
323 Case MVW_CEN_IZQ
324 Call LeeGeomTextoZ(txt, ancho_txt, alto_txt)
325 If Ang = 0 Then
326 x1 = x1
327 y1 = y1 - alto_txt / 2
328 Else
329 Ang = Ang / 180 * PI
330 x1 = x1 - alto_txt / 2 * Sin(Ang)
331 y1 = y1 - alto_txt / 2 * Cos(Ang)
332 End If
333 x1c = (x1 - x_cam) * mZoom + x_des
334 y1c = (y1 - y_cam) * mZoom + y_des
335 SetTextAlign hdc, TA_LEFT + TA_TOP
336 TextOut hdc, x1c, y1c, txt, Len(txt)
337 Case MVW_CEN_CEN
338 Call LeeGeomTextoZ(txt, ancho_txt, alto_txt)
339 If Ang = 0 Then
340 x1 = x1 - ancho_txt / 2
341 y1 = y1 - alto_txt / 2
342 Else
343 Ang = Ang / 180 * PI
344 //****No implementado****
345 End If
346 x1c = (x1 - x_cam) * mZoom + x_des
347 y1c = (y1 - y_cam) * mZoom + y_des
348 SetTextAlign hdc, TA_LEFT + TA_TOP
349 TextOut hdc, x1c, y1c, txt, Len(txt)
350 Case MVW_INF_DER
351 x1c = (x1 - x_cam) * mZoom + x_des
352 y1c = (y1 - y_cam) * mZoom + y_des
353 SetTextAlign hdc, TA_RIGHT + TA_BOTTOM
354 TextOut hdc, x1c, y1c, txt, Len(txt)
355 Case MVW_INF_IZQ
356 x1c = (x1 - x_cam) * mZoom + x_des
357 y1c = (y1 - y_cam) * mZoom + y_des
358 SetTextAlign hdc, TA_LEFT + TA_BOTTOM
359 TextOut hdc, x1c, y1c, txt, Len(txt)
360 Case MVW_INF_CEN
361 x1c = (x1 - x_cam) * mZoom + x_des
362 y1c = (y1 - y_cam) * mZoom + y_des
363 SetTextAlign hdc, TA_CENTER + TA_BOTTOM
364 TextOut hdc, x1c, y1c, txt, Len(txt)
365 End Select
366 End;
367
368 Public Sub texto0(x1 As Single, y1 As Single, txt As String)
369 //Escribe un texto "sin transformación"
370 Dim x1c As Single, y1c As Single //coordenadas corregidas
371 x1c = x1
372 y1c = y1
373 SetTextAlign hdc, TA_LEFT
374 TextOut hdc, x1c, y1c, txt, Len(txt)
375 End;
376
377 Public Sub MultiTexto(cad As String, x1 As Single, y1 As Single, _
378 x2 As Single, y2 As Single, _
379 Optional color As Long = vbBlack, _
380 Optional alinea As Long = DT_LEFT)
381 //Escribe texto en varias líneas, en el rectángulo indicado. Realiza saltos entre palabras
382 //o cuando una palabra excede el ancho del cuadro. Si una línea adicional no entra completa
383 //no se visualiza. Si la cadena completa no entra en el cuadro se recorta
384 Dim rc As RECT
385 rc.Left = (x1 - x_cam) * mZoom + x_des: rc.Top = (y1 - y_cam) * mZoom + y_des
386 rc.Right = (x2 - x_cam) * mZoom + x_des: rc.Bottom = (y2 - y_cam) * mZoom + y_des
387 SetTextColor hdc, color
388 //DrawText hdc, cad, Len(cad), rc, DT_WORDBREAK + DT_EDITCONTROL //+ DT_END_ELLIPSIS
389 DrawText hdc, cad, Len(cad), rc, DT_WORDBREAK + alinea
390 End;
391
392 Public Sub MultiTexto0(cad As String, x1 As Single, y1 As Single, _
393 x2 As Single, y2 As Single, _
394 Optional color As Long = vbBlack)
395 //Escribe texto en varias líneas, en el rectángulo indicado. Realiza saltos entre palabras
396 //o cuando una palabra excede el ancho del cuadro. Si una línea adicional no entra completa
397 //no se visualiza. Si la cadena completa no entra en el cuadro se recorta y se le agrega "..."
398 Dim rc As RECT
399 rc.Left = x1: rc.Top = y1
400 rc.Right = x2: rc.Bottom = y2
401 SetTextColor hdc, color
402 DrawText hdc, cad, Len(cad), rc, DT_WORDBREAK + DT_EDITCONTROL //+ DT_END_ELLIPSIS
403 End;
404 *)
405 procedure TMotGraf.Line(x1, y1, x2, y2: Single);
406 //Dibuja una línea
407 begin
408 Canvas.Line(XPant(x1), YPant(y1), XPant(x2), YPant(y2));
409 End;
410 procedure TMotGraf.Line0(x1, y1, x2, y2: Integer);
411 //Dibuja una línea , sin transformación
412 begin
413 Canvas.Line(x1, y1, x2, y2);
414 End;
415
416 (*
417 Public Sub Circulo(x1 As Single, y1 As Single, radio As Single)
418 //Dibuja un círculo relleno
419 Dim x1c As Single, y1c As Single //coordenadas corregidas
420 Dim rc As Single
421 x1c = (x1 - x_cam) * mZoom + x_des
422 y1c = (y1 - y_cam) * mZoom + y_des
423 rc = radio * mZoom
424 Ellipse hdc, (x1c - rc), (y1c - rc), (x1c + rc), (y1c + rc)
425 End;
426
427 Public Sub circulo0(x1 As Single, y1 As Single, radio As Single)
428 //Dibuja un círculo relleno, "sin transformación"
429 Dim x1c As Single, y1c As Single //coordenadas corregidas
430 Dim rc As Single
431 x1c = x1
432 y1c = y1
433 rc = radio
434 Ellipse hdc, (x1c - rc), (y1c - rc), (x1c + rc), (y1c + rc)
435 End;
436
437 Public Sub Arco(x1 As Single, y1 As Single, radio As Single, _
438 AngIni As Single, Ang As Single)
439 Dim x1c As Single, y1c As Single //coordenadas corregidas
440 Dim rc As Single
441 Dim PT As POINTAPI
442 x1c = (x1 - x_cam) * mZoom + x_des
443 y1c = (y1 - y_cam) * mZoom + y_des
444 rc = radio * mZoom
445 BeginPath hdc
446 MoveToEx hdc, x1c, y1c, ret_pt
447 AngleArc hdc, x1c, y1c, rc, AngIni, Ang
448 LineTo hdc, x1c, y1c
449 EndPath hdc
450 StrokeAndFillPath hdc
451 //arc hdc, (x1c - rc), (y1c - rc), (x1c + rc), (y1c + rc),
452 End;
453
454 *)
455
456 procedure TMotGraf.Rectang(x1, y1, x2, y2: Single);
457 //Dibuja un rectángulo
458 begin
459 Canvas.Frame(XPant(x1), YPant(y1), XPant(x2), YPant(y2));
460 End;
461 procedure TMotGraf.Rectang0(x1, y1, x2, y2: Integer);
462 //Dibuja un rectángulo sin "transformación"
463 begin
464 Canvas.Frame(x1, y1, x2, y2);
465 End;
466 procedure TMotGraf.RectangR(x1, y1, x2, y2: Single);
467 //Dibuja un rectángulo relleno
468 begin
469 Canvas.Rectangle(XPant(x1), YPant(y1), XPant(x2), YPant(y2));
470 End;
471 procedure TMotGraf.RectangR0(x1, y1, x2, y2: Integer);
472 //Dibuja un rectángulo relleno sin "transformación"
473 begin
474 Canvas.Rectangle(x1, y1, x2, y2);
475 End;
476 procedure TMotGraf.RectRedonR(x1, y1, x2, y2: Single);
477 //Dibuja un rectángulo relleno con bordes redondeados
478 begin
479 Canvas.RoundRect(XPant(x1), YPant(y1), XPant(x2), YPant(y2), round(10 * Zoom), Round(10 * Zoom));
480 End;
481 procedure TMotGraf.Barra(x1, y1, x2, y2: Single; colFon: TColor = -1);
482 //Rellena un área rectangular, no rellena el borde derecho e inferior.
483 //Es más rápido que rellenar con Rectangle()
484 var rc: TRect;
485 begin
486 rc.Left := XPant(x1);
487 rc.Top := YPant(y1);
488 rc.Right := XPant(x2);
489 rc.Bottom := YPant(y2);
490 if colFon<> -1 then Canvas.Brush.Color := colFon;
491 Canvas.FillRect(rc); //fondo
492 End;
493 procedure TMotGraf.Barra0(x1, y1, x2, y2: Integer; colFon: TColor);
494 //Rellena un área rectangular, no rellena el borde derecho e inferior.
495 //Es más rápido que rellenar con Rectangle()
496 begin
497 Canvas.Brush.Color := colFon;
498 Canvas.FillRect(x1,y1,x2,y2); //fondo
499 End;
500
501 procedure TMotGraf.Arc(x1, y1, x2, y2: Single; Angle16Deg,
502 Angle16DegLength: Integer);
503 begin
504 Canvas.Arc(XPant(x1), YPant(y1), XPant(x2), YPant(y2), Angle16Deg, Angle16DegLength);
505 end;
506 procedure TMotGraf.Ellipse(x1, y1, x2, y2: Single);
507 begin
508 Canvas.Ellipse(XPant(x1), YPant(y1), XPant(x2), YPant(y2));
509 end;
510 procedure TMotGraf.RadialPie(x1, y1, x2, y2: Single; StartAngle16Deg, Angle16DegLength: integer);
511 begin
512 Canvas.RadialPie(XPant(x1), YPant(y1), XPant(x2), YPant(y2), StartAngle16Deg, Angle16DegLength);
513 end;
514
515 (*
516 Public Sub polilinea(x1 As Single, y1 As Single, _
517 x2 As Single, y2 As Single, _
518 x3 As Single, Y3 As Single, _
519 Optional x4 As Single = -10000, Optional y4 As Single = -10000, _
520 Optional x5 As Single = -10000, Optional y5 As Single = -10000, _
521 Optional x6 As Single = -10000, Optional y6 As Single = -10000)
522 //Dibuja un polígono usando llamadas a la API de Windows
523 Dim Ptos3(1 To 7) As Tpunto //puntos
524 Dim ptos(1 To 7) As POINTAPI //arreglo de puntos a dibujar
525 Dim nPtos As Long
526 Dim x1c As Single, y1c As Single
527 Dim i As Integer
528 Ptos3(1).X = x1: Ptos3(1).Y = y1
529 Ptos3(2).X = x2: Ptos3(2).Y = y2
530 Ptos3(3).X = x3: Ptos3(3).Y = Y3
531 nPtos = 3
532 If x4 <> -10000 Then Ptos3(4).X = x4: Ptos3(4).Y = y4: nPtos = 4
533 If x5 <> -10000 Then Ptos3(5).X = x5: Ptos3(5).Y = y5: nPtos = 5
534 If x6 <> -10000 Then Ptos3(6).X = x6: Ptos3(6).Y = y6: nPtos = 6
535 //cierra el polígono
536 Ptos3(nPtos + 1).X = Ptos3(1).X
537 Ptos3(nPtos + 1).Y = Ptos3(1).Y
538 //transformación
539 For i = 1 To nPtos + 1
540 ptos(i).X = (x_des + (Ptos3(i).X - x_cam) * mZoom)
541 ptos(i).Y = (y_des + (Ptos3(i).Y - y_cam) * mZoom)
542 Next
543 Call Polyline(hdc, ptos(1), nPtos + 1)
544 End;
545
546 Public Sub polilinea0(x1 As Single, y1 As Single, _
547 x2 As Single, y2 As Single, _
548 x3 As Single, Y3 As Single, _
549 Optional x4 As Single = -10000, Optional y4 As Single = -10000, _
550 Optional x5 As Single = -10000, Optional y5 As Single = -10000, _
551 Optional x6 As Single = -10000, Optional y6 As Single = -10000)
552 //Dibuja un polígono usando llamadas a la API de Windows, sin "transformación"
553 Dim Ptos3(1 To 7) As Tpunto //puntos
554 Dim ptos(1 To 7) As POINTAPI //arreglo de puntos a dibujar
555 Dim nPtos As Long
556 Dim x1c As Single, y1c As Single
557 Dim i As Integer
558 Ptos3(1).X = x1: Ptos3(1).Y = y1
559 Ptos3(2).X = x2: Ptos3(2).Y = y2
560 Ptos3(3).X = x3: Ptos3(3).Y = Y3
561 nPtos = 3
562 If x4 <> -10000 Then Ptos3(4).X = x4: Ptos3(4).Y = y4: nPtos = 4
563 If x5 <> -10000 Then Ptos3(5).X = x5: Ptos3(5).Y = y5: nPtos = 5
564 If x6 <> -10000 Then Ptos3(6).X = x6: Ptos3(6).Y = y6: nPtos = 6
565 //cierra el polígono
566 Ptos3(nPtos + 1).X = Ptos3(1).X
567 Ptos3(nPtos + 1).Y = Ptos3(1).Y
568 //transformación
569 For i = 1 To nPtos + 1
570 ptos(i).X = Ptos3(i).X
571 ptos(i).Y = Ptos3(i).Y
572 Next
573 Call Polyline(hdc, ptos(1), nPtos + 1)
574 End;
575
576 Public Sub poligono0(x1 As Single, y1 As Single, _
577 x2 As Single, y2 As Single, _
578 x3 As Single, Y3 As Single, _
579 Optional x4 As Single = -10000, Optional y4 As Single = -10000, _
580 Optional x5 As Single = -10000, Optional y5 As Single = -10000, _
581 Optional x6 As Single = -10000, Optional y6 As Single = -10000)
582 //Dibuja un polígono relleno usando llamadas a la API de Windows "sin transformación"
583 Dim Ptos3(1 To 7) As Tpunto //puntos
584 Dim ptos(1 To 7) As POINTAPI //arreglo de puntos a dibujar
585 Dim nPtos As Long
586 Dim x1c As Single, y1c As Single
587 Dim i As Integer
588 Ptos3(1).X = x1: Ptos3(1).Y = y1
589 Ptos3(2).X = x2: Ptos3(2).Y = y2
590 Ptos3(3).X = x3: Ptos3(3).Y = Y3
591 nPtos = 3
592 If x4 <> -10000 Then Ptos3(4).X = x4: Ptos3(4).Y = y4: nPtos = 4
593 If x5 <> -10000 Then Ptos3(5).X = x5: Ptos3(5).Y = y5: nPtos = 5
594 If x6 <> -10000 Then Ptos3(6).X = x6: Ptos3(6).Y = y6: nPtos = 6
595 //cierra el polígono
596 Ptos3(nPtos + 1).X = Ptos3(1).X
597 Ptos3(nPtos + 1).Y = Ptos3(1).Y
598 //transformación
599 For i = 1 To nPtos + 1
600 ptos(i).X = Ptos3(i).X
601 ptos(i).Y = Ptos3(i).Y
602 Next
603 Call Polygon(hdc, ptos(1), nPtos + 1) //dibuja borde
604 End;
605 *)
606 procedure TMotGraf.Polygon(x1, y1, x2, y2, x3, y3 : Single;
607 x4: Single = -10000; y4: Single = -10000;
608 x5: Single = -10000; y5: Single = -10000;
609 x6: Single = -10000; y6: Single = -10000);
610 //Dibuja un polígono relleno.
611 var
612 Ptos: array of TPoint; //arreglo de puntos a dibujar
613 nPtos: integer;
614 begin
615 //calcula número de puntos
616 If x4 = -10000 Then nPtos := 3
617 else if x5 = -10000 Then nPtos := 4
618 else If x6 = -10000 Then nPtos := 5
619 else nPtos := 6;
620 SetLength(Ptos, nPtos); //dimensiona
621 //Llena arreglo
622 Ptos[0].x := XPant(x1); Ptos[0].y := YPant(y1);
623 Ptos[1].x := XPant(x2); Ptos[1].y := YPant(y2);
624 Ptos[2].x := XPant(x3); Ptos[2].y := YPant(y3);
625 If x4 <> -10000 Then begin
626 Ptos[3].x := XPant(x4); Ptos[3].y := YPant(y4);
627 end;
628 If x5 <> -10000 Then begin
629 Ptos[4].x := XPant(x5); Ptos[4].y := YPant(y5);
630 end;
631 If x6 <> -10000 Then begin
632 Ptos[5].x := XPant(x6); Ptos[5].y := YPant(y6);
633 end;
634 Canvas.Polygon(Ptos); //dibuja
635 End;
636 procedure TMotGraf.Polygon(const Points: array of TFPoint);
637 //Dibuja un polígono relleno.
638 var
639 Ptos: array of TPoint; //arreglo de puntos a dibujar
640 i: Integer;
641 begin
642 SetLength(Ptos, high(Points)+1); //dimensiona
643 //transforma puntos
644 for i:= 0 to high(Points) do begin
645 Ptos[i].x := XPant(Points[i].x);
646 Ptos[i].y := YPant(Points[i].y);
647 end;
648 Canvas.Polygon(Ptos); //dibuja
649 End;
650
651 //*****************************FUNCIONES DE TRANSFORMACIÓN********************************
652 //Las siguientes funciones son por así decirlo, "estandar".
653 //Cuando se creen otras clases de dispositivo interfase gráfica deberían tener también estas
654 //funciones que son siempre necesarias.
XPantnull655 function TMotGraf.XPant(x:Single): Integer; INLINE; //INLINE Para acelerar las llamadas
656 //Función de la geometría del motor. Da la transformación lineal de la coordenada x.
657 begin
658 XPant := Round((x - x_cam) * Zoom + x_des);
659 end;
TMotGraf.YPantnull660 function TMotGraf.YPant(y:Single): Integer; INLINE; //INLINE Para acelerar las llamadas
661 //Función de la geometría del motor. Da la transformación lineal de la coordenada y.
662 begin
663 YPant := Round((y - y_cam) * Zoom + y_des);
664 end;
665 procedure TMotGraf.XYpant(xv, yv: Single; out xp, yp: Integer);
666 //Devuelve las coordenadas de pantalla para un punto virtual (x,y,z).
667 begin
668 xp := Xpant(xv);
669 yp := Ypant(yv);
670 End;
Xvirtnull671 function TMotGraf.Xvirt(xr, yr: Integer): Single; //INLINE Para acelerar las llamadas
672 //Obtiene la coordenada X virtual (del punto X,Y,Z ) a partir de unas coordenadas de pantalla
673 begin
674 Xvirt := (xr - x_des) / Zoom + x_cam;
675 End;
Yvirtnull676 function TMotGraf.Yvirt(xr, yr: Integer): Single; //INLINE Para acelerar las llamadas
677 //Obtiene la coordenada Y virtual (del punto X,Y,Z ) a partir de unas coordenadas de pantalla
678 begin
679 Yvirt := (yr - y_des) / Zoom + y_cam;
680 End;
681 procedure TMotGraf.XYvirt(xp, yp: Integer; out xv, yv: Single);
682 //Devuelve las coordenadas virtuales xv,yv a partir de unas coordenadas de pantalla
683 //(o del ratón). Equivale a intersecar un plano
684 //paralelo al plano XY con la línea de mira del ratón en pantalla.
685 begin
686 xv := Xvirt(xp, yp);
687 yv := Yvirt(yp, yp);
688 End;
689 procedure TMotGraf.SetWindow(ScaleWidth, ScaleHeight: Real;
690 xMin, xMax, yMin, yMax: Real);
691 //Fija las coordenadas de pantalla de manera que se ajusten a las nuevas que se dan
692 //Recibe coordenadas virtuales
693 var zoomX: Real;
694 zoomY: Real;
695 dxcen: Real; //Desplazamiento en x para centrar
696 dycen: Real; //Desplazamiento en y para centrar
697 begin
698 If xMax <= xMin Then Exit;
699 If yMax <= yMin Then Exit;
700 //calcula el zoom por efecto de dX
701 zoomX := ScaleWidth / (xMax - xMin);
702 //calcula el zoom por efecto de dY
703 zoomY := ScaleHeight / (yMax - yMin);
704 //toma el zoom menor, en caso de relación de aspecto diferente de 1
705 If zoomY > zoomX Then //toma el zoom de x
706 begin
707 Zoom := zoomX;
708 dxcen := 0;
709 dycen := (ScaleHeight / Zoom - (yMax - yMin)) / 2; //para centrar en vertical
710 end
711 Else //zoomX > zoomy ,toma el zoom de y
712 begin
713 Zoom := zoomY;
714 dycen := 0;
715 dxcen := (ScaleWidth / Zoom - (xMax - xMin)) / 2; //para centrar en horizontal
716 end;
717 //fija las coordenadas de cámara
718 x_cam := xMin + x_des / Zoom - dxcen;
719 y_cam := yMin + y_des / Zoom - dycen;
720 End;
721 procedure TMotGraf.Scroll(dx, dy: Integer);
722 //Desplaza el escenario (el punto de rotación siempre está en el centro de la pantalla)
723 begin
724 y_cam := y_cam - dy;
725 x_cam := x_cam - dx;
726 End;
727 procedure TMotGraf.ObtenerDesplaz2(xr, yr: Integer; Xant, Yant: Integer;
728 out dx, dy: Single);
729 //Obtiene los desplazamientos dx, dy para los objetos gráficos en base a
730 //los movimientos del ratón. Sólo desplaza en 2D
731 begin
732 //desplazamiento en plano XY en caso alfa=0, fi=0
733 dx := (xr - Xant) / Zoom;
734 dy := (yr - Yant) / Zoom;
735 End;
736 (*
737 Public Function LeeGeomTextoZ(cad As String, ancho As Single, alto As Single)
738 //Devuelve el ancho y alto del texto. El ancho y alto del texto debe ser independiente
739 //del zoom, pero como despues de llamar a FijaTexto se altera el tamaño del font
740 //se requiere la corrección por el factor del zoom.
741 Dim szText As SIZE
742 Dim res As Long
743 res = GetTextExtentPoint32(hdc, cad, Len(cad), szText)
744 ancho = szText.cx / mZoom
745 alto = szText.cy / mZoom
746 End Function
747
748 Public Function LeeGeomTexto0(cad As String, ancho As Single, alto As Single)
749 //Devuelve el ancho y alto del texto. No considera el zoom.
750 Dim szText As SIZE
751 Dim res As Long
752 res = GetTextExtentPoint32(hdc, cad, Len(cad), szText)
753 ancho = szText.cx
754 alto = szText.cy
755 End Function
756
757 Public Function NCaracTextAncho(cad As String, ancho As Long) As Long
758 //Devuelve el número de caracteres de una línea que entran en un ancho determinado
759 Dim s As SIZE
760 Dim entran As Long
761 GetTextExtentExPoint hdc, cad, Len(cad), ancho, entran, ByVal 0&, s
762 NCaracTextAncho = entran
763 End Function
764
765 *)
766 ////////////////////////////// FUNCIONES DE PERSPECTIVA //////////////////////////////
767 procedure TMotGraf.SavePerspectiveIn(var p: TPerspectiva);
768 //guarda sus datos de perspectiva en una variable perspectiva
769 begin
770 p.x_cam := x_cam;
771 p.y_cam := y_cam;
772 p.zoom := Zoom;
773 End;
774 procedure TMotGraf.ReadPerspectiveFrom(p: TPerspectiva);
775 //lee sus datos de perspectiva de una variable perspectiva
776 begin
777 x_cam := p.x_cam;
778 y_cam := p.y_cam;
779 Zoom := p.Zoom;
780 End;
781
782 //*********************************************************************************
783 procedure TMotGraf.DrawIcon(x1, y1: Single; idx: integer);
784 //Dibuja una de las imágenes alamcenadas en la propiedad ImageList
785 begin
786 ImageList.Draw(Canvas, XPant(x1),YPant(y1), idx);
787 end;
788 procedure TMotGraf.DrawImage(im: TGraphic; x1, y1, dx, dy: Single);
789 //Dibuja imagen. Debe recibir el ancho y alto de la imagen
790 //en pixeles. Estos valores "ancho" y "alto" no se puede obtener
791 //de manera directa con im.Width e im.Height, porque vienen en unidades
792 //HIMETRIC, y se requeriría acceder al método Scale() para la conversión.
793 //
794 var r:TRect;
795 begin
796 if im = nil then exit;
797 r.Left:=XPant(x1);
798 r.Top :=YPant(y1);
799 r.Right :=r.Left + round(dx * Zoom);
800 r.Bottom:=r.Top + round(dy * Zoom);
801 Canvas.StretchDraw(r,im);
802 End;
803 procedure TMotGraf.DrawImageN(im: TGraphic; x1, y1: Single);
804 //Igual a DibujarImagen() pero no hace escalamiento de la imagen, solo por el Zoom.
805 var r:TRect;
806 begin
807 if im = nil then exit;
808 // Canvas.Draw(XPant(x1), YPant(y1),im);
809 r.Left:=XPant(x1);
810 r.Top :=YPant(y1);
811 r.Right :=r.Left + round(im.Width * Zoom); //se probó quitándole 1, pero así cuadra mejor
812 r.Bottom:=r.Top + round(im.Height * Zoom);
813 Canvas.StretchDraw(r,im);
814 End;
815 procedure TMotGraf.DrawImage0(im: TGraphic; x1, y1, dx, dy: Integer);
816 //Dibuja imagen sin transformación
817 var r:TRect;
818 begin
819 if im = nil then exit;
820 // Canvas.Draw(x1, y1,im);
821 r.Left:=x1;
822 r.Top :=y1;
823 r.Right:=x1+dx;
824 r.Bottom:=y1+dy;
825 Canvas.StretchDraw(r,im);
826 // Canvas.StretchDraw(x1,y1,dx,dy,im); //por algún motivo no funciona{ TODO : ???? Debería funcionar }
827 End;
828
829 //////////////////////// Funciones de Dibujo de Controles /////////////////////////
830 procedure TMotGraf.DrawButtonBord(x1, y1: Single; ancho, alto: Single);
831 //Dibuja el borde de los botones
832 begin
833 SetColor(clGray, clWhite, 1);
834 Canvas.RoundRect(XPant(x1), YPant(y1), XPant(x1+ancho), YPant(y1+alto),
835 round(6 * Zoom), Round(6 * Zoom));
836 end;
837 procedure TMotGraf.DrawButtonBack(x1, y1: Single; ancho, alto: Single);
838 //Dibuja el fondo de los botones
839 begin
840 SetColor(clGray, clScrollBar, 1);
841 Canvas.RoundRect(XPant(x1), YPant(y1), XPant(x1+ancho), YPant(y1+alto),
842 round(6 * Zoom), Round(6 * Zoom));
843 end;
844 procedure TMotGraf.DibVnormal(x1, y1: Single; ancho, alto: Single);
845 //Dibuja una V en modo normal. Usado para dibujar el ícono de los botones
846 var xm: Single;
847 begin
848 SetPen(psSolid,2,clGray);
849 xm := x1 + round(ancho/2); //se redondea antes (ancho/2), para evitar vavriación en la
850 //posición, al dibujar en diferentes posiciones.
851 Line(x1, y1, xm, y1+alto);
852 Line(xm,y1+alto,x1+ancho,y1);
853 end;
854 procedure TMotGraf.DrawCheck(px, py: Single; ancho, alto: Single);
855 //Dibuja una marca de tipo "Check". Útil para implementar el control "Check"
856 var xm: Single;
857 begin
858 SetPen(psSolid,2,clGray);
859 xm := round(ancho/4);
860 Line(px , py + 3, px + xm, py + alto);
861 Line(px + xm, py + alto, px + ancho, py );
862 End;
863 procedure TMotGraf.DrawTrianUp(x1, y1: Single; ancho, alto: Single);
864 //Dibuja un pequeño triángulo apuntando hacia arriba
865 var
866 Ptos: array of TPoint; //arreglo de puntos a dibujar
867 begin
868 SetLength(Ptos, 3); //dimensiona
869 //Llena arreglo
870 Ptos[0].x := XPant(x1); Ptos[0].y := YPant(y1+alto);
871 Ptos[1].x := XPant(x1+ancho); Ptos[1].y := YPant(y1+alto);
872 Ptos[2].x := XPant(x1+ancho/2); Ptos[2].y := YPant(y1);
873 Canvas.Polygon(Ptos); //dibuja
874 end;
875 procedure TMotGraf.DrawTrianDown(x1, y1: Single; ancho, alto: Single);
876 //Dibuja un pequeño triángulo apuntando hacia abajo
877 var
878 Ptos: array of TPoint; //arreglo de puntos a dibujar
879 begin
880 SetLength(Ptos, 3); //dimensiona
881 //Llena arreglo
882 Ptos[0].x := XPant(x1); Ptos[0].y := YPant(y1);
883 Ptos[1].x := XPant(x1+ancho); Ptos[1].y := YPant(y1);
884 Ptos[2].x := XPant(x1+ancho/2); Ptos[2].y := YPant(y1+alto);
885 Canvas.Polygon(Ptos); //dibuja
886 end;
887
888 end.
889
890