• R/O
  • SSH
  • HTTPS

decimalbasic: Commit


Commit MetaInfo

Revision3 (tree)
Time2011-11-07 21:18:33
Authorshiraishikazuo

Log Message

(empty log message)

Change Summary

Incremental Difference

--- graphlib.pas (revision 2)
+++ graphlib.pas (nonexistent)
@@ -1,2487 +0,0 @@
1-unit graphlib;
2-{$IFDEF FPC}
3- {$MODE Delphi}{$H+}
4-{$ENDIF}
5-
6-(***************************************)
7-(* Copyright (C) 2009, SHIRAISHI Kazuo *)
8-(***************************************)
9-
10-{********}
11-interface
12-{********}
13-uses arrays,baslib;
14-
15-function PixelX(x:extended):longint; overload;
16-function PixelY(x:extended):longint; overload;
17-function WindowX(x:extended):extended; overload;
18-function WindowY(x:extended):extended; overload;
19-
20-procedure SetColorMix(cc:double; er,eg,eb:double; InsideofWhen:boolean); overload;
21-procedure SetWindow(l,r,b,t:double; insideofWhen:boolean); overload;
22-procedure SetViewPort(l,r,b,t:double; insideofWhen:boolean); overload;
23-procedure SetDeviceWindow(l,r,b,t:double; insideofWhen:boolean); overload;
24-procedure SetDeviceViewport(l,r,b,t:double; insideofWhen:boolean); overload;
25-
26-const
27- MaxLineStyle=5;
28- MaxPointStyle=7;
29- MaxAreaStyleIndex=6;
30-
31-procedure SetPointColor(x:double; InsideOfWhen:boolean); overload;
32-procedure setLineColor(x:double; InsideOfWhen:boolean); overload;
33-procedure setAreaColor(x:double; InsideOfWhen:boolean); overload;
34-procedure setTextColor(x:double; InsideOfWhen:boolean); overload;
35-procedure setAllColor(x:double; InsideOfWhen:boolean); overload;
36-procedure SetPointColor(const s:string; InsideOfWhen:boolean);overload;
37-procedure setLineColor(const s:string; InsideOfWhen:boolean);overload;
38-procedure setAreaColor(const s:string; InsideOfWhen:boolean);overload;
39-procedure setTextColor(const s:string; InsideOfWhen:boolean);overload;
40-procedure setAllColor(const s:string; InsideOfWhen:boolean); overload;
41-procedure SetAxisColor(x:double; InsideOfWhen:boolean); overload;
42-procedure SetAxisColor(const s:string; InsideOfWhen:boolean);overload;
43-
44-
45-procedure setPointStyle(x:double; InsideOfWhen:boolean); overload;
46-procedure setLineStyle(x:double; InsideOfWhen:boolean); overload;
47-procedure setLineWidth(x:double; InsideOfWhen:boolean); overload;
48-procedure setAreaStyle(const s:string);
49-procedure setAreaStyleIndex(x:double; InsideOfWhen:boolean); overload;
50-procedure setTextHeight(x:double; InsideOfWhen:boolean); overload;
51-procedure setTextAngle(x:double; AngleDegrees:boolean); overload;
52-procedure setTextJustify( s1,s2:string; InsideOfWhen:boolean);
53-
54-
55-function ColorOfName(s:string; insideofWhen:boolean):LongInt;
56-function ColorIndex(r,g,b:double):LongInt; overload;
57-
58-
59-procedure SetClip(const s:string; insideofwhen:boolean);
60-procedure SetTextFont(const s:string; x:double); overload;
61-procedure SetTextBackGround(const s:string);
62-procedure SetBitmapSize(x,y:double); overload;
63-
64-procedure GraphPoints(const a:array of double);
65-procedure GraphLines(const a:array of Double);
66-procedure BeamOff;
67-procedure PlotPoints(const a:array of double);
68-procedure PlotLines(const a:array of Double);
69-procedure GraphArea(const a: array of double);
70-procedure PlotArea(const a:array of double);
71-
72-procedure PlotText(x,y:double; const s:string); overload;
73-procedure PlotTextUsing(x,y:double; const form:string; a:array of const); overload;
74-procedure GraphText(x,y:double; const s:string); overload;
75-procedure GraphTextUsing(x,y:double; const form:string; a:array of const); overload;
76-procedure PlotLabel(x,y:double; const s:string); overload;
77-procedure PlotLabelUsing(x,y:double; const form:string; a:array of const); overload;
78-procedure GraphLabel(x,y:double; const s:string); overload;
79-procedure GraphLabelUsing(x,y:double; const form:string; a:array of const); overload;
80-procedure PlotLetters(x,y:double; const s:string); overload;
81-procedure PlotLettersUsing(x,y:double; const form:string; a:array of const); overload;
82-
83-procedure MatPlotPoints(const x,y:TArray1N);overload;
84-procedure MatPlotPoints(const m:TArray2N);overload;
85-procedure MatPlotLines(const x,y:TArray1N);overload;
86-procedure MatPlotLines(const m:TArray2N);overload;
87-procedure MatPlotArea(const x,y:TArray1N);overload;
88-procedure MatPlotArea(const m:TArray2N);overload;
89-
90-procedure MatPlotPointsLimit(n:double; const x,y:TArray1N);overload;
91-procedure MatPlotPointsLimit(n:double; const m:TArray2N);overload;
92-procedure MatPlotLinesLimit(n:double; const x,y:TArray1N);overload;
93-procedure MatPlotLinesLimit(n:double; const m:TArray2N);overload;
94-procedure MatPlotAreaLimit(n:double; const x,y:TArray1N);overload;
95-procedure MatPlotAreaLimit(n:double; const m:TArray2N);overload;
96-
97-procedure MatPlotCells(const p:TArray2N; const x1,y1,x2,y2:double; insideofWhen:boolean); overload;
98-procedure MatGraphCells(const p:TArray2N; const x1,y1,x2,y2:double; insideofWhen:boolean); overload;
99-
100-{GET & LOCATE}
101-procedure PointAt(x0,y0:Double; LocateSt:boolean); overload;
102-procedure GetPoint(var x,y:Double; NoBeamOff:boolean; Locatest:boolean); overload;
103-procedure MousePoll(var x,y,l,r:Double); overload;
104-procedure MatGetPointVarilen(m:TArray2N; Locatest:boolean); overload; overload;
105-procedure MatGetPointVarilen(m1,m2:TArray1N; Locatest:boolean); overload; overload;
106-procedure MatGetPoint(m1,m2:TArray1N; Locatest:boolean); overload; overload;
107-procedure MatGetPoint(m:TArray2N; Locatest:boolean);overload; overload;
108-
109-
110-Procedure LocateChoice( var x:Double);overload;
111-Procedure LocateChoice(n:Double; var x:Double);overload;
112-Procedure LocateChoice(n,i0:Double; var x:Double);overload;
113-Procedure LocateChoice(const a:TArray1S; var x:Double);overload;
114-
115-procedure LocateValue(n:Double; var x:double; name0:ansistring);overload;
116-procedure LocateValue(n:Double; left0,right0:double; var x:double; name0:ansistring);overload;
117-procedure LocateValue(n:Double; left0,right0,ini0:double; var x:double; name0:ansistring);overload;
118-procedure LocateValueNowait(n:Double; var x:double; name0:ansistring);overload;
119-procedure LocateValueNowait(n:Double; left0,right0:double; var x:double; name0:ansistring);overload;
120-procedure LocateValueNowait(n:Double; left0,right0,ini0:double; var x:double; name0:ansistring);overload;
121-procedure LocateValue(n:Double; ini0:double; var x:double; name0:ansistring);overload;
122-procedure LocateValueNowait(n:Double; ini0:double; var x:double; name0:ansistring);overload;
123-
124-
125-{ASK Statements}
126-function ASkWindow(var x1,x2,y1,y2:double):integer; overload;
127-function ASkViewport(var x1,x2,y1,y2:double):integer; overload;
128-function ASkDeviceWindow(var x1,x2,y1,y2:double):integer; overload;
129-function ASkDeviceViewport(var x1,x2,y1,y2:double):integer; overload;
130-
131-function AskPixelSize( var var1,var2:double):integer; overload;
132-function AskPixelSize( var var1,var2:integer):integer; overload;
133-function AskPixelSize(n1,n2,n3,n4:double; var var1,var2:double):integer;overload;
134-function AskPixelSize(n1,n2,n3,n4:double; var var1,var2:integer):integer;overload;
135-function AskPixelValue(x,y:double; var var1:double):integer; overload;
136-function AskPixelArray(x,y:double; a:Tarray2N):integer; overload;
137-function AskPixelArray(x,y:double; a:Tarray2N; s:TStrVar):integer; overload;
138-
139-function getlinecolor(var x:double):integer; overload;
140-function getlinestyle(var x:double):integer; overload;
141-function getlinewidth(var x:double):integer; overload;
142-function getpointcolor(var x:double):integer; overload;
143-function getpointstyle(var x:double):integer; overload;
144-function getareacolor(var x:double):integer; overload;
145-function gettextcolor(var x:double):integer; overload;
146-function getmaxcolor(var x:double):integer; overload;
147-function getaxiscolor(var x:double):integer; overload;
148-function getMaxPointDevice(var x:double):integer; overload;
149-function getMaxMultiPointDevice(var x:double):integer; overload;
150-function getMaxChoiceDevice(var x:double):integer; overload;
151-function getMaxValueDevice(var x:double):integer; overload;
152-function getAreaStyleIndex(var x:double):integer; overload;
153-function getmaxlinestyle(var x:double):integer; overload;
154-function getmaxpointstyle(var x:double):integer; overload;
155-
156-function ASkTextHeight(var x:double):integer; overload;
157-function AskTextAngle(var x:double):integer; overload;
158-function AskTextAngleRad(var x:double):integer; overload;
159-function AskDeviceSize(var x,y:double; t:TStrVar):integer; overload;
160-function AskBitmapSize(var x,y:double):integer; overload;
161-function AskTextJustify(h,v:TStrVar):integer; overload;
162-function AskTextWidth(const s:string; var width:double):integer; overload;
163-function AskColorMix(ColorIndex:double; var red,green,blue:double):integer; overload;
164-function AskClip(svar:TStrvar):integer;
165-function AskColorMode(svar:TStrvar):integer;
166-function AskBeamMode(svar:TStrvar):integer;
167-
168-procedure FLOOD( x,y:double);
169-procedure FLOODFill( x,y:double);
170-
171-
172-function drawaxes0(x,y:double):boolean;
173-function drawgrid0(x,y:double):boolean;
174-function drawaxes2(x,y:double):boolean;
175-function drawgrid2(x,y:double):boolean;
176-function drawcircle(x,y:double):boolean;
177-function drawdisk(x,y:double):boolean;
178-
179-Procedure GSAVE(const fname,pf:string);
180-
181-{*************}
182-implementation
183-{*************}
184-uses
185- Forms, Classes, SysUtils, Graphics,
186- MyUtils, base,float,affine,graphsys,format,LocateFrm,locatech, gridaxes;
187-
188-function PixelX(x:extended):longint;
189-begin
190- with MyGraphSys do
191- result:=DeviceX(x) - DeviceX(left);
192-end;
193-
194-function PixelY(x:extended):longint;
195-begin
196- with MyGraphSys do
197- result:=DeviceY(bottom) - DeviceY(x)
198-end;
199-
200-function WindowX(x:extended):extended;
201-begin
202- with MyGraphSys do
203- result:=VirtualX( DeviceX(left) + LongIntRound(x) )
204-end;
205-
206-function WindowY(x:extended):extended;
207-begin
208- with MyGraphSys do
209- result:=VirtualY( DeviceY(bottom) - LongIntRound(x))
210-end;
211-
212-{*********}
213-{SET COLOR}
214-{*********}
215-const
216- idxColorMax=255;
217- ercodeColor=11085;
218-
219-procedure SetPointColor(x:double; InsideOfWhen:boolean); overload;
220-var
221- c:LongInt;
222-begin
223- c:=LongIntRound(x) and $ffffff;
224- if (InsideOfWhen or not JISSetWindow)
225- and not MyPalette.PaletteDisabled
226- and ((c<0) or (c>idxColorMax)) then
227- setexception(ercodeColor);
228- MyGraphSys.PointColor:=c
229-end;
230-
231-procedure setLineColor(x:double; InsideOfWhen:boolean); overload;
232-var
233- c:LongInt;
234-begin
235- c:=LongIntRound(x) and $ffffff;
236- if (InsideOfWhen or not JISSetWindow)
237- and not MyPalette.PaletteDisabled
238- and ((c<0) or (c>idxColorMax)) then
239- setexception(ercodeColor);
240- MyGraphSys.SetLineColor(c)
241-end;
242-
243-procedure setAreaColor(x:double; InsideOfWhen:boolean); overload;
244-var
245- c:LongInt;
246-begin
247- c:=LongIntRound(x) and $ffffff;
248- if (InsideOfWhen or not JISSetWindow)
249- and not MyPalette.PaletteDisabled
250- and ((c<0) or (c>idxColorMax)) then
251- setexception(ercodeColor);
252- MyGraphSys.areaColor:=c
253-end;
254-
255-procedure setTextColor(x:double; InsideOfWhen:boolean); overload;
256-var
257- c:LongInt;
258-begin
259- c:=LongIntRound(x) and $ffffff;
260- if (InsideOfWhen or not JISSetWindow)
261- and not MyPalette.PaletteDisabled
262- and ((c<0) or (c>idxColorMax)) then
263- setexception(ercodeColor);
264- MyGraphSys.SetTextColor(c)
265-end;
266-
267-procedure setAllColor(x:double; InsideOfWhen:boolean); overload;
268-var
269- c:LongInt;
270-begin
271- c:=LongIntRound(x) and $ffffff;
272- if (InsideOfWhen or not JISSetWindow)
273- and not MyPalette.PaletteDisabled
274- and ((c<0) or (c>idxColorMax)) then
275- setexception(ercodeColor);
276- MyGraphSys.PointColor:=c;
277- MyGraphSys.SetLineColor(c);
278- MyGraphSys.AreaColor:=c;
279- MyGraphSys.SetTextColor(c);
280-end;
281-
282-
283-function ColorOfName(s:string; insideofWhen:boolean):LongInt;
284-var
285- i:integer;
286-begin
287- for i:=1 to length(s) do s[i]:=upcase(s[i]);
288- if (s='BLACK') or (s='黒') then
289- result:=Black
290- else if (s='BLUE')or (s='青') then
291- result:=Blue
292- else if (s='RED') or (s='赤') then
293- result:=Red
294- else if s='MAGENTA' then
295- result:=Magenta
296- else if (s='GREEN') or (s='緑') then
297- result:=Green
298- else if s='CYAN' then
299- result:=cyan
300- else if (s='YELLOW') or (s='黄') then
301- result:=Yellow
302- else if (s='WHITE') or (s='白') then
303- result:=White
304- else if s='GRAY' then
305- result:=clGray
306- else if s='NAVY' then
307- result:=clNAVY
308- else if s='SILVER' then
309- result:=clSILVER
310- else if s='LIME' then
311- result:=clGREEN
312- else
313- begin
314- result:=-1;
315- if insideofwhen or not JISSetWindow then
316- setexception(11085);
317- end;
318-end;
319-
320-function ColorIndex(r,g,b:double):LongInt;
321-begin
322- result:= MyPalette.colorindex(LongIntRound(r*255)
323- +LongIntRound(g*255)*$100
324- +LongIntRound(b*255)*$10000);
325-end;
326-
327-procedure SetPointColor(const s:string; InsideOfWhen:boolean);overload;
328-var
329- c:LongInt;
330- color:LongInt;
331-begin
332- color:=GraphLib.ColorOfName(s,insideofWhen);
333- if color>=0 then
334- begin
335- c:=MyPalette.ColorIndex(color);
336- if c>=0 then
337- MyGraphSys.PointColor:=c;
338- end
339-end;
340-
341-procedure setLineColor(const s:string; InsideOfWhen:boolean);overload;
342-var
343- c:LongInt;
344- color:LongInt;
345-begin
346- color:=GraphLib.ColorOfName(s,insideofWhen);
347- if color>=0 then
348- begin
349- c:=MyPalette.ColorIndex(color);
350- if c>=0 then
351- MyGraphSys.SetLineColor(c);
352- end
353-end;
354-
355-procedure setAreaColor(const s:string; InsideOfWhen:boolean);overload;
356-var
357- c:LongInt;
358- color:LongInt;
359-begin
360- color:=GraphLib.ColorOfName(s,insideofWhen);
361- if color>=0 then
362- begin
363- c:=MyPalette.ColorIndex(color);
364- if c>=0 then
365- MyGraphSys.AreaColor:=c;
366- end
367-end;
368-
369-procedure setTextColor(const s:string; InsideOfWhen:boolean);overload;
370-var
371- c:LongInt;
372- color:LongInt;
373-begin
374- color:=GraphLib.ColorOfName(s,insideofWhen);
375- if color>=0 then
376- begin
377- c:=MyPalette.ColorIndex(color);
378- if c>=0 then
379- MyGraphSys.SetTextColor(c);
380- end
381-end;
382-
383-procedure setAllColor(const s:string; InsideOfWhen:boolean);overload;
384-var
385- c:LongInt;
386- color:LongInt;
387-begin
388- color:=GraphLib.ColorOfName(s,insideofWhen);
389- if color>=0 then
390- begin
391- c:=MyPalette.ColorIndex(color);
392- if c>=0 then
393- SetAllColor(c,InsideOfWhen);
394- end
395-end;
396-
397-procedure SetAxisColor(x:double; InsideOfWhen:boolean);overload;
398-var
399- c:LongInt;
400-begin
401- c:=LongIntRound(x);
402- if c>=0 then
403- GraphSys.axescolor:=c
404-end;
405-
406-procedure SetAxisColor(const s:string; InsideOfWhen:boolean);overload;
407-var
408- c:LongInt;
409- color:LongInt;
410-begin
411- color:=GraphLib.ColorOfName(s,insideofWhen);
412- if color>=0 then
413- begin
414- c:=MyPalette.ColorIndex(color);
415- if c>=0 then
416- SetAxisColor(c,InsideOfWhen);
417- end
418-end;
419-
420-
421-
422-
423-
424-
425-
426-function CoordinateTest(var l,r,b,t:double; insideofwhen:boolean):boolean;
427-begin
428- if currenttransform<>nil then
429- setexception(11004);
430- if ((l=r) or (b=t)) then
431- if InsideOfWhen or not JISSetWindow then
432- setexception(11051)
433- else
434- result:=false
435- else
436- result:=true;
437-end;
438-
439-procedure SetWindow(l,r,b,t:double; insideofWhen:boolean);
440-begin
441- if CoordinateTest(l,r,b,t,insideofwhen)then
442- MyGraphSys.setWindow(l,r,b,t) ;
443- Application.ProcessMessages;
444-end;
445-
446-function TestInterval(const l,r,b,t:extended):boolean;
447-begin
448- result:=(0<=l) and (r<=1) and (0<=b) and (t<=1)
449-end;
450-
451-procedure SetViewPort(l,r,b,t:double; InsideOfWhen:boolean);
452-begin
453- if CoordinateTest(l,r,b,t, InsideOfWhen)then
454- if testInterval(l,r,b,t) then
455- MyGraphSys.setViewport(l,r,b,t)
456- else if InsideOfWhen or not JISSetWindow then
457- setexception(11052);
458-end;
459-
460-procedure SetDeviceWindow(l,r,b,t:double; InsideOfWhen:boolean);
461-begin
462- if CoordinateTest(l,r,b,t, InsideOfWhen)then
463- if testInterval(l,r,b,t) then
464- MyGraphSys.setDeviceWindow(l,r,b,t)
465- else if InsideOfWhen or not JISSetWindow then
466- setexception(11053);
467-end;
468-
469-procedure SetDeviceViewPort(l,r,b,t:double; InsideOfWhen:boolean);
470-begin
471- if CoordinateTest(l,r,b,t, InsideOfWhen)then
472- if (l<r) and (b<t) then
473- MyGraphSys.setDeviceViewport(l,r,b,t)
474- else if InsideOfWhen or not JISSetWindow then
475- setexception(11054);
476-end;
477-
478-{*********}
479-{SET COLOR}
480-{*********}
481-
482-{*************}
483-{SET COLOR MIX}
484-{*************}
485-
486- procedure SetColorMixSub(c:byte;r,g,b:byte);
487-var
488- col:TColor;
489-begin
490- col:=r+g*word($100)+b*longint($10000) ;
491- with MyGraphSys do
492- begin
493- MyPalette[c]:=col ;
494- setlinecolor(linecolor);
495- settextcolor(textcolor);
496- end;
497-end;
498-
499-procedure SetColorMix(cc:double; er,eg,eb:double; InsideofWhen:boolean);
500-var
501- c,r,g,b:byte;
502-begin
503- if (cc<0) or (cc>maxColor) or MyPalette.PaletteDisabled then
504- if InsideOfWhen or not JISSetWindow then
505- setexception(11085);
506-
507- if (er<0) or (er>1) or (eg<0) or (eg>1) or (eb<0) or (eb>1) then
508- if InsideOfWhen or not JISSetWindow then
509- setexception(11088);
510- c:=LongIntRound(cc);
511- r:=LongIntRound(er*255);
512- g:=LongIntRound(eg*255);
513- b:=LongIntRound(eb*255);
514- setcolormixsub(c,r,g,b);
515-end;
516-
517-procedure setPointStyle(x:double; InsideOfWhen:boolean);
518-var
519- c:LongInt;
520-begin
521- c:=LongIntRound(x);
522- if (c>0) and (c<=maxpointstyle) then
523- MyGraphSys.pointstyle:=c
524- else if insideofwhen or not JISSetWindow then
525- setexception(11056) ;
526-end;
527-
528-procedure setLineStyle(x:double; InsideOfWhen:boolean);
529-var
530- c:LongInt;
531- s:TPenStyle;
532-begin
533- c:=LongIntRound(x);
534- if (c>0) and (c<=5) then
535- begin
536- case c of
537- 1: s:=psSolid;
538- 2: s:=psDash;
539- 3: s:=psDot;
540- 4: s:=psDashDot;
541- 5: s:=psDashDotDot;
542- end;
543- MyGraphSys.setPenStyle(s);
544- end
545- else
546- if insideofwhen or not JISSetWindow then
547- setexception(11062)
548-end;
549-
550-
551-procedure setAreaStyleIndex(x:double; InsideOfWhen:boolean);
552-var
553- c:LongInt;
554-begin
555- c:=LongIntRound(x);
556- if (c>0) and (c<=6) then
557- MyGraphSys.SetAreaStyleIndex(c)
558- else if insideofwhen or not JISSetWindow then
559- setexception(11000) ;
560-end;
561-
562-procedure setTextHeight(x:double; InsideOfWhen:boolean);
563-begin
564- if x>0 then
565- MyGraphSys.SetTextHeight(x)
566- else if insideofWhen or not JISSetWindow then
567- setexception(11073);
568-end;
569-procedure setLineWidth(x:double; InsideOfWhen:boolean);
570-var
571- c:LongInt;
572-begin
573- c:=LongIntRound(x);
574- if c>0 then
575- MyGraphSys.setlinewidth(c);
576-end;
577-
578-procedure setTextAngle(x:double; AngleDegrees:boolean);
579-var
580- a:Integer;
581-begin
582- if not Angledegrees then
583- x:=x * 180. / PI;
584- a:=SysTem.Round(x - Floor(x/360.0 ) * 360.0 );
585- MyGraphSys.textangle:=a;
586-end;
587-
588-procedure setAreaStyle(const s:string);
589-var
590- c:TAreaStyle;
591-begin
592- if UpperCase(s)='HOLLOW' then c:=asHollow
593- else if UpperCase(s)='SOLID' then c:=asSolid
594- else if UpperCase(s)='HATCH' then c:=asHatch
595- else setexception(11000);
596- MyGraphSys.SetAreaStyle(c);
597-end;
598-
599-procedure setTextJustify( s1,s2:string; InsideOfWhen:boolean);
600- var
601- h:tjHorizontal;
602- v:tjVirtical;
603- begin
604- s1:=ansiUpperCase(s1);
605- s2:=ansiUpperCase(s2);
606-
607- h:=tjLEFT;
608- while (h<=tjRIGHT) and (Hjustification[h]<>s1) do inc(h);
609- if system.ord(h)<=system.ord(tjRIGHT) then
610- MyGraphSys.Hjustify:=h
611- else if insideofwhen or not JISSetWindow then
612- setexception(4102) ;
613-
614- v:=tjTOP;
615- while (v<=tjBOTTOM) and (Vjustification[v]<>s2) do inc(v);
616- if system.ord(v)<=system.ord(tjBOTTOM) then
617- MyGraphSys.Vjustify:=v
618- else if insideofwhen or not JISSetWindow then
619- setexception(4102) ;
620-end;
621-
622-
623-(*
624-procedure setpointcolor(c:integer);
625-begin
626- c:=c and $ffffff;
627- MyGraphSys.PointColor:=c;
628-end;
629-
630-procedure setlinecolor(c:integer);
631-begin
632- c:=c and $ffffff;
633- MyGraphSys.setlinecolor(c);
634-end;
635-
636-procedure setareacolor(c:integer);
637-begin
638- c:=c and $ffffff;
639- MyGraphSys.areacolor:=c ;
640-end;
641-
642-procedure settextcolor(c:integer);
643-begin
644- c:=c and $ffffff;
645- MyGraphSys.settextcolor(c);
646-end;
647-*)
648-
649-procedure SetClip(const s:string; insideofwhen:boolean);
650-begin
651- with MyGraphSys do
652- if Uppercase(s)='ON' then setclip(true)
653- else if Uppercase(s)='OFF' then setclip(false)
654- else if InsideOfWhen or not JISSetWindow then
655- setexception(4101);
656-end;
657-
658-procedure SetTextFont(const s:string; x:double);
659-begin
660- MyGraphSys.SetTextFont(s, LongIntRound(x));
661-end;
662-
663-procedure SetTextBackGround(const s:string);
664-begin
665- if UpperCase(s)='TRANSPARENT' then iBKmode:=TRANSPARENT
666- else if UpperCase(s)='OPAQUE' then iBKmode:=OPAQUE
667- else setexception(11000);
668-end;
669-
670-procedure SetBitmapSize(x,y:double);
671-begin
672- try
673- MyGraphSys.setBitmapSize(LongIntRound(x),LongIntRound(y))
674- except
675- setexception(9050);
676- end;
677-end;
678-
679-{*************************}
680-{PLOT POINT and PLOT LINES}
681-{*************************}
682-var
683- x0,y0:extended;
684-
685-procedure ProjectivePlotTo(const x1,y1:extended);
686-var
687- a,b,s,t,u,x,y:extended;
688-label
689- Retry1,Retry2;
690-begin
691- with CurrentTransform do
692- begin
693- if MyGraphSys.beam=true then
694- begin
695- a:=x1-x0;
696- b:=y1-y0;
697- s:=ox*a+oy*b;
698- t:=-(ox*x0+oy*y0+oo);
699- if s<>0 then
700- begin
701- t:=t/s;
702-
703- if (t>0 - 1e-14) and (t<=1 + 1e-14) then
704- begin
705-
706- u:=t;
707- Retry1:
708- u:=u-0.0001;
709- if u>0 then
710- begin
711- x:=a*u+x0;
712- y:=b*u+y0;
713- if transform(x,y) then
714- MyGraphSys.PlotTo(x,y)
715- else
716- GOTO Retry1;
717- end;
718-
719- MyGraphSys.beam:=false;
720-
721- u:=1-t;
722- Retry2:
723- u:=u-0.0001;
724- if u>0 then
725- begin
726- x:=a*(1-u)+x0;
727- y:=b*(1-u)+y0;
728- if transform(x,y) then
729- MyGraphSys.PlotTo(x,y)
730- else
731- GOTO Retry2;
732- end;
733- end;
734- end;
735- end;
736-
737- x:=x1;
738- y:=y1;
739- if transform(x,y) then
740- MyGraphSys.PlotTo(x,y);
741- x0:=x1;
742- y0:=y1;
743- MyGraphSys.beam:=true;
744- end;
745-end;
746-
747-type
748- TPointArray=array[ 0..1023] of TPoint;
749- PPointArray=^TPointArray;
750-
751-procedure GraphPoints(const a: array of double);
752-var
753- i:integer;
754- p:PPointArray;
755- x,y:double;
756-begin
757- GetMem(p,sizeof(double)*Length(a));
758- try
759- for i:=0 to High(a) div 2 do
760- begin
761- x:=a[2*i];
762- y:=a[2*i+1];
763- MyGraphSys.putMark(x,y);
764- end;
765- finally
766- FreeMem(p, sizeof(double)*Length(a));
767- end;
768- MyGraphSys.ThinRepaint;
769-end;
770-
771-
772-procedure PlotPoints(const a: array of double);
773-var
774- i:integer;
775- p:PPointArray;
776- x,y:double;
777-begin
778- with MyGraphSys do
779- if BeamMode=bmRigorous then beam:=false;
780-
781- GetMem(p,sizeof(double)*Length(a));
782- try
783- for i:=0 to High(a) div 2 do
784- begin
785- x:=a[2*i];
786- y:=a[2*i+1];
787- if currenttransform.transform(x,y) then
788- MyGraphSys.putMark(x,y);
789- end;
790- finally
791- FreeMem(p, sizeof(double)*Length(a));
792- end;
793- MyGraphSys.ThinRepaint;
794-end;
795-
796-procedure GraphLines(const a: array of double);
797-var
798- i:integer;
799- p:PPointArray;
800- x,y:double;
801-begin
802- MyGraphSys.beam:=false;
803- GetMem(p,sizeof(double)*Length(a));
804- try
805- for i:=0 to High(a) div 2 do
806- begin
807- x:=a[2*i];
808- y:=a[2*i+1];
809- MyGraphSys.PlotTo(x,y);
810- end
811- finally
812- FreeMem(p, sizeof(double)*Length(a));
813- end;
814- MyGraphSys.beam:=false;
815- MyGraphSys.ThinRepaint;
816-end;
817-
818-procedure PlotLines(const a: array of double);
819-var
820- i:integer;
821- p:PPointArray;
822- x,y:double;
823-begin
824- GetMem(p,sizeof(double)*Length(a));
825- try
826- if (CurrentTransform=nil) or CurrentTransform.IsAffine then
827- for i:=0 to High(a) div 2 do
828- begin
829- x:=a[2*i];
830- y:=a[2*i+1];
831- if currenttransform.transform(x,y) then
832- MyGraphSys.PlotTo(x,y);
833- end
834- else
835- for i:=0 to High(a) div 2 do
836- begin
837- x:=a[2*i];
838- y:=a[2*i+1];
839- ProjectivePlotTo(x,y)
840- end;
841- finally
842- FreeMem(p, sizeof(double)*Length(a));
843- end;
844- MyGraphSys.ThinRepaint;
845-end;
846-
847-procedure BeamOff;
848-begin
849- MyGraphSys.beam:=false;
850-end;
851-
852-{*********}
853-{PLOT AREA}
854-{*********}
855-
856-type
857- TCoordinate=Packed Record
858- x,y:extended;
859- end;
860- TCoordinateArray=Packed Array[0..1023] of TCoordinate;
861- PCoordinateArray=^TCoordinateArray;
862-
863- function NormalSegment(const x0,y0,x1,y1:extended):boolean;
864-var
865- a,b,s,t:extended;
866-begin
867- result:=true;
868- if CurrentTransform=nil then exit;
869- with CurrentTransform do
870- begin
871- a:=x1-x0;
872- b:=y1-y0;
873- s:=ox*a+oy*b;
874- t:=-(ox*x0+oy*y0+oo);
875- if s<>0 then
876- begin
877- t:=t/s;
878- if (t>=0) and (t<=1) then
879- result:=false;
880- end
881- else if t=0 then
882- result:=false;
883- end
884-end;
885-
886-function TestNormalSegments(p:PCoordinateArray; count:integer):boolean;
887-var
888- i:integer;
889-begin
890- result:=true;
891- for i:=0 to count-1 do
892- result:=result and NormalSegment(p^[i].x, p^[i].y,
893- p^[(i+1)mod count].x, p^[(i+1)mod count].y);
894-end;
895-
896-
897-function Inner(x,y:extended; p:PCoordinateArray; count:integer):boolean;
898-var
899- i:integer;
900- x0,y0,x1,y1,y2:extended;
901- xt:extended;
902-begin
903- if (p^[0].x = p^[count-1].x) and (p^[0].y = p^[count-1].y) then dec(count);
904-
905- result:=false;
906-
907- for i:=0 to count -1 do
908- begin
909- x0:=p^[i].x;
910- y0:=p^[i].y;
911- x1:=p^[(i+1) mod count].x;
912- y1:=p^[(i+1) mod count].y;
913- y2:=p^[(i+2) mod count].y;
914-
915- if (y0 - y) * (y - y1) >0 then
916- begin
917- xt:=(x1-x0)/(y1-y0)*(y-y0)+x0;
918- if x=xt then begin result:=true; exit end
919- else if x<xt then result:=not result;
920- end
921- else if y=y1 then
922- begin
923- if (y0=y1) then
924- begin
925- if ((x -x0)*(x - x1)<=0) then
926- begin result:=true ; exit end ;
927- end
928- else if (y=y1) and ((y0 - y1)*(y1 - y2)>0) then
929- begin
930- if x<x1 then result:= not result
931- end
932- end
933- end;
934-end;
935-
936-function ReMakeList(p:PCoordinateArray; q:PPointArray; count:integer; GRAPHst:boolean):integer; //結果は点の個数
937-var
938- i,index:integer;
939- x,y:extended;
940-begin
941- result:=0;
942- for i:=0 to count-1 do
943- begin
944- x:=p^[i].x;
945- y:=p^[i].y;
946- if GRAPHst or currenttransform.transform(x,y) then
947- begin
948- q^[result].x:=restrict(MyGraphSys.deviceX(x));
949- q^[result].y:=restrict(MyGraphSys.deviceY(y));
950- inc(result)
951- end
952- end;
953-end;
954-
955-
956-procedure ProjectivePolygonSub(p:PCoordinateArray; lim:integer);
957-var
958- q:PPointArray;
959- a,b:integer;
960- x,y,yy:extended;
961-begin
962- if TestNormalSegments(p,lim) then
963- begin
964- GetMem(q,lim*sizeof(TPoint));
965- try
966- MyGraphSys.Polygon(slice(q^,ReMakeList(p,q,lim,false)));
967- finally
968- Freemem(q,lim*sizeof(TPoinT));
969- end
970- end
971- else
972- with MyGraphSys do
973- for b:=ClipRect.top to Cliprect.Bottom do
974- begin
975- yy:=virtualY(b);
976- for a:=ClipRect.Left to Cliprect.Right do
977- begin
978- x:=virtualX(a);
979- y:=yy;
980- if currenttransform.invtransform(x,y) then
981- if inner(x,y,p,lim) then
982- PutColor(a,b,areacolor);
983- end;
984- end;
985-end;
986-
987-procedure PlotAreaProjective(Const a:Array of double);
988-var
989- P:PCoordinateArray;
990- i:integer;
991- count:integer;
992-begin
993- count:=Length(a) div 2;
994- GetMem(p, count*SizeOf(TCoordinate));
995- try
996- for i:=0 to count -1 do
997- begin
998- p^[i].x:=a[2*i];
999- p^[i].y:=a[2*i+1];
1000- end;
1001- ProjectivePolygonSub(p,count);
1002- finally
1003- FreeMem(p, count*SizeOf(TCoordinate));
1004- end;
1005-end;
1006-
1007-procedure PlotAreaNormal(const a: array of double);
1008-var
1009- i:integer;
1010- p:PPointArray;
1011- x,y:double;
1012-begin
1013- GetMem(p,sizeof(TPoint)*Length(a));
1014- try
1015- for i:=0 to High(a) div 2 do
1016- begin
1017- x:=a[2*i];
1018- y:=a[2*i+1];
1019- if not currenttransform.transform(x,y) then exit;
1020- p^[i].x:=restrict(MyGraphSys.deviceX(x));
1021- p^[i].y:=restrict(MyGraphSys.deviceY(y));
1022- end;
1023- MyGraphSys.Polygon(Slice(p^,Length(a) div 2));
1024- finally
1025- FreeMem(p, sizeof(TPoint)*Length(a));
1026- end;
1027-end;
1028-
1029-procedure PlotArea(const a: array of double); overload;
1030-begin
1031- with MyGraphSys do
1032- if BeamMode=bmRigorous then beam:=false;
1033-
1034- if (CurrentTransform=nil) or CurrentTransform.IsAffine then
1035- PlotAreaNormal(a)
1036- else
1037- PlotAreaProjective(a);
1038- MyGraphSys.ThinRepaint;
1039-end;
1040-
1041-procedure GraphArea(const a: array of double);
1042-var
1043- i:integer;
1044- p:PPointArray;
1045- x,y:double;
1046-begin
1047- BeamOff;
1048- GetMem(p,sizeof(TPoint)*Length(a));
1049- try
1050- for i:=0 to High(a) div 2 do
1051- begin
1052- x:=a[2*i];
1053- y:=a[2*i+1];
1054- p^[i].x:=restrict(MyGraphSys.deviceX(x));
1055- p^[i].y:=restrict(MyGraphSys.deviceY(y));
1056- end;
1057- MyGraphSys.Polygon(Slice(p^,Length(a) div 2));
1058- finally
1059- FreeMem(p, sizeof(TPoint)*Length(a));
1060- end;
1061- MyGraphSys.ThinRepaint;
1062-end;
1063-
1064-
1065-{*********}
1066-{PLOT TEXT}
1067-{*********}
1068-
1069-
1070-
1071-procedure GraphText(x,y:double; const s:string);
1072-begin
1073- with MyGraphSys do beam:=false;
1074- MyGraphSys.PutText(x,y,s);
1075- MyGraphSys.ThinRepaint;
1076-end;
1077-
1078-procedure PlotText(x,y:double; const s:string);
1079-begin
1080- with MyGraphSys do
1081- if BeamMode=bmRigorous then beam:=false;
1082- if currenttransform.transform(x,y) then
1083- MyGraphSys.PlotText(x,y,s);
1084- MyGraphSys.ThinRepaint;
1085-end;
1086-
1087-function TextUsing(const form:string; a:array of const):String;
1088-var
1089- i,code,c:integer;
1090- s:string;
1091-begin
1092- i:=1;
1093- s:=literals(form,i);
1094- for c:=0 to High(a) do
1095- begin
1096- with a[c] do
1097- case VType of
1098- vtInteger: s:=s + formatEx(VInteger,form,i,code);
1099- vtInt64: s:=s + formatEx(VINT64^,form,i,code);
1100- vtExtended: s:=s + formatEx(VExtended^,form,i,code);
1101- vtchar: s:=s + formatStr(VChar,form,i,code);
1102- vtString: s:=s + formatStr(VString^,form,i,code);
1103- vtAnsiString:s:=s + formatStr(string(VAnsiString),form,i,code);
1104- end;
1105- s:=s +literals(form,i)
1106- end;
1107- result:=s;
1108-end;
1109-
1110-procedure PlotTextUsing(x,y:double; const form:string; a:array of const);
1111-begin
1112- PlotText(x,y,TextUsing(form,a));
1113-end;
1114-
1115-procedure GraphTextUsing(x,y:double; const form:string; a:array of const);
1116-begin
1117- GraphText(x,y,TextUsing(form,a));
1118-end;
1119-
1120-procedure GraphLabel(x,y:double; const s:string);
1121-begin
1122- with MyGraphSys do
1123- if BeamMode=bmRigorous then beam:=false;
1124- MyGraphSys.PutText(x,y,s);
1125- MyGraphSys.ThinRepaint;
1126-end;
1127-
1128-procedure PlotLabel(x,y:double; const s:string);
1129-begin
1130- with MyGraphSys do
1131- if BeamMode=bmRigorous then beam:=false;
1132- if currenttransform.transform(x,y) then
1133- MyGraphSys.PutText(x,y,s);
1134- MyGraphSys.ThinRepaint;
1135-end;
1136-
1137-procedure PlotLetters(x,y:double; const s:string);
1138-begin
1139- with MyGraphSys do
1140- if BeamMode=bmRigorous then beam:=false;
1141- if currenttransform.transform(x,y) then
1142- MyGraphSys.PlotLetters(x,y,s);
1143- MyGraphSys.ThinRepaint;
1144-end;
1145-
1146-procedure GraphLabelUsing(x,y:double; const form:string; a:array of const);
1147-begin
1148- PlotLabel(x,y,TextUsing(form,a));
1149-end;
1150-
1151-procedure PlotlabelUsing(x,y:double; const form:string; a:array of const);
1152-begin
1153- PlotLabel(x,y,TextUsing(form,a));
1154-end;
1155-
1156-
1157-procedure PlotLettersUsing(x,y:double; const form:string; a:array of const);
1158-begin
1159- PlotLetters(x,y,TextUsing(form,a));
1160-end;
1161-
1162-
1163-{********}
1164-{MAT PLOT}
1165-{********}
1166-
1167-
1168-procedure MatPlotPointsSub(n:integer; const m1,m2:TArray1N);overload;
1169-var
1170- i:integer;
1171- x,y:double;
1172-begin
1173- for i:=0 to n-1 do
1174- begin
1175- x:=m1.elements[i];
1176- y:=m2.elements[i];
1177- if currenttransform.transform(x,y) then
1178- MyGraphSys.putMark(x,y);
1179- end;
1180-end;
1181-
1182-procedure MatPlotPointsSub(n:integer; const m:TArray2N);overload;
1183-var
1184- i:integer;
1185- s:integer;
1186- x,y:double;
1187-begin
1188- s:=m.size2;
1189- if s<=1 then
1190- setexception(6401);
1191-
1192- for i:=0 to n-1 do
1193- begin
1194- x:=m.elements[i*s];
1195- y:=m.elements[i*s+1];
1196- if currenttransform.transform(x,y) then
1197- MyGraphSys.putMark(x,y);
1198- end;
1199-end;
1200-
1201-
1202-function SetCoordinate(p:PPointArray; n:integer; x,y:TArray1N):boolean;overload;
1203-var
1204- i:integer;
1205- xx,yy:double;
1206-begin
1207- result:=false;
1208- for i:=0 to n-1 do
1209- begin
1210- xx:=x.elements[i];
1211- yy:=y.elements[i];
1212- if not currenttransform.transform(xx,yy) then exit;
1213- p^[i].x:=restrict(MyGraphSys.deviceX(xx));
1214- p^[i].y:=restrict(MyGraphSys.deviceY(yy));
1215- end;
1216- result:=true;
1217-end;
1218-
1219-function SetCoordinate(p:PPointArray; n:integer; m:TArray2N):boolean;overload;
1220-var
1221- i:integer;
1222- s:integer;
1223- xx,yy:double;
1224-begin
1225- result:=false;
1226- s:=m.Size2;
1227- if s<=1 then
1228- setexception(6401);
1229-
1230- for i:=0 to n-1 do
1231- begin
1232- xx:=m.elements[i*s];
1233- yy:=m.elements[i*s+1];
1234- if not currenttransform.transform(xx,yy) then exit;
1235- p^[i].x:=restrict(MyGraphSys.deviceX(xx));
1236- p^[i].y:=restrict(MyGraphSys.deviceY(yy));
1237- end;
1238- result:=true;
1239-end;
1240-
1241-
1242-procedure MatPlotLinesSub(n:integer; const x,y:TArray1N);overload;
1243-var
1244- p:PPointArray;
1245-begin
1246- BeamOff;
1247- Getmem(p,n*sizeof(TPoint));
1248- try
1249- if SetCoordinate(p,n,x,y) then
1250- MyGraphSys.PolyLine(slice(p^,n));
1251- finally
1252- Freemem(p,n*sizeof(TPoint));
1253- end;
1254- MyGraphSys.beam:=false;
1255- MyGraphSys.ThinRepaint;
1256-end;
1257-
1258-procedure MatPlotLinesSub(n:integer; const m:TArray2N);overload;
1259-var
1260- p:PPointArray;
1261-begin
1262- BeamOff;
1263- Getmem(p,n*sizeof(TPoint));
1264- try
1265- if SetCoordinate(p,n,m) then
1266- MyGraphSys.PolyLine(slice(p^,n));
1267- finally
1268- Freemem(p,n*sizeof(TPoint));
1269- end;
1270- MyGraphSys.beam:=false;
1271- MyGraphSys.ThinRepaint;
1272-end;
1273-
1274-procedure MatPlotAreaSub(n:integer; const x,y:TArray1N);overload;
1275-var
1276- p:PDoubleArray;
1277- i:integer;
1278-begin
1279- if n<3 then setexception(11100);
1280- Getmem(p,2*n*sizeof(Double));
1281- try
1282- for i:=0 to n-1 do
1283- begin
1284- p^[2*i]:=x.elements^[i];
1285- p^[2*i+1]:=y.elements^[i];
1286- end;
1287- PlotArea(slice(p^,2*n))
1288- finally
1289- Freemem(p,2*n*sizeof(Double));
1290- end;
1291- MyGraphSys.ThinRepaint;
1292-end;
1293-
1294-procedure MatPlotAreaSub(n:integer; const m:TArray2N);overload;
1295-begin
1296- if n<3 then setexception(11100);
1297- PlotArea(slice(m.elements^,n*2))
1298-end;
1299-
1300-
1301-procedure MatPlotPoints(const x,y:TArray1N);overload;
1302-begin
1303- if x.Size=y.Size then
1304- MatPlotPointsSub(x.Size, x, y)
1305- else
1306- SetException(6401);
1307-end;
1308-
1309-procedure MatPlotPoints(const m:TArray2N);overload;
1310-begin
1311- MatPlotPointsSub(m.Size1, m)
1312-end;
1313-
1314-procedure MatPlotLines(const x,y:TArray1N);overload;
1315-begin
1316- if (x.Size=y.Size) then
1317- MatPlotLinesSub(x.Size, x, y)
1318- else
1319- SetException(6401);
1320-end;
1321-
1322-procedure MatPlotLines(const m:TArray2N);overload;
1323-begin
1324- MatPlotLinesSub(m.size1, m)
1325-end;
1326-
1327-procedure MatPlotArea(const x,y:TArray1N);overload;
1328-begin
1329- if (x.Size=y.Size) then
1330- MatPlotAreaSub(x.Size, x, y)
1331- else
1332- SetException(6401);
1333-end;
1334-
1335-
1336-procedure MatPlotArea(const m:TArray2N);overload;
1337-begin
1338- MatPlotAreaSub(m.size1, m)
1339-end;
1340-
1341-procedure MatPlotPointsLimit(n:double; const x,y:TArray1N);overload;
1342-var
1343- nn:integer;
1344-begin
1345- nn:=LongIntRound(n);
1346- if (nn>=0) and (nn<=x.size1) and (nn<=y.size1) then
1347- MatPlotPointsSub(nn, x,y)
1348- else
1349- SetException(6402)
1350-end;
1351-
1352-procedure MatPlotPointsLimit(n:double; const m:TArray2N);overload;
1353-var
1354- nn:integer;
1355-begin
1356- nn:=LongIntRound(n);
1357- if (nn>=0) and (nn<=m.size1) then
1358- MatPlotPointsSub(nn, m)
1359- else
1360- SetException(6402)
1361-end;
1362-
1363-
1364-procedure MatPlotLinesLimit(n:double; const x,y:TArray1N);overload;
1365-var
1366- nn:integer;
1367-begin
1368- nn:=LongIntRound(n);
1369- if (nn>0) and (nn<=x.size1) and (nn<=y.size1) then
1370- MatPlotLinesSub(nn, x,y)
1371- else
1372- SetException(6402)
1373-end;
1374-
1375-procedure MatPlotLinesLimit(n:double; const m:TArray2N);overload;
1376-var
1377- nn:integer;
1378-begin
1379- nn:=LongIntRound(n);
1380- if (nn>0) and (nn<=m.size1) then
1381- MatPlotLinesSub(nn, m)
1382- else
1383- SetException(6402)
1384-end;
1385-
1386-procedure MatPlotAreaLimit(n:double; const x,y:TArray1N);overload;
1387-var
1388- nn:integer;
1389-begin
1390- nn:=LongIntRound(n);
1391- if (nn>0) and (nn<=x.size1) and (nn<=y.size1) then
1392- MatPlotAreaSub(nn, x,y)
1393- else
1394- SetException(6402)
1395-end;
1396-
1397-
1398-procedure MatPlotAreaLimit(n:double; const m:TArray2N);overload;
1399-var
1400- nn:integer;
1401-begin
1402- nn:=LongIntRound(n);
1403- if (nn>0) and (nn<=m.size1) then
1404- MatPlotAreaSub(nn, m)
1405- else
1406- SetException(6402)
1407-end;
1408-
1409-
1410-{**************}
1411-{MAT PLOT CELLS}
1412-{**************}
1413-
1414-procedure MatCells(p:TArray2N; const x1,y1,x2,y2:double; GRAPHst,insideofWhen:boolean);
1415-var
1416- a,b,i,j:integer;
1417- color:longint;
1418- x,y,w,h:extended;
1419- xx,yy,dx,dy:extended;
1420- //colorbyte:^byte;
1421- svDrawMode:boolean;
1422- PaletteDisabled:boolean;
1423- red,green,blue:byte;
1424- Points:array[1..4]of TPoint;
1425- a1,b1,a2,b2,a3,b3,a4,b4:extended;
1426- f:boolean;
1427-begin
1428- if p.size=0 then exit;
1429-
1430- f:=false;
1431- if (MyGraphSys is TScreenBMPGraphSys)
1432- and ((CurrentTransform=nil)
1433- or CurrentTransform.IsAffine and (abs(CurrentTransform.det)>1/1024)) then
1434- begin
1435-
1436- PaletteDisabled:=MyPalette.PaletteDisabled;
1437- svDrawMode:=GraphSys.HiddenDrawMode;
1438- MyGraphSys.SetHiddenDrawMode(true);
1439-
1440- x:=MyGraphSys.virtualX(0);
1441- y:=MyGraphSys.virtualY(0);
1442- dx:=MyGraphSys.virtualX(1);
1443- dy:=MyGraphSys.virtualY(1);
1444- if not GRAPHst then
1445- begin
1446- currenttransform.invtransform(x,y);
1447- currenttransform.invtransform(dx,dy);
1448- end;
1449- dx:=dx-x;
1450- dy:=y-dy;
1451-
1452- if (x2-x1)*dx<0 then
1453- dx:=-dx;
1454- if (y2-y1)*dy<0 then
1455- dy:=-dy;
1456- w:=p.size1/(x2-x1+dx);
1457- h:=p.size2/(y2-y1+dy);
1458-
1459- with TScreenBMPGraphSys(MyGraphSys) do
1460- for b:=ClipRect.top to Cliprect.Bottom do
1461- begin
1462- (*
1463- colorbyte:=BitMap1.ScanLine[b];
1464- *)
1465- y:=virtualY(b);
1466- yy:=y;
1467- for a:=ClipRect.Left to Cliprect.Right do
1468- begin
1469- x:=virtualX(a);
1470- y:=yy;
1471- if not GRAPHst then
1472- currenttransform.invtransform(x,y);
1473- i:=floor(w*(x-x1)+1e-9 {計算誤差の補償});
1474- j:=floor(h*(y-y1)+1e-9 {計算誤差の補償});
1475- (*
1476- if (i>=0) and (i<p.size[1]) and (j>=0) and (j<p.size[2]) then
1477- begin
1478- with p do color:=ItemEvaLInteger(i*size[2]+j);
1479- if (color>=0) and
1480- ((color<=maxcolor) or PaletteDisabled) then
1481- begin
1482- if not PaletteDisabled then
1483- color:=MyPalette[color];
1484- red:=byte(color);
1485- color:=color shr 8;
1486- green:=byte(color);
1487- color:=color shr 8;
1488- blue:=byte(color);
1489- colorbyte^:=blue;
1490- inc(colorbyte);
1491- colorbyte^:=green;
1492- inc(colorbyte);
1493- colorbyte^:=red;
1494- inc(colorbyte);
1495- inc(colorbyte);
1496- end;
1497- end
1498- else
1499- inc(colorbyte,4); //32ビットBMP
1500- *)
1501-
1502- if (i>=0) and (i<p.size1) and (j>=0) and (j<p.size2) then
1503- begin
1504- with p do color:=LongintRound(elements^[i*size2+j]);
1505- if not ((color>=0) and (color<=maxcolor) or PaletteDisabled) then f:=true;
1506- if not PaletteDisabled then
1507- color:=MyPalette[color];
1508- Bitmap1.Canvas.pixels[a,b]:=color;
1509- end;
1510-
1511- end;
1512- end;
1513- MyGraphSys.setHiddenDrawMode(SvDrawMode);
1514- end
1515- else if (CurrentTransform<>nil) and (abs(CurrentTransform.det)>1/1024) and
1516- ((MyGraphSys is TScreenBMPGraphSys) or
1517- not (NormalSegment(x1,y1,x1,y2)
1518- and NormalSegment(x1,y2,x2,y2)
1519- and NormalSegment(x2,y2,x2,y1)
1520- and NormalSegment(x2,y1,x1,y1))) then
1521- begin
1522- w:=(p.size1-0.0001)/(x2-x1);
1523- h:=(p.size2-0.0001)/(y2-y1);
1524-
1525- with MyGraphSys do
1526- for b:=ClipRect.top to Cliprect.Bottom do
1527- begin
1528- yy:=virtualY(b);
1529- for a:=ClipRect.Left to Cliprect.Right do
1530- begin
1531- x:=virtualX(a);
1532- y:=yy;
1533- if currenttransform.invtransform(x,y) then
1534- try
1535- i:=floor(w*(x-x1)+1e-9 {計算誤差の補償});
1536- j:=floor(h*(y-y1)+1e-9 {計算誤差の補償});
1537- if (i>=0) and (i<p.size1) and (j>=0) and (j<p.size2) then
1538- begin
1539- with p do color:=LongintRound(elements^[i*size2+j]);
1540- if not ((color>=0) and (color<=maxcolor) or PaletteDisabled) then f:=true;
1541- PutColor(a,b,color);
1542- end;
1543- except
1544- end;
1545- end;
1546- end;
1547- end
1548- else
1549- begin
1550- w:=(x2-x1)/p.size1;
1551- h:=(y2-y1)/p.size2;
1552- x:=x1;
1553- y:=y1;
1554- for i:=0 to p.size1-1 do
1555- begin
1556- for j:=0 to p.size2-1 do
1557- begin
1558- with p do color:=LongIntRound(elements^[i*size2+j]);
1559- if not ((color>=0) and (color<=maxcolor) or PaletteDisabled) then f:=true;
1560- x:=x1+w*i; xx:=x+w;
1561- y:=y1+h*j; yy:=y+h;
1562- a1:=x; b1:=y;
1563- a2:=xx;b2:=y;
1564- a3:=xx;b3:=yy;
1565- a4:=x; b4:=yy;
1566- if GRAPHst or
1567- currenttransform.transform(a1,b1) and
1568- currenttransform.transform(a2,b2) and
1569- currenttransform.transform(a3,b3) and
1570- currenttransform.transform(a4,b4) then
1571- begin
1572- with MyGraphSys do
1573- begin
1574- Points[1].x:=DeviceX(a1); Points[1].y:=DeviceY(b1);
1575- Points[2].x:=DeviceX(a2); Points[2].y:=DeviceY(b2);
1576- Points[3].x:=DeviceX(a3); Points[3].y:=DeviceY(b3);
1577- Points[4].x:=DeviceX(a4); Points[4].y:=DeviceY(b4);
1578- end;
1579- MyGraphsys.ColorPolygon( Points, color);
1580- end;
1581- end;
1582- end;
1583- end;
1584- if insideofwhen and f then setexception(11085)
1585-end;
1586-
1587-procedure MatPlotCells(const p:TArray2N; const x1,y1,x2,y2:double; insideofWhen:boolean);
1588-begin
1589- MatCells(p,x1,y1,x2,y2,false,insideofWhen);
1590- MyGraphSys.ThinRepaint;
1591-end;
1592-
1593-procedure MatGraphCells(const p:TArray2N; const x1,y1,x2,y2:double; insideofWhen:boolean);
1594-begin
1595- MatCells(p,x1,y1,x2,y2,true,insideofWhen);
1596- MyGraphSys.ThinRepaint;
1597-end;
1598-
1599-{************}
1600-{GET & LOCATE}
1601-{************}
1602-procedure PointAt(x0,y0:Double; LocateSt:boolean);
1603-var
1604- vx,vy:integer;
1605-begin
1606- if LocateSt or CurrentTransform.transform(x0,y0) then
1607- begin
1608- vx:=MyGraphSys.deviceX(x0);
1609- vy:=MyGraphSys.deviceY(y0);
1610- MyGraphSys.MoveMouse(vx,vy);
1611- end;
1612-end;
1613-
1614-procedure GetPointSub(var x,y:Double; NoBeamOff:boolean; LocateSt:boolean);
1615-var
1616- vx,vy:integer;
1617-begin
1618- with MyGraphSys do
1619- beam:=beam and ((BeamMode=bmImmortal) or NoBeamOff);
1620- MyGraphSys.getpoint(vx,vy);
1621- x:=MyGraphSys.virtualX(vx);
1622- y:=MyGraphSys.virtualY(vy);
1623- if LOCATEst or currenttransform.invtransform(x,y) then
1624- begin
1625- end
1626- else
1627- setexception(-3009)
1628-end;
1629-
1630-procedure GetPoint(var x,y:Double; NoBeamOff:boolean; Locatest:boolean);
1631-begin
1632- GetPointSub(x,y,NoBeamOff,Locatest)
1633-end;
1634-
1635-procedure MousePoll(var x,y,l,r:Double);
1636-var
1637- vx,vy:integer;
1638- left,right:boolean;
1639-begin
1640- MyGraphSys.MousePol(vx,vy,left,right);
1641- x:=MyGraphSys.virtualX(vx);
1642- y:=MyGraphSys.virtualY(vy);
1643- if currenttransform.invtransform(x,y) then
1644- begin
1645- l:=byte(left);
1646- r:=byte(right);
1647- end
1648- else
1649- setexception(-3009)
1650-end;
1651-
1652-
1653-Procedure LocateChoice( var x:Double);
1654-begin
1655- LocateChoice(8,x)
1656-end;
1657-
1658-Procedure LocateChoice(n:Double; var x:Double);
1659-begin
1660- if n=1 then n:=8;
1661- LocateChoice(n,0,x)
1662-end;
1663-
1664-
1665-Procedure LocateChoice(n,i0:Double; var x:Double);
1666-var
1667- dev0,ini0:integer;
1668- capts:TStringList;
1669- i:integer;
1670-begin
1671- with MyGraphsys do
1672- if beamMode=bmRigorous then beam:=false;
1673- dev0:=LongIntRound(n);
1674- ini0:=LongIntRound(i0);
1675- if (dev0>255) or (dev0<=0) then
1676- setexception(11140);
1677- capts:=TStringList.create;
1678- try
1679- for i:=1 to dev0 do
1680- Capts.Add(inttostr(i));
1681- x:=LocateChoiceForm.Choice(dev0,ini0,Capts)
1682- finally
1683- capts.free
1684- end;
1685- with MyGraphsys do
1686- if beamMode=bmRigorous then beam:=false;
1687-end;
1688-
1689-Procedure LocateChoice(const a:TArray1S; var x:Double);
1690-var
1691- dev0,ini0:integer;
1692- capts:TStringList;
1693- i:integer;
1694-begin
1695- with MyGraphsys do
1696- if beamMode=bmRigorous then beam:=false;
1697- ini0:=0;
1698- dev0:=a.Size1;
1699- if (dev0>255) or (dev0<=0) then
1700- setexception(11140);
1701- capts:=TStringList.create;
1702- try
1703- with a do
1704- begin
1705- for i:=0 to size-1 do
1706- capts.add(elements^[i]);
1707- end;
1708- x:=LocateChoiceForm.Choice(dev0,ini0,Capts);
1709- finally
1710- capts.free
1711- end;
1712- with MyGraphsys do
1713- if beamMode=bmRigorous then beam:=false;
1714-end;
1715-
1716-procedure LocateValue(n:Double; var x:double; name0:ansistring);overload;
1717-begin
1718- case LongIntRound(n) of
1719- 1: x:=LocateForm.Value1(false,false,false,0,1,0.5,name0);
1720- 2: x:=LocateForm.Value2(false,false,false,0,1,0.5,name0);
1721- 3: x:=LocateForm.Value3(false,false,false,0,1,0.5,name0);
1722- 4: x:=LocateForm.Value4(false,false,false,0,1,0.5,name0);
1723- 5: x:=LocateForm.Value5(false,false,false,0,1,0.5,name0);
1724- end;
1725-end;
1726-
1727-procedure LocateValue(n:Double; left0,right0:double; var x:double; name0:ansistring);overload;
1728-begin
1729- case LongIntRound(n) of
1730- 1: x:=LocateForm.Value1(true,false,false,left0,right0,0.5,name0);
1731- 2: x:=LocateForm.Value2(true,false,false,left0,right0,0.5,name0);
1732- 3: x:=LocateForm.Value3(true,false,false,left0,right0,0.5,name0);
1733- 4: x:=LocateForm.Value4(true,false,false,left0,right0,0.5,name0);
1734- 5: x:=LocateForm.Value5(true,false,false,left0,right0,0.5,name0);
1735- end;
1736-end;
1737-
1738-procedure LocateValue(n:Double; left0,right0,ini0:double; var x:double; name0:ansistring);overload;
1739-begin
1740- case LongIntRound(n) of
1741- 1: x:=LocateForm.Value1(true,true,false,left0,right0,ini0,name0);
1742- 2: x:=LocateForm.Value2(true,true,false,left0,right0,ini0,name0);
1743- 3: x:=LocateForm.Value3(true,true,false,left0,right0,ini0,name0);
1744- 4: x:=LocateForm.Value4(true,true,false,left0,right0,ini0,name0);
1745- 5: x:=LocateForm.Value5(true,true,false,left0,right0,ini0,name0);
1746- end;
1747-end;
1748-
1749-procedure LocateValueNowait(n:Double; var x:double; name0:ansistring);overload;
1750-begin
1751- case LongIntRound(n) of
1752- 1: x:=LocateForm.Value1(false,false,true,0,0,0,name0);
1753- 2: x:=LocateForm.Value2(false,false,true,0,0,0,name0);
1754- 3: x:=LocateForm.Value3(false,false,true,0,0,0,name0);
1755- 4: x:=LocateForm.Value4(false,false,true,0,0,0,name0);
1756- 5: x:=LocateForm.Value5(false,false,true,0,0,0,name0);
1757- end;
1758-end;
1759-
1760-procedure LocateValueNowait(n:Double; left0,right0:double; var x:double; name0:ansistring);overload;
1761-begin
1762- case LongIntRound(n) of
1763- 1: x:=LocateForm.Value1(true,false,true,left0,right0,0,name0);
1764- 2: x:=LocateForm.Value2(true,false,true,left0,right0,0,name0);
1765- 3: x:=LocateForm.Value3(true,false,true,left0,right0,0,name0);
1766- 4: x:=LocateForm.Value4(true,false,true,left0,right0,0,name0);
1767- 5: x:=LocateForm.Value5(true,false,true,left0,right0,0,name0);
1768- end;
1769-end;
1770-
1771-procedure LocateValueNowait(n:Double; left0,right0,ini0:double; var x:double; name0:ansistring);overload;
1772-begin
1773- case LongIntRound(n) of
1774- 1: x:=LocateForm.Value1(true,true,true,left0,right0,ini0,name0);
1775- 2: x:=LocateForm.Value2(true,true,true,left0,right0,ini0,name0);
1776- 3: x:=LocateForm.Value3(true,true,true,left0,right0,ini0,name0);
1777- 4: x:=LocateForm.Value4(true,true,true,left0,right0,ini0,name0);
1778- 5: x:=LocateForm.Value5(true,true,true,left0,right0,ini0,name0);
1779- end;
1780-end;
1781-
1782-procedure LocateValue(n:Double; ini0:double; var x:double; name0:ansistring);overload;
1783-begin
1784- case LongIntRound(n) of
1785- 1: x:=LocateForm.Value1(false,true,false,0,0,ini0,name0);
1786- 2: x:=LocateForm.Value2(false,true,false,0,0,ini0,name0);
1787- 3: x:=LocateForm.Value3(false,true,false,0,0,ini0,name0);
1788- 4: x:=LocateForm.Value4(false,true,false,0,0,ini0,name0);
1789- 5: x:=LocateForm.Value5(false,true,false,0,0,ini0,name0);
1790- end;
1791-end;
1792-
1793-procedure LocateValueNowait(n:Double; ini0:double; var x:double; name0:ansistring);overload;
1794-begin
1795- case LongIntRound(n) of
1796- 1: x:=LocateForm.Value1(false,true,false,0,0,ini0,name0);
1797- 2: x:=LocateForm.Value2(false,true,false,0,0,ini0,name0);
1798- 3: x:=LocateForm.Value3(false,true,false,0,0,ini0,name0);
1799- 4: x:=LocateForm.Value4(false,true,false,0,0,ini0,name0);
1800- 5: x:=LocateForm.Value5(false,true,false,0,0,ini0,name0);
1801- end;
1802-end;
1803-
1804-
1805-
1806-
1807-
1808-
1809-
1810-
1811-
1812-
1813-
1814-
1815-
1816-
1817-
1818-
1819-
1820-
1821-
1822-
1823-
1824-procedure MatGetPointVarilen(m:TArray2N; Locatest:boolean); overload;
1825-var
1826- vx,vy,vx0,vy0:integer;
1827- maxlen:integer;
1828- x,y:extended;
1829- i:integer;
1830- left,right:boolean;
1831-begin
1832- MyGraphsys.beam:=false;
1833- vx0:=low(integer);
1834- vy0:=low(integer);
1835-
1836- maxlen:=m.MaxSize div 2;
1837- m.size2:=2;
1838-
1839- repeat
1840- sleep(10);
1841- MyGraphSys.MousePol(vx,vy,left,right)
1842- until left=false;
1843- repeat
1844- sleep(10);
1845- MyGraphSys.MousePol(vx,vy,left,right)
1846- until left=true;
1847- i:=0;
1848- while (i<maxlen) and (left=true) do
1849- begin
1850- if (vx<>vy0)or(vy<>vy0) then
1851- begin
1852- x:=MyGraphsys.virtualX(vx);
1853- y:=MyGraphsys.VirtualY(vy);
1854- if Locatest or CurrentTransform.InvTransform(x,y) then
1855- with m do
1856- begin
1857- elements^[i*size2]:=x;
1858- elements^[i*size2+1]:=y;
1859- end
1860- else
1861- setexception(-3009) ;
1862- end;
1863- inc(i);
1864- sleep(20);
1865- MyGraphSys.MousePol(vx,vy,left,right)
1866- end;
1867- if i=maxlen then beep;
1868-
1869- m.size1:=i;
1870-end;
1871-
1872-procedure MatGetPointVarilen(m1,m2:TArray1N; Locatest:boolean); overload;
1873-var
1874- vx,vy,vx0,vy0:integer;
1875- maxlen:integer;
1876- x,y:extended;
1877- i:integer;
1878- left,right:boolean;
1879-begin
1880- MyGraphsys.beam:=false;
1881- vx0:=low(integer);
1882- vy0:=low(integer);
1883-
1884- maxlen:=min(m1.MaxSize,m2.MaxSize);
1885-
1886- repeat
1887- sleep(10);
1888- MyGraphSys.MousePol(vx,vy,left,right)
1889- until left=false;
1890- repeat
1891- sleep(10);
1892- MyGraphSys.MousePol(vx,vy,left,right)
1893- until left=true;
1894-
1895- i:=0;
1896- while (i<maxlen) and (left=true) do
1897- begin
1898- if (vx<>vy0)or(vy<>vy0) then
1899- begin
1900- x:=MyGraphsys.virtualX(vx);
1901- y:=MyGraphsys.VirtualY(vy);
1902- if Locatest or CurrentTransform.InvTransform(x,y) then
1903- begin
1904- m1.elements^[i]:=x;
1905- m2.elements^[i]:=y;
1906- end
1907- else
1908- setexception(-3009) ;
1909- end;
1910- inc(i);
1911- sleep(20);
1912- MyGraphSys.MousePol(vx,vy,left,right)
1913- end;
1914- if i=maxlen then beep;
1915-
1916- m1.size1:=i;
1917- m2.size1:=i;
1918-end;
1919-
1920-procedure MatGetPoint(m1,m2:TArray1N; Locatest:boolean); overload;
1921-var
1922- vx,vy,vx0,vy0:integer;
1923- maxlen:integer;
1924- x,y:extended;
1925- i:integer;
1926- left,right:boolean;
1927-
1928-begin
1929- maxlen:=m1.size1;
1930- if maxlen<>m2.size1 then setexception(6401);
1931-
1932- MyGraphsys.beam:=false;
1933-
1934- for i:=0 to maxlen-1 do
1935- begin
1936- MyGraphsys.getpoint(vx,vy);
1937- x:=MyGraphsys.virtualX(vx);
1938- y:=MyGraphsys.VirtualY(vy);
1939- if Locatest or CurrentTransform.InvTransform(x,y) then
1940- begin
1941- m1.elements^[i]:=x;
1942- m2.elements^[i]:=y;
1943- end
1944- else
1945- setexception(-3009) ;
1946- end;
1947-end;
1948-
1949-procedure MatGetPoint(m:TArray2N; Locatest:boolean);overload;
1950-var
1951- vx,vy,vx0,vy0:integer;
1952- maxlen:integer;
1953- x,y:extended;
1954- i:integer;
1955- left,right:boolean;
1956-begin
1957- if m.size2<2 then
1958- setexception(6401);
1959- maxlen:=m.size1;
1960-
1961- MyGraphsys.beam:=false;
1962-
1963- for i:=0 to maxlen-1 do
1964- begin
1965- MyGraphsys.getpoint(vx,vy);
1966- x:=MyGraphsys.virtualX(vx);
1967- y:=MyGraphsys.VirtualY(vy);
1968- if Locatest or CurrentTransform.InvTransform(x,y) then
1969- with m do
1970- begin
1971- elements^[i*size2]:=x;
1972- elements^[i*size2+1]:=y;
1973- end
1974- else
1975- setexception(-3009) ;
1976- end;
1977-end;
1978-
1979-{**************}
1980-{ASK Statements}
1981-{**************}
1982-function ASkWindow(var x1,x2,y1,y2:double):integer;
1983-begin
1984- result:=0;
1985- with MyGraphsys do
1986- begin
1987- x1:=left;
1988- x2:=right;
1989- y1:=bottom;
1990- y2:=top;
1991- end;
1992-end;
1993-
1994-function ASkViewport(var x1,x2,y1,y2:double):integer;
1995-begin
1996- result:=0;
1997- with MyGraphsys do
1998- begin
1999- x1:=VPleft;
2000- x2:=VPright;
2001- y1:=VPbottom;
2002- y2:=VPtop;
2003- end;
2004-end;
2005-
2006-function ASkDeviceWindow(var x1,x2,y1,y2:double):integer;
2007-begin
2008- result:=0;
2009- with MyGraphsys do
2010- begin
2011- x1:=DWleft;
2012- x2:=DWright;
2013- y1:=DWbottom;
2014- y2:=DWtop;
2015- end;
2016-end;
2017-
2018-function ASkDeviceViewport(var x1,x2,y1,y2:double):integer;
2019-var
2020- l,r,b,t:extended;
2021-begin
2022- result:=0;
2023- MyGraphSys.AskDeviceViewPort(l,r,b,t);
2024- x1:=l;
2025- x2:=r;
2026- y1:=b;
2027- y2:=t;
2028-end;
2029-
2030-
2031-function AskPixelSize( var var1,var2:double):integer;overload;
2032-begin
2033- result:=0;
2034- var1:=MyGraphSys.GWidth;
2035- var2:=MyGraphSys.GHeight
2036-end;
2037-
2038-
2039-function AskPixelSize(n1,n2,n3,n4:double; var var1,var2:double):integer;overload;
2040-
2041- function Floor(x:extended):extended; assembler;
2042- asm
2043- FLD x
2044- FLDCW RoundNins
2045- FRNDINT
2046- FLDCW RoundMost
2047- end;
2048- function Ceil(x:extended):extended; assembler;
2049- asm
2050- FLD x
2051- FLDCW RoundPlus
2052- FRNDINT
2053- FLDCW RoundMost
2054- end;
2055-const eps=1e-15;
2056-var
2057- t:extended;
2058- x1,x2,y1,y2:extended;
2059-begin
2060- result:=0;
2061- (*
2062- if n1>n3 then begin t:=n3; n3:=n1; n1:=t end;
2063- if n2<n4 then begin t:=n4; n4:=n2; n2:=t end;
2064- *)
2065- with MyGraphSys do
2066- if (n1-n3)*(right-left)>0 then begin t:=n3; n3:=n1; n1:=t end; //2011.11.6
2067- with MyGraphSys do
2068- if (n2-n4)*(top-bottom)<0 then begin t:=n4; n4:=n2; n2:=t end; //2011.11.6
2069-
2070- x1:=ceil(MyGraphSys.DeviceX(n1)-eps);
2071- x2:=floor(MyGraphSys.DeviceX(n3)+eps);
2072- y1:=ceil(MyGraphSys.DeviceY(n2)-eps);
2073- y2:=floor(MyGraphSys.DeviceY(n4)+eps);
2074- var1:=x2-x1+1;
2075- var2:=y2-y1+1;
2076- (*
2077- if MyGraphSys is TScreenGraphSys then
2078- begin
2079- x1:=ceil((n1-left)*TScreenGraphSys(MyGraphSys).HMulti-eps);
2080- x2:=floor((n3-left)*TScreenGraphSys(MyGraphSys).HMulti+eps);
2081- y1:=ceil((top-n2)*TScreenGraphSys(MyGraphSys).VMulti-eps);
2082- y2:=floor((top-n4)*TScreenGraphSys(MyGraphSys).VMulti+eps);
2083- var1.assignX(x2-x1+1);
2084- var2.assignX(y2-y1+1)
2085- end
2086- else
2087- begin
2088- var1.assignX(0);
2089- var2.assignX(0)
2090- end
2091- *)
2092-end;
2093-
2094-function AskPixelSize( var var1,var2:integer):integer;overload;
2095-var
2096- x1,x2:double;
2097-begin
2098- result:=AskPixelsize(x1,x2);
2099- var1:=System.Round(x1);
2100- var2:=System.Round(x2);
2101-end;
2102-
2103-function AskPixelSize(n1,n2,n3,n4:double; var var1,var2:integer):integer;overload;
2104-var
2105- x1,x2:double;
2106-begin
2107- result:=AskPixelsize(n1,n2,n3,n4,x1,x2);
2108- var1:=System.Round(x1);
2109- var2:=System.Round(x2);
2110-end;
2111-
2112-
2113-function AskPixelValue(x,y:double; var var1:double):integer;
2114-begin
2115- result:=0;
2116- var1:=MyGraphSys.ColorIndexOf(MyGraphSys.DeviceX(x),MyGraphSys.DeviceY(y))
2117-end;
2118-
2119-function AskPixelArraySub(x,y:double; a:Tarray2N):boolean;
2120-var
2121- x1,y1:longint;
2122- i,j:longint;
2123- c:integer;
2124-begin
2125- x1:=MyGraphSys.DeviceX(x);
2126- y1:=MyGraphSys.DeviceY(y);
2127- result:=true;
2128- if a<>nil then
2129- begin
2130- for i:=0 to a.size1-1 do
2131- for j:=0 to a.size2-1 do
2132- begin
2133- c:=MyGraphSys.ColorIndexOf(x1+i,y1+j);
2134- with a do elements^[i*size2+j]:=c;
2135- if c=-1 then result:=false;
2136- end;
2137- end;
2138-
2139-end;
2140-
2141-function AskPixelArray(x,y:double; a:Tarray2N):integer; overload;
2142-begin
2143- result:=0;
2144- AskPixelArraySub(x,y,a)
2145-end;
2146-
2147-function AskPixelArray(x,y:double; a:Tarray2N; s:TStrVar):integer; overload;
2148-begin
2149- result:=0;
2150- if AskPixelArraySub(x,y,a) then
2151- s.str:= 'ABSENT'
2152- else
2153- s.str:='PRESENT';
2154- s.free
2155-end;
2156-
2157-function getlinecolor(var x:double):integer;
2158-begin
2159- result:=0;
2160- x:=MyGraphSys.linecolor;
2161-end;
2162-
2163-function getlinestyle(var x:double):integer;
2164-begin
2165- result:=0;
2166- x:=Integer(MyGraphSys.PenStyle) + 1;
2167-end;
2168-
2169-function getlinewidth(var x:double):integer;
2170-begin
2171- result:=0;
2172- x:=MyGraphSys.linewidth;
2173-end;
2174-
2175-function getpointcolor(var x:double):integer;
2176-begin
2177- result:=0;
2178- x:=MyGraphSys.pointcolor;
2179-end;
2180-
2181-function getpointstyle(var x:double):integer;
2182-begin
2183- result:=0;
2184- x:=MyGraphSys.pointstyle;
2185-end;
2186-
2187-function getareacolor(var x:double):integer;
2188-begin
2189- result:=0;
2190- x:=MyGraphSys.areacolor;
2191-end;
2192-
2193-function gettextcolor(var x:double):integer;
2194-begin
2195- result:=0;
2196- x:=MyGraphSys.textcolor;
2197-end;
2198-
2199-function getmaxcolor(var x:double):integer;
2200-begin
2201- result:=0;
2202- if mypalette.PaletteDisabled then
2203- x:=$ffffff
2204- else
2205- x:=GraphSys.maxcolor;
2206-end;
2207-
2208-function getaxiscolor(var x:double):integer;
2209-begin
2210- result:=0;
2211- x:=GraphSys.axescolor;
2212-end;
2213-
2214-function getMaxPointDevice(var x:double):integer;
2215-begin
2216- result:=0;
2217- x:=1
2218-end;
2219-
2220-function getMaxMultiPointDevice(var x:double):integer;
2221-begin
2222- result:=0;
2223- x:=1
2224-end;
2225-
2226-function getMaxChoiceDevice(var x:double):integer;
2227-begin
2228- result:=0;
2229- x:=1
2230-end;
2231-
2232-function getMaxValueDevice(var x:double):integer;
2233-begin
2234- result:=0;
2235- x:=1
2236-end;
2237-
2238-function getAreaStyleIndex(var x:double):integer;
2239-begin
2240- result:=0;
2241- x:=MyGraphSys.AreaStyleIndex;
2242-end;
2243-
2244-function getmaxlinestyle(var x:double):integer;
2245-begin
2246- result:=0;
2247- x:=MaxLineStyle
2248-end;
2249-
2250-function getmaxpointstyle(var x:double):integer;
2251-begin
2252- result:=0;
2253- x:=MaxPointStyle
2254-end;
2255-
2256-function ASkTextHeight(var x:double):integer;
2257-begin
2258- result:=0;
2259- x:=MyGraphSys.gettextheight;
2260-end;
2261-
2262-function AskTextAngle(var x:double):integer;
2263-begin
2264- result:=0;
2265- x:=MyGraphSys.TextAngle;
2266-end;
2267-
2268-function AskTextAngleRad(var x:double):integer;
2269-begin
2270- result:=0;
2271- x:=MyGraphSys.TextAngle/180.0*PI;
2272-end;
2273-
2274-
2275-function AskDeviceSize(var x,y:double; t:TStrVar):integer;
2276-var
2277- w,h:extended;
2278- s:string;
2279-begin
2280- result:=0;
2281- MyGraphSys.AskDeviceSize(w,h,s);
2282- x:=w;
2283- y:=h;
2284- t.str:=s;
2285- t.free;
2286-end;
2287-
2288-function AskBitmapSize(var x,y:double):integer;
2289-begin
2290- result:=0;
2291- x:=MyGraphSys.GWidth;
2292- y:=MyGraphSys.GHeight;
2293-end;
2294-
2295-function AskTextJustify(h,v:TStrVar):integer;
2296-begin
2297- result:=0;
2298- with MyGraphSys do
2299- begin
2300- h.str:=HJustification[HJustify];
2301- v.str:=VJustification[VJustify];
2302- h.free;
2303- v.free;
2304- end;
2305-end;
2306-
2307-function AskTextWidth(const s:string; var width:double):integer;
2308-begin
2309- result:=0;
2310- with MyGraphSys do
2311- width:=VirtualX(textwidth(s))-VirtualX(0);
2312-end;
2313-
2314-procedure AskColorMixSub(cc:integer;var r,g,b:byte);
2315-var
2316- col:TColor;
2317-begin
2318- col:=MyPalette[cc];
2319- b:=(col and $ff0000) div $10000;
2320- g:=(col and $00ff00) div $100;
2321- r:=col and $0000ff;
2322-end;
2323-
2324-function AskColorMix(ColorIndex:double; var red,green,blue:double):integer;
2325-var
2326- cc:longint;
2327- r,g,b:byte;
2328-begin
2329- result:=0;
2330- cc:=LongIntRound(ColorIndex);
2331- if (cc<0) or (cc>maxcolor) and not MyPalette.paletteDisabled then
2332- begin
2333- red:=0;
2334- green:=0;
2335- blue:=0;
2336- result:=11086;
2337- end
2338- else
2339- begin
2340- askColorMixSub(cc,r,g,b);
2341- red:=r/255;
2342- green:=g/255;
2343- blue:=b/255;
2344- end;
2345-end;
2346-
2347-function AskClip(svar:TStrvar):integer;
2348-var
2349- s:string;
2350-begin
2351- result:=0;
2352- if MyGraphSys.clip then s:='ON' else s:='OFF';
2353- svar.str:=s;
2354- svar.free;
2355-end;
2356-
2357-function AskAreaStyle(svar:TStrvar):integer;
2358-var
2359- s:string;
2360-begin
2361- result:=0;
2362- case MyGraphSys.AreaStyle of
2363- asSolid: s:='SOLID';
2364- asHollow:s:='HOLLOW';
2365- asHATCH: s:='HATCH';
2366- end;
2367- svar.str:=s;
2368- svar.free;
2369-end;
2370-
2371-function AskColorMode(svar:TStrvar):integer;
2372-begin
2373- result:=0;
2374- svar.str:=MyGraphSys.AskColorMode;
2375- svar.free;
2376-end;
2377-
2378-function AskBeamMode(svar:TStrvar):integer;
2379-begin
2380- result:=0;
2381- svar.str:=MyGraphSys.AskBeamMode;
2382- svar.free;
2383-end;
2384-
2385-
2386-procedure FLOOD( x,y:double);
2387-var
2388- a,b:longint;
2389-begin
2390- if currenttransform.transform(x,y) then
2391- begin
2392- a:=MyGraphSys.deviceX(x);
2393- b:=MyGraphSys.deviceY(y);
2394- MyGraphSys.FLOOD(a,b);
2395- end;
2396-end;
2397-
2398-procedure FLOODFill( x,y:double);
2399-var
2400- a,b:longint;
2401-begin
2402- if currenttransform.transform(x,y) then
2403- begin
2404- a:=MyGraphSys.deviceX(x);
2405- b:=MyGraphSys.deviceY(y);
2406- MyGraphSys.FLOODFill(a,b);
2407- end;
2408-end;
2409-
2410-
2411-{***********}
2412-{Grid & Axes}
2413-{***********}
2414-
2415-function drawaxes0(x,y:double):boolean;
2416-begin
2417- result:=gridaxes.drawaxes0(x,y);
2418-end;
2419-
2420-function drawgrid0(x,y:double):boolean;
2421-begin
2422- result:=gridaxes.drawgrid0(x,y);
2423-end;
2424-
2425-function drawaxes2(x,y:double):boolean;
2426-begin
2427- result:=gridaxes.drawaxes2(x,y);
2428-end;
2429-
2430-function drawgrid2(x,y:double):boolean;
2431-begin
2432- result:=gridaxes.drawgrid2(x,y);
2433-end;
2434-
2435-function drawcircle(x,y:double):boolean;
2436-begin
2437- result:=gridaxes.drawcircle(x,y);
2438-end;
2439-
2440-function drawdisk(x,y:double):boolean;
2441-begin
2442- result:=gridaxes.drawdisk(x,y);
2443-end;
2444-
2445-{*****}
2446-{GSAVE}
2447-{*****}
2448-Procedure GSAVE(const fname,pf:string);
2449-var
2450- ext:string;
2451- n,i:integer;
2452-begin
2453- ext:=UpperCase( ExtractFileExt(fname));
2454- try
2455- if (ext='.BMP') then
2456- begin
2457- if lowercase(pf)='4bit' then
2458- MyGraphSys.SaveFileFormat(fname,pf4bit)
2459- else if lowercase(pf)='1bit' then
2460- MyGraphSys.SaveFileFormat(fname,pf1bit)
2461- else
2462- MyGraphSys.SaveBMPFile(fname)
2463- end
2464- else if (ext='.JPG') or (ext='.JPEG') or (ext='.JPE') then
2465- begin
2466- n:=0;
2467- i:=POS('%',pf);
2468- if i>0 then
2469- {$R-}
2470- SYSTEM.VAL(copy(pf,1,i-1),n,i);
2471- {$R+}
2472- if (n<0) or (n>100) then n:=0;
2473- MyGraphSys.SaveJpegFile(fname,n) ;
2474- end
2475- else if ext='.GIF' then
2476- MyGraphSys.SaveGIFFile(fname)
2477- else if ext='.EMF' then
2478- MyGraphSys.SaveEMFFile(fname)
2479- else
2480- setexception(9052)
2481- except
2482- setexception(9052)
2483- end;
2484-end;
2485-
2486-
2487-end.
--- BASICAcc/graphlib.pas (nonexistent)
+++ BASICAcc/graphlib.pas (revision 3)
@@ -0,0 +1,2487 @@
1+unit graphlib;
2+{$IFDEF FPC}
3+ {$MODE Delphi}{$H+}
4+{$ENDIF}
5+
6+(***************************************)
7+(* Copyright (C) 2009, SHIRAISHI Kazuo *)
8+(***************************************)
9+
10+{********}
11+interface
12+{********}
13+uses arrays,baslib;
14+
15+function PixelX(x:extended):longint; overload;
16+function PixelY(x:extended):longint; overload;
17+function WindowX(x:extended):extended; overload;
18+function WindowY(x:extended):extended; overload;
19+
20+procedure SetColorMix(cc:double; er,eg,eb:double; InsideofWhen:boolean); overload;
21+procedure SetWindow(l,r,b,t:double; insideofWhen:boolean); overload;
22+procedure SetViewPort(l,r,b,t:double; insideofWhen:boolean); overload;
23+procedure SetDeviceWindow(l,r,b,t:double; insideofWhen:boolean); overload;
24+procedure SetDeviceViewport(l,r,b,t:double; insideofWhen:boolean); overload;
25+
26+const
27+ MaxLineStyle=5;
28+ MaxPointStyle=7;
29+ MaxAreaStyleIndex=6;
30+
31+procedure SetPointColor(x:double; InsideOfWhen:boolean); overload;
32+procedure setLineColor(x:double; InsideOfWhen:boolean); overload;
33+procedure setAreaColor(x:double; InsideOfWhen:boolean); overload;
34+procedure setTextColor(x:double; InsideOfWhen:boolean); overload;
35+procedure setAllColor(x:double; InsideOfWhen:boolean); overload;
36+procedure SetPointColor(const s:string; InsideOfWhen:boolean);overload;
37+procedure setLineColor(const s:string; InsideOfWhen:boolean);overload;
38+procedure setAreaColor(const s:string; InsideOfWhen:boolean);overload;
39+procedure setTextColor(const s:string; InsideOfWhen:boolean);overload;
40+procedure setAllColor(const s:string; InsideOfWhen:boolean); overload;
41+procedure SetAxisColor(x:double; InsideOfWhen:boolean); overload;
42+procedure SetAxisColor(const s:string; InsideOfWhen:boolean);overload;
43+
44+
45+procedure setPointStyle(x:double; InsideOfWhen:boolean); overload;
46+procedure setLineStyle(x:double; InsideOfWhen:boolean); overload;
47+procedure setLineWidth(x:double; InsideOfWhen:boolean); overload;
48+procedure setAreaStyle(const s:string);
49+procedure setAreaStyleIndex(x:double; InsideOfWhen:boolean); overload;
50+procedure setTextHeight(x:double; InsideOfWhen:boolean); overload;
51+procedure setTextAngle(x:double; AngleDegrees:boolean); overload;
52+procedure setTextJustify( s1,s2:string; InsideOfWhen:boolean);
53+
54+
55+function ColorOfName(s:string; insideofWhen:boolean):LongInt;
56+function ColorIndex(r,g,b:double):LongInt; overload;
57+
58+
59+procedure SetClip(const s:string; insideofwhen:boolean);
60+procedure SetTextFont(const s:string; x:double); overload;
61+procedure SetTextBackGround(const s:string);
62+procedure SetBitmapSize(x,y:double); overload;
63+
64+procedure GraphPoints(const a:array of double);
65+procedure GraphLines(const a:array of Double);
66+procedure BeamOff;
67+procedure PlotPoints(const a:array of double);
68+procedure PlotLines(const a:array of Double);
69+procedure GraphArea(const a: array of double);
70+procedure PlotArea(const a:array of double);
71+
72+procedure PlotText(x,y:double; const s:string); overload;
73+procedure PlotTextUsing(x,y:double; const form:string; a:array of const); overload;
74+procedure GraphText(x,y:double; const s:string); overload;
75+procedure GraphTextUsing(x,y:double; const form:string; a:array of const); overload;
76+procedure PlotLabel(x,y:double; const s:string); overload;
77+procedure PlotLabelUsing(x,y:double; const form:string; a:array of const); overload;
78+procedure GraphLabel(x,y:double; const s:string); overload;
79+procedure GraphLabelUsing(x,y:double; const form:string; a:array of const); overload;
80+procedure PlotLetters(x,y:double; const s:string); overload;
81+procedure PlotLettersUsing(x,y:double; const form:string; a:array of const); overload;
82+
83+procedure MatPlotPoints(const x,y:TArray1N);overload;
84+procedure MatPlotPoints(const m:TArray2N);overload;
85+procedure MatPlotLines(const x,y:TArray1N);overload;
86+procedure MatPlotLines(const m:TArray2N);overload;
87+procedure MatPlotArea(const x,y:TArray1N);overload;
88+procedure MatPlotArea(const m:TArray2N);overload;
89+
90+procedure MatPlotPointsLimit(n:double; const x,y:TArray1N);overload;
91+procedure MatPlotPointsLimit(n:double; const m:TArray2N);overload;
92+procedure MatPlotLinesLimit(n:double; const x,y:TArray1N);overload;
93+procedure MatPlotLinesLimit(n:double; const m:TArray2N);overload;
94+procedure MatPlotAreaLimit(n:double; const x,y:TArray1N);overload;
95+procedure MatPlotAreaLimit(n:double; const m:TArray2N);overload;
96+
97+procedure MatPlotCells(const p:TArray2N; const x1,y1,x2,y2:double; insideofWhen:boolean); overload;
98+procedure MatGraphCells(const p:TArray2N; const x1,y1,x2,y2:double; insideofWhen:boolean); overload;
99+
100+{GET & LOCATE}
101+procedure PointAt(x0,y0:Double; LocateSt:boolean); overload;
102+procedure GetPoint(var x,y:Double; NoBeamOff:boolean; Locatest:boolean); overload;
103+procedure MousePoll(var x,y,l,r:Double); overload;
104+procedure MatGetPointVarilen(m:TArray2N; Locatest:boolean); overload; overload;
105+procedure MatGetPointVarilen(m1,m2:TArray1N; Locatest:boolean); overload; overload;
106+procedure MatGetPoint(m1,m2:TArray1N; Locatest:boolean); overload; overload;
107+procedure MatGetPoint(m:TArray2N; Locatest:boolean);overload; overload;
108+
109+
110+Procedure LocateChoice( var x:Double);overload;
111+Procedure LocateChoice(n:Double; var x:Double);overload;
112+Procedure LocateChoice(n,i0:Double; var x:Double);overload;
113+Procedure LocateChoice(const a:TArray1S; var x:Double);overload;
114+
115+procedure LocateValue(n:Double; var x:double; name0:ansistring);overload;
116+procedure LocateValue(n:Double; left0,right0:double; var x:double; name0:ansistring);overload;
117+procedure LocateValue(n:Double; left0,right0,ini0:double; var x:double; name0:ansistring);overload;
118+procedure LocateValueNowait(n:Double; var x:double; name0:ansistring);overload;
119+procedure LocateValueNowait(n:Double; left0,right0:double; var x:double; name0:ansistring);overload;
120+procedure LocateValueNowait(n:Double; left0,right0,ini0:double; var x:double; name0:ansistring);overload;
121+procedure LocateValue(n:Double; ini0:double; var x:double; name0:ansistring);overload;
122+procedure LocateValueNowait(n:Double; ini0:double; var x:double; name0:ansistring);overload;
123+
124+
125+{ASK Statements}
126+function ASkWindow(var x1,x2,y1,y2:double):integer; overload;
127+function ASkViewport(var x1,x2,y1,y2:double):integer; overload;
128+function ASkDeviceWindow(var x1,x2,y1,y2:double):integer; overload;
129+function ASkDeviceViewport(var x1,x2,y1,y2:double):integer; overload;
130+
131+function AskPixelSize( var var1,var2:double):integer; overload;
132+function AskPixelSize( var var1,var2:integer):integer; overload;
133+function AskPixelSize(n1,n2,n3,n4:double; var var1,var2:double):integer;overload;
134+function AskPixelSize(n1,n2,n3,n4:double; var var1,var2:integer):integer;overload;
135+function AskPixelValue(x,y:double; var var1:double):integer; overload;
136+function AskPixelArray(x,y:double; a:Tarray2N):integer; overload;
137+function AskPixelArray(x,y:double; a:Tarray2N; s:TStrVar):integer; overload;
138+
139+function getlinecolor(var x:double):integer; overload;
140+function getlinestyle(var x:double):integer; overload;
141+function getlinewidth(var x:double):integer; overload;
142+function getpointcolor(var x:double):integer; overload;
143+function getpointstyle(var x:double):integer; overload;
144+function getareacolor(var x:double):integer; overload;
145+function gettextcolor(var x:double):integer; overload;
146+function getmaxcolor(var x:double):integer; overload;
147+function getaxiscolor(var x:double):integer; overload;
148+function getMaxPointDevice(var x:double):integer; overload;
149+function getMaxMultiPointDevice(var x:double):integer; overload;
150+function getMaxChoiceDevice(var x:double):integer; overload;
151+function getMaxValueDevice(var x:double):integer; overload;
152+function getAreaStyleIndex(var x:double):integer; overload;
153+function getmaxlinestyle(var x:double):integer; overload;
154+function getmaxpointstyle(var x:double):integer; overload;
155+
156+function ASkTextHeight(var x:double):integer; overload;
157+function AskTextAngle(var x:double):integer; overload;
158+function AskTextAngleRad(var x:double):integer; overload;
159+function AskDeviceSize(var x,y:double; t:TStrVar):integer; overload;
160+function AskBitmapSize(var x,y:double):integer; overload;
161+function AskTextJustify(h,v:TStrVar):integer; overload;
162+function AskTextWidth(const s:string; var width:double):integer; overload;
163+function AskColorMix(ColorIndex:double; var red,green,blue:double):integer; overload;
164+function AskClip(svar:TStrvar):integer;
165+function AskColorMode(svar:TStrvar):integer;
166+function AskBeamMode(svar:TStrvar):integer;
167+
168+procedure FLOOD( x,y:double);
169+procedure FLOODFill( x,y:double);
170+
171+
172+function drawaxes0(x,y:double):boolean;
173+function drawgrid0(x,y:double):boolean;
174+function drawaxes2(x,y:double):boolean;
175+function drawgrid2(x,y:double):boolean;
176+function drawcircle(x,y:double):boolean;
177+function drawdisk(x,y:double):boolean;
178+
179+Procedure GSAVE(const fname,pf:string);
180+
181+{*************}
182+implementation
183+{*************}
184+uses
185+ Forms, Classes, SysUtils, Graphics,
186+ MyUtils, base,float,affine,graphsys,format,LocateFrm,locatech, gridaxes;
187+
188+function PixelX(x:extended):longint;
189+begin
190+ with MyGraphSys do
191+ result:=DeviceX(x) - DeviceX(left);
192+end;
193+
194+function PixelY(x:extended):longint;
195+begin
196+ with MyGraphSys do
197+ result:=DeviceY(bottom) - DeviceY(x)
198+end;
199+
200+function WindowX(x:extended):extended;
201+begin
202+ with MyGraphSys do
203+ result:=VirtualX( DeviceX(left) + LongIntRound(x) )
204+end;
205+
206+function WindowY(x:extended):extended;
207+begin
208+ with MyGraphSys do
209+ result:=VirtualY( DeviceY(bottom) - LongIntRound(x))
210+end;
211+
212+{*********}
213+{SET COLOR}
214+{*********}
215+const
216+ idxColorMax=255;
217+ ercodeColor=11085;
218+
219+procedure SetPointColor(x:double; InsideOfWhen:boolean); overload;
220+var
221+ c:LongInt;
222+begin
223+ c:=LongIntRound(x) and $ffffff;
224+ if (InsideOfWhen or not JISSetWindow)
225+ and not MyPalette.PaletteDisabled
226+ and ((c<0) or (c>idxColorMax)) then
227+ setexception(ercodeColor);
228+ MyGraphSys.PointColor:=c
229+end;
230+
231+procedure setLineColor(x:double; InsideOfWhen:boolean); overload;
232+var
233+ c:LongInt;
234+begin
235+ c:=LongIntRound(x) and $ffffff;
236+ if (InsideOfWhen or not JISSetWindow)
237+ and not MyPalette.PaletteDisabled
238+ and ((c<0) or (c>idxColorMax)) then
239+ setexception(ercodeColor);
240+ MyGraphSys.SetLineColor(c)
241+end;
242+
243+procedure setAreaColor(x:double; InsideOfWhen:boolean); overload;
244+var
245+ c:LongInt;
246+begin
247+ c:=LongIntRound(x) and $ffffff;
248+ if (InsideOfWhen or not JISSetWindow)
249+ and not MyPalette.PaletteDisabled
250+ and ((c<0) or (c>idxColorMax)) then
251+ setexception(ercodeColor);
252+ MyGraphSys.areaColor:=c
253+end;
254+
255+procedure setTextColor(x:double; InsideOfWhen:boolean); overload;
256+var
257+ c:LongInt;
258+begin
259+ c:=LongIntRound(x) and $ffffff;
260+ if (InsideOfWhen or not JISSetWindow)
261+ and not MyPalette.PaletteDisabled
262+ and ((c<0) or (c>idxColorMax)) then
263+ setexception(ercodeColor);
264+ MyGraphSys.SetTextColor(c)
265+end;
266+
267+procedure setAllColor(x:double; InsideOfWhen:boolean); overload;
268+var
269+ c:LongInt;
270+begin
271+ c:=LongIntRound(x) and $ffffff;
272+ if (InsideOfWhen or not JISSetWindow)
273+ and not MyPalette.PaletteDisabled
274+ and ((c<0) or (c>idxColorMax)) then
275+ setexception(ercodeColor);
276+ MyGraphSys.PointColor:=c;
277+ MyGraphSys.SetLineColor(c);
278+ MyGraphSys.AreaColor:=c;
279+ MyGraphSys.SetTextColor(c);
280+end;
281+
282+
283+function ColorOfName(s:string; insideofWhen:boolean):LongInt;
284+var
285+ i:integer;
286+begin
287+ for i:=1 to length(s) do s[i]:=upcase(s[i]);
288+ if (s='BLACK') or (s='黒') then
289+ result:=Black
290+ else if (s='BLUE')or (s='青') then
291+ result:=Blue
292+ else if (s='RED') or (s='赤') then
293+ result:=Red
294+ else if s='MAGENTA' then
295+ result:=Magenta
296+ else if (s='GREEN') or (s='緑') then
297+ result:=Green
298+ else if s='CYAN' then
299+ result:=cyan
300+ else if (s='YELLOW') or (s='黄') then
301+ result:=Yellow
302+ else if (s='WHITE') or (s='白') then
303+ result:=White
304+ else if s='GRAY' then
305+ result:=clGray
306+ else if s='NAVY' then
307+ result:=clNAVY
308+ else if s='SILVER' then
309+ result:=clSILVER
310+ else if s='LIME' then
311+ result:=clGREEN
312+ else
313+ begin
314+ result:=-1;
315+ if insideofwhen or not JISSetWindow then
316+ setexception(11085);
317+ end;
318+end;
319+
320+function ColorIndex(r,g,b:double):LongInt;
321+begin
322+ result:= MyPalette.colorindex(LongIntRound(r*255)
323+ +LongIntRound(g*255)*$100
324+ +LongIntRound(b*255)*$10000);
325+end;
326+
327+procedure SetPointColor(const s:string; InsideOfWhen:boolean);overload;
328+var
329+ c:LongInt;
330+ color:LongInt;
331+begin
332+ color:=GraphLib.ColorOfName(s,insideofWhen);
333+ if color>=0 then
334+ begin
335+ c:=MyPalette.ColorIndex(color);
336+ if c>=0 then
337+ MyGraphSys.PointColor:=c;
338+ end
339+end;
340+
341+procedure setLineColor(const s:string; InsideOfWhen:boolean);overload;
342+var
343+ c:LongInt;
344+ color:LongInt;
345+begin
346+ color:=GraphLib.ColorOfName(s,insideofWhen);
347+ if color>=0 then
348+ begin
349+ c:=MyPalette.ColorIndex(color);
350+ if c>=0 then
351+ MyGraphSys.SetLineColor(c);
352+ end
353+end;
354+
355+procedure setAreaColor(const s:string; InsideOfWhen:boolean);overload;
356+var
357+ c:LongInt;
358+ color:LongInt;
359+begin
360+ color:=GraphLib.ColorOfName(s,insideofWhen);
361+ if color>=0 then
362+ begin
363+ c:=MyPalette.ColorIndex(color);
364+ if c>=0 then
365+ MyGraphSys.AreaColor:=c;
366+ end
367+end;
368+
369+procedure setTextColor(const s:string; InsideOfWhen:boolean);overload;
370+var
371+ c:LongInt;
372+ color:LongInt;
373+begin
374+ color:=GraphLib.ColorOfName(s,insideofWhen);
375+ if color>=0 then
376+ begin
377+ c:=MyPalette.ColorIndex(color);
378+ if c>=0 then
379+ MyGraphSys.SetTextColor(c);
380+ end
381+end;
382+
383+procedure setAllColor(const s:string; InsideOfWhen:boolean);overload;
384+var
385+ c:LongInt;
386+ color:LongInt;
387+begin
388+ color:=GraphLib.ColorOfName(s,insideofWhen);
389+ if color>=0 then
390+ begin
391+ c:=MyPalette.ColorIndex(color);
392+ if c>=0 then
393+ SetAllColor(c,InsideOfWhen);
394+ end
395+end;
396+
397+procedure SetAxisColor(x:double; InsideOfWhen:boolean);overload;
398+var
399+ c:LongInt;
400+begin
401+ c:=LongIntRound(x);
402+ if c>=0 then
403+ GraphSys.axescolor:=c
404+end;
405+
406+procedure SetAxisColor(const s:string; InsideOfWhen:boolean);overload;
407+var
408+ c:LongInt;
409+ color:LongInt;
410+begin
411+ color:=GraphLib.ColorOfName(s,insideofWhen);
412+ if color>=0 then
413+ begin
414+ c:=MyPalette.ColorIndex(color);
415+ if c>=0 then
416+ SetAxisColor(c,InsideOfWhen);
417+ end
418+end;
419+
420+
421+
422+
423+
424+
425+
426+function CoordinateTest(var l,r,b,t:double; insideofwhen:boolean):boolean;
427+begin
428+ if currenttransform<>nil then
429+ setexception(11004);
430+ if ((l=r) or (b=t)) then
431+ if InsideOfWhen or not JISSetWindow then
432+ setexception(11051)
433+ else
434+ result:=false
435+ else
436+ result:=true;
437+end;
438+
439+procedure SetWindow(l,r,b,t:double; insideofWhen:boolean);
440+begin
441+ if CoordinateTest(l,r,b,t,insideofwhen)then
442+ MyGraphSys.setWindow(l,r,b,t) ;
443+ Application.ProcessMessages;
444+end;
445+
446+function TestInterval(const l,r,b,t:extended):boolean;
447+begin
448+ result:=(0<=l) and (r<=1) and (0<=b) and (t<=1)
449+end;
450+
451+procedure SetViewPort(l,r,b,t:double; InsideOfWhen:boolean);
452+begin
453+ if CoordinateTest(l,r,b,t, InsideOfWhen)then
454+ if testInterval(l,r,b,t) then
455+ MyGraphSys.setViewport(l,r,b,t)
456+ else if InsideOfWhen or not JISSetWindow then
457+ setexception(11052);
458+end;
459+
460+procedure SetDeviceWindow(l,r,b,t:double; InsideOfWhen:boolean);
461+begin
462+ if CoordinateTest(l,r,b,t, InsideOfWhen)then
463+ if testInterval(l,r,b,t) then
464+ MyGraphSys.setDeviceWindow(l,r,b,t)
465+ else if InsideOfWhen or not JISSetWindow then
466+ setexception(11053);
467+end;
468+
469+procedure SetDeviceViewPort(l,r,b,t:double; InsideOfWhen:boolean);
470+begin
471+ if CoordinateTest(l,r,b,t, InsideOfWhen)then
472+ if (l<r) and (b<t) then
473+ MyGraphSys.setDeviceViewport(l,r,b,t)
474+ else if InsideOfWhen or not JISSetWindow then
475+ setexception(11054);
476+end;
477+
478+{*********}
479+{SET COLOR}
480+{*********}
481+
482+{*************}
483+{SET COLOR MIX}
484+{*************}
485+
486+ procedure SetColorMixSub(c:byte;r,g,b:byte);
487+var
488+ col:TColor;
489+begin
490+ col:=r+g*word($100)+b*longint($10000) ;
491+ with MyGraphSys do
492+ begin
493+ MyPalette[c]:=col ;
494+ setlinecolor(linecolor);
495+ settextcolor(textcolor);
496+ end;
497+end;
498+
499+procedure SetColorMix(cc:double; er,eg,eb:double; InsideofWhen:boolean);
500+var
501+ c,r,g,b:byte;
502+begin
503+ if (cc<0) or (cc>maxColor) or MyPalette.PaletteDisabled then
504+ if InsideOfWhen or not JISSetWindow then
505+ setexception(11085);
506+
507+ if (er<0) or (er>1) or (eg<0) or (eg>1) or (eb<0) or (eb>1) then
508+ if InsideOfWhen or not JISSetWindow then
509+ setexception(11088);
510+ c:=LongIntRound(cc);
511+ r:=LongIntRound(er*255);
512+ g:=LongIntRound(eg*255);
513+ b:=LongIntRound(eb*255);
514+ setcolormixsub(c,r,g,b);
515+end;
516+
517+procedure setPointStyle(x:double; InsideOfWhen:boolean);
518+var
519+ c:LongInt;
520+begin
521+ c:=LongIntRound(x);
522+ if (c>0) and (c<=maxpointstyle) then
523+ MyGraphSys.pointstyle:=c
524+ else if insideofwhen or not JISSetWindow then
525+ setexception(11056) ;
526+end;
527+
528+procedure setLineStyle(x:double; InsideOfWhen:boolean);
529+var
530+ c:LongInt;
531+ s:TPenStyle;
532+begin
533+ c:=LongIntRound(x);
534+ if (c>0) and (c<=5) then
535+ begin
536+ case c of
537+ 1: s:=psSolid;
538+ 2: s:=psDash;
539+ 3: s:=psDot;
540+ 4: s:=psDashDot;
541+ 5: s:=psDashDotDot;
542+ end;
543+ MyGraphSys.setPenStyle(s);
544+ end
545+ else
546+ if insideofwhen or not JISSetWindow then
547+ setexception(11062)
548+end;
549+
550+
551+procedure setAreaStyleIndex(x:double; InsideOfWhen:boolean);
552+var
553+ c:LongInt;
554+begin
555+ c:=LongIntRound(x);
556+ if (c>0) and (c<=6) then
557+ MyGraphSys.SetAreaStyleIndex(c)
558+ else if insideofwhen or not JISSetWindow then
559+ setexception(11000) ;
560+end;
561+
562+procedure setTextHeight(x:double; InsideOfWhen:boolean);
563+begin
564+ if x>0 then
565+ MyGraphSys.SetTextHeight(x)
566+ else if insideofWhen or not JISSetWindow then
567+ setexception(11073);
568+end;
569+procedure setLineWidth(x:double; InsideOfWhen:boolean);
570+var
571+ c:LongInt;
572+begin
573+ c:=LongIntRound(x);
574+ if c>0 then
575+ MyGraphSys.setlinewidth(c);
576+end;
577+
578+procedure setTextAngle(x:double; AngleDegrees:boolean);
579+var
580+ a:Integer;
581+begin
582+ if not Angledegrees then
583+ x:=x * 180. / PI;
584+ a:=SysTem.Round(x - Floor(x/360.0 ) * 360.0 );
585+ MyGraphSys.textangle:=a;
586+end;
587+
588+procedure setAreaStyle(const s:string);
589+var
590+ c:TAreaStyle;
591+begin
592+ if UpperCase(s)='HOLLOW' then c:=asHollow
593+ else if UpperCase(s)='SOLID' then c:=asSolid
594+ else if UpperCase(s)='HATCH' then c:=asHatch
595+ else setexception(11000);
596+ MyGraphSys.SetAreaStyle(c);
597+end;
598+
599+procedure setTextJustify( s1,s2:string; InsideOfWhen:boolean);
600+ var
601+ h:tjHorizontal;
602+ v:tjVirtical;
603+ begin
604+ s1:=ansiUpperCase(s1);
605+ s2:=ansiUpperCase(s2);
606+
607+ h:=tjLEFT;
608+ while (h<=tjRIGHT) and (Hjustification[h]<>s1) do inc(h);
609+ if system.ord(h)<=system.ord(tjRIGHT) then
610+ MyGraphSys.Hjustify:=h
611+ else if insideofwhen or not JISSetWindow then
612+ setexception(4102) ;
613+
614+ v:=tjTOP;
615+ while (v<=tjBOTTOM) and (Vjustification[v]<>s2) do inc(v);
616+ if system.ord(v)<=system.ord(tjBOTTOM) then
617+ MyGraphSys.Vjustify:=v
618+ else if insideofwhen or not JISSetWindow then
619+ setexception(4102) ;
620+end;
621+
622+
623+(*
624+procedure setpointcolor(c:integer);
625+begin
626+ c:=c and $ffffff;
627+ MyGraphSys.PointColor:=c;
628+end;
629+
630+procedure setlinecolor(c:integer);
631+begin
632+ c:=c and $ffffff;
633+ MyGraphSys.setlinecolor(c);
634+end;
635+
636+procedure setareacolor(c:integer);
637+begin
638+ c:=c and $ffffff;
639+ MyGraphSys.areacolor:=c ;
640+end;
641+
642+procedure settextcolor(c:integer);
643+begin
644+ c:=c and $ffffff;
645+ MyGraphSys.settextcolor(c);
646+end;
647+*)
648+
649+procedure SetClip(const s:string; insideofwhen:boolean);
650+begin
651+ with MyGraphSys do
652+ if Uppercase(s)='ON' then setclip(true)
653+ else if Uppercase(s)='OFF' then setclip(false)
654+ else if InsideOfWhen or not JISSetWindow then
655+ setexception(4101);
656+end;
657+
658+procedure SetTextFont(const s:string; x:double);
659+begin
660+ MyGraphSys.SetTextFont(s, LongIntRound(x));
661+end;
662+
663+procedure SetTextBackGround(const s:string);
664+begin
665+ if UpperCase(s)='TRANSPARENT' then iBKmode:=TRANSPARENT
666+ else if UpperCase(s)='OPAQUE' then iBKmode:=OPAQUE
667+ else setexception(11000);
668+end;
669+
670+procedure SetBitmapSize(x,y:double);
671+begin
672+ try
673+ MyGraphSys.setBitmapSize(LongIntRound(x),LongIntRound(y))
674+ except
675+ setexception(9050);
676+ end;
677+end;
678+
679+{*************************}
680+{PLOT POINT and PLOT LINES}
681+{*************************}
682+var
683+ x0,y0:extended;
684+
685+procedure ProjectivePlotTo(const x1,y1:extended);
686+var
687+ a,b,s,t,u,x,y:extended;
688+label
689+ Retry1,Retry2;
690+begin
691+ with CurrentTransform do
692+ begin
693+ if MyGraphSys.beam=true then
694+ begin
695+ a:=x1-x0;
696+ b:=y1-y0;
697+ s:=ox*a+oy*b;
698+ t:=-(ox*x0+oy*y0+oo);
699+ if s<>0 then
700+ begin
701+ t:=t/s;
702+
703+ if (t>0 - 1e-14) and (t<=1 + 1e-14) then
704+ begin
705+
706+ u:=t;
707+ Retry1:
708+ u:=u-0.0001;
709+ if u>0 then
710+ begin
711+ x:=a*u+x0;
712+ y:=b*u+y0;
713+ if transform(x,y) then
714+ MyGraphSys.PlotTo(x,y)
715+ else
716+ GOTO Retry1;
717+ end;
718+
719+ MyGraphSys.beam:=false;
720+
721+ u:=1-t;
722+ Retry2:
723+ u:=u-0.0001;
724+ if u>0 then
725+ begin
726+ x:=a*(1-u)+x0;
727+ y:=b*(1-u)+y0;
728+ if transform(x,y) then
729+ MyGraphSys.PlotTo(x,y)
730+ else
731+ GOTO Retry2;
732+ end;
733+ end;
734+ end;
735+ end;
736+
737+ x:=x1;
738+ y:=y1;
739+ if transform(x,y) then
740+ MyGraphSys.PlotTo(x,y);
741+ x0:=x1;
742+ y0:=y1;
743+ MyGraphSys.beam:=true;
744+ end;
745+end;
746+
747+type
748+ TPointArray=array[ 0..1023] of TPoint;
749+ PPointArray=^TPointArray;
750+
751+procedure GraphPoints(const a: array of double);
752+var
753+ i:integer;
754+ p:PPointArray;
755+ x,y:double;
756+begin
757+ GetMem(p,sizeof(double)*Length(a));
758+ try
759+ for i:=0 to High(a) div 2 do
760+ begin
761+ x:=a[2*i];
762+ y:=a[2*i+1];
763+ MyGraphSys.putMark(x,y);
764+ end;
765+ finally
766+ FreeMem(p, sizeof(double)*Length(a));
767+ end;
768+ MyGraphSys.ThinRepaint;
769+end;
770+
771+
772+procedure PlotPoints(const a: array of double);
773+var
774+ i:integer;
775+ p:PPointArray;
776+ x,y:double;
777+begin
778+ with MyGraphSys do
779+ if BeamMode=bmRigorous then beam:=false;
780+
781+ GetMem(p,sizeof(double)*Length(a));
782+ try
783+ for i:=0 to High(a) div 2 do
784+ begin
785+ x:=a[2*i];
786+ y:=a[2*i+1];
787+ if currenttransform.transform(x,y) then
788+ MyGraphSys.putMark(x,y);
789+ end;
790+ finally
791+ FreeMem(p, sizeof(double)*Length(a));
792+ end;
793+ MyGraphSys.ThinRepaint;
794+end;
795+
796+procedure GraphLines(const a: array of double);
797+var
798+ i:integer;
799+ p:PPointArray;
800+ x,y:double;
801+begin
802+ MyGraphSys.beam:=false;
803+ GetMem(p,sizeof(double)*Length(a));
804+ try
805+ for i:=0 to High(a) div 2 do
806+ begin
807+ x:=a[2*i];
808+ y:=a[2*i+1];
809+ MyGraphSys.PlotTo(x,y);
810+ end
811+ finally
812+ FreeMem(p, sizeof(double)*Length(a));
813+ end;
814+ MyGraphSys.beam:=false;
815+ MyGraphSys.ThinRepaint;
816+end;
817+
818+procedure PlotLines(const a: array of double);
819+var
820+ i:integer;
821+ p:PPointArray;
822+ x,y:double;
823+begin
824+ GetMem(p,sizeof(double)*Length(a));
825+ try
826+ if (CurrentTransform=nil) or CurrentTransform.IsAffine then
827+ for i:=0 to High(a) div 2 do
828+ begin
829+ x:=a[2*i];
830+ y:=a[2*i+1];
831+ if currenttransform.transform(x,y) then
832+ MyGraphSys.PlotTo(x,y);
833+ end
834+ else
835+ for i:=0 to High(a) div 2 do
836+ begin
837+ x:=a[2*i];
838+ y:=a[2*i+1];
839+ ProjectivePlotTo(x,y)
840+ end;
841+ finally
842+ FreeMem(p, sizeof(double)*Length(a));
843+ end;
844+ MyGraphSys.ThinRepaint;
845+end;
846+
847+procedure BeamOff;
848+begin
849+ MyGraphSys.beam:=false;
850+end;
851+
852+{*********}
853+{PLOT AREA}
854+{*********}
855+
856+type
857+ TCoordinate=Packed Record
858+ x,y:extended;
859+ end;
860+ TCoordinateArray=Packed Array[0..1023] of TCoordinate;
861+ PCoordinateArray=^TCoordinateArray;
862+
863+ function NormalSegment(const x0,y0,x1,y1:extended):boolean;
864+var
865+ a,b,s,t:extended;
866+begin
867+ result:=true;
868+ if CurrentTransform=nil then exit;
869+ with CurrentTransform do
870+ begin
871+ a:=x1-x0;
872+ b:=y1-y0;
873+ s:=ox*a+oy*b;
874+ t:=-(ox*x0+oy*y0+oo);
875+ if s<>0 then
876+ begin
877+ t:=t/s;
878+ if (t>=0) and (t<=1) then
879+ result:=false;
880+ end
881+ else if t=0 then
882+ result:=false;
883+ end
884+end;
885+
886+function TestNormalSegments(p:PCoordinateArray; count:integer):boolean;
887+var
888+ i:integer;
889+begin
890+ result:=true;
891+ for i:=0 to count-1 do
892+ result:=result and NormalSegment(p^[i].x, p^[i].y,
893+ p^[(i+1)mod count].x, p^[(i+1)mod count].y);
894+end;
895+
896+
897+function Inner(x,y:extended; p:PCoordinateArray; count:integer):boolean;
898+var
899+ i:integer;
900+ x0,y0,x1,y1,y2:extended;
901+ xt:extended;
902+begin
903+ if (p^[0].x = p^[count-1].x) and (p^[0].y = p^[count-1].y) then dec(count);
904+
905+ result:=false;
906+
907+ for i:=0 to count -1 do
908+ begin
909+ x0:=p^[i].x;
910+ y0:=p^[i].y;
911+ x1:=p^[(i+1) mod count].x;
912+ y1:=p^[(i+1) mod count].y;
913+ y2:=p^[(i+2) mod count].y;
914+
915+ if (y0 - y) * (y - y1) >0 then
916+ begin
917+ xt:=(x1-x0)/(y1-y0)*(y-y0)+x0;
918+ if x=xt then begin result:=true; exit end
919+ else if x<xt then result:=not result;
920+ end
921+ else if y=y1 then
922+ begin
923+ if (y0=y1) then
924+ begin
925+ if ((x -x0)*(x - x1)<=0) then
926+ begin result:=true ; exit end ;
927+ end
928+ else if (y=y1) and ((y0 - y1)*(y1 - y2)>0) then
929+ begin
930+ if x<x1 then result:= not result
931+ end
932+ end
933+ end;
934+end;
935+
936+function ReMakeList(p:PCoordinateArray; q:PPointArray; count:integer; GRAPHst:boolean):integer; //結果は点の個数
937+var
938+ i,index:integer;
939+ x,y:extended;
940+begin
941+ result:=0;
942+ for i:=0 to count-1 do
943+ begin
944+ x:=p^[i].x;
945+ y:=p^[i].y;
946+ if GRAPHst or currenttransform.transform(x,y) then
947+ begin
948+ q^[result].x:=restrict(MyGraphSys.deviceX(x));
949+ q^[result].y:=restrict(MyGraphSys.deviceY(y));
950+ inc(result)
951+ end
952+ end;
953+end;
954+
955+
956+procedure ProjectivePolygonSub(p:PCoordinateArray; lim:integer);
957+var
958+ q:PPointArray;
959+ a,b:integer;
960+ x,y,yy:extended;
961+begin
962+ if TestNormalSegments(p,lim) then
963+ begin
964+ GetMem(q,lim*sizeof(TPoint));
965+ try
966+ MyGraphSys.Polygon(slice(q^,ReMakeList(p,q,lim,false)));
967+ finally
968+ Freemem(q,lim*sizeof(TPoinT));
969+ end
970+ end
971+ else
972+ with MyGraphSys do
973+ for b:=ClipRect.top to Cliprect.Bottom do
974+ begin
975+ yy:=virtualY(b);
976+ for a:=ClipRect.Left to Cliprect.Right do
977+ begin
978+ x:=virtualX(a);
979+ y:=yy;
980+ if currenttransform.invtransform(x,y) then
981+ if inner(x,y,p,lim) then
982+ PutColor(a,b,areacolor);
983+ end;
984+ end;
985+end;
986+
987+procedure PlotAreaProjective(Const a:Array of double);
988+var
989+ P:PCoordinateArray;
990+ i:integer;
991+ count:integer;
992+begin
993+ count:=Length(a) div 2;
994+ GetMem(p, count*SizeOf(TCoordinate));
995+ try
996+ for i:=0 to count -1 do
997+ begin
998+ p^[i].x:=a[2*i];
999+ p^[i].y:=a[2*i+1];
1000+ end;
1001+ ProjectivePolygonSub(p,count);
1002+ finally
1003+ FreeMem(p, count*SizeOf(TCoordinate));
1004+ end;
1005+end;
1006+
1007+procedure PlotAreaNormal(const a: array of double);
1008+var
1009+ i:integer;
1010+ p:PPointArray;
1011+ x,y:double;
1012+begin
1013+ GetMem(p,sizeof(TPoint)*Length(a));
1014+ try
1015+ for i:=0 to High(a) div 2 do
1016+ begin
1017+ x:=a[2*i];
1018+ y:=a[2*i+1];
1019+ if not currenttransform.transform(x,y) then exit;
1020+ p^[i].x:=restrict(MyGraphSys.deviceX(x));
1021+ p^[i].y:=restrict(MyGraphSys.deviceY(y));
1022+ end;
1023+ MyGraphSys.Polygon(Slice(p^,Length(a) div 2));
1024+ finally
1025+ FreeMem(p, sizeof(TPoint)*Length(a));
1026+ end;
1027+end;
1028+
1029+procedure PlotArea(const a: array of double); overload;
1030+begin
1031+ with MyGraphSys do
1032+ if BeamMode=bmRigorous then beam:=false;
1033+
1034+ if (CurrentTransform=nil) or CurrentTransform.IsAffine then
1035+ PlotAreaNormal(a)
1036+ else
1037+ PlotAreaProjective(a);
1038+ MyGraphSys.ThinRepaint;
1039+end;
1040+
1041+procedure GraphArea(const a: array of double);
1042+var
1043+ i:integer;
1044+ p:PPointArray;
1045+ x,y:double;
1046+begin
1047+ BeamOff;
1048+ GetMem(p,sizeof(TPoint)*Length(a));
1049+ try
1050+ for i:=0 to High(a) div 2 do
1051+ begin
1052+ x:=a[2*i];
1053+ y:=a[2*i+1];
1054+ p^[i].x:=restrict(MyGraphSys.deviceX(x));
1055+ p^[i].y:=restrict(MyGraphSys.deviceY(y));
1056+ end;
1057+ MyGraphSys.Polygon(Slice(p^,Length(a) div 2));
1058+ finally
1059+ FreeMem(p, sizeof(TPoint)*Length(a));
1060+ end;
1061+ MyGraphSys.ThinRepaint;
1062+end;
1063+
1064+
1065+{*********}
1066+{PLOT TEXT}
1067+{*********}
1068+
1069+
1070+
1071+procedure GraphText(x,y:double; const s:string);
1072+begin
1073+ with MyGraphSys do beam:=false;
1074+ MyGraphSys.PutText(x,y,s);
1075+ MyGraphSys.ThinRepaint;
1076+end;
1077+
1078+procedure PlotText(x,y:double; const s:string);
1079+begin
1080+ with MyGraphSys do
1081+ if BeamMode=bmRigorous then beam:=false;
1082+ if currenttransform.transform(x,y) then
1083+ MyGraphSys.PlotText(x,y,s);
1084+ MyGraphSys.ThinRepaint;
1085+end;
1086+
1087+function TextUsing(const form:string; a:array of const):String;
1088+var
1089+ i,code,c:integer;
1090+ s:string;
1091+begin
1092+ i:=1;
1093+ s:=literals(form,i);
1094+ for c:=0 to High(a) do
1095+ begin
1096+ with a[c] do
1097+ case VType of
1098+ vtInteger: s:=s + formatEx(VInteger,form,i,code);
1099+ vtInt64: s:=s + formatEx(VINT64^,form,i,code);
1100+ vtExtended: s:=s + formatEx(VExtended^,form,i,code);
1101+ vtchar: s:=s + formatStr(VChar,form,i,code);
1102+ vtString: s:=s + formatStr(VString^,form,i,code);
1103+ vtAnsiString:s:=s + formatStr(string(VAnsiString),form,i,code);
1104+ end;
1105+ s:=s +literals(form,i)
1106+ end;
1107+ result:=s;
1108+end;
1109+
1110+procedure PlotTextUsing(x,y:double; const form:string; a:array of const);
1111+begin
1112+ PlotText(x,y,TextUsing(form,a));
1113+end;
1114+
1115+procedure GraphTextUsing(x,y:double; const form:string; a:array of const);
1116+begin
1117+ GraphText(x,y,TextUsing(form,a));
1118+end;
1119+
1120+procedure GraphLabel(x,y:double; const s:string);
1121+begin
1122+ with MyGraphSys do
1123+ if BeamMode=bmRigorous then beam:=false;
1124+ MyGraphSys.PutText(x,y,s);
1125+ MyGraphSys.ThinRepaint;
1126+end;
1127+
1128+procedure PlotLabel(x,y:double; const s:string);
1129+begin
1130+ with MyGraphSys do
1131+ if BeamMode=bmRigorous then beam:=false;
1132+ if currenttransform.transform(x,y) then
1133+ MyGraphSys.PutText(x,y,s);
1134+ MyGraphSys.ThinRepaint;
1135+end;
1136+
1137+procedure PlotLetters(x,y:double; const s:string);
1138+begin
1139+ with MyGraphSys do
1140+ if BeamMode=bmRigorous then beam:=false;
1141+ if currenttransform.transform(x,y) then
1142+ MyGraphSys.PlotLetters(x,y,s);
1143+ MyGraphSys.ThinRepaint;
1144+end;
1145+
1146+procedure GraphLabelUsing(x,y:double; const form:string; a:array of const);
1147+begin
1148+ PlotLabel(x,y,TextUsing(form,a));
1149+end;
1150+
1151+procedure PlotlabelUsing(x,y:double; const form:string; a:array of const);
1152+begin
1153+ PlotLabel(x,y,TextUsing(form,a));
1154+end;
1155+
1156+
1157+procedure PlotLettersUsing(x,y:double; const form:string; a:array of const);
1158+begin
1159+ PlotLetters(x,y,TextUsing(form,a));
1160+end;
1161+
1162+
1163+{********}
1164+{MAT PLOT}
1165+{********}
1166+
1167+
1168+procedure MatPlotPointsSub(n:integer; const m1,m2:TArray1N);overload;
1169+var
1170+ i:integer;
1171+ x,y:double;
1172+begin
1173+ for i:=0 to n-1 do
1174+ begin
1175+ x:=m1.elements[i];
1176+ y:=m2.elements[i];
1177+ if currenttransform.transform(x,y) then
1178+ MyGraphSys.putMark(x,y);
1179+ end;
1180+end;
1181+
1182+procedure MatPlotPointsSub(n:integer; const m:TArray2N);overload;
1183+var
1184+ i:integer;
1185+ s:integer;
1186+ x,y:double;
1187+begin
1188+ s:=m.size2;
1189+ if s<=1 then
1190+ setexception(6401);
1191+
1192+ for i:=0 to n-1 do
1193+ begin
1194+ x:=m.elements[i*s];
1195+ y:=m.elements[i*s+1];
1196+ if currenttransform.transform(x,y) then
1197+ MyGraphSys.putMark(x,y);
1198+ end;
1199+end;
1200+
1201+
1202+function SetCoordinate(p:PPointArray; n:integer; x,y:TArray1N):boolean;overload;
1203+var
1204+ i:integer;
1205+ xx,yy:double;
1206+begin
1207+ result:=false;
1208+ for i:=0 to n-1 do
1209+ begin
1210+ xx:=x.elements[i];
1211+ yy:=y.elements[i];
1212+ if not currenttransform.transform(xx,yy) then exit;
1213+ p^[i].x:=restrict(MyGraphSys.deviceX(xx));
1214+ p^[i].y:=restrict(MyGraphSys.deviceY(yy));
1215+ end;
1216+ result:=true;
1217+end;
1218+
1219+function SetCoordinate(p:PPointArray; n:integer; m:TArray2N):boolean;overload;
1220+var
1221+ i:integer;
1222+ s:integer;
1223+ xx,yy:double;
1224+begin
1225+ result:=false;
1226+ s:=m.Size2;
1227+ if s<=1 then
1228+ setexception(6401);
1229+
1230+ for i:=0 to n-1 do
1231+ begin
1232+ xx:=m.elements[i*s];
1233+ yy:=m.elements[i*s+1];
1234+ if not currenttransform.transform(xx,yy) then exit;
1235+ p^[i].x:=restrict(MyGraphSys.deviceX(xx));
1236+ p^[i].y:=restrict(MyGraphSys.deviceY(yy));
1237+ end;
1238+ result:=true;
1239+end;
1240+
1241+
1242+procedure MatPlotLinesSub(n:integer; const x,y:TArray1N);overload;
1243+var
1244+ p:PPointArray;
1245+begin
1246+ BeamOff;
1247+ Getmem(p,n*sizeof(TPoint));
1248+ try
1249+ if SetCoordinate(p,n,x,y) then
1250+ MyGraphSys.PolyLine(slice(p^,n));
1251+ finally
1252+ Freemem(p,n*sizeof(TPoint));
1253+ end;
1254+ MyGraphSys.beam:=false;
1255+ MyGraphSys.ThinRepaint;
1256+end;
1257+
1258+procedure MatPlotLinesSub(n:integer; const m:TArray2N);overload;
1259+var
1260+ p:PPointArray;
1261+begin
1262+ BeamOff;
1263+ Getmem(p,n*sizeof(TPoint));
1264+ try
1265+ if SetCoordinate(p,n,m) then
1266+ MyGraphSys.PolyLine(slice(p^,n));
1267+ finally
1268+ Freemem(p,n*sizeof(TPoint));
1269+ end;
1270+ MyGraphSys.beam:=false;
1271+ MyGraphSys.ThinRepaint;
1272+end;
1273+
1274+procedure MatPlotAreaSub(n:integer; const x,y:TArray1N);overload;
1275+var
1276+ p:PDoubleArray;
1277+ i:integer;
1278+begin
1279+ if n<3 then setexception(11100);
1280+ Getmem(p,2*n*sizeof(Double));
1281+ try
1282+ for i:=0 to n-1 do
1283+ begin
1284+ p^[2*i]:=x.elements^[i];
1285+ p^[2*i+1]:=y.elements^[i];
1286+ end;
1287+ PlotArea(slice(p^,2*n))
1288+ finally
1289+ Freemem(p,2*n*sizeof(Double));
1290+ end;
1291+ MyGraphSys.ThinRepaint;
1292+end;
1293+
1294+procedure MatPlotAreaSub(n:integer; const m:TArray2N);overload;
1295+begin
1296+ if n<3 then setexception(11100);
1297+ PlotArea(slice(m.elements^,n*2))
1298+end;
1299+
1300+
1301+procedure MatPlotPoints(const x,y:TArray1N);overload;
1302+begin
1303+ if x.Size=y.Size then
1304+ MatPlotPointsSub(x.Size, x, y)
1305+ else
1306+ SetException(6401);
1307+end;
1308+
1309+procedure MatPlotPoints(const m:TArray2N);overload;
1310+begin
1311+ MatPlotPointsSub(m.Size1, m)
1312+end;
1313+
1314+procedure MatPlotLines(const x,y:TArray1N);overload;
1315+begin
1316+ if (x.Size=y.Size) then
1317+ MatPlotLinesSub(x.Size, x, y)
1318+ else
1319+ SetException(6401);
1320+end;
1321+
1322+procedure MatPlotLines(const m:TArray2N);overload;
1323+begin
1324+ MatPlotLinesSub(m.size1, m)
1325+end;
1326+
1327+procedure MatPlotArea(const x,y:TArray1N);overload;
1328+begin
1329+ if (x.Size=y.Size) then
1330+ MatPlotAreaSub(x.Size, x, y)
1331+ else
1332+ SetException(6401);
1333+end;
1334+
1335+
1336+procedure MatPlotArea(const m:TArray2N);overload;
1337+begin
1338+ MatPlotAreaSub(m.size1, m)
1339+end;
1340+
1341+procedure MatPlotPointsLimit(n:double; const x,y:TArray1N);overload;
1342+var
1343+ nn:integer;
1344+begin
1345+ nn:=LongIntRound(n);
1346+ if (nn>=0) and (nn<=x.size1) and (nn<=y.size1) then
1347+ MatPlotPointsSub(nn, x,y)
1348+ else
1349+ SetException(6402)
1350+end;
1351+
1352+procedure MatPlotPointsLimit(n:double; const m:TArray2N);overload;
1353+var
1354+ nn:integer;
1355+begin
1356+ nn:=LongIntRound(n);
1357+ if (nn>=0) and (nn<=m.size1) then
1358+ MatPlotPointsSub(nn, m)
1359+ else
1360+ SetException(6402)
1361+end;
1362+
1363+
1364+procedure MatPlotLinesLimit(n:double; const x,y:TArray1N);overload;
1365+var
1366+ nn:integer;
1367+begin
1368+ nn:=LongIntRound(n);
1369+ if (nn>0) and (nn<=x.size1) and (nn<=y.size1) then
1370+ MatPlotLinesSub(nn, x,y)
1371+ else
1372+ SetException(6402)
1373+end;
1374+
1375+procedure MatPlotLinesLimit(n:double; const m:TArray2N);overload;
1376+var
1377+ nn:integer;
1378+begin
1379+ nn:=LongIntRound(n);
1380+ if (nn>0) and (nn<=m.size1) then
1381+ MatPlotLinesSub(nn, m)
1382+ else
1383+ SetException(6402)
1384+end;
1385+
1386+procedure MatPlotAreaLimit(n:double; const x,y:TArray1N);overload;
1387+var
1388+ nn:integer;
1389+begin
1390+ nn:=LongIntRound(n);
1391+ if (nn>0) and (nn<=x.size1) and (nn<=y.size1) then
1392+ MatPlotAreaSub(nn, x,y)
1393+ else
1394+ SetException(6402)
1395+end;
1396+
1397+
1398+procedure MatPlotAreaLimit(n:double; const m:TArray2N);overload;
1399+var
1400+ nn:integer;
1401+begin
1402+ nn:=LongIntRound(n);
1403+ if (nn>0) and (nn<=m.size1) then
1404+ MatPlotAreaSub(nn, m)
1405+ else
1406+ SetException(6402)
1407+end;
1408+
1409+
1410+{**************}
1411+{MAT PLOT CELLS}
1412+{**************}
1413+
1414+procedure MatCells(p:TArray2N; const x1,y1,x2,y2:double; GRAPHst,insideofWhen:boolean);
1415+var
1416+ a,b,i,j:integer;
1417+ color:longint;
1418+ x,y,w,h:extended;
1419+ xx,yy,dx,dy:extended;
1420+ //colorbyte:^byte;
1421+ svDrawMode:boolean;
1422+ PaletteDisabled:boolean;
1423+ red,green,blue:byte;
1424+ Points:array[1..4]of TPoint;
1425+ a1,b1,a2,b2,a3,b3,a4,b4:extended;
1426+ f:boolean;
1427+begin
1428+ if p.size=0 then exit;
1429+
1430+ f:=false;
1431+ if (MyGraphSys is TScreenBMPGraphSys)
1432+ and ((CurrentTransform=nil)
1433+ or CurrentTransform.IsAffine and (abs(CurrentTransform.det)>1/1024)) then
1434+ begin
1435+
1436+ PaletteDisabled:=MyPalette.PaletteDisabled;
1437+ svDrawMode:=GraphSys.HiddenDrawMode;
1438+ MyGraphSys.SetHiddenDrawMode(true);
1439+
1440+ x:=MyGraphSys.virtualX(0);
1441+ y:=MyGraphSys.virtualY(0);
1442+ dx:=MyGraphSys.virtualX(1);
1443+ dy:=MyGraphSys.virtualY(1);
1444+ if not GRAPHst then
1445+ begin
1446+ currenttransform.invtransform(x,y);
1447+ currenttransform.invtransform(dx,dy);
1448+ end;
1449+ dx:=dx-x;
1450+ dy:=y-dy;
1451+
1452+ if (x2-x1)*dx<0 then
1453+ dx:=-dx;
1454+ if (y2-y1)*dy<0 then
1455+ dy:=-dy;
1456+ w:=p.size1/(x2-x1+dx);
1457+ h:=p.size2/(y2-y1+dy);
1458+
1459+ with TScreenBMPGraphSys(MyGraphSys) do
1460+ for b:=ClipRect.top to Cliprect.Bottom do
1461+ begin
1462+ (*
1463+ colorbyte:=BitMap1.ScanLine[b];
1464+ *)
1465+ y:=virtualY(b);
1466+ yy:=y;
1467+ for a:=ClipRect.Left to Cliprect.Right do
1468+ begin
1469+ x:=virtualX(a);
1470+ y:=yy;
1471+ if not GRAPHst then
1472+ currenttransform.invtransform(x,y);
1473+ i:=floor(w*(x-x1)+1e-9 {計算誤差の補償});
1474+ j:=floor(h*(y-y1)+1e-9 {計算誤差の補償});
1475+ (*
1476+ if (i>=0) and (i<p.size[1]) and (j>=0) and (j<p.size[2]) then
1477+ begin
1478+ with p do color:=ItemEvaLInteger(i*size[2]+j);
1479+ if (color>=0) and
1480+ ((color<=maxcolor) or PaletteDisabled) then
1481+ begin
1482+ if not PaletteDisabled then
1483+ color:=MyPalette[color];
1484+ red:=byte(color);
1485+ color:=color shr 8;
1486+ green:=byte(color);
1487+ color:=color shr 8;
1488+ blue:=byte(color);
1489+ colorbyte^:=blue;
1490+ inc(colorbyte);
1491+ colorbyte^:=green;
1492+ inc(colorbyte);
1493+ colorbyte^:=red;
1494+ inc(colorbyte);
1495+ inc(colorbyte);
1496+ end;
1497+ end
1498+ else
1499+ inc(colorbyte,4); //32ビットBMP
1500+ *)
1501+
1502+ if (i>=0) and (i<p.size1) and (j>=0) and (j<p.size2) then
1503+ begin
1504+ with p do color:=LongintRound(elements^[i*size2+j]);
1505+ if not ((color>=0) and (color<=maxcolor) or PaletteDisabled) then f:=true;
1506+ if not PaletteDisabled then
1507+ color:=MyPalette[color];
1508+ Bitmap1.Canvas.pixels[a,b]:=color;
1509+ end;
1510+
1511+ end;
1512+ end;
1513+ MyGraphSys.setHiddenDrawMode(SvDrawMode);
1514+ end
1515+ else if (CurrentTransform<>nil) and (abs(CurrentTransform.det)>1/1024) and
1516+ ((MyGraphSys is TScreenBMPGraphSys) or
1517+ not (NormalSegment(x1,y1,x1,y2)
1518+ and NormalSegment(x1,y2,x2,y2)
1519+ and NormalSegment(x2,y2,x2,y1)
1520+ and NormalSegment(x2,y1,x1,y1))) then
1521+ begin
1522+ w:=(p.size1-0.0001)/(x2-x1);
1523+ h:=(p.size2-0.0001)/(y2-y1);
1524+
1525+ with MyGraphSys do
1526+ for b:=ClipRect.top to Cliprect.Bottom do
1527+ begin
1528+ yy:=virtualY(b);
1529+ for a:=ClipRect.Left to Cliprect.Right do
1530+ begin
1531+ x:=virtualX(a);
1532+ y:=yy;
1533+ if currenttransform.invtransform(x,y) then
1534+ try
1535+ i:=floor(w*(x-x1)+1e-9 {計算誤差の補償});
1536+ j:=floor(h*(y-y1)+1e-9 {計算誤差の補償});
1537+ if (i>=0) and (i<p.size1) and (j>=0) and (j<p.size2) then
1538+ begin
1539+ with p do color:=LongintRound(elements^[i*size2+j]);
1540+ if not ((color>=0) and (color<=maxcolor) or PaletteDisabled) then f:=true;
1541+ PutColor(a,b,color);
1542+ end;
1543+ except
1544+ end;
1545+ end;
1546+ end;
1547+ end
1548+ else
1549+ begin
1550+ w:=(x2-x1)/p.size1;
1551+ h:=(y2-y1)/p.size2;
1552+ x:=x1;
1553+ y:=y1;
1554+ for i:=0 to p.size1-1 do
1555+ begin
1556+ for j:=0 to p.size2-1 do
1557+ begin
1558+ with p do color:=LongIntRound(elements^[i*size2+j]);
1559+ if not ((color>=0) and (color<=maxcolor) or PaletteDisabled) then f:=true;
1560+ x:=x1+w*i; xx:=x+w;
1561+ y:=y1+h*j; yy:=y+h;
1562+ a1:=x; b1:=y;
1563+ a2:=xx;b2:=y;
1564+ a3:=xx;b3:=yy;
1565+ a4:=x; b4:=yy;
1566+ if GRAPHst or
1567+ currenttransform.transform(a1,b1) and
1568+ currenttransform.transform(a2,b2) and
1569+ currenttransform.transform(a3,b3) and
1570+ currenttransform.transform(a4,b4) then
1571+ begin
1572+ with MyGraphSys do
1573+ begin
1574+ Points[1].x:=DeviceX(a1); Points[1].y:=DeviceY(b1);
1575+ Points[2].x:=DeviceX(a2); Points[2].y:=DeviceY(b2);
1576+ Points[3].x:=DeviceX(a3); Points[3].y:=DeviceY(b3);
1577+ Points[4].x:=DeviceX(a4); Points[4].y:=DeviceY(b4);
1578+ end;
1579+ MyGraphsys.ColorPolygon( Points, color);
1580+ end;
1581+ end;
1582+ end;
1583+ end;
1584+ if insideofwhen and f then setexception(11085)
1585+end;
1586+
1587+procedure MatPlotCells(const p:TArray2N; const x1,y1,x2,y2:double; insideofWhen:boolean);
1588+begin
1589+ MatCells(p,x1,y1,x2,y2,false,insideofWhen);
1590+ MyGraphSys.ThinRepaint;
1591+end;
1592+
1593+procedure MatGraphCells(const p:TArray2N; const x1,y1,x2,y2:double; insideofWhen:boolean);
1594+begin
1595+ MatCells(p,x1,y1,x2,y2,true,insideofWhen);
1596+ MyGraphSys.ThinRepaint;
1597+end;
1598+
1599+{************}
1600+{GET & LOCATE}
1601+{************}
1602+procedure PointAt(x0,y0:Double; LocateSt:boolean);
1603+var
1604+ vx,vy:integer;
1605+begin
1606+ if LocateSt or CurrentTransform.transform(x0,y0) then
1607+ begin
1608+ vx:=MyGraphSys.deviceX(x0);
1609+ vy:=MyGraphSys.deviceY(y0);
1610+ MyGraphSys.MoveMouse(vx,vy);
1611+ end;
1612+end;
1613+
1614+procedure GetPointSub(var x,y:Double; NoBeamOff:boolean; LocateSt:boolean);
1615+var
1616+ vx,vy:integer;
1617+begin
1618+ with MyGraphSys do
1619+ beam:=beam and ((BeamMode=bmImmortal) or NoBeamOff);
1620+ MyGraphSys.getpoint(vx,vy);
1621+ x:=MyGraphSys.virtualX(vx);
1622+ y:=MyGraphSys.virtualY(vy);
1623+ if LOCATEst or currenttransform.invtransform(x,y) then
1624+ begin
1625+ end
1626+ else
1627+ setexception(-3009)
1628+end;
1629+
1630+procedure GetPoint(var x,y:Double; NoBeamOff:boolean; Locatest:boolean);
1631+begin
1632+ GetPointSub(x,y,NoBeamOff,Locatest)
1633+end;
1634+
1635+procedure MousePoll(var x,y,l,r:Double);
1636+var
1637+ vx,vy:integer;
1638+ left,right:boolean;
1639+begin
1640+ MyGraphSys.MousePol(vx,vy,left,right);
1641+ x:=MyGraphSys.virtualX(vx);
1642+ y:=MyGraphSys.virtualY(vy);
1643+ if currenttransform.invtransform(x,y) then
1644+ begin
1645+ l:=byte(left);
1646+ r:=byte(right);
1647+ end
1648+ else
1649+ setexception(-3009)
1650+end;
1651+
1652+
1653+Procedure LocateChoice( var x:Double);
1654+begin
1655+ LocateChoice(8,x)
1656+end;
1657+
1658+Procedure LocateChoice(n:Double; var x:Double);
1659+begin
1660+ if n=1 then n:=8;
1661+ LocateChoice(n,0,x)
1662+end;
1663+
1664+
1665+Procedure LocateChoice(n,i0:Double; var x:Double);
1666+var
1667+ dev0,ini0:integer;
1668+ capts:TStringList;
1669+ i:integer;
1670+begin
1671+ with MyGraphsys do
1672+ if beamMode=bmRigorous then beam:=false;
1673+ dev0:=LongIntRound(n);
1674+ ini0:=LongIntRound(i0);
1675+ if (dev0>255) or (dev0<=0) then
1676+ setexception(11140);
1677+ capts:=TStringList.create;
1678+ try
1679+ for i:=1 to dev0 do
1680+ Capts.Add(inttostr(i));
1681+ x:=LocateChoiceForm.Choice(dev0,ini0,Capts)
1682+ finally
1683+ capts.free
1684+ end;
1685+ with MyGraphsys do
1686+ if beamMode=bmRigorous then beam:=false;
1687+end;
1688+
1689+Procedure LocateChoice(const a:TArray1S; var x:Double);
1690+var
1691+ dev0,ini0:integer;
1692+ capts:TStringList;
1693+ i:integer;
1694+begin
1695+ with MyGraphsys do
1696+ if beamMode=bmRigorous then beam:=false;
1697+ ini0:=0;
1698+ dev0:=a.Size1;
1699+ if (dev0>255) or (dev0<=0) then
1700+ setexception(11140);
1701+ capts:=TStringList.create;
1702+ try
1703+ with a do
1704+ begin
1705+ for i:=0 to size-1 do
1706+ capts.add(elements^[i]);
1707+ end;
1708+ x:=LocateChoiceForm.Choice(dev0,ini0,Capts);
1709+ finally
1710+ capts.free
1711+ end;
1712+ with MyGraphsys do
1713+ if beamMode=bmRigorous then beam:=false;
1714+end;
1715+
1716+procedure LocateValue(n:Double; var x:double; name0:ansistring);overload;
1717+begin
1718+ case LongIntRound(n) of
1719+ 1: x:=LocateForm.Value1(false,false,false,0,1,0.5,name0);
1720+ 2: x:=LocateForm.Value2(false,false,false,0,1,0.5,name0);
1721+ 3: x:=LocateForm.Value3(false,false,false,0,1,0.5,name0);
1722+ 4: x:=LocateForm.Value4(false,false,false,0,1,0.5,name0);
1723+ 5: x:=LocateForm.Value5(false,false,false,0,1,0.5,name0);
1724+ end;
1725+end;
1726+
1727+procedure LocateValue(n:Double; left0,right0:double; var x:double; name0:ansistring);overload;
1728+begin
1729+ case LongIntRound(n) of
1730+ 1: x:=LocateForm.Value1(true,false,false,left0,right0,0.5,name0);
1731+ 2: x:=LocateForm.Value2(true,false,false,left0,right0,0.5,name0);
1732+ 3: x:=LocateForm.Value3(true,false,false,left0,right0,0.5,name0);
1733+ 4: x:=LocateForm.Value4(true,false,false,left0,right0,0.5,name0);
1734+ 5: x:=LocateForm.Value5(true,false,false,left0,right0,0.5,name0);
1735+ end;
1736+end;
1737+
1738+procedure LocateValue(n:Double; left0,right0,ini0:double; var x:double; name0:ansistring);overload;
1739+begin
1740+ case LongIntRound(n) of
1741+ 1: x:=LocateForm.Value1(true,true,false,left0,right0,ini0,name0);
1742+ 2: x:=LocateForm.Value2(true,true,false,left0,right0,ini0,name0);
1743+ 3: x:=LocateForm.Value3(true,true,false,left0,right0,ini0,name0);
1744+ 4: x:=LocateForm.Value4(true,true,false,left0,right0,ini0,name0);
1745+ 5: x:=LocateForm.Value5(true,true,false,left0,right0,ini0,name0);
1746+ end;
1747+end;
1748+
1749+procedure LocateValueNowait(n:Double; var x:double; name0:ansistring);overload;
1750+begin
1751+ case LongIntRound(n) of
1752+ 1: x:=LocateForm.Value1(false,false,true,0,0,0,name0);
1753+ 2: x:=LocateForm.Value2(false,false,true,0,0,0,name0);
1754+ 3: x:=LocateForm.Value3(false,false,true,0,0,0,name0);
1755+ 4: x:=LocateForm.Value4(false,false,true,0,0,0,name0);
1756+ 5: x:=LocateForm.Value5(false,false,true,0,0,0,name0);
1757+ end;
1758+end;
1759+
1760+procedure LocateValueNowait(n:Double; left0,right0:double; var x:double; name0:ansistring);overload;
1761+begin
1762+ case LongIntRound(n) of
1763+ 1: x:=LocateForm.Value1(true,false,true,left0,right0,0,name0);
1764+ 2: x:=LocateForm.Value2(true,false,true,left0,right0,0,name0);
1765+ 3: x:=LocateForm.Value3(true,false,true,left0,right0,0,name0);
1766+ 4: x:=LocateForm.Value4(true,false,true,left0,right0,0,name0);
1767+ 5: x:=LocateForm.Value5(true,false,true,left0,right0,0,name0);
1768+ end;
1769+end;
1770+
1771+procedure LocateValueNowait(n:Double; left0,right0,ini0:double; var x:double; name0:ansistring);overload;
1772+begin
1773+ case LongIntRound(n) of
1774+ 1: x:=LocateForm.Value1(true,true,true,left0,right0,ini0,name0);
1775+ 2: x:=LocateForm.Value2(true,true,true,left0,right0,ini0,name0);
1776+ 3: x:=LocateForm.Value3(true,true,true,left0,right0,ini0,name0);
1777+ 4: x:=LocateForm.Value4(true,true,true,left0,right0,ini0,name0);
1778+ 5: x:=LocateForm.Value5(true,true,true,left0,right0,ini0,name0);
1779+ end;
1780+end;
1781+
1782+procedure LocateValue(n:Double; ini0:double; var x:double; name0:ansistring);overload;
1783+begin
1784+ case LongIntRound(n) of
1785+ 1: x:=LocateForm.Value1(false,true,false,0,0,ini0,name0);
1786+ 2: x:=LocateForm.Value2(false,true,false,0,0,ini0,name0);
1787+ 3: x:=LocateForm.Value3(false,true,false,0,0,ini0,name0);
1788+ 4: x:=LocateForm.Value4(false,true,false,0,0,ini0,name0);
1789+ 5: x:=LocateForm.Value5(false,true,false,0,0,ini0,name0);
1790+ end;
1791+end;
1792+
1793+procedure LocateValueNowait(n:Double; ini0:double; var x:double; name0:ansistring);overload;
1794+begin
1795+ case LongIntRound(n) of
1796+ 1: x:=LocateForm.Value1(false,true,false,0,0,ini0,name0);
1797+ 2: x:=LocateForm.Value2(false,true,false,0,0,ini0,name0);
1798+ 3: x:=LocateForm.Value3(false,true,false,0,0,ini0,name0);
1799+ 4: x:=LocateForm.Value4(false,true,false,0,0,ini0,name0);
1800+ 5: x:=LocateForm.Value5(false,true,false,0,0,ini0,name0);
1801+ end;
1802+end;
1803+
1804+
1805+
1806+
1807+
1808+
1809+
1810+
1811+
1812+
1813+
1814+
1815+
1816+
1817+
1818+
1819+
1820+
1821+
1822+
1823+
1824+procedure MatGetPointVarilen(m:TArray2N; Locatest:boolean); overload;
1825+var
1826+ vx,vy,vx0,vy0:integer;
1827+ maxlen:integer;
1828+ x,y:extended;
1829+ i:integer;
1830+ left,right:boolean;
1831+begin
1832+ MyGraphsys.beam:=false;
1833+ vx0:=low(integer);
1834+ vy0:=low(integer);
1835+
1836+ maxlen:=m.MaxSize div 2;
1837+ m.size2:=2;
1838+
1839+ repeat
1840+ sleep(10);
1841+ MyGraphSys.MousePol(vx,vy,left,right)
1842+ until left=false;
1843+ repeat
1844+ sleep(10);
1845+ MyGraphSys.MousePol(vx,vy,left,right)
1846+ until left=true;
1847+ i:=0;
1848+ while (i<maxlen) and (left=true) do
1849+ begin
1850+ if (vx<>vy0)or(vy<>vy0) then
1851+ begin
1852+ x:=MyGraphsys.virtualX(vx);
1853+ y:=MyGraphsys.VirtualY(vy);
1854+ if Locatest or CurrentTransform.InvTransform(x,y) then
1855+ with m do
1856+ begin
1857+ elements^[i*size2]:=x;
1858+ elements^[i*size2+1]:=y;
1859+ end
1860+ else
1861+ setexception(-3009) ;
1862+ end;
1863+ inc(i);
1864+ sleep(20);
1865+ MyGraphSys.MousePol(vx,vy,left,right)
1866+ end;
1867+ if i=maxlen then beep;
1868+
1869+ m.size1:=i;
1870+end;
1871+
1872+procedure MatGetPointVarilen(m1,m2:TArray1N; Locatest:boolean); overload;
1873+var
1874+ vx,vy,vx0,vy0:integer;
1875+ maxlen:integer;
1876+ x,y:extended;
1877+ i:integer;
1878+ left,right:boolean;
1879+begin
1880+ MyGraphsys.beam:=false;
1881+ vx0:=low(integer);
1882+ vy0:=low(integer);
1883+
1884+ maxlen:=min(m1.MaxSize,m2.MaxSize);
1885+
1886+ repeat
1887+ sleep(10);
1888+ MyGraphSys.MousePol(vx,vy,left,right)
1889+ until left=false;
1890+ repeat
1891+ sleep(10);
1892+ MyGraphSys.MousePol(vx,vy,left,right)
1893+ until left=true;
1894+
1895+ i:=0;
1896+ while (i<maxlen) and (left=true) do
1897+ begin
1898+ if (vx<>vy0)or(vy<>vy0) then
1899+ begin
1900+ x:=MyGraphsys.virtualX(vx);
1901+ y:=MyGraphsys.VirtualY(vy);
1902+ if Locatest or CurrentTransform.InvTransform(x,y) then
1903+ begin
1904+ m1.elements^[i]:=x;
1905+ m2.elements^[i]:=y;
1906+ end
1907+ else
1908+ setexception(-3009) ;
1909+ end;
1910+ inc(i);
1911+ sleep(20);
1912+ MyGraphSys.MousePol(vx,vy,left,right)
1913+ end;
1914+ if i=maxlen then beep;
1915+
1916+ m1.size1:=i;
1917+ m2.size1:=i;
1918+end;
1919+
1920+procedure MatGetPoint(m1,m2:TArray1N; Locatest:boolean); overload;
1921+var
1922+ vx,vy,vx0,vy0:integer;
1923+ maxlen:integer;
1924+ x,y:extended;
1925+ i:integer;
1926+ left,right:boolean;
1927+
1928+begin
1929+ maxlen:=m1.size1;
1930+ if maxlen<>m2.size1 then setexception(6401);
1931+
1932+ MyGraphsys.beam:=false;
1933+
1934+ for i:=0 to maxlen-1 do
1935+ begin
1936+ MyGraphsys.getpoint(vx,vy);
1937+ x:=MyGraphsys.virtualX(vx);
1938+ y:=MyGraphsys.VirtualY(vy);
1939+ if Locatest or CurrentTransform.InvTransform(x,y) then
1940+ begin
1941+ m1.elements^[i]:=x;
1942+ m2.elements^[i]:=y;
1943+ end
1944+ else
1945+ setexception(-3009) ;
1946+ end;
1947+end;
1948+
1949+procedure MatGetPoint(m:TArray2N; Locatest:boolean);overload;
1950+var
1951+ vx,vy,vx0,vy0:integer;
1952+ maxlen:integer;
1953+ x,y:extended;
1954+ i:integer;
1955+ left,right:boolean;
1956+begin
1957+ if m.size2<2 then
1958+ setexception(6401);
1959+ maxlen:=m.size1;
1960+
1961+ MyGraphsys.beam:=false;
1962+
1963+ for i:=0 to maxlen-1 do
1964+ begin
1965+ MyGraphsys.getpoint(vx,vy);
1966+ x:=MyGraphsys.virtualX(vx);
1967+ y:=MyGraphsys.VirtualY(vy);
1968+ if Locatest or CurrentTransform.InvTransform(x,y) then
1969+ with m do
1970+ begin
1971+ elements^[i*size2]:=x;
1972+ elements^[i*size2+1]:=y;
1973+ end
1974+ else
1975+ setexception(-3009) ;
1976+ end;
1977+end;
1978+
1979+{**************}
1980+{ASK Statements}
1981+{**************}
1982+function ASkWindow(var x1,x2,y1,y2:double):integer;
1983+begin
1984+ result:=0;
1985+ with MyGraphsys do
1986+ begin
1987+ x1:=left;
1988+ x2:=right;
1989+ y1:=bottom;
1990+ y2:=top;
1991+ end;
1992+end;
1993+
1994+function ASkViewport(var x1,x2,y1,y2:double):integer;
1995+begin
1996+ result:=0;
1997+ with MyGraphsys do
1998+ begin
1999+ x1:=VPleft;
2000+ x2:=VPright;
2001+ y1:=VPbottom;
2002+ y2:=VPtop;
2003+ end;
2004+end;
2005+
2006+function ASkDeviceWindow(var x1,x2,y1,y2:double):integer;
2007+begin
2008+ result:=0;
2009+ with MyGraphsys do
2010+ begin
2011+ x1:=DWleft;
2012+ x2:=DWright;
2013+ y1:=DWbottom;
2014+ y2:=DWtop;
2015+ end;
2016+end;
2017+
2018+function ASkDeviceViewport(var x1,x2,y1,y2:double):integer;
2019+var
2020+ l,r,b,t:extended;
2021+begin
2022+ result:=0;
2023+ MyGraphSys.AskDeviceViewPort(l,r,b,t);
2024+ x1:=l;
2025+ x2:=r;
2026+ y1:=b;
2027+ y2:=t;
2028+end;
2029+
2030+
2031+function AskPixelSize( var var1,var2:double):integer;overload;
2032+begin
2033+ result:=0;
2034+ var1:=MyGraphSys.GWidth;
2035+ var2:=MyGraphSys.GHeight
2036+end;
2037+
2038+
2039+function AskPixelSize(n1,n2,n3,n4:double; var var1,var2:double):integer;overload;
2040+
2041+ function Floor(x:extended):extended; assembler;
2042+ asm
2043+ FLD x
2044+ FLDCW RoundNins
2045+ FRNDINT
2046+ FLDCW RoundMost
2047+ end;
2048+ function Ceil(x:extended):extended; assembler;
2049+ asm
2050+ FLD x
2051+ FLDCW RoundPlus
2052+ FRNDINT
2053+ FLDCW RoundMost
2054+ end;
2055+const eps=1e-15;
2056+var
2057+ t:extended;
2058+ x1,x2,y1,y2:extended;
2059+begin
2060+ result:=0;
2061+ (*
2062+ if n1>n3 then begin t:=n3; n3:=n1; n1:=t end;
2063+ if n2<n4 then begin t:=n4; n4:=n2; n2:=t end;
2064+ *)
2065+ with MyGraphSys do
2066+ if (n1-n3)*(right-left)>0 then begin t:=n3; n3:=n1; n1:=t end; //2011.11.6
2067+ with MyGraphSys do
2068+ if (n2-n4)*(top-bottom)<0 then begin t:=n4; n4:=n2; n2:=t end; //2011.11.6
2069+
2070+ x1:=ceil(MyGraphSys.DeviceX(n1)-eps);
2071+ x2:=floor(MyGraphSys.DeviceX(n3)+eps);
2072+ y1:=ceil(MyGraphSys.DeviceY(n2)-eps);
2073+ y2:=floor(MyGraphSys.DeviceY(n4)+eps);
2074+ var1:=x2-x1+1;
2075+ var2:=y2-y1+1;
2076+ (*
2077+ if MyGraphSys is TScreenGraphSys then
2078+ begin
2079+ x1:=ceil((n1-left)*TScreenGraphSys(MyGraphSys).HMulti-eps);
2080+ x2:=floor((n3-left)*TScreenGraphSys(MyGraphSys).HMulti+eps);
2081+ y1:=ceil((top-n2)*TScreenGraphSys(MyGraphSys).VMulti-eps);
2082+ y2:=floor((top-n4)*TScreenGraphSys(MyGraphSys).VMulti+eps);
2083+ var1.assignX(x2-x1+1);
2084+ var2.assignX(y2-y1+1)
2085+ end
2086+ else
2087+ begin
2088+ var1.assignX(0);
2089+ var2.assignX(0)
2090+ end
2091+ *)
2092+end;
2093+
2094+function AskPixelSize( var var1,var2:integer):integer;overload;
2095+var
2096+ x1,x2:double;
2097+begin
2098+ result:=AskPixelsize(x1,x2);
2099+ var1:=System.Round(x1);
2100+ var2:=System.Round(x2);
2101+end;
2102+
2103+function AskPixelSize(n1,n2,n3,n4:double; var var1,var2:integer):integer;overload;
2104+var
2105+ x1,x2:double;
2106+begin
2107+ result:=AskPixelsize(n1,n2,n3,n4,x1,x2);
2108+ var1:=System.Round(x1);
2109+ var2:=System.Round(x2);
2110+end;
2111+
2112+
2113+function AskPixelValue(x,y:double; var var1:double):integer;
2114+begin
2115+ result:=0;
2116+ var1:=MyGraphSys.ColorIndexOf(MyGraphSys.DeviceX(x),MyGraphSys.DeviceY(y))
2117+end;
2118+
2119+function AskPixelArraySub(x,y:double; a:Tarray2N):boolean;
2120+var
2121+ x1,y1:longint;
2122+ i,j:longint;
2123+ c:integer;
2124+begin
2125+ x1:=MyGraphSys.DeviceX(x);
2126+ y1:=MyGraphSys.DeviceY(y);
2127+ result:=true;
2128+ if a<>nil then
2129+ begin
2130+ for i:=0 to a.size1-1 do
2131+ for j:=0 to a.size2-1 do
2132+ begin
2133+ c:=MyGraphSys.ColorIndexOf(x1+i,y1+j);
2134+ with a do elements^[i*size2+j]:=c;
2135+ if c=-1 then result:=false;
2136+ end;
2137+ end;
2138+
2139+end;
2140+
2141+function AskPixelArray(x,y:double; a:Tarray2N):integer; overload;
2142+begin
2143+ result:=0;
2144+ AskPixelArraySub(x,y,a)
2145+end;
2146+
2147+function AskPixelArray(x,y:double; a:Tarray2N; s:TStrVar):integer; overload;
2148+begin
2149+ result:=0;
2150+ if AskPixelArraySub(x,y,a) then
2151+ s.str:= 'ABSENT'
2152+ else
2153+ s.str:='PRESENT';
2154+ s.free
2155+end;
2156+
2157+function getlinecolor(var x:double):integer;
2158+begin
2159+ result:=0;
2160+ x:=MyGraphSys.linecolor;
2161+end;
2162+
2163+function getlinestyle(var x:double):integer;
2164+begin
2165+ result:=0;
2166+ x:=Integer(MyGraphSys.PenStyle) + 1;
2167+end;
2168+
2169+function getlinewidth(var x:double):integer;
2170+begin
2171+ result:=0;
2172+ x:=MyGraphSys.linewidth;
2173+end;
2174+
2175+function getpointcolor(var x:double):integer;
2176+begin
2177+ result:=0;
2178+ x:=MyGraphSys.pointcolor;
2179+end;
2180+
2181+function getpointstyle(var x:double):integer;
2182+begin
2183+ result:=0;
2184+ x:=MyGraphSys.pointstyle;
2185+end;
2186+
2187+function getareacolor(var x:double):integer;
2188+begin
2189+ result:=0;
2190+ x:=MyGraphSys.areacolor;
2191+end;
2192+
2193+function gettextcolor(var x:double):integer;
2194+begin
2195+ result:=0;
2196+ x:=MyGraphSys.textcolor;
2197+end;
2198+
2199+function getmaxcolor(var x:double):integer;
2200+begin
2201+ result:=0;
2202+ if mypalette.PaletteDisabled then
2203+ x:=$ffffff
2204+ else
2205+ x:=GraphSys.maxcolor;
2206+end;
2207+
2208+function getaxiscolor(var x:double):integer;
2209+begin
2210+ result:=0;
2211+ x:=GraphSys.axescolor;
2212+end;
2213+
2214+function getMaxPointDevice(var x:double):integer;
2215+begin
2216+ result:=0;
2217+ x:=1
2218+end;
2219+
2220+function getMaxMultiPointDevice(var x:double):integer;
2221+begin
2222+ result:=0;
2223+ x:=1
2224+end;
2225+
2226+function getMaxChoiceDevice(var x:double):integer;
2227+begin
2228+ result:=0;
2229+ x:=1
2230+end;
2231+
2232+function getMaxValueDevice(var x:double):integer;
2233+begin
2234+ result:=0;
2235+ x:=1
2236+end;
2237+
2238+function getAreaStyleIndex(var x:double):integer;
2239+begin
2240+ result:=0;
2241+ x:=MyGraphSys.AreaStyleIndex;
2242+end;
2243+
2244+function getmaxlinestyle(var x:double):integer;
2245+begin
2246+ result:=0;
2247+ x:=MaxLineStyle
2248+end;
2249+
2250+function getmaxpointstyle(var x:double):integer;
2251+begin
2252+ result:=0;
2253+ x:=MaxPointStyle
2254+end;
2255+
2256+function ASkTextHeight(var x:double):integer;
2257+begin
2258+ result:=0;
2259+ x:=MyGraphSys.gettextheight;
2260+end;
2261+
2262+function AskTextAngle(var x:double):integer;
2263+begin
2264+ result:=0;
2265+ x:=MyGraphSys.TextAngle;
2266+end;
2267+
2268+function AskTextAngleRad(var x:double):integer;
2269+begin
2270+ result:=0;
2271+ x:=MyGraphSys.TextAngle/180.0*PI;
2272+end;
2273+
2274+
2275+function AskDeviceSize(var x,y:double; t:TStrVar):integer;
2276+var
2277+ w,h:extended;
2278+ s:string;
2279+begin
2280+ result:=0;
2281+ MyGraphSys.AskDeviceSize(w,h,s);
2282+ x:=w;
2283+ y:=h;
2284+ t.str:=s;
2285+ t.free;
2286+end;
2287+
2288+function AskBitmapSize(var x,y:double):integer;
2289+begin
2290+ result:=0;
2291+ x:=MyGraphSys.GWidth;
2292+ y:=MyGraphSys.GHeight;
2293+end;
2294+
2295+function AskTextJustify(h,v:TStrVar):integer;
2296+begin
2297+ result:=0;
2298+ with MyGraphSys do
2299+ begin
2300+ h.str:=HJustification[HJustify];
2301+ v.str:=VJustification[VJustify];
2302+ h.free;
2303+ v.free;
2304+ end;
2305+end;
2306+
2307+function AskTextWidth(const s:string; var width:double):integer;
2308+begin
2309+ result:=0;
2310+ with MyGraphSys do
2311+ width:=VirtualX(textwidth(s))-VirtualX(0);
2312+end;
2313+
2314+procedure AskColorMixSub(cc:integer;var r,g,b:byte);
2315+var
2316+ col:TColor;
2317+begin
2318+ col:=MyPalette[cc];
2319+ b:=(col and $ff0000) div $10000;
2320+ g:=(col and $00ff00) div $100;
2321+ r:=col and $0000ff;
2322+end;
2323+
2324+function AskColorMix(ColorIndex:double; var red,green,blue:double):integer;
2325+var
2326+ cc:longint;
2327+ r,g,b:byte;
2328+begin
2329+ result:=0;
2330+ cc:=LongIntRound(ColorIndex);
2331+ if (cc<0) or (cc>maxcolor) and not MyPalette.paletteDisabled then
2332+ begin
2333+ red:=0;
2334+ green:=0;
2335+ blue:=0;
2336+ result:=11086;
2337+ end
2338+ else
2339+ begin
2340+ askColorMixSub(cc,r,g,b);
2341+ red:=r/255;
2342+ green:=g/255;
2343+ blue:=b/255;
2344+ end;
2345+end;
2346+
2347+function AskClip(svar:TStrvar):integer;
2348+var
2349+ s:string;
2350+begin
2351+ result:=0;
2352+ if MyGraphSys.clip then s:='ON' else s:='OFF';
2353+ svar.str:=s;
2354+ svar.free;
2355+end;
2356+
2357+function AskAreaStyle(svar:TStrvar):integer;
2358+var
2359+ s:string;
2360+begin
2361+ result:=0;
2362+ case MyGraphSys.AreaStyle of
2363+ asSolid: s:='SOLID';
2364+ asHollow:s:='HOLLOW';
2365+ asHATCH: s:='HATCH';
2366+ end;
2367+ svar.str:=s;
2368+ svar.free;
2369+end;
2370+
2371+function AskColorMode(svar:TStrvar):integer;
2372+begin
2373+ result:=0;
2374+ svar.str:=MyGraphSys.AskColorMode;
2375+ svar.free;
2376+end;
2377+
2378+function AskBeamMode(svar:TStrvar):integer;
2379+begin
2380+ result:=0;
2381+ svar.str:=MyGraphSys.AskBeamMode;
2382+ svar.free;
2383+end;
2384+
2385+
2386+procedure FLOOD( x,y:double);
2387+var
2388+ a,b:longint;
2389+begin
2390+ if currenttransform.transform(x,y) then
2391+ begin
2392+ a:=MyGraphSys.deviceX(x);
2393+ b:=MyGraphSys.deviceY(y);
2394+ MyGraphSys.FLOOD(a,b);
2395+ end;
2396+end;
2397+
2398+procedure FLOODFill( x,y:double);
2399+var
2400+ a,b:longint;
2401+begin
2402+ if currenttransform.transform(x,y) then
2403+ begin
2404+ a:=MyGraphSys.deviceX(x);
2405+ b:=MyGraphSys.deviceY(y);
2406+ MyGraphSys.FLOODFill(a,b);
2407+ end;
2408+end;
2409+
2410+
2411+{***********}
2412+{Grid & Axes}
2413+{***********}
2414+
2415+function drawaxes0(x,y:double):boolean;
2416+begin
2417+ result:=gridaxes.drawaxes0(x,y);
2418+end;
2419+
2420+function drawgrid0(x,y:double):boolean;
2421+begin
2422+ result:=gridaxes.drawgrid0(x,y);
2423+end;
2424+
2425+function drawaxes2(x,y:double):boolean;
2426+begin
2427+ result:=gridaxes.drawaxes2(x,y);
2428+end;
2429+
2430+function drawgrid2(x,y:double):boolean;
2431+begin
2432+ result:=gridaxes.drawgrid2(x,y);
2433+end;
2434+
2435+function drawcircle(x,y:double):boolean;
2436+begin
2437+ result:=gridaxes.drawcircle(x,y);
2438+end;
2439+
2440+function drawdisk(x,y:double):boolean;
2441+begin
2442+ result:=gridaxes.drawdisk(x,y);
2443+end;
2444+
2445+{*****}
2446+{GSAVE}
2447+{*****}
2448+Procedure GSAVE(const fname,pf:string);
2449+var
2450+ ext:string;
2451+ n,i:integer;
2452+begin
2453+ ext:=UpperCase( ExtractFileExt(fname));
2454+ try
2455+ if (ext='.BMP') then
2456+ begin
2457+ if lowercase(pf)='4bit' then
2458+ MyGraphSys.SaveFileFormat(fname,pf4bit)
2459+ else if lowercase(pf)='1bit' then
2460+ MyGraphSys.SaveFileFormat(fname,pf1bit)
2461+ else
2462+ MyGraphSys.SaveBMPFile(fname)
2463+ end
2464+ else if (ext='.JPG') or (ext='.JPEG') or (ext='.JPE') then
2465+ begin
2466+ n:=0;
2467+ i:=POS('%',pf);
2468+ if i>0 then
2469+ {$R-}
2470+ SYSTEM.VAL(copy(pf,1,i-1),n,i);
2471+ {$R+}
2472+ if (n<0) or (n>100) then n:=0;
2473+ MyGraphSys.SaveJpegFile(fname,n) ;
2474+ end
2475+ else if ext='.GIF' then
2476+ MyGraphSys.SaveGIFFile(fname)
2477+ else if ext='.EMF' then
2478+ MyGraphSys.SaveEMFFile(fname)
2479+ else
2480+ setexception(9052)
2481+ except
2482+ setexception(9052)
2483+ end;
2484+end;
2485+
2486+
2487+end.
Show on old repository browser