← Back to branch summary

~ubuntu-branches/ubuntu/lucid/fpc/lucid-proposed

« back to all changes in this revision

Viewing changes to fpcsrc/packages/base/graph/inc/graph.inc

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-10-09 23:29:00 UTC
  • mfrom: (4.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20081009232900-553f61m37jkp6upv
Tags: 2.2.2-4
http://bugs.debian.org/498882
[ Torsten Werner ]
* Update ABI version in fpc-depends automatically.
* Remove empty directories from binary package fpc-source.

[ Mazen Neifer ]
* Removed leading path when calling update-alternatives to remove a Linitian
  error.
* Fixed clean target.
* Improved description of packages. (Closes: #498882)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/base/graph/inc/graph.inc
1
 
{
2
 
    This file is part of the Free Pascal run time library.
3
 
    Copyright (c) 1999-2000 by the Free Pascal development team
4
 
 
5
 
    Graph unit implementation part
6
 
 
7
 
    See the file COPYING.FPC, included in this distribution,
8
 
    for details about the copyright.
9
 
 
10
 
    This program is distributed in the hope that it will be useful,
11
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
12
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
 
 
14
 
 **********************************************************************}
15
 
 
16
 
var
17
 
  ExitSave: pointer;
18
 
 
19
 
const
20
 
  firstCallOfInitGraph: boolean = true;
21
 
 
22
 
 
23
 
{$ifdef logging}
24
 
var debuglog: text;
25
 
 
26
 
function strf(l: longint): string;
27
 
begin
28
 
  str(l, strf)
29
 
end;
30
 
 
31
 
Procedure Log(Const s: String);
32
 
Begin
33
 
  Append(debuglog);
34
 
  Write(debuglog, s);
35
 
  Close(debuglog);
36
 
End;
37
 
 
38
 
Procedure LogLn(Const s: string);
39
 
Begin
40
 
  Append(debuglog);
41
 
  Writeln(debuglog,s);
42
 
  Close(debuglog);
43
 
End;
44
 
{$endif logging}
45
 
 
46
 
const
47
 
   StdBufferSize = 4096;   { Buffer size for FloodFill }
48
 
 
49
 
type
50
 
  tinttable = array[0..16383] of smallint;
51
 
  pinttable = ^tinttable;
52
 
 
53
 
  WordArray = Array [0..StdbufferSize] Of word;
54
 
  PWordArray = ^WordArray;
55
 
 
56
 
 
57
 
const
58
 
   { Mask for each bit in byte used to determine pattern }
59
 
   BitArray: Array[0..7] of byte =
60
 
     ($01,$02,$04,$08,$10,$20,$40,$80);
61
 
   RevbitArray: Array[0..7] of byte =
62
 
     ($80,$40,$20,$10,$08,$04,$02,$01);
63
 
 
64
 
    { pre expanded line patterns }
65
 
    { 0 = LSB of byte pattern    }
66
 
    { 15 = MSB of byte pattern   }
67
 
    LinePatterns: Array[0..15] of BOOLEAN =
68
 
     (TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,
69
 
      TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE);
70
 
 
71
 
const
72
 
  BGIPath : string = '.';
73
 
 
74
 
 
75
 
  { Default font 8x8 system from IBM PC }
76
 
  {$i fontdata.inc}
77
 
 
78
 
 
79
 
 
80
 
var
81
 
  CurrentColor:     Word;
82
 
  CurrentBkColor: Word;
83
 
  CurrentX : smallint;   { viewport relative }
84
 
  CurrentY : smallint;   { viewport relative }
85
 
 
86
 
  ClipPixels: Boolean;  { Should cliiping be enabled }
87
 
 
88
 
 
89
 
  CurrentWriteMode: smallint;
90
 
 
91
 
 
92
 
  _GraphResult : smallint;
93
 
 
94
 
 
95
 
  LineInfo : LineSettingsType;
96
 
  FillSettings: FillSettingsType;
97
 
 
98
 
  { information for Text Output routines }
99
 
  CurrentTextInfo : TextSettingsType;
100
 
  CurrentXRatio, CurrentYRatio: graph_float;
101
 
  installedfonts: longint;  { Number of installed fonts }
102
 
 
103
 
 
104
 
  StartXViewPort: smallint; { absolute }
105
 
  StartYViewPort: smallint; { absolute }
106
 
  ViewWidth : smallint;
107
 
  ViewHeight: smallint;
108
 
 
109
 
 
110
 
  IsGraphMode : Boolean; { Indicates if we are in graph mode or not }
111
 
 
112
 
 
113
 
  ArcCall: ArcCoordsType;   { Information on the last call to Arc or Ellipse }
114
 
 
115
 
 
116
 
var
117
 
 
118
 
  { ******************** HARDWARE INFORMATION ********************* }
119
 
  { Should be set in InitGraph once only.                           }
120
 
  IntCurrentMode : smallint;
121
 
  IntCurrentDriver : smallint;       { Currently loaded driver          }
122
 
  IntCurrentNewDriver: smallint;
123
 
  XAspect : word;
124
 
  YAspect : word;
125
 
  MaxX : smallint;       { Maximum resolution - ABSOLUTE }
126
 
  MaxY : smallint;       { Maximum resolution - ABSOLUTE }
127
 
  MaxColor : Longint;
128
 
  PaletteSize : longint; { Maximum palette entry we can set, usually equal}
129
 
                         { maxcolor.                                      }
130
 
  HardwarePages : byte;  { maximum number of hardware visual pages        }
131
 
  DriverName: String;
132
 
  DirectColor : Boolean ; { Is it a direct color mode? }
133
 
  ModeList : PModeInfo;
134
 
  newModeList: TNewModeInfo;
135
 
  DirectVideo : Boolean;  { Direct access to video memory? }
136
 
 
137
 
 
138
 
 
139
 
 
140
 
{--------------------------------------------------------------------------}
141
 
{                                                                          }
142
 
{                    LINE AND LINE RELATED ROUTINES                        }
143
 
{                                                                          }
144
 
{--------------------------------------------------------------------------}
145
 
 
146
 
  {$i clip.inc}
147
 
 
148
 
  procedure HLineDefault(x,x2,y: smallint); {$ifndef fpc}far;{$endif fpc}
149
 
 
150
 
   var
151
 
    xtmp: smallint;
152
 
   Begin
153
 
 
154
 
    { must we swap the values? }
155
 
    if x >= x2 then
156
 
      Begin
157
 
        xtmp := x2;
158
 
        x2 := x;
159
 
        x:= xtmp;
160
 
      end;
161
 
    { First convert to global coordinates }
162
 
    X   := X + StartXViewPort;
163
 
    X2  := X2 + StartXViewPort;
164
 
    Y   := Y + StartYViewPort;
165
 
    if ClipPixels then
166
 
      Begin
167
 
         if LineClipped(x,y,x2,y,StartXViewPort,StartYViewPort,
168
 
                StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
169
 
            exit;
170
 
      end;
171
 
    for x:= x to x2 do
172
 
      DirectPutPixel(X,Y);
173
 
   end;
174
 
 
175
 
 
176
 
  procedure VLineDefault(x,y,y2: smallint); {$ifndef fpc}far;{$endif fpc}
177
 
 
178
 
   var
179
 
    ytmp: smallint;
180
 
  Begin
181
 
    { must we swap the values? }
182
 
    if y >= y2 then
183
 
     Begin
184
 
       ytmp := y2;
185
 
       y2 := y;
186
 
       y:= ytmp;
187
 
     end;
188
 
    { First convert to global coordinates }
189
 
    X   := X + StartXViewPort;
190
 
    Y2  := Y2 + StartYViewPort;
191
 
    Y   := Y + StartYViewPort;
192
 
    if ClipPixels then
193
 
      Begin
194
 
         if LineClipped(x,y,x,y2,StartXViewPort,StartYViewPort,
195
 
                StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
196
 
            exit;
197
 
      end;
198
 
    for y := y to y2 do Directputpixel(x,y)
199
 
  End;
200
 
 
201
 
  Procedure DirectPutPixelClip(x,y: smallint);
202
 
  { for thickwidth lines, because they may call DirectPutPixel for coords }
203
 
  { outside the current viewport (bug found by CEC)                       }
204
 
  Begin
205
 
    If (Not ClipPixels) Or
206
 
       ((X >= StartXViewPort) And (X <= (StartXViewPort + ViewWidth)) And
207
 
        (Y >= StartYViewPort) And (Y <= (StartYViewPort + ViewHeight))) then
208
 
      Begin
209
 
        DirectPutPixel(x,y)
210
 
      End
211
 
  End;
212
 
 
213
 
  procedure LineDefault(X1, Y1, X2, Y2: smallint); {$ifndef fpc}far;{$endif fpc}
214
 
 
215
 
  var X, Y :           smallint;
216
 
      deltax, deltay : smallint;
217
 
      d, dinc1, dinc2: smallint;
218
 
      xinc1          : smallint;
219
 
      xinc2          : smallint;
220
 
      yinc1          : smallint;
221
 
      yinc2          : smallint;
222
 
      i              : smallint;
223
 
      Flag           : Boolean; { determines pixel direction in thick lines }
224
 
      NumPixels      : smallint;
225
 
      PixelCount     : smallint;
226
 
      OldCurrentColor: Word;
227
 
      swtmp          : smallint;
228
 
      TmpNumPixels   : smallint;
229
 
 begin
230
 
{******************************************}
231
 
{  SOLID LINES                             }
232
 
{******************************************}
233
 
  if lineinfo.LineStyle = SolidLn then
234
 
    Begin
235
 
       { we separate normal and thick width for speed }
236
 
       { and because it would not be 100% compatible  }
237
 
       { with the TP graph unit otherwise             }
238
 
       if y1 = y2 then
239
 
        Begin
240
 
     {******************************************}
241
 
     {  SOLID LINES HORIZONTAL                  }
242
 
     {******************************************}
243
 
          if lineinfo.Thickness=NormWidth then
244
 
            hline(x1,x2,y2)
245
 
          else
246
 
            begin
247
 
               { thick width }
248
 
               hline(x1,x2,y2-1);
249
 
               hline(x1,x2,y2);
250
 
               hline(x2,x2,y2+1);
251
 
            end;
252
 
        end
253
 
    else
254
 
    if x1 = x2 then
255
 
        Begin
256
 
     {******************************************}
257
 
     {  SOLID LINES VERTICAL                    }
258
 
     {******************************************}
259
 
          if lineinfo.Thickness=NormWidth then
260
 
            vline(x1,y1,y2)
261
 
          else
262
 
            begin
263
 
            { thick width }
264
 
              vline(x1-1,y1,y2);
265
 
              vline(x1,y1,y2);
266
 
              vline(x1+1,y1,y2);
267
 
            end;
268
 
        end
269
 
    else
270
 
    begin
271
 
     { Convert to global coordinates. }
272
 
     x1 := x1 + StartXViewPort;
273
 
     x2 := x2 + StartXViewPort;
274
 
     y1 := y1 + StartYViewPort;
275
 
     y2 := y2 + StartYViewPort;
276
 
     { if fully clipped then exit... }
277
 
     if ClipPixels then
278
 
       begin
279
 
       if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort,
280
 
           StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
281
 
              exit;
282
 
       end;
283
 
     {******************************************}
284
 
     {  SLOPED SOLID LINES                      }
285
 
     {******************************************}
286
 
           oldCurrentColor :=
287
 
           CurrentColor;
288
 
           { Calculate deltax and deltay for initialisation }
289
 
           deltax := abs(x2 - x1);
290
 
           deltay := abs(y2 - y1);
291
 
 
292
 
          { Initialize all vars based on which is the independent variable }
293
 
          if deltax >= deltay then
294
 
            begin
295
 
 
296
 
             Flag := FALSE;
297
 
             { x is independent variable }
298
 
             numpixels := deltax + 1;
299
 
             d := (2 * deltay) - deltax;
300
 
             dinc1 := deltay Shl 1;
301
 
             dinc2 := (deltay - deltax) shl 1;
302
 
             xinc1 := 1;
303
 
             xinc2 := 1;
304
 
             yinc1 := 0;
305
 
             yinc2 := 1;
306
 
            end
307
 
          else
308
 
            begin
309
 
 
310
 
             Flag := TRUE;
311
 
             { y is independent variable }
312
 
             numpixels := deltay + 1;
313
 
             d := (2 * deltax) - deltay;
314
 
             dinc1 := deltax Shl 1;
315
 
             dinc2 := (deltax - deltay) shl 1;
316
 
             xinc1 := 0;
317
 
             xinc2 := 1;
318
 
             yinc1 := 1;
319
 
             yinc2 := 1;
320
 
            end;
321
 
 
322
 
         { Make sure x and y move in the right directions }
323
 
         if x1 > x2 then
324
 
           begin
325
 
            xinc1 := - xinc1;
326
 
            xinc2 := - xinc2;
327
 
           end;
328
 
         if y1 > y2 then
329
 
          begin
330
 
           yinc1 := - yinc1;
331
 
           yinc2 := - yinc2;
332
 
          end;
333
 
 
334
 
         { Start drawing at <x1, y1> }
335
 
         x := x1;
336
 
         y := y1;
337
 
 
338
 
 
339
 
         If LineInfo.Thickness=NormWidth then
340
 
 
341
 
          Begin
342
 
 
343
 
            { Draw the pixels }
344
 
            for i := 1 to numpixels do
345
 
              begin
346
 
                DirectPutPixel(x, y);
347
 
                if d < 0 then
348
 
                  begin
349
 
                   d := d + dinc1;
350
 
                   x := x + xinc1;
351
 
                   y := y + yinc1;
352
 
                  end
353
 
                else
354
 
                  begin
355
 
                   d := d + dinc2;
356
 
                   x := x + xinc2;
357
 
                   y := y + yinc2;
358
 
                  end;
359
 
                  CurrentColor := OldCurrentColor;
360
 
             end;
361
 
          end
362
 
        else
363
 
         { Thick width lines }
364
 
          begin
365
 
            { Draw the pixels }
366
 
             for i := 1 to numpixels do
367
 
               begin
368
 
                { all depending on the slope, we can determine         }
369
 
                { in what direction the extra width pixels will be put }
370
 
                If Flag then
371
 
                  Begin
372
 
                    DirectPutPixelClip(x-1,y);
373
 
                    DirectPutPixelClip(x,y);
374
 
                    DirectPutPixelClip(x+1,y);
375
 
                  end
376
 
                else
377
 
                  Begin
378
 
                    DirectPutPixelClip(x, y-1);
379
 
                    DirectPutPixelClip(x, y);
380
 
                    DirectPutPixelClip(x, y+1);
381
 
                  end;
382
 
                if d < 0 then
383
 
                  begin
384
 
                    d := d + dinc1;
385
 
                    x := x + xinc1;
386
 
                    y := y + yinc1;
387
 
                  end
388
 
                else
389
 
                  begin
390
 
                    d := d + dinc2;
391
 
                    x := x + xinc2;
392
 
                    y := y + yinc2;
393
 
                  end;
394
 
                CurrentColor := OldCurrentColor;
395
 
               end;
396
 
          end;
397
 
        end;
398
 
  end
399
 
   else
400
 
{******************************************}
401
 
{  begin patterned lines                   }
402
 
{******************************************}
403
 
    Begin
404
 
      { Convert to global coordinates. }
405
 
      x1 := x1 + StartXViewPort;
406
 
      x2 := x2 + StartXViewPort;
407
 
      y1 := y1 + StartYViewPort;
408
 
      y2 := y2 + StartYViewPort;
409
 
      { if fully clipped then exit... }
410
 
      if ClipPixels then
411
 
       begin
412
 
       if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort,
413
 
           StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
414
 
              exit;
415
 
       end;
416
 
 
417
 
      OldCurrentColor := CurrentColor;
418
 
      PixelCount:=0;
419
 
      if y1 = y2 then
420
 
            Begin
421
 
             { Check if we must swap }
422
 
         if x1 >= x2 then
423
 
               Begin
424
 
                 swtmp := x1;
425
 
                 x1 := x2;
426
 
                 x2 := swtmp;
427
 
               end;
428
 
         if LineInfo.Thickness = NormWidth then
429
 
              Begin
430
 
               for PixelCount:=x1 to x2 do
431
 
                     { optimization: PixelCount mod 16 }
432
 
                     if LinePatterns[PixelCount and 15] = TRUE then
433
 
                      begin
434
 
                        DirectPutPixel(PixelCount,y2);
435
 
                      end;
436
 
              end
437
 
             else
438
 
              Begin
439
 
               for i:=-1 to 1 do
440
 
                     Begin
441
 
                       for PixelCount:=x1 to x2 do
442
 
                         { Optimization from Thomas - mod 16 = and 15 }
443
 
                         {this optimization has been performed by the compiler
444
 
                          for while as well (JM)}
445
 
                         if LinePatterns[PixelCount and 15] = TRUE then
446
 
                           begin
447
 
                                 DirectPutPixelClip(PixelCount,y2+i);
448
 
                           end;
449
 
                     end;
450
 
              end;
451
 
        end
452
 
      else
453
 
      if x1 = x2 then
454
 
           Begin
455
 
            { Check if we must swap }
456
 
            if y1 >= y2 then
457
 
              Begin
458
 
                swtmp := y1;
459
 
                y1 := y2;
460
 
                y2 := swtmp;
461
 
              end;
462
 
            if LineInfo.Thickness = NormWidth then
463
 
              Begin
464
 
                for PixelCount:=y1 to y2 do
465
 
                    { compare if we should plot a pixel here , compare }
466
 
                    { with predefined line patterns...                 }
467
 
                    if LinePatterns[PixelCount and 15] = TRUE then
468
 
                      begin
469
 
                    DirectPutPixel(x1,PixelCount);
470
 
                      end;
471
 
              end
472
 
            else
473
 
              Begin
474
 
                for i:=-1 to 1 do
475
 
                     Begin
476
 
                       for PixelCount:=y1 to y2 do
477
 
                       { compare if we should plot a pixel here , compare }
478
 
                       { with predefined line patterns...                 }
479
 
                         if LinePatterns[PixelCount and 15] = TRUE then
480
 
                           begin
481
 
                             DirectPutPixelClip(x1+i,PixelCount);
482
 
                           end;
483
 
                     end;
484
 
              end;
485
 
           end
486
 
      else
487
 
           Begin
488
 
             oldCurrentColor := CurrentColor;
489
 
             { Calculate deltax and deltay for initialisation }
490
 
             deltax := abs(x2 - x1);
491
 
             deltay := abs(y2 - y1);
492
 
 
493
 
             { Initialize all vars based on which is the independent variable }
494
 
             if deltax >= deltay then
495
 
               begin
496
 
 
497
 
                 Flag := FALSE;
498
 
                 { x is independent variable }
499
 
                 numpixels := deltax + 1;
500
 
                 d := (2 * deltay) - deltax;
501
 
                 dinc1 := deltay Shl 1;
502
 
                 dinc2 := (deltay - deltax) shl 1;
503
 
                 xinc1 := 1;
504
 
                 xinc2 := 1;
505
 
                 yinc1 := 0;
506
 
                 yinc2 := 1;
507
 
              end
508
 
            else
509
 
              begin
510
 
 
511
 
                Flag := TRUE;
512
 
                { y is independent variable }
513
 
                numpixels := deltay + 1;
514
 
                d := (2 * deltax) - deltay;
515
 
                dinc1 := deltax Shl 1;
516
 
                dinc2 := (deltax - deltay) shl 1;
517
 
                xinc1 := 0;
518
 
                xinc2 := 1;
519
 
                yinc1 := 1;
520
 
                yinc2 := 1;
521
 
              end;
522
 
 
523
 
            { Make sure x and y move in the right directions }
524
 
            if x1 > x2 then
525
 
              begin
526
 
                xinc1 := - xinc1;
527
 
                xinc2 := - xinc2;
528
 
              end;
529
 
            if y1 > y2 then
530
 
              begin
531
 
                yinc1 := - yinc1;
532
 
                yinc2 := - yinc2;
533
 
              end;
534
 
 
535
 
            { Start drawing at <x1, y1> }
536
 
            x := x1;
537
 
            y := y1;
538
 
 
539
 
            If LineInfo.Thickness=ThickWidth then
540
 
 
541
 
             Begin
542
 
               TmpNumPixels := NumPixels-1;
543
 
               { Draw the pixels }
544
 
               for i := 0 to TmpNumPixels do
545
 
                 begin
546
 
                     { all depending on the slope, we can determine         }
547
 
                     { in what direction the extra width pixels will be put }
548
 
                       If Flag then
549
 
                          Begin
550
 
                            { compare if we should plot a pixel here , compare }
551
 
                            { with predefined line patterns...                 }
552
 
                            if LinePatterns[i and 15] = TRUE then
553
 
                              begin
554
 
                                DirectPutPixelClip(x-1,y);
555
 
                                DirectPutPixelClip(x,y);
556
 
                                DirectPutPixelClip(x+1,y);
557
 
                              end;
558
 
                          end
559
 
                       else
560
 
                          Begin
561
 
                            { compare if we should plot a pixel here , compare }
562
 
                            { with predefined line patterns...                 }
563
 
                            if LinePatterns[i and 15] = TRUE then
564
 
                             begin
565
 
                               DirectPutPixelClip(x,y-1);
566
 
                               DirectPutPixelClip(x,y);
567
 
                               DirectPutPixelClip(x,y+1);
568
 
                             end;
569
 
                          end;
570
 
                   if d < 0 then
571
 
                         begin
572
 
                           d := d + dinc1;
573
 
                           x := x + xinc1;
574
 
                           y := y + yinc1;
575
 
                         end
576
 
                   else
577
 
                         begin
578
 
                   d := d + dinc2;
579
 
                   x := x + xinc2;
580
 
                   y := y + yinc2;
581
 
                         end;
582
 
                end;
583
 
            end
584
 
           else
585
 
            Begin
586
 
             { instead of putting in loop , substract by one now }
587
 
             TmpNumPixels := NumPixels-1;
588
 
            { NormWidth }
589
 
             for i := 0 to TmpNumPixels do
590
 
             begin
591
 
                  if LinePatterns[i and 15] = TRUE then
592
 
                    begin
593
 
                          DirectPutPixel(x,y);
594
 
                    end;
595
 
             if d < 0 then
596
 
                 begin
597
 
                   d := d + dinc1;
598
 
                   x := x + xinc1;
599
 
                   y := y + yinc1;
600
 
                 end
601
 
             else
602
 
                 begin
603
 
                   d := d + dinc2;
604
 
                   x := x + xinc2;
605
 
                   y := y + yinc2;
606
 
                 end;
607
 
             end;
608
 
            end
609
 
        end;
610
 
{******************************************}
611
 
{  end patterned lines                     }
612
 
{******************************************}
613
 
       { restore color }
614
 
       CurrentColor:=OldCurrentColor;
615
 
   end;
616
 
 end;  { Line }
617
 
 
618
 
 
619
 
  {********************************************************}
620
 
  { Procedure DummyPatternLine()                           }
621
 
  {--------------------------------------------------------}
622
 
  { This is suimply an procedure that does nothing which   }
623
 
  { can be passed as a patternlineproc for non-filled      }
624
 
  { ellipses                                               }
625
 
  {********************************************************}
626
 
  Procedure DummyPatternLine(x1, x2, y: smallint); {$ifdef tp} far; {$endif tp}
627
 
  begin
628
 
  end;
629
 
 
630
 
 
631
 
  {********************************************************}
632
 
  { Procedure InternalEllipse()                            }
633
 
  {--------------------------------------------------------}
634
 
  { This routine first calculates all points required to   }
635
 
  { draw a circle to the screen, and stores the points     }
636
 
  { to display in a buffer before plotting them. The       }
637
 
  { aspect ratio of the screen is taken into account when  }
638
 
  { calculating the values.                                }
639
 
  {--------------------------------------------------------}
640
 
  { INPUTS: X,Y : Center coordinates of Ellipse.           }
641
 
  {  XRadius - X-Axis radius of ellipse.                   }
642
 
  {  YRadius - Y-Axis radius of ellipse.                   }
643
 
  {  stAngle, EndAngle: Start angle and end angles of the  }
644
 
  {  ellipse (used for partial ellipses and circles)       }
645
 
  {  pl: procedure which either draws a patternline (for   }
646
 
  {      FillEllipse) or does nothing (arc etc)            }
647
 
  {--------------------------------------------------------}
648
 
  { NOTE: -                                                }
649
 
  {       -                                                }
650
 
  {********************************************************}
651
 
 
652
 
  Procedure InternalEllipseDefault(X,Y: smallint;XRadius: word;
653
 
    YRadius:word; stAngle,EndAngle: word; pl: PatternLineProc); {$ifndef fpc}far;{$endif fpc}
654
 
   Const ConvFac = Pi/180.0;
655
 
 
656
 
   var
657
 
    j, Delta, DeltaEnd: graph_float;
658
 
    NumOfPixels: longint;
659
 
    TempTerm: graph_float;
660
 
    xtemp, ytemp, xp, yp, xm, ym, xnext, ynext,
661
 
      plxpyp, plxmyp, plxpym, plxmym: smallint;
662
 
    BackupColor, TmpAngle, OldLineWidth: word;
663
 
  Begin
664
 
   If LineInfo.ThickNess = ThickWidth Then
665
 
    { first draw the two outer ellipses using normwidth and no filling (JM) }
666
 
     Begin
667
 
       OldLineWidth := LineInfo.Thickness;
668
 
       LineInfo.Thickness := NormWidth;
669
 
       InternalEllipseDefault(x,y,XRadius,YRadius,StAngle,EndAngle,
670
 
                              {$ifdef fpc}@{$endif fpc}DummyPatternLine);
671
 
       InternalEllipseDefault(x,y,XRadius+1,YRadius+1,StAngle,EndAngle,
672
 
                              {$ifdef fpc}@{$endif fpc}DummyPatternLine);
673
 
       If (XRadius > 0) and (YRadius > 0) Then
674
 
         { draw the smallest ellipse last, since that one will use the }
675
 
         { original pl, so it could possibly draw patternlines (JM)    }
676
 
         Begin
677
 
           Dec(XRadius);
678
 
           Dec(YRadius);
679
 
         End
680
 
       Else Exit;
681
 
       { restore line thickness }
682
 
       LineInfo.Thickness := OldLineWidth;
683
 
     End;
684
 
   { Adjust for screen aspect ratio }
685
 
   XRadius:=(longint(XRadius)*10000) div XAspect;
686
 
   YRadius:=(longint(YRadius)*10000) div YAspect;
687
 
   If xradius = 0 then inc(xradius);
688
 
   if yradius = 0 then inc(yradius);
689
 
   { check for an ellipse with negligable x and y radius }
690
 
   If (xradius <= 1) and (yradius <= 1) then
691
 
     begin
692
 
       putpixel(x,y,CurrentColor);
693
 
       ArcCall.X := X;
694
 
       ArcCall.Y := Y;
695
 
       ArcCall.XStart := X;
696
 
       ArcCall.YStart := Y;
697
 
       ArcCall.XEnd := X;
698
 
       ArcCall.YEnd := Y;
699
 
       exit;
700
 
     end;
701
 
   { check if valid angles }
702
 
   stangle := stAngle mod 361;
703
 
   EndAngle := EndAngle mod 361;
704
 
   { if impossible angles then swap them! }
705
 
   if Endangle < StAngle then
706
 
     Begin
707
 
       TmpAngle:=EndAngle;
708
 
       EndAngle:=StAngle;
709
 
       Stangle:=TmpAngle;
710
 
     end;
711
 
   { approximate the number of pixels required by using the circumference }
712
 
   { equation of an ellipse.                                              }
713
 
   { Changed this formula a it (trial and error), but the net result is that }
714
 
   { less pixels have to be calculated now                                   }
715
 
   NumOfPixels:=Round(Sqrt(3)*sqrt(sqr(XRadius)+sqr(YRadius)));
716
 
   { Calculate the angle precision required }
717
 
   Delta := 90.0 / NumOfPixels;
718
 
   { for restoring after PatternLine }
719
 
   BackupColor := CurrentColor;
720
 
   { removed from inner loop to make faster }
721
 
   { store some arccall info }
722
 
   ArcCall.X := X;
723
 
   ArcCall.Y := Y;
724
 
   TempTerm := (StAngle)*ConvFac;
725
 
   ArcCall.XStart := round(XRadius*Cos(TempTerm)) + X;
726
 
   ArcCall.YStart := round(YRadius*Sin(TempTerm+Pi)) + Y;
727
 
   TempTerm := (EndAngle)*ConvFac;
728
 
   ArcCall.XEnd := round(XRadius*Cos(TempTerm)) + X;
729
 
   ArcCall.YEnd := round(YRadius*Sin(TempTerm+Pi)) + Y;
730
 
   { Always just go over the first 90 degrees. Could be optimized a   }
731
 
   { bit if StAngle and EndAngle lie in the same quadrant, left as an }
732
 
   { exercise for the reader :) (JM)                                  }
733
 
   j := 0;
734
 
   { calculate stop position, go 1 further than 90 because otherwise }
735
 
   { 1 pixel is sometimes not drawn (JM)                             }
736
 
   DeltaEnd := 91;
737
 
   { Calculate points }
738
 
   xnext := XRadius;
739
 
   ynext := 0;
740
 
   Repeat
741
 
     xtemp := xnext;
742
 
     ytemp := ynext;
743
 
     { this is used by both sin and cos }
744
 
     TempTerm := (j+Delta)*ConvFac;
745
 
     { Calculate points }
746
 
     xnext := round(XRadius*Cos(TempTerm));
747
 
     ynext := round(YRadius*Sin(TempTerm+Pi));
748
 
 
749
 
     xp := x + xtemp;
750
 
     xm := x - xtemp;
751
 
     yp := y + ytemp;
752
 
     ym := y - ytemp;
753
 
     plxpyp := maxsmallint;
754
 
     plxmyp := -maxsmallint-1;
755
 
     plxpym := maxsmallint;
756
 
     plxmym := -maxsmallint-1;
757
 
     If (j >= StAngle) and (j <= EndAngle) then
758
 
       begin
759
 
         plxpyp := xp;
760
 
         PutPixel(xp,yp,CurrentColor);
761
 
       end;
762
 
     If ((180-j) >= StAngle) and ((180-j) <= EndAngle) then
763
 
       begin
764
 
         plxmyp := xm;
765
 
         PutPixel(xm,yp,CurrentColor);
766
 
       end;
767
 
     If ((j+180) >= StAngle) and ((j+180) <= EndAngle) then
768
 
       begin
769
 
         plxmym := xm;
770
 
         PutPixel(xm,ym,CurrentColor);
771
 
       end;
772
 
     If ((360-j) >= StAngle) and ((360-j) <= EndAngle) then
773
 
       begin
774
 
         plxpym := xp;
775
 
         PutPixel(xp,ym,CurrentColor);
776
 
       end;
777
 
     If (ynext <> ytemp) and
778
 
        (xp - xm >= 1) then
779
 
       begin
780
 
         CurrentColor := FillSettings.Color;
781
 
         pl(plxmyp+1,plxpyp-1,yp);
782
 
         pl(plxmym+1,plxpym-1,ym);
783
 
         CurrentColor := BackupColor;
784
 
       end;
785
 
     j:=j+Delta;
786
 
   Until j > (DeltaEnd);
787
 
  end;
788
 
 
789
 
 
790
 
  procedure PatternLineDefault(x1,x2,y: smallint); {$ifndef fpc}far;{$endif fpc}
791
 
  {********************************************************}
792
 
  { Draws a horizontal patterned line according to the     }
793
 
  { current Fill Settings.                                 }
794
 
  {********************************************************}
795
 
  { Important notes:                                       }
796
 
  {  - CurrentColor must be set correctly before entering  }
797
 
  {    this routine.                                       }
798
 
  {********************************************************}
799
 
   var
800
 
    NrIterations: smallint;
801
 
    i           : smallint;
802
 
    j           : smallint;
803
 
    TmpFillPattern : byte;
804
 
    OldWriteMode : word;
805
 
    OldCurrentColor : word;
806
 
   begin
807
 
     { convert to global coordinates ... }
808
 
     x1 := x1 + StartXViewPort;
809
 
     x2 := x2 + StartXViewPort;
810
 
     y  := y + StartYViewPort;
811
 
     { if line was fully clipped then exit...}
812
 
     if LineClipped(x1,y,x2,y,StartXViewPort,StartYViewPort,
813
 
        StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
814
 
         exit;
815
 
 
816
 
     OldWriteMode := CurrentWriteMode;
817
 
     CurrentWriteMode := NormalPut;
818
 
 
819
 
 
820
 
     { Get the current pattern }
821
 
     TmpFillPattern := FillPatternTable
822
 
       [FillSettings.Pattern][(y and $7)+1];
823
 
 
824
 
     Case TmpFillPattern Of
825
 
       0:
826
 
         begin
827
 
           OldCurrentColor := CurrentColor;
828
 
           CurrentColor := CurrentBkColor;
829
 
  { hline converts the coordinates to global ones, but that has been done }
830
 
  { already here!!! Convert them back to local ones... (JM)                }
831
 
           HLine(x1-StartXViewPort,x2-StartXViewPort,y-StartYViewPort);
832
 
           CurrentColor := OldCurrentColor;
833
 
         end;
834
 
       $ff:
835
 
         begin
836
 
           HLine(x1-StartXViewPort,x2-StartXViewPort,y-StartYViewPort);
837
 
         end;
838
 
       else
839
 
         begin
840
 
           { number of times to go throuh the 8x8 pattern }
841
 
           NrIterations := abs(x2 - x1+8) div 8;
842
 
           For i:= 0 to NrIterations do
843
 
             Begin
844
 
               for j:=0 to 7 do
845
 
                    Begin
846
 
                            { x1 mod 8 }
847
 
                    if RevBitArray[x1 and 7] and TmpFillPattern <> 0 then
848
 
                       DirectPutpixel(x1,y)
849
 
                    else
850
 
                      begin
851
 
                            { According to the TP graph manual, we overwrite everything }
852
 
                            { which is filled up - checked against VGA and CGA drivers  }
853
 
                            { of TP.                                                    }
854
 
                            OldCurrentColor := CurrentColor;
855
 
                            CurrentColor := CurrentBkColor;
856
 
                            DirectPutPixel(x1,y);
857
 
                            CurrentColor := OldCurrentColor;
858
 
                      end;
859
 
                    Inc(x1);
860
 
                    if x1 > x2 then
861
 
                     begin
862
 
                           CurrentWriteMode := OldWriteMode;
863
 
                           exit;
864
 
                     end;
865
 
                   end;
866
 
             end;
867
 
          end;
868
 
     End;
869
 
     CurrentWriteMode := OldWriteMode;
870
 
   end;
871
 
 
872
 
 
873
 
 
874
 
 
875
 
  procedure LineRel(Dx, Dy: smallint);
876
 
 
877
 
   Begin
878
 
     Line(CurrentX, CurrentY, CurrentX + Dx, CurrentY + Dy);
879
 
     CurrentX := CurrentX + Dx;
880
 
     CurrentY := CurrentY + Dy;
881
 
   end;
882
 
 
883
 
 
884
 
  procedure LineTo(x,y : smallint);
885
 
 
886
 
   Begin
887
 
     Line(CurrentX, CurrentY, X, Y);
888
 
     CurrentX := X;
889
 
     CurrentY := Y;
890
 
   end;
891
 
 
892
 
 
893
 
 
894
 
 
895
 
  procedure Rectangle(x1,y1,x2,y2:smallint);
896
 
 
897
 
   begin
898
 
     { Do not draw the end points }
899
 
     Line(x1,y1,x2-1,y1);
900
 
     Line(x1,y1+1,x1,y2);
901
 
     Line(x2,y1,x2,y2-1);
902
 
     Line(x1+1,y2,x2,y2);
903
 
   end;
904
 
 
905
 
 
906
 
  procedure GetLineSettings(var ActiveLineInfo : LineSettingsType);
907
 
 
908
 
   begin
909
 
    Activelineinfo:=Lineinfo;
910
 
   end;
911
 
 
912
 
 
913
 
  procedure SetLineStyle(LineStyle: word; Pattern: word; Thickness: word);
914
 
 
915
 
   var
916
 
    i: byte;
917
 
    j: byte;
918
 
 
919
 
   Begin
920
 
    if (LineStyle > UserBitLn) or ((Thickness <> Normwidth) and (Thickness <> ThickWidth)) then
921
 
      _GraphResult := grError
922
 
    else
923
 
      begin
924
 
       LineInfo.Thickness := Thickness;
925
 
       LineInfo.LineStyle := LineStyle;
926
 
       case LineStyle of
927
 
            UserBitLn: Lineinfo.Pattern := pattern;
928
 
            SolidLn:   Lineinfo.Pattern  := $ffff;  { ------- }
929
 
            DashedLn : Lineinfo.Pattern := $F8F8;   { -- -- --}
930
 
            DottedLn:  LineInfo.Pattern := $CCCC;   { - - - - }
931
 
            CenterLn: LineInfo.Pattern :=  $FC78;   { -- - -- }
932
 
       end; { end case }
933
 
       { setup pattern styles }
934
 
       j:=16;
935
 
       for i:=0 to 15 do
936
 
        Begin
937
 
         dec(j);
938
 
         { bitwise mask for each bit in the word }
939
 
         if (word($01 shl i) AND LineInfo.Pattern) <> 0 then
940
 
               LinePatterns[j]:=TRUE
941
 
             else
942
 
               LinePatterns[j]:=FALSE;
943
 
        end;
944
 
      end;
945
 
   end;
946
 
 
947
 
 
948
 
 
949
 
 
950
 
{--------------------------------------------------------------------------}
951
 
{                                                                          }
952
 
{                    VIEWPORT RELATED ROUTINES                             }
953
 
{                                                                          }
954
 
{--------------------------------------------------------------------------}
955
 
 
956
 
 
957
 
Procedure ClearViewPortDefault; {$ifndef fpc}far;{$endif fpc}
958
 
var
959
 
 j: smallint;
960
 
 OldWriteMode, OldCurColor: word;
961
 
 LineSets : LineSettingsType;
962
 
Begin
963
 
  { CP is always RELATIVE coordinates }
964
 
  CurrentX := 0;
965
 
  CurrentY := 0;
966
 
 
967
 
  { Save all old settings }
968
 
  OldCurColor := CurrentColor;
969
 
  CurrentColor:=CurrentBkColor;
970
 
  OldWriteMode:=CurrentWriteMode;
971
 
  CurrentWriteMode:=NormalPut;
972
 
  GetLineSettings(LineSets);
973
 
  { reset to normal line style...}
974
 
  SetLineStyle(SolidLn, 0, NormWidth);
975
 
  { routines are relative here...}
976
 
  { ViewHeight is Height-1 !     }
977
 
  for J:=0 to ViewHeight do
978
 
       HLine(0, ViewWidth , J);
979
 
 
980
 
  { restore old settings...}
981
 
  SetLineStyle(LineSets.LineStyle, LineSets.Pattern, LineSets.Thickness);
982
 
  CurrentColor := OldCurColor;
983
 
  CurrentWriteMode := OldWriteMode;
984
 
end;
985
 
 
986
 
 
987
 
Procedure SetViewPort(X1, Y1, X2, Y2: smallint; Clip: Boolean);
988
 
Begin
989
 
  if (X1 > GetMaxX) or (X2 > GetMaxX) or (X1 > X2) or (X1 < 0) then
990
 
  Begin
991
 
{$ifdef logging}
992
 
    logln('invalid setviewport parameters: ('
993
 
      +strf(x1)+','+strf(y1)+'), ('+strf(x2)+','+strf(y2)+')');
994
 
    logln('maxx = '+strf(getmaxx)+', maxy = '+strf(getmaxy));
995
 
{$endif logging}
996
 
    _GraphResult := grError;
997
 
    exit;
998
 
  end;
999
 
  if (Y1 > GetMaxY) or (Y2 > GetMaxY) or (Y1 > Y2) or (Y1 < 0) then
1000
 
  Begin
1001
 
{$ifdef logging}
1002
 
    logln('invalid setviewport parameters: ('
1003
 
      +strf(x1)+','+strf(y1)+'), ('+strf(x2)+','+strf(y2)+')');
1004
 
    logln('maxx = '+strf(getmaxx)+', maxy = '+strf(getmaxy));
1005
 
{$endif logging}
1006
 
    _GraphResult := grError;
1007
 
    exit;
1008
 
  end;
1009
 
  { CP is always RELATIVE coordinates }
1010
 
  CurrentX := 0;
1011
 
  CurrentY := 0;
1012
 
  StartXViewPort := X1;
1013
 
  StartYViewPort := Y1;
1014
 
  ViewWidth :=  X2-X1;
1015
 
  ViewHeight:=  Y2-Y1;
1016
 
  ClipPixels := Clip;
1017
 
end;
1018
 
 
1019
 
 
1020
 
procedure GetViewSettings(var viewport : ViewPortType);
1021
 
begin
1022
 
  ViewPort.X1 := StartXViewPort;
1023
 
  ViewPort.Y1 := StartYViewPort;
1024
 
  ViewPort.X2 := ViewWidth + StartXViewPort;
1025
 
  ViewPort.Y2 := ViewHeight + StartYViewPort;
1026
 
  ViewPort.Clip := ClipPixels;
1027
 
end;
1028
 
 
1029
 
procedure ClearDevice;
1030
 
var
1031
 
  ViewPort: ViewPortType;
1032
 
begin
1033
 
  { Reset the CP }
1034
 
  CurrentX := 0;
1035
 
  CurrentY := 0;
1036
 
  { save viewport }
1037
 
  ViewPort.X1 :=  StartXviewPort;
1038
 
  ViewPort.X2 :=  ViewWidth - StartXViewPort;
1039
 
  ViewPort.Y1 :=  StartYViewPort;
1040
 
  ViewPort.Y2 :=  ViewHeight - StartYViewPort;
1041
 
  ViewPort.Clip := ClipPixels;
1042
 
  { put viewport to full screen }
1043
 
  StartXViewPort := 0;
1044
 
  ViewHeight := MaxY;
1045
 
  StartYViewPort := 0;
1046
 
  ViewWidth := MaxX;
1047
 
  ClipPixels := TRUE;
1048
 
  ClearViewPort;
1049
 
  { restore old viewport }
1050
 
  StartXViewPort := ViewPort.X1;
1051
 
  ViewWidth := ViewPort.X2-ViewPort.X1;
1052
 
  StartYViewPort := ViewPort.Y1;
1053
 
  ViewHeight := ViewPort.Y2-ViewPort.Y1;
1054
 
  ClipPixels := ViewPort.Clip;
1055
 
end;
1056
 
 
1057
 
 
1058
 
 
1059
 
{--------------------------------------------------------------------------}
1060
 
{                                                                          }
1061
 
{                      BITMAP PUT/GET ROUTINES                             }
1062
 
{                                                                          }
1063
 
{--------------------------------------------------------------------------}
1064
 
 
1065
 
 
1066
 
  Procedure GetScanlineDefault (X1, X2, Y : smallint; Var Data); {$ifndef fpc}far;{$endif fpc}
1067
 
  {**********************************************************}
1068
 
  { Procedure GetScanLine()                                  }
1069
 
  {----------------------------------------------------------}
1070
 
  { Returns the full scanline of the video line of the Y     }
1071
 
  { coordinate. The values are returned in a WORD array      }
1072
 
  { each WORD representing a pixel of the specified scanline }
1073
 
  { note: we only need the pixels inside the ViewPort! (JM)  }
1074
 
  { note2: extended so you can specify start and end X coord }
1075
 
  {   so it is usable for GetImage too (JM)                  }
1076
 
  {**********************************************************}
1077
 
 
1078
 
 
1079
 
  Var
1080
 
    x : smallint;
1081
 
  Begin
1082
 
     For x:=X1 to X2 Do
1083
 
       WordArray(Data)[x-x1]:=GetPixel(x, y);
1084
 
  End;
1085
 
 
1086
 
 
1087
 
 
1088
 
Function DefaultImageSize(X1,Y1,X2,Y2: smallint): longint; {$ifndef fpc}far;{$endif fpc}
1089
 
Begin
1090
 
  { each pixel uses two bytes, to enable modes with colors up to 64K }
1091
 
  { to work.                                                         }
1092
 
  DefaultImageSize := 12 + (((X2-X1+1)*(Y2-Y1+1))*2);
1093
 
end;
1094
 
 
1095
 
Procedure DefaultPutImage(X,Y: smallint; var Bitmap; BitBlt: Word); {$ifndef fpc}far;{$endif fpc}
1096
 
type
1097
 
  pt = array[0..$fffffff] of word;
1098
 
  ptw = array[0..2] of longint;
1099
 
var
1100
 
  k: longint;
1101
 
  oldCurrentColor: word;
1102
 
  oldCurrentWriteMode, i, j, y1, x1, deltaX, deltaX1, deltaY: smallint;
1103
 
Begin
1104
 
{$ifdef logging}
1105
 
  LogLn('putImage at ('+strf(x)+','+strf(y)+') with width '+strf(ptw(Bitmap)[0])+
1106
 
    ' and height '+strf(ptw(Bitmap)[1]));
1107
 
  deltaY := 0;
1108
 
{$endif logging}
1109
 
  inc(x,startXViewPort);
1110
 
  inc(y,startYViewPort);
1111
 
  { width/height are 1-based, coordinates are zero based }
1112
 
  x1 := ptw(Bitmap)[0]+x-1; { get width and adjust end coordinate accordingly }
1113
 
  y1 := ptw(Bitmap)[1]+y-1; { get height and adjust end coordinate accordingly }
1114
 
 
1115
 
  deltaX := 0;
1116
 
  deltaX1 := 0;
1117
 
  k := 3 * sizeOf(Longint) div sizeOf(Word); { Three reserved longs at start of bitmap }
1118
 
 { check which part of the image is in the viewport }
1119
 
  if clipPixels then
1120
 
    begin
1121
 
      if y < startYViewPort then
1122
 
        begin
1123
 
          deltaY := startYViewPort - y;
1124
 
          inc(k,(x1-x+1)*deltaY);
1125
 
          y := startYViewPort;
1126
 
         end;
1127
 
      if y1 > startYViewPort+viewHeight then
1128
 
        y1 := startYViewPort+viewHeight;
1129
 
      if x < startXViewPort then
1130
 
        begin
1131
 
          deltaX := startXViewPort-x;
1132
 
          x := startXViewPort;
1133
 
        end;
1134
 
      if x1 > startXViewPort + viewWidth then
1135
 
        begin
1136
 
          deltaX1 := x1 - (startXViewPort + viewWidth);
1137
 
          x1 := startXViewPort + viewWidth;
1138
 
        end;
1139
 
    end;
1140
 
{$ifdef logging}
1141
 
  LogLn('deltax: '+strf(deltax)+', deltax1: '+strf(deltax1)+',deltay: '+strf(deltay));
1142
 
{$endif logging}
1143
 
  oldCurrentColor := currentColor;
1144
 
  oldCurrentWriteMode := currentWriteMode;
1145
 
  currentWriteMode := bitBlt;
1146
 
  for j:=Y to Y1 do
1147
 
   Begin
1148
 
     inc(k,deltaX);
1149
 
     for i:=X to X1 do
1150
 
      begin
1151
 
        currentColor := pt(bitmap)[k];
1152
 
        directPutPixel(i,j);
1153
 
        inc(k);
1154
 
     end;
1155
 
     inc(k,deltaX1);
1156
 
   end;
1157
 
  currentWriteMode := oldCurrentWriteMode;
1158
 
  currentColor := oldCurrentColor;
1159
 
end;
1160
 
 
1161
 
Procedure DefaultGetImage(X1,Y1,X2,Y2: smallint; Var Bitmap); {$ifndef fpc}far;{$endif fpc}
1162
 
type
1163
 
  pt = array[0..$fffffff] of word;
1164
 
  ptw = array[0..2] of longint;
1165
 
var
1166
 
  i,j: smallint;
1167
 
  k: longint;
1168
 
Begin
1169
 
  k:= 3 * Sizeof(longint) div sizeof(word); { Three reserved longs at start of bitmap }
1170
 
  i := x2 - x1 + 1;
1171
 
  for j:=Y1 to Y2 do
1172
 
   Begin
1173
 
     GetScanLine(x1,x2,j,pt(Bitmap)[k]);
1174
 
     inc(k,i);
1175
 
   end;
1176
 
   ptw(Bitmap)[0] := X2-X1+1;   { First longint  is width  }
1177
 
   ptw(Bitmap)[1] := Y2-Y1+1;   { Second longint is height }
1178
 
   ptw(bitmap)[2] := 0;       { Third longint is reserved}
1179
 
end;
1180
 
 
1181
 
 
1182
 
 
1183
 
 
1184
 
 
1185
 
 
1186
 
  Procedure GetArcCoords(var ArcCoords: ArcCoordsType);
1187
 
   Begin
1188
 
     ArcCoords.X := ArcCall.X;
1189
 
     ArcCoords.Y := ArcCall.Y;
1190
 
     ArcCoords.XStart := ArcCall.XStart;
1191
 
     ArcCoords.YStart := ArcCall.YStart;
1192
 
     ArcCoords.XEnd := ArcCall.XEnd;
1193
 
     ArcCoords.YEnd := ArcCall.YEnd;
1194
 
   end;
1195
 
 
1196
 
 
1197
 
  procedure SetVisualPageDefault(page : word); {$ifndef fpc}far;{$endif fpc}
1198
 
   begin
1199
 
   end;
1200
 
 
1201
 
 
1202
 
  procedure SetActivePageDefault(page : word); {$ifndef fpc}far;{$endif fpc}
1203
 
   begin
1204
 
   end;
1205
 
 
1206
 
  procedure DirectPutPixelDefault(X,Y: smallint);
1207
 
   begin
1208
 
     Writeln(stderr,'Error: Not in graphics mode (use InitGraph and test GraphResult afterwards)');
1209
 
     Halt(1);
1210
 
   end;
1211
 
 
1212
 
  function GetPixelDefault(X,Y: smallint): word;
1213
 
   begin
1214
 
     Writeln(stderr,'Error: Not in graphics mode (use InitGraph and test GraphResult afterwards)');
1215
 
     Halt(1);
1216
 
     exit(0); { avoid warning }
1217
 
   end;
1218
 
 
1219
 
  procedure PutPixelDefault(X,Y: smallint; Color: Word);
1220
 
   begin
1221
 
     Writeln(stderr,'Error: Not in graphics mode (use InitGraph and test GraphResult afterwards)');
1222
 
     Halt(1);
1223
 
   end;
1224
 
 
1225
 
  procedure SetRGBPaletteDefault(ColorNum, RedValue, GreenValue, BlueValue: smallint);
1226
 
   begin
1227
 
     Writeln(stderr,'Error: Not in graphics mode (use InitGraph and test GraphResult afterwards)');
1228
 
     Halt(1);
1229
 
   end;
1230
 
 
1231
 
  procedure GetRGBPaletteDefault(ColorNum: smallint; var
1232
 
            RedValue, GreenValue, BlueValue: smallint);
1233
 
   begin
1234
 
     Writeln(stderr,'Error: Not in graphics mode (use InitGraph and test GraphResult afterwards)');
1235
 
     Halt(1);
1236
 
   end;
1237
 
 
1238
 
 
1239
 
  procedure OutTextXYDefault(x,y : smallint;const TextString : string);forward;
1240
 
  procedure CircleDefault(X, Y: smallint; Radius:Word);forward;
1241
 
 
1242
 
{$i palette.inc}
1243
 
 
1244
 
  Procedure DefaultHooks;
1245
 
  {********************************************************}
1246
 
  { Procedure DefaultHooks()                               }
1247
 
  {--------------------------------------------------------}
1248
 
  { Resets all hookable routine either to nil for those    }
1249
 
  { which need overrides, and others to defaults.          }
1250
 
  { This is called each time SetGraphMode() is called.     }
1251
 
  {********************************************************}
1252
 
  Begin
1253
 
    { All default hooks procedures }
1254
 
 
1255
 
    { required...}
1256
 
    DirectPutPixel := {$ifdef fpc}@{$endif}DirectPutPixelDefault;
1257
 
    PutPixel := {$ifdef fpc}@{$endif}PutPixelDefault;
1258
 
    GetPixel := {$ifdef fpc}@{$endif}GetPixelDefault;
1259
 
    SetRGBPalette := {$ifdef fpc}@{$endif}SetRGBPaletteDefault;
1260
 
    GetRGBPalette := {$ifdef fpc}@{$endif}GetRGBPaletteDefault;
1261
 
    { optional...}
1262
 
    SetAllPalette := {$ifdef fpc}@{$endif}SetAllPaletteDefault;
1263
 
    SetActivePage := {$ifdef fpc}@{$endif}SetActivePageDefault;
1264
 
    SetVisualPage := {$ifdef fpc}@{$endif}SetVisualPageDefault;
1265
 
    ClearViewPort := {$ifdef fpc}@{$endif}ClearViewportDefault;
1266
 
    PutImage := {$ifdef fpc}@{$endif}DefaultPutImage;
1267
 
    GetImage := {$ifdef fpc}@{$endif}DefaultGetImage;
1268
 
    ImageSize := {$ifdef fpc}@{$endif}DefaultImageSize;
1269
 
    GraphFreeMemPtr := nil;
1270
 
    GraphGetMemPtr := nil;
1271
 
    GetScanLine := {$ifdef fpc}@{$endif}GetScanLineDefault;
1272
 
    Line := {$ifdef fpc}@{$endif}LineDefault;
1273
 
    InternalEllipse := {$ifdef fpc}@{$endif}InternalEllipseDefault;
1274
 
    PatternLine := {$ifdef fpc}@{$endif}PatternLineDefault;
1275
 
    HLine := {$ifdef fpc}@{$endif}HLineDefault;
1276
 
    VLine := {$ifdef fpc}@{$endif}VLineDefault;
1277
 
    OuttextXY := {$ifdef fpc}@{$endif}OuttextXYDefault;
1278
 
    Circle := {$ifdef fpc}@{$endif}CircleDefault;
1279
 
  end;
1280
 
 
1281
 
  Procedure InitVars;
1282
 
  {********************************************************}
1283
 
  { Procedure InitVars()                                   }
1284
 
  {--------------------------------------------------------}
1285
 
  { Resets all internal variables, and resets all          }
1286
 
  { overridable routines.                                  }
1287
 
  {********************************************************}
1288
 
   Begin
1289
 
    DirectVideo := TRUE;  { By default use fastest access possible }
1290
 
    ArcCall.X := 0;
1291
 
    ArcCall.Y := 0;
1292
 
    ArcCall.XStart := 0;
1293
 
    ArcCall.YStart := 0;
1294
 
    ArcCall.XEnd := 0;
1295
 
    ArcCall.YEnd := 0;
1296
 
    { Reset to default values }
1297
 
    IntCurrentMode := 0;
1298
 
    IntCurrentDriver := 0;
1299
 
    IntCurrentNewDriver := 0;
1300
 
    XAspect := 0;
1301
 
    YAspect := 0;
1302
 
    MaxX := 0;
1303
 
    MaxY := 0;
1304
 
    MaxColor := 0;
1305
 
    PaletteSize := 0;
1306
 
    DirectColor := FALSE;
1307
 
    HardwarePages := 0;
1308
 
    if hardwarepages=0 then; { remove note }
1309
 
    DefaultHooks;
1310
 
  end;
1311
 
 
1312
 
{$i modes.inc}
1313
 
 
1314
 
  function InstallUserDriver(Name: string; AutoDetectPtr: Pointer): smallint;
1315
 
   begin
1316
 
     _graphResult := grError;
1317
 
     InstallUserDriver:=grError;
1318
 
   end;
1319
 
 
1320
 
  function RegisterBGIDriver(driver: pointer): smallint;
1321
 
 
1322
 
   begin
1323
 
     _graphResult := grError;
1324
 
     RegisterBGIDriver:=grError;
1325
 
   end;
1326
 
 
1327
 
 
1328
 
 
1329
 
{ ----------------------------------------------------------------- }
1330
 
 
1331
 
 
1332
 
  Procedure Arc(X,Y : smallint; StAngle,EndAngle,Radius: word);
1333
 
 
1334
 
{   var
1335
 
    OldWriteMode: word;}
1336
 
 
1337
 
   Begin
1338
 
     { Only if we are using thickwidths lines do we accept }
1339
 
     { XORput write modes.                                 }
1340
 
{     OldWriteMode := CurrentWriteMode;
1341
 
     if (LineInfo.Thickness = NormWidth) then
1342
 
       CurrentWriteMode := NormalPut;}
1343
 
     InternalEllipse(X,Y,Radius,Radius,StAngle,Endangle,{$ifdef fpc}@{$endif}DummyPatternLine);
1344
 
{     CurrentWriteMode := OldWriteMode;}
1345
 
   end;
1346
 
 
1347
 
 
1348
 
 procedure Ellipse(X,Y : smallint; stAngle, EndAngle: word; XRadius,YRadius: word);
1349
 
  Begin
1350
 
    InternalEllipse(X,Y,XRadius,YRadius,StAngle,Endangle,{$ifdef fpc}@{$endif}DummyPatternLine);
1351
 
  end;
1352
 
 
1353
 
 
1354
 
 procedure FillEllipse(X, Y: smallint; XRadius, YRadius: Word);
1355
 
  {********************************************************}
1356
 
  { Procedure FillEllipse()                                }
1357
 
  {--------------------------------------------------------}
1358
 
  { Draws a filled ellipse using (X,Y) as a center point   }
1359
 
  { and XRadius and YRadius as the horizontal and vertical }
1360
 
  { axes. The ellipse is filled with the current fill color}
1361
 
  { and fill style, and is bordered with the current color.}
1362
 
  {********************************************************}
1363
 
  begin
1364
 
    InternalEllipse(X,Y,XRadius,YRadius,0,360,PatternLine)
1365
 
  end;
1366
 
 
1367
 
 
1368
 
 
1369
 
 procedure CircleDefault(X, Y: smallint; Radius:Word);
1370
 
  {********************************************************}
1371
 
  { Draws a circle centered at X,Y with the given Radius.  }
1372
 
  {********************************************************}
1373
 
  { Important notes:                                       }
1374
 
  {  - Thickwidth circles use the current write mode, while}
1375
 
  {    normal width circles ALWAYS use CopyPut/NormalPut   }
1376
 
  {    mode. (Tested against VGA BGI driver -CEC 13/Aug/99 }
1377
 
  {********************************************************}
1378
 
  var OriginalArcInfo: ArcCoordsType;
1379
 
      OldWriteMode: word;
1380
 
 
1381
 
  begin
1382
 
     if (Radius = 0) then
1383
 
          Exit;
1384
 
 
1385
 
     if (Radius = 1) then
1386
 
     begin
1387
 
      { only normal put mode is supported by a call to PutPixel }
1388
 
          PutPixel(X, Y, CurrentColor);
1389
 
          Exit;
1390
 
     end;
1391
 
 
1392
 
     { save state of arc information }
1393
 
     { because it is not needed for  }
1394
 
     { a circle call.                }
1395
 
     move(ArcCall,OriginalArcInfo, sizeof(ArcCall));
1396
 
     if LineInfo.Thickness = Normwidth then
1397
 
       begin
1398
 
             OldWriteMode := CurrentWriteMode;
1399
 
             CurrentWriteMode := CopyPut;
1400
 
       end;
1401
 
     InternalEllipse(X,Y,Radius,Radius,0,360,{$ifdef fpc}@{$endif}DummyPatternLine);
1402
 
     if LineInfo.Thickness = Normwidth then
1403
 
         CurrentWriteMode := OldWriteMode;
1404
 
     { restore arc information }
1405
 
     move(OriginalArcInfo, ArcCall,sizeof(ArcCall));
1406
 
 end;
1407
 
 
1408
 
 procedure SectorPL(x1,x2,y: smallint); {$ifndef fpc}far;{$endif fpc}
1409
 
 var plx1, plx2: smallint;
1410
 
 begin
1411
 
   If (x1 = -maxsmallint) Then
1412
 
     If (x2 = maxsmallint-1) Then
1413
 
       { no ellipse points drawn on this line }
1414
 
       If (((Y < ArcCall.Y) and (Y > ArcCall.YStart)) or
1415
 
          ((Y > ArcCall.Y) and (Y < ArcCall.YStart))) Then
1416
 
         { there is a part of the sector at this y coordinate, but no    }
1417
 
         { ellips points are plotted on this line, so draw a patternline }
1418
 
         { between the lines connecting (arccall.x,arccall.y) with       }
1419
 
         { the start and the end of the arc (JM)                         }
1420
 
         { use: y-y1=(y2-y1)/(x2-x1)*(x-x1) =>                           }
1421
 
         { x = (y-y1)/(y2-y1)*(x2-x1)+x1                                 }
1422
 
         Begin
1423
 
           plx1 := (y-ArcCall.Y)*(ArcCall.XStart-ArcCall.X)
1424
 
                   div (ArcCall.YStart-ArcCall.Y)+ArcCall.X;
1425
 
           plx2 := (y-ArcCall.Y)*(ArcCall.XEnd-ArcCall.X)
1426
 
                   div (ArcCall.YEnd-ArcCall.Y)+ArcCall.X;
1427
 
           If plx1 > plx2 then
1428
 
             begin
1429
 
               plx1 := plx1 xor plx2;
1430
 
               plx2 := plx1 xor plx2;
1431
 
               plx1 := plx1 xor plx2;
1432
 
             end;
1433
 
         End
1434
 
       { otherwise two points which have nothing to do with the sector }
1435
 
       Else exit
1436
 
     Else
1437
 
       { the arc is plotted at the right side, but not at the left side, }
1438
 
       { fill till the line between (ArcCall.X,ArcCall.Y) and            }
1439
 
       { (ArcCall.XStart,ArcCall.YStart)                                 }
1440
 
       Begin
1441
 
         If (y < ArcCall.Y) then
1442
 
           begin
1443
 
             plx1 := (y-ArcCall.Y)*(ArcCall.XEnd-ArcCall.X)
1444
 
                     div (ArcCall.YEnd-ArcCall.Y)+ArcCall.X
1445
 
           end
1446
 
         else if (y > ArcCall.Y) then
1447
 
           begin
1448
 
             plx1 := (y-ArcCall.Y)*(ArcCall.XStart-ArcCall.X)
1449
 
                     div (ArcCall.YStart-ArcCall.Y)+ArcCall.X
1450
 
             end
1451
 
         else plx1 := ArcCall.X;
1452
 
         plx2 := x2;
1453
 
       End
1454
 
   Else
1455
 
     If (x2 = maxsmallint-1) Then
1456
 
       { the arc is plotted at the left side, but not at the rigth side.   }
1457
 
       { the right limit can be either the first or second line. Just take }
1458
 
       { the closest one, but watch out for division by zero!              }
1459
 
       Begin
1460
 
         If (y < ArcCall.Y) then
1461
 
           begin
1462
 
             plx2 := (y-ArcCall.Y)*(ArcCall.XStart-ArcCall.X)
1463
 
                     div (ArcCall.YStart-ArcCall.Y)+ArcCall.X
1464
 
           end
1465
 
         else if (y > ArcCall.Y) then
1466
 
           begin
1467
 
             plx2 := (y-ArcCall.Y)*(ArcCall.XEnd-ArcCall.X)
1468
 
                     div (ArcCall.YEnd-ArcCall.Y)+ArcCall.X
1469
 
           end
1470
 
         else plx2 := ArcCall.X;
1471
 
         plx1 := x1;
1472
 
       End
1473
 
     Else
1474
 
       { the arc is plotted at both sides }
1475
 
       Begin
1476
 
         plx1 := x1;
1477
 
         plx2 := x2;
1478
 
       End;
1479
 
   If plx2 > plx1 then
1480
 
     Begin
1481
 
       PatternLine(plx1,plx2,y);
1482
 
     end;
1483
 
 end;
1484
 
 
1485
 
 procedure Sector(x, y: smallint; StAngle,EndAngle, XRadius, YRadius: Word);
1486
 
  begin
1487
 
     internalellipse(x,y,XRadius, YRadius, StAngle, EndAngle, {$ifdef fpc}@{$endif}SectorPL);
1488
 
     Line(ArcCall.XStart, ArcCall.YStart, x,y);
1489
 
     Line(x,y,ArcCall.Xend,ArcCall.YEnd);
1490
 
  end;
1491
 
 
1492
 
 
1493
 
 
1494
 
   procedure SetFillStyle(Pattern : word; Color: word);
1495
 
 
1496
 
   begin
1497
 
     { on invalid input, the current fill setting will be }
1498
 
     { unchanged.                                         }
1499
 
     if (Pattern > UserFill) or (Color > GetMaxColor) then
1500
 
      begin
1501
 
{$ifdef logging}
1502
 
           logln('invalid fillstyle parameters');
1503
 
{$endif logging}
1504
 
           _GraphResult := grError;
1505
 
           exit;
1506
 
      end;
1507
 
     FillSettings.Color := Color;
1508
 
     FillSettings.Pattern := Pattern;
1509
 
   end;
1510
 
 
1511
 
 
1512
 
  procedure SetFillPattern(Pattern: FillPatternType; Color: word);
1513
 
  {********************************************************}
1514
 
  { Changes the Current FillPattern to a user defined      }
1515
 
  { pattern and changes also the current fill color.       }
1516
 
  { The FillPattern is saved in the FillPattern array so   }
1517
 
  { it can still be used with SetFillStyle(UserFill,Color) }
1518
 
  {********************************************************}
1519
 
   var
1520
 
    i: smallint;
1521
 
 
1522
 
   begin
1523
 
     if Color > GetMaxColor then
1524
 
       begin
1525
 
{$ifdef logging}
1526
 
            logln('invalid fillpattern parameters');
1527
 
{$endif logging}
1528
 
            _GraphResult := grError;
1529
 
            exit;
1530
 
       end;
1531
 
 
1532
 
     FillSettings.Color := Color;
1533
 
     FillSettings.Pattern := UserFill;
1534
 
 
1535
 
     { Save the pattern in the buffer }
1536
 
     For i:=1 to 8 do
1537
 
       FillPatternTable[UserFill][i] := Pattern[i];
1538
 
 
1539
 
   end;
1540
 
 
1541
 
  procedure Bar(x1,y1,x2,y2:smallint);
1542
 
  {********************************************************}
1543
 
  { Important notes for compatibility with BP:             }
1544
 
  {     - WriteMode is always CopyPut                      }
1545
 
  {     - No contour is drawn for the lines                }
1546
 
  {********************************************************}
1547
 
  var y               : smallint;
1548
 
      origcolor       : longint;
1549
 
      origlinesettings: Linesettingstype;
1550
 
      origwritemode   : smallint;
1551
 
   begin
1552
 
     origlinesettings:=lineinfo;
1553
 
     origcolor:=CurrentColor;
1554
 
     if y1>y2 then
1555
 
       begin
1556
 
          y:=y1;
1557
 
          y1:=y2;
1558
 
          y2:=y;
1559
 
       end;
1560
 
 
1561
 
     { Always copy mode for Bars }
1562
 
     origwritemode := CurrentWriteMode;
1563
 
     CurrentWriteMode := CopyPut;
1564
 
 
1565
 
     { All lines used are of this style }
1566
 
     Lineinfo.linestyle:=solidln;
1567
 
     Lineinfo.thickness:=normwidth;
1568
 
 
1569
 
     case Fillsettings.pattern of
1570
 
     EmptyFill :
1571
 
       begin
1572
 
         Currentcolor:=CurrentBkColor;
1573
 
         for y:=y1 to y2 do
1574
 
           Hline(x1,x2,y);
1575
 
       end;
1576
 
     SolidFill :
1577
 
       begin
1578
 
         CurrentColor:=FillSettings.color;
1579
 
           for y:=y1 to y2 do
1580
 
              Hline(x1,x2,y);
1581
 
       end;
1582
 
     else
1583
 
      Begin
1584
 
        CurrentColor:=FillSettings.color;
1585
 
        for y:=y1 to y2 do
1586
 
          patternline(x1,x2,y);
1587
 
      end;
1588
 
    end;
1589
 
    CurrentColor:= Origcolor;
1590
 
    LineInfo := OrigLineSettings;
1591
 
    CurrentWriteMode := OrigWritemode;
1592
 
   end;
1593
 
 
1594
 
 
1595
 
 
1596
 
 
1597
 
procedure bar3D(x1, y1, x2, y2 : smallint;depth : word;top : boolean);
1598
 
var
1599
 
 origwritemode : smallint;
1600
 
 OldX, OldY : smallint;
1601
 
begin
1602
 
  origwritemode := CurrentWriteMode;
1603
 
  CurrentWriteMode := CopyPut;
1604
 
  Bar(x1,y1,x2,y2);
1605
 
  Rectangle(x1,y1,x2,y2);
1606
 
 
1607
 
  { Current CP should not be updated in Bar3D }
1608
 
  { therefore save it and then restore it on  }
1609
 
  { exit.                                     }
1610
 
  OldX := CurrentX;
1611
 
  OldY := CurrentY;
1612
 
 
1613
 
  if top then begin
1614
 
    Moveto(x1,y1);
1615
 
    Lineto(x1+depth,y1-depth);
1616
 
    Lineto(x2+depth,y1-depth);
1617
 
    Lineto(x2,y1);
1618
 
  end;
1619
 
  if Depth <> 0 then
1620
 
    Begin
1621
 
      Moveto(x2+depth,y1-depth);
1622
 
      Lineto(x2+depth,y2-depth);
1623
 
      Lineto(x2,y2);
1624
 
    end;
1625
 
  { restore CP }
1626
 
  CurrentX := OldX;
1627
 
  CurrentY := OldY;
1628
 
  CurrentWriteMode := origwritemode;
1629
 
end;
1630
 
 
1631
 
 
1632
 
 
1633
 
{--------------------------------------------------------------------------}
1634
 
{                                                                          }
1635
 
{                       COLOR AND PALETTE ROUTINES                         }
1636
 
{                                                                          }
1637
 
{--------------------------------------------------------------------------}
1638
 
 
1639
 
 
1640
 
  procedure SetColor(Color: Word);
1641
 
 
1642
 
   Begin
1643
 
     CurrentColor := Color;
1644
 
   end;
1645
 
 
1646
 
 
1647
 
  function GetColor: Word;
1648
 
 
1649
 
   Begin
1650
 
     GetColor := CurrentColor;
1651
 
   end;
1652
 
 
1653
 
  function GetBkColor: Word;
1654
 
 
1655
 
   Begin
1656
 
     GetBkColor := CurrentBkColor;
1657
 
   end;
1658
 
 
1659
 
 
1660
 
  procedure SetBkColor(ColorNum: Word);
1661
 
  { Background color means background screen color in this case, and it is  }
1662
 
  { INDEPENDANT of the viewport settings, so we must clear the whole screen }
1663
 
  { with the color.                                                         }
1664
 
   var
1665
 
     ViewPort: ViewportType;
1666
 
   Begin
1667
 
     GetViewSettings(Viewport);
1668
 
{$ifdef logging}
1669
 
      logln('calling setviewport from setbkcolor');
1670
 
{$endif logging}
1671
 
     SetViewPort(0,0,MaxX,MaxY,FALSE);
1672
 
{$ifdef logging}
1673
 
      logln('calling setviewport from setbkcolor done');
1674
 
{$endif logging}
1675
 
     CurrentBkColor := ColorNum;
1676
 
     {ClearViewPort;}
1677
 
     if not DirectColor and (ColorNum<256) then
1678
 
      SetRGBPalette(0,
1679
 
          DefaultColors[ColorNum].Red,
1680
 
          DefaultColors[ColorNum].Green,
1681
 
          DefaultColors[ColorNum].Blue);
1682
 
     SetViewport(ViewPort.X1,Viewport.Y1,Viewport.X2,Viewport.Y2,Viewport.Clip);
1683
 
   end;
1684
 
 
1685
 
 
1686
 
  function GetMaxColor: word;
1687
 
  { Checked against TP VGA driver - CEC }
1688
 
 
1689
 
   begin
1690
 
      GetMaxColor:=MaxColor-1; { based on an index of zero so subtract one }
1691
 
   end;
1692
 
 
1693
 
 
1694
 
 
1695
 
 
1696
 
 
1697
 
 
1698
 
   Procedure MoveRel(Dx, Dy: smallint);
1699
 
    Begin
1700
 
     CurrentX := CurrentX + Dx;
1701
 
     CurrentY := CurrentY + Dy;
1702
 
   end;
1703
 
 
1704
 
   Procedure MoveTo(X,Y: smallint);
1705
 
  {********************************************************}
1706
 
  { Procedure MoveTo()                                     }
1707
 
  {--------------------------------------------------------}
1708
 
  { Moves the current pointer in VIEWPORT relative         }
1709
 
  { coordinates to the specified X,Y coordinate.           }
1710
 
  {********************************************************}
1711
 
    Begin
1712
 
     CurrentX := X;
1713
 
     CurrentY := Y;
1714
 
    end;
1715
 
 
1716
 
 
1717
 
function GraphErrorMsg(ErrorCode: smallint): string;
1718
 
Begin
1719
 
 GraphErrorMsg:='';
1720
 
 case ErrorCode of
1721
 
  grOk,grFileNotFound,grInvalidDriver: exit;
1722
 
  grNoInitGraph: GraphErrorMsg:='Graphics driver not installed';
1723
 
  grNotDetected: GraphErrorMsg:='Graphics hardware not detected';
1724
 
  grNoLoadMem,grNoScanMem,grNoFloodMem: GraphErrorMsg := 'Not enough memory for graphics';
1725
 
  grNoFontMem: GraphErrorMsg := 'Not enough memory to load font';
1726
 
  grFontNotFound: GraphErrorMsg:= 'Font file not found';
1727
 
  grInvalidMode: GraphErrorMsg := 'Invalid graphics mode';
1728
 
  grError: GraphErrorMsg:='Graphics error';
1729
 
  grIoError: GraphErrorMsg:='Graphics I/O error';
1730
 
  grInvalidFont,grInvalidFontNum: GraphErrorMsg := 'Invalid font';
1731
 
  grInvalidVersion: GraphErrorMsg:='Invalid driver version';
1732
 
 end;
1733
 
end;
1734
 
 
1735
 
 
1736
 
 
1737
 
 
1738
 
  Function GetMaxX: smallint;
1739
 
  { Routine checked against VGA driver - CEC }
1740
 
   Begin
1741
 
     GetMaxX := MaxX;
1742
 
   end;
1743
 
 
1744
 
  Function GetMaxY: smallint;
1745
 
  { Routine checked against VGA driver - CEC }
1746
 
   Begin
1747
 
    GetMaxY := MaxY;
1748
 
   end;
1749
 
 
1750
 
 
1751
 
 
1752
 
 
1753
 
Function GraphResult: smallint;
1754
 
Begin
1755
 
  GraphResult := _GraphResult;
1756
 
  _GraphResult := grOk;
1757
 
end;
1758
 
 
1759
 
 
1760
 
  Function GetX: smallint;
1761
 
   Begin
1762
 
     GetX := CurrentX;
1763
 
   end;
1764
 
 
1765
 
 
1766
 
  Function GetY: smallint;
1767
 
   Begin
1768
 
     GetY := CurrentY;
1769
 
   end;
1770
 
 
1771
 
   Function GetDriverName: string;
1772
 
    begin
1773
 
      GetDriverName:=DriverName;
1774
 
    end;
1775
 
 
1776
 
 
1777
 
   procedure graphdefaults;
1778
 
   { PS: GraphDefaults does not ZERO the ArcCall structure }
1779
 
   { so a call to GetArcCoords will not change even the    }
1780
 
   { returned values even if GraphDefaults is called in    }
1781
 
   { between.                                              }
1782
 
    var
1783
 
     i: smallint;
1784
 
   begin
1785
 
     lineinfo.linestyle:=solidln;
1786
 
     lineinfo.thickness:=normwidth;
1787
 
     { reset line style pattern }
1788
 
     for i:=0 to 15 do
1789
 
       LinePatterns[i] := TRUE;
1790
 
 
1791
 
     { By default, according to the TP prog's reference }
1792
 
     { the default pattern is solid, and the default    }
1793
 
     { color is the maximum color in the palette.       }
1794
 
     fillsettings.color:=GetMaxColor;
1795
 
     fillsettings.pattern:=solidfill;
1796
 
     { GraphDefaults resets the User Fill pattern to $ff }
1797
 
     { checked with VGA BGI driver - CEC                 }
1798
 
     for i:=1 to 8 do
1799
 
       FillPatternTable[UserFill][i] := $ff;
1800
 
 
1801
 
 
1802
 
     CurrentColor:=white;
1803
 
 
1804
 
 
1805
 
     ClipPixels := TRUE;
1806
 
     { Reset the viewport }
1807
 
     StartXViewPort := 0;
1808
 
     StartYViewPort := 0;
1809
 
     ViewWidth := MaxX;
1810
 
     ViewHeight := MaxY;
1811
 
 
1812
 
     { Reset CP }
1813
 
     CurrentX := 0;
1814
 
     CurrentY := 0;
1815
 
 
1816
 
     SetBkColor(Black);
1817
 
 
1818
 
     { normal write mode }
1819
 
     CurrentWriteMode := CopyPut;
1820
 
 
1821
 
     { Schriftart einstellen }
1822
 
     CurrentTextInfo.font := DefaultFont;
1823
 
     CurrentTextInfo.direction:=HorizDir;
1824
 
     CurrentTextInfo.charsize:=1;
1825
 
     CurrentTextInfo.horiz:=LeftText;
1826
 
     CurrentTextInfo.vert:=TopText;
1827
 
 
1828
 
     XAspect:=10000; YAspect:=10000;
1829
 
   end;
1830
 
 
1831
 
 
1832
 
  procedure GetAspectRatio(var Xasp,Yasp : word);
1833
 
  begin
1834
 
    XAsp:=XAspect;
1835
 
    YAsp:=YAspect;
1836
 
  end;
1837
 
 
1838
 
  procedure SetAspectRatio(Xasp, Yasp : word);
1839
 
  begin
1840
 
    Xaspect:= XAsp;
1841
 
    YAspect:= YAsp;
1842
 
  end;
1843
 
 
1844
 
 
1845
 
  procedure SetWriteMode(WriteMode : smallint);
1846
 
  { TP sets the writemodes according to the following scheme (JM) }
1847
 
   begin
1848
 
     Case writemode of
1849
 
       xorput, andput: CurrentWriteMode := XorPut;
1850
 
       notput, orput, copyput: CurrentWriteMode := CopyPut;
1851
 
     End;
1852
 
   end;
1853
 
 
1854
 
 
1855
 
  procedure GetFillSettings(var Fillinfo:Fillsettingstype);
1856
 
   begin
1857
 
     Fillinfo:=Fillsettings;
1858
 
   end;
1859
 
 
1860
 
  procedure GetFillPattern(var FillPattern:FillPatternType);
1861
 
   begin
1862
 
     FillPattern:=FillpatternTable[UserFill];
1863
 
   end;
1864
 
 
1865
 
  procedure DrawPoly(numpoints : word;var polypoints);
1866
 
    type
1867
 
      ppointtype = ^pointtype;
1868
 
      pt = array[0..16000] of pointtype;
1869
 
    var
1870
 
      i : longint;
1871
 
    begin
1872
 
      if numpoints < 2 then
1873
 
        begin
1874
 
          _GraphResult := grError;
1875
 
          exit;
1876
 
        end;
1877
 
      for i:=0 to numpoints-2 do
1878
 
        line(pt(polypoints)[i].x,
1879
 
             pt(polypoints)[i].y,
1880
 
             pt(polypoints)[i+1].x,
1881
 
             pt(polypoints)[i+1].y);
1882
 
    end;
1883
 
 
1884
 
 
1885
 
  procedure PieSlice(X,Y,stangle,endAngle:smallint;Radius: Word);
1886
 
  begin
1887
 
    Sector(x,y,stangle,endangle,radius,radius);
1888
 
  end;
1889
 
 
1890
 
{$i fills.inc}
1891
 
{$i gtext.inc}
1892
 
 
1893
 
  procedure internDetectGraph(var GraphDriver, GraphMode:smallint;
1894
 
    calledFromInitGraph: boolean);
1895
 
  var LoMode, HiMode: smallint;
1896
 
      CpyMode: smallint;
1897
 
      CpyDriver: smallint;
1898
 
  begin
1899
 
    HiMode := -1;
1900
 
    LoMode := -1;
1901
 
    if not calledFromInitGraph or
1902
 
       (graphDriver < lowNewDriver) or
1903
 
       (graphDriver > highNewDriver) then
1904
 
      begin
1905
 
        { Search lowest supported bitDepth }
1906
 
        graphdriver := D1bit;
1907
 
        while (graphDriver <= highNewDriver) and
1908
 
              (hiMode = -1) do
1909
 
          begin
1910
 
            getModeRange(graphDriver,loMode,hiMode);
1911
 
            inc(graphDriver);
1912
 
          end;
1913
 
        dec(graphdriver);
1914
 
        if hiMode = -1 then
1915
 
          begin
1916
 
            _GraphResult := grNotDetected;
1917
 
            exit;
1918
 
          end;
1919
 
        CpyMode := 0;
1920
 
        repeat
1921
 
           GetModeRange(GraphDriver,LoMode,HiMode);
1922
 
           { save the highest mode possible...}
1923
 
           {$ifdef logging}
1924
 
           logln('Found driver '+strf(graphdriver)+' with modes '+
1925
 
                  strf(lomode)+' - '+strf(himode));
1926
 
           {$endif logging}
1927
 
           if HiMode <> -1 then
1928
 
             begin
1929
 
               CpyMode:=HiMode;
1930
 
               CpyDriver:=GraphDriver;
1931
 
             end;
1932
 
           { go to next driver if it exists...}
1933
 
           Inc(graphDriver);
1934
 
        until (graphDriver > highNewDriver);
1935
 
      end
1936
 
    else
1937
 
      begin
1938
 
        cpyMode := 0;
1939
 
        getModeRange(graphDriver,loMode,hiMode);
1940
 
        if hiMode <> -1 then
1941
 
          begin
1942
 
            cpyDriver := graphDriver;
1943
 
            cpyMode := hiMode;
1944
 
          end;
1945
 
      end;
1946
 
    if cpyMode = 0 then
1947
 
      begin
1948
 
        _GraphResult := grNotDetected;
1949
 
        exit;
1950
 
      end;
1951
 
    _GraphResult := grOK;
1952
 
    GraphDriver := CpyDriver;
1953
 
    GraphMode := CpyMode;
1954
 
  end;
1955
 
 
1956
 
  procedure detectGraph(var GraphDriver: smallint; var GraphMode:smallint);
1957
 
  begin
1958
 
    internDetectGraph(graphDriver,graphMode,false);
1959
 
  end;
1960
 
 
1961
 
  procedure InitGraph(var GraphDriver:smallint;var GraphMode:smallint;
1962
 
    const PathToDriver:String);
1963
 
  const
1964
 
    dirchar = System.DirectorySeparator;
1965
 
  begin
1966
 
    InitVars;
1967
 
    { path to the fonts (where they will be searched)...}
1968
 
    bgipath:=PathToDriver;
1969
 
    if (Length(bgipath) > 0) and (bgipath[length(bgipath)]<>dirchar) then
1970
 
      bgipath:=bgipath+dirchar;
1971
 
 
1972
 
    if not assigned(SaveVideoState) then
1973
 
      RunError(216);
1974
 
    DriverName:=InternalDriverName;   { DOS Graphics driver }
1975
 
 
1976
 
    if (Graphdriver=Detect)
1977
 
       or (GraphMode = detectMode) then
1978
 
      begin
1979
 
        internDetectGraph(GraphDriver,GraphMode,true);
1980
 
        If _GraphResult = grNotDetected then Exit;
1981
 
 
1982
 
        { _GraphResult is now already set to grOK by DetectGraph }
1983
 
        IntCurrentDriver := GraphDriver;
1984
 
 
1985
 
        if (graphDriver >= lowNewDriver) and
1986
 
           (graphDriver <= highNewDriver) then
1987
 
          IntCurrentNewDriver := GraphDriver
1988
 
        else IntCurrentNewDriver := -1;
1989
 
 
1990
 
        { Actually set the graph mode...}
1991
 
        if firstCallOfInitgraph then
1992
 
          begin
1993
 
            SaveVideoState;
1994
 
            firstCallOfInitgraph := false;
1995
 
          end;
1996
 
        SetGraphMode(GraphMode);
1997
 
      end
1998
 
    else
1999
 
      begin
2000
 
        { Search if that graphics modec actually exists...}
2001
 
        if SearchMode(GraphDriver,GraphMode) = nil then
2002
 
          begin
2003
 
            _GraphResult := grInvalidMode;
2004
 
            exit;
2005
 
         end
2006
 
        else
2007
 
         begin
2008
 
           _GraphResult := grOK;
2009
 
           IntCurrentDriver := GraphDriver;
2010
 
 
2011
 
           if (graphDriver >= lowNewDriver) and
2012
 
              (graphDriver <= highNewDriver) then
2013
 
             IntCurrentNewDriver := GraphDriver
2014
 
           else IntCurrentNewDriver := -1;
2015
 
 
2016
 
           if firstCallOfInitgraph then
2017
 
             begin
2018
 
               SaveVideoState;
2019
 
               firstCallOfInitgraph := false;
2020
 
             end;
2021
 
           SetGraphMode(GraphMode);
2022
 
         end;
2023
 
      end;
2024
 
  end;
2025
 
 
2026
 
 
2027
 
 procedure SetDirectVideo(DirectAccess: boolean);
2028
 
  begin
2029
 
    DirectVideo := DirectAccess;
2030
 
  end;
2031
 
 
2032
 
 function GetDirectVideo: boolean;
2033
 
  begin
2034
 
    GetDirectVideo := DirectVideo;
2035
 
  end;
2036
 
 
2037
 
 procedure GraphExitProc; {$ifndef fpc} far; {$endif fpc}
2038
 
 { deallocates all memory allocated by the graph unit }
2039
 
  var
2040
 
    list: PModeInfo;
2041
 
    tmp : PModeInfo;
2042
 
    c: longint;
2043
 
  begin
2044
 
   { restore old exitproc! }
2045
 
   exitproc := exitsave;
2046
 
   if IsGraphMode and ((errorcode<>0) or (erroraddr<>nil)) then
2047
 
     CloseGraph;
2048
 
   { release memory allocated for fonts }
2049
 
   for c := 1 to installedfonts do
2050
 
     with fonts[c] Do
2051
 
       If assigned(instr) Then
2052
 
         System.Freemem(instr,instrlength);
2053
 
   { release memory allocated for modelist }
2054
 
   list := ModeList;
2055
 
   while assigned(list) do
2056
 
     begin
2057
 
       tmp := list;
2058
 
       list:=list^.next;
2059
 
       dispose(tmp);
2060
 
     end;
2061
 
   for c := lowNewDriver to highNewDriver do
2062
 
     begin
2063
 
       list := newModeList.modeinfo[c];
2064
 
       while assigned(list) do
2065
 
         begin
2066
 
           tmp := list;
2067
 
           list:=list^.next;
2068
 
           dispose(tmp);
2069
 
         end;
2070
 
     end;
2071
 
{$IFDEF DPMI}
2072
 
  { We had copied the buffer of mode information }
2073
 
  { and allocated it dynamically... now free it  }
2074
 
  { Warning: if GetVESAInfo returned false, this buffer is not allocated! (JM)}
2075
 
   If hasVesa then
2076
 
     Dispose(VESAInfo.ModeList);
2077
 
{$ENDIF}
2078
 
  end;
2079
 
 
2080
 
 
2081
 
procedure InitializeGraph;
2082
 
begin
2083
 
{$ifdef logging}
2084
 
 assign(debuglog,'grlog.txt');
2085
 
 rewrite(debuglog);
2086
 
 close(debuglog);
2087
 
{$endif logging}
2088
 
 isgraphmode := false;
2089
 
 ModeList := nil;
2090
 
 fillChar(newModeList.modeinfo,sizeof(newModeList.modeinfo),#0);
2091
 
 { lo and hi modenumber are -1 currently (no modes supported) }
2092
 
 fillChar(newModeList.loHiModeNr,sizeof(newModeList.loHiModeNr),#255);
2093
 
 SaveVideoState := nil;
2094
 
 RestoreVideoState := nil;
2095
 
 { This must be called at startup... because GetGraphMode may }
2096
 
 { be called even when not in graph mode.                     }
2097
 
{$ifdef logging}
2098
 
 LogLn('Calling QueryAdapterInfo...');
2099
 
{$endif logging}
2100
 
 QueryAdapterInfo;
2101
 
 { Install standard fonts }
2102
 
 { This is done BEFORE startup... }
2103
 
 InstalledFonts := 0;
2104
 
 InstallUserFont('TRIP');
2105
 
 InstallUserFont('LITT');
2106
 
 InstallUserFont('SANS');
2107
 
 InstallUserFont('GOTH');
2108
 
 InstallUserFont('SCRI');
2109
 
 InstallUserFont('SIMP');
2110
 
 InstallUserFont('TSCR');
2111
 
 InstallUserFont('LCOM');
2112
 
 InstallUserFont('EURO');
2113
 
 InstallUserFont('BOLD');
2114
 
 { This installs an exit procedure which cleans up the mode list...}
2115
 
 ExitSave := ExitProc;
2116
 
 ExitProc := @GraphExitProc;
2117
 
{$ifdef win32}
2118
 
 charmessagehandler:=nil;
2119
 
{$endif win32}
2120
 
end;