1{
2    This file is part of the Free Pascal run time library.
3    Copyright (c) 1999-2000 by Florian Klaempfl
4
5    This file implements the linux GGI support for the graph unit
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 **********************************************************************}
15unit Graph;
16interface
17
18uses
19  { in the interface so the graphh definitions of moveto etc override }
20  { the ones in the universal interfaces                              }
21  MacOSAll;
22
23{$pascalmainname FPCMacOSXGraphMain}
24
25{$i graphh.inc}
26
27Const
28  { Supported modes }
29  G320x200x16       = 1;
30  G640x200x16       = 2;
31  G640x350x16       = 3;
32  G640x480x16       = 4;
33  G320x200x256      = 5;
34  G320x240x256      = 6;
35  G320x400x256      = 7;
36  G360x480x256      = 8;
37  G640x480x2        = 9;
38
39  G640x480x256      = 10;
40  G800x600x256      = 11;
41  G1024x768x256     = 12;
42
43  G1280x1024x256    = 13;   { Additional modes. }
44
45  G320x200x32K      = 14;
46  G320x200x64K      = 15;
47  G320x200x16M      = 16;
48  G640x480x32K      = 17;
49  G640x480x64K      = 18;
50  G640x480x16M      = 19;
51  G800x600x32K      = 20;
52  G800x600x64K      = 21;
53  G800x600x16M      = 22;
54  G1024x768x32K     = 23;
55  G1024x768x64K     = 24;
56  G1024x768x16M     = 25;
57  G1280x1024x32K    = 26;
58  G1280x1024x64K    = 27;
59  G1280x1024x16M    = 28;
60
61  G800x600x16       = 29;
62  G1024x768x16      = 30;
63  G1280x1024x16     = 31;
64
65  G720x348x2        = 32;               { Hercules emulation mode }
66
67  G320x200x16M32    = 33;       { 32-bit per pixel modes. }
68  G640x480x16M32    = 34;
69  G800x600x16M32    = 35;
70  G1024x768x16M32   = 36;
71  G1280x1024x16M32  = 37;
72
73  { additional resolutions }
74  G1152x864x16      = 38;
75  G1152x864x256     = 39;
76  G1152x864x32K     = 40;
77  G1152x864x64K     = 41;
78  G1152x864x16M     = 42;
79  G1152x864x16M32   = 43;
80
81  G1600x1200x16     = 44;
82  G1600x1200x256    = 45;
83  G1600x1200x32K    = 46;
84  G1600x1200x64K    = 47;
85  G1600x1200x16M    = 48;
86  G1600x1200x16M32  = 49;
87
88
89implementation
90
91uses
92  { for FOUR_CHAR_CODE }
93  macpas,
94  baseunix,
95  unix,
96  ctypes,
97  pthreads;
98
99const
100  InternalDriverName = 'Quartz';
101
102  kEventClassFPCGraph = $46504367; // 'FPCg'
103  kEventInitGraph     = $496E6974; // 'Init'
104  kEventFlush         = $466c7368; // 'Flsh'
105  kEventCloseGraph    = $446f6e65; // 'Done'
106  kEventQuit          = $51756974; // 'Quit'
107
108  kEventGraphInited   = $49746564 ; // Ited;
109  kEventGraphClosed   = $436c6564 ; // Cled;
110
111//  initGraphSpec  : EventTypeSpec = (eventClass: kEventClassFPCGraph; eventKind: kEventInitGraph);
112//  flushGraphSpec : EventTypeSpec = (eventClass: kEventClassFPCGraph; eventKind: kEventFlush);
113//  closeGraphSpec  : EventTypeSpec = (eventClass: kEventClassFPCGraph; eventKind: kEventCloseGraph);
114  allGraphSpec: array[0..3] of EventTypeSpec = ((eventClass: kEventClassFPCGraph; eventKind: kEventInitGraph),
115                                                (eventClass: kEventClassFPCGraph; eventKind: kEventFlush),
116                                                (eventClass: kEventClassFPCGraph; eventKind: kEventCloseGraph),
117                                                (eventClass: kEventClassFPCGraph; eventKind: kEventQuit));
118
119  GraphInitedSpec: array[0..0] of EventTypeSpec = ((eventClass: kEventClassFPCGraph; eventKind: kEventGraphInited));
120  GraphClosedSpec: array[0..0] of EventTypeSpec = ((eventClass: kEventClassFPCGraph; eventKind: kEventGraphClosed));
121
122{$i graph.inc}
123
124  type
125    PByte = ^Byte;
126    PLongInt = ^LongInt;
127
128    PByteArray = ^TByteArray;
129    TByteArray = array [0..MAXINT - 1] of Byte;
130
131  var
132    graphdrawing: TRTLCriticalSection;
133
134{ ---------------------------------------------------------------------
135   SVGA bindings.
136
137  ---------------------------------------------------------------------}
138
139Const
140  { Text }
141
142  WRITEMODE_OVERWRITE = 0;
143  WRITEMODE_MASKED    = 1;
144  FONT_EXPANDED       = 0;
145  FONT_COMPRESSED     = 2;
146
147 { Types }
148 type
149  PGraphicsContext = ^TGraphicsContext;
150  TGraphicsContext = record
151                       ModeType: Byte;
152                       ModeFlags: Byte;
153                       Dummy: Byte;
154                       FlipPage: Byte;
155                       Width: LongInt;
156                       Height: LongInt;
157                       BytesPerPixel: LongInt;
158                       Colors: LongInt;
159                       BitsPerPixel: LongInt;
160                       ByteWidth: LongInt;
161                       VBuf: pointer;
162                       Clip: LongInt;
163                       ClipX1: LongInt;
164                       ClipY1: LongInt;
165                       ClipX2: LongInt;
166                       ClipY2: LongInt;
167                       ff: pointer;
168                     end;
169
170Const
171  GLASTMODE         = 49;
172  ModeNames : Array[0..GLastMode] of string [18] =
173   ('Text',
174    'G320x200x16',
175    'G640x200x16',
176    'G640x350x16',
177    'G640x480x16',
178    'G320x200x256',
179    'G320x240x256',
180    'G320x400x256',
181    'G360x480x256',
182    'G640x480x2',
183    'G640x480x256',
184    'G800x600x256',
185    'G1024x768x256',
186    'G1280x1024x256',
187    'G320x200x32K',
188    'G320x200x64K',
189    'G320x200x16M',
190    'G640x480x32K',
191    'G640x480x64K',
192    'G640x480x16M',
193    'G800x600x32K',
194    'G800x600x64K',
195    'G800x600x16M',
196    'G1024x768x32K',
197    'G1024x768x64K',
198    'G1024x768x16M',
199    'G1280x1024x32K',
200    'G1280x1024x64K',
201    'G1280x1024x16M',
202    'G800x600x16',
203    '1024x768x16',
204    '1280x1024x16',
205    'G720x348x2',
206    'G320x200x16M32',
207    'G640x480x16M32',
208    'G800x600x16M32',
209    'G1024x768x16M32',
210    'G1280x1024x16M32',
211    'G1152x864x16',
212    'G1152x864x256',
213    'G1152x864x32K',
214    'G1152x864x64K',
215    'G1152x864x16M',
216    'G1152x864x16M32',
217    'G1600x1200x16',
218    'G1600x1200x256',
219    'G1600x1200x32K',
220    'G1600x1200x64K',
221    'G1600x1200x16M',
222    'G1600x1200x16M32');
223
224
225{ ---------------------------------------------------------------------
226    Mac OS X - specific stuff
227  ---------------------------------------------------------------------}
228
229
230var
231  { where all the drawing occurs }
232  offscreen: CGContextRef;
233  { the drawing window's contents to which offscreen is flushed }
234  graphHIView: HIViewRef;
235  { the drawing window itself }
236  myMainWindow: WindowRef;
237  maineventqueue: EventQueueRef;
238  updatepending: boolean;
239
240  colorpalette: array[0..255,1..3] of single;
241
242
243{ create a new offscreen bitmap context in which we can draw (and from }
244{ which we can read again)                                             }
245function CreateBitmapContext (pixelsWide, pixelsHigh: SInt32) : CGContextRef;
246var
247    colorSpace        : CGColorSpaceRef;
248    bitmapData        : Pointer;
249    bitmapByteCount   : SInt32;
250    bitmapBytesPerRow : SInt32;
251begin
252  CreateBitmapContext := nil;
253
254  bitmapBytesPerRow   := (pixelsWide * 4);// always draw in 24 bit colour (+ 8 bit alpha)
255  bitmapByteCount     := (bitmapBytesPerRow * pixelsHigh);
256
257  colorSpace := CGColorSpaceCreateDeviceRGB;// 2
258  bitmapData := getmem ( bitmapByteCount );// 3
259  if (bitmapData = nil) then
260    exit;
261
262  CreateBitmapContext := CGBitmapContextCreate (bitmapData,
263                                  pixelsWide,
264                                  pixelsHigh,
265                                  8,      // bits per component
266                                  bitmapBytesPerRow,
267                                  colorSpace,
268                                  kCGImageAlphaPremultipliedLast);
269  if (CreateBitmapContext = nil) then
270    begin
271      system.freemem (bitmapData);
272      writeln (stderr, 'Could not create graphics context!');
273      exit;
274    end;
275    CGColorSpaceRelease( colorSpace );
276    { disable anti-aliasing }
277    CGContextTranslateCTM(CreateBitmapContext,0.5,0.5);
278end;
279
280
281{ dispose the offscreen bitmap context }
282procedure DisposeBitmapContext(var bmContext: CGContextRef);
283begin
284  system.freemem(CGBitmapContextGetData(bmContext));
285  CGContextRelease(bmContext);
286  bmContext:=nil;
287end;
288
289
290{ create a HIView to add to a window, in which we can then draw }
291function CreateHIView (inWindow: WindowRef; const inBounds: Rect; var outControl: HIObjectRef): OSStatus;
292  var
293    root  : ControlRef;
294    event : EventRef;
295    err   : OSStatus;
296  label
297    CantCreate, CantGetRootControl, CantSetParameter, CantCreateEvent{, CantRegister};
298  begin
299    // Make an initialization event
300    err := CreateEvent( nil, kEventClassHIObject, kEventHIObjectInitialize,
301                        GetCurrentEventTime(), 0, event );
302    if (err <> noErr) then
303      goto CantCreateEvent;
304
305    // If bounds were specified, push the them into the initialization event
306    // so that they can be used in the initialization handler.
307    err := SetEventParameter( event, FOUR_CHAR_CODE('boun'), typeQDRectangle,
308           sizeof( Rect ), @inBounds );
309    if (err <> noErr) then
310      goto CantSetParameter;
311
312    err := HIObjectCreate( { kHIViewClassID } CFSTR('com.apple.hiview'), event, outControl );
313    assert(err = noErr);
314
315    // If a parent window was specified, place the new view into the
316    // parent window.
317    err := GetRootControl( inWindow, root );
318    if (err <> noErr) then
319      goto CantGetRootControl;
320    err := HIViewAddSubview( root, outControl );
321    if (err <> noErr) then
322      goto CantGetRootControl;
323
324    err := HIViewSetVisible(outControl, true);
325
326CantCreate:
327CantGetRootControl:
328CantSetParameter:
329CantCreateEvent:
330    ReleaseEvent( event );
331
332    CreateHIView := err;
333  end;
334
335
336{ Event handler which does the actual drawing by copying the offscreen to }
337{ the HIView of the drawing window                                        }
338function MyDrawEventHandler (myHandler: EventHandlerCallRef;
339                        event: EventRef; userData: pointer): OSStatus; mwpascal;
340  var
341    myContext: CGContextRef;
342    bounds: HIRect;
343    img: CGImageRef;
344  begin
345//      writeln('event');
346      MyDrawEventHandler := GetEventParameter (event, // 1
347                              kEventParamCGContextRef,
348                              typeCGContextRef,
349                              nil,
350                              sizeof (CGContextRef),
351                              nil,
352                              @myContext);
353    if (MyDrawEventHandler <> noErr) then
354      exit;
355    MyDrawEventHandler := HIViewGetBounds (HIViewRef(userData), bounds);
356    if (MyDrawEventHandler <> noErr) then
357      exit;
358    EnterCriticalSection(graphdrawing);
359    img:=CGBitmapContextCreateImage(offscreen);
360    CGContextDrawImage(myContext,
361                       bounds,
362                       img);
363    updatepending:=false;
364    LeaveCriticalSection(graphdrawing);
365    CGImageRelease(img);
366end;
367
368
369{ force the draw event handler to fire }
370procedure UpdateScreen;
371var
372  event : EventRef;
373begin
374  if (updatepending) then
375    exit;
376
377  if (CreateEvent(nil, kEventClassFPCGraph, kEventFlush, GetCurrentEventTime(), 0, event) <> noErr) then
378    exit;
379
380  if (PostEventToQueue(MainEventQueue,event,kEventPriorityLow) <> noErr) then
381    begin
382      ReleaseEvent(event);
383      exit;
384    end;
385  updatepending:=true;
386end;
387
388
389{ ---------------------------------------------------------------------
390    Required procedures
391  ---------------------------------------------------------------------}
392var
393  LastColor: smallint;   {Cache the last set color to improve speed}
394
395procedure q_SetColor(color: smallint);
396begin
397  if color <> LastColor then
398    begin
399//      writeln('setting color to ',color);
400      EnterCriticalSection(graphdrawing);
401      case maxcolor of
402        16:
403          begin
404            CGContextSetRGBFillColor(offscreen,colorpalette[color,1],colorpalette[color,2],colorpalette[color,3],1);
405            CGContextSetRGBStrokeColor(offscreen,colorpalette[color,1],colorpalette[color,2],colorpalette[color,3],1);
406          end;
407        256:
408          begin
409            CGContextSetRGBFillColor(offscreen,colorpalette[color,1],colorpalette[color,2],colorpalette[color,3],1);
410            CGContextSetRGBStrokeColor(offscreen,colorpalette[color,1],colorpalette[color,2],colorpalette[color,3],1);
411          end;
412        32678:
413          begin
414            CGContextSetRGBFillColor(offscreen,((color and $7ffff) shr 10)/31.0,((color shr 5) and 31)/31.0,(color and 31)/31.0,1);
415            CGContextSetRGBStrokeColor(offscreen,((color and $7ffff) shr 10)/31.0,((color shr 5) and 31)/31.0,(color and 31)/31.0,1);
416          end;
417        65536:
418          begin
419            CGContextSetRGBFillColor(offscreen,(word(color) shr 11)/31.0,((word(color) shr 5) and 63)/63.0,(color and 31)/31.0,1);
420            CGContextSetRGBStrokeColor(offscreen,(word(color) shr 11)/31.0,((word(color) shr 5) and 63)/63.0,(color and 31)/31.0,1);
421          end;
422        else
423          runerror(218);
424      end;
425      LeaveCriticalSection(graphdrawing);
426      lastcolor:=color;
427    end
428end;
429
430
431procedure q_savevideostate;
432begin
433end;
434
435procedure q_restorevideostate;
436begin
437end;
438
439
440function CGRectMake(x,y, width, height: single): CGRect; inline;
441begin
442  CGRectMake.origin.x:=x;
443  CGRectMake.origin.y:=y;
444  CGRectMake.size.width:=width;
445  CGRectMake.size.height:=height;
446end;
447
448
449Function ClipCoords (Var X,Y : smallint) : Boolean;
450{ Adapt to viewport, return TRUE if still in viewport,
451  false if outside viewport}
452
453begin
454  X:= X + StartXViewPort;
455  Y:= Y + StartYViewPort;
456  ClipCoords:=Not ClipPixels;
457  if ClipPixels then
458    Begin
459    ClipCoords:=(X < StartXViewPort) or (X > (StartXViewPort + ViewWidth));
460    ClipCoords:=ClipCoords or
461               ((Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)));
462    ClipCoords:=Not ClipCoords;
463    end;
464end;
465
466
467procedure q_directpixelproc(X,Y: smallint);
468
469Var Color : Word;
470
471begin
472  case CurrentWriteMode of
473    XORPut:
474      begin
475        { getpixel wants local/relative coordinates }
476        Color := GetPixel(x-StartXViewPort,y-StartYViewPort);
477        Color := CurrentColor Xor Color;
478      end;
479    OrPut:
480      begin
481        { getpixel wants local/relative coordinates }
482        Color := GetPixel(x-StartXViewPort,y-StartYViewPort);
483        Color := CurrentColor Or Color;
484      end;
485    AndPut:
486      begin
487        { getpixel wants local/relative coordinates }
488        Color := GetPixel(x-StartXViewPort,y-StartYViewPort);
489        Color := CurrentColor And Color;
490      end;
491    NotPut:
492      begin
493        Color := Not CurrentColor;
494      end
495  else
496    Color:=CurrentColor;
497  end;
498  q_SetColor(Color);
499  EnterCriticalSection(graphdrawing);
500  CGContextBeginPath(offscreen);
501  CGContextMoveToPoint(offscreen,x,y);
502  CGContextAddLineToPoint(offscreen,x,y);
503  CGContextClosePath(offscreen);
504  CGContextStrokePath(offscreen);
505  UpdateScreen;
506  LeaveCriticalSection(graphdrawing);
507end;
508
509procedure q_putpixelproc(X,Y: smallint; Color: Word);
510begin
511  if Not ClipCoords(X,Y) Then
512    exit;
513  q_setcolor(Color);
514  EnterCriticalSection(graphdrawing);
515  CGContextBeginPath(offscreen);
516  CGContextMoveToPoint(offscreen,x,y);
517  CGContextAddLineToPoint(offscreen,x,y);
518  CGContextClosePath(offscreen);
519  CGContextStrokePath(offscreen);
520  UpdateScreen;
521  LeaveCriticalSection(graphdrawing);
522end;
523
524function q_getpixelproc (X,Y: smallint): word;
525type
526  pbyte = ^byte;
527var
528  p: pbyte;
529  rsingle, gsingle, bsingle, dist, closest: single;
530  count: longint;
531  red, green, blue: byte;
532begin
533 if not ClipCoords(X,Y) then
534   exit;
535 p := pbyte(CGBitmapContextGetData(offscreen));
536 y:=maxy-y;
537 inc(p,(y*(maxx+1)+x)*4);
538 red:=p^;
539 green:=(p+1)^;
540 blue:=(p+2)^;
541 case maxcolor of
542   16, 256:
543     begin
544       { find closest color using least squares }
545       rsingle:=red/255.0;
546       gsingle:=green/255.0;
547       bsingle:=blue/255.0;
548       closest:=255.0;
549       q_getpixelproc:=0;
550       for count := 0 to maxcolor-1 do
551         begin
552           dist:=sqr(colorpalette[count,1]-rsingle) +
553                sqr(colorpalette[count,2]-gsingle) +
554                sqr(colorpalette[count,3]-bsingle);
555           if (dist < closest) then
556             begin
557               closest:=dist;
558               q_getpixelproc:=count;
559             end;
560         end;
561       exit;
562     end;
563   32678:
564     q_getpixelproc:=((red div 8) shl 7) or ((green div 8) shl 2) or (blue div 8);
565   65536:
566     q_getpixelproc:=((red div 8) shl 8) or ((green div 4) shl 3) or (blue div 8);
567 end;
568end;
569
570procedure q_clrviewproc;
571
572begin
573  q_SetColor(CurrentBkColor);
574  EnterCriticalSection(graphdrawing);
575  CGContextFillRect(offscreen,CGRectMake(StartXViewPort,StartYViewPort,ViewWidth+1,ViewHeight+1));
576  UpdateScreen;
577  LeaveCriticalSection(graphdrawing);
578  { reset coordinates }
579  CurrentX := 0;
580  CurrentY := 0;
581end;
582
583procedure q_putimageproc (X,Y: smallint; var Bitmap; BitBlt: Word);
584begin
585{
586  With TBitMap(BitMap) do
587    gl_putbox(x, y, width, height, @Data);
588}
589end;
590
591procedure q_getimageproc (X1,Y1,X2,Y2: smallint; Var Bitmap);
592begin
593{  with TBitmap(Bitmap) do
594    begin
595    Width := x2 - x1 + 1;
596    Height := y2 - y1 + 1;
597    gl_getbox(x1,y1, x2 - x1 + 1, y2 - y1 + 1, @Data);
598    end;
599}
600end;
601
602{
603function  q_imagesizeproc (X1,Y1,X2,Y2: smallint): longint;
604begin
605 q_imagesizeproc := SizeOf(TBitmap) + (x2 - x1 + 1) * (y2 - y1 + 1) * PhysicalScreen^.BytesPerPixel;
606
607end;
608}
609
610procedure q_lineproc_intern (X1, Y1, X2, Y2 : smallint);
611begin
612  if (CurrentWriteMode in [OrPut,AndPut,XorPut]) then
613    begin
614      LineDefault(X1,Y1,X2,Y2);
615      exit
616    end
617  else
618    begin
619      { Convert to global coordinates. }
620      x1 := x1 + StartXViewPort;
621      x2 := x2 + StartXViewPort;
622      y1 := y1 + StartYViewPort;
623      y2 := y2 + StartYViewPort;
624      if ClipPixels then
625        if LineClipped(x1,y1,x2,y2,StartXViewPort,StartYViewPort,
626                       StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
627           exit;
628      if (CurrentWriteMode = NotPut) then
629        q_SetColor(not(currentcolor))
630      else
631        q_SetColor(currentcolor);
632    end;
633  EnterCriticalSection(graphdrawing);
634  CGContextBeginPath(offscreen);
635  CGContextMoveToPoint(offscreen,x1,y1);
636  CGContextAddLineToPoint(offscreen,x2,y2);
637  CGContextClosePath(offscreen);
638  CGContextStrokePath(offscreen);
639  UpdateScreen;
640  LeaveCriticalSection(graphdrawing);
641end;
642
643
644procedure q_lineproc (X1, Y1, X2, Y2 : smallint);
645begin
646  if (CurrentWriteMode in [OrPut,AndPut,XorPut]) or
647     (lineinfo.LineStyle <> SolidLn) or
648     (lineinfo.Thickness<>NormWidth) then
649    begin
650      LineDefault(X1,Y1,X2,Y2);
651      exit
652    end
653  else
654    begin
655      { Convert to global coordinates. }
656      x1 := x1 + StartXViewPort;
657      x2 := x2 + StartXViewPort;
658      y1 := y1 + StartYViewPort;
659      y2 := y2 + StartYViewPort;
660      if ClipPixels then
661        if LineClipped(x1,y1,x2,y2,StartXViewPort,StartYViewPort,
662                       StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
663           exit;
664      if (CurrentWriteMode = NotPut) then
665        q_SetColor(not(currentcolor))
666      else
667        q_SetColor(currentcolor);
668    end;
669  EnterCriticalSection(graphdrawing);
670  CGContextBeginPath(offscreen);
671  CGContextMoveToPoint(offscreen,x1,y1);
672  CGContextAddLineToPoint(offscreen,x2,y2);
673  CGContextClosePath(offscreen);
674  CGContextStrokePath(offscreen);
675  UpdateScreen;
676  LeaveCriticalSection(graphdrawing);
677end;
678
679
680procedure q_hlineproc (x, x2,y : smallint);
681begin
682  if (CurrentWriteMode in [OrPut,AndPut,XorPut]) then
683    HLineDefault(X,X2,Y)
684  else
685    q_lineproc_intern(x,y,x2,y);
686end;
687
688procedure q_vlineproc (x,y,y2: smallint);
689begin
690  if (CurrentWriteMode in [OrPut,AndPut,XorPut]) then
691    VLineDefault(x,y,y2)
692  else
693    q_lineproc_intern(x,y,x,y2);
694end;
695
696procedure q_patternlineproc (x1,x2,y: smallint);
697begin
698end;
699
700procedure q_ellipseproc  (X,Y: smallint;XRadius: word;
701  YRadius:word; stAngle,EndAngle: word; fp: PatternLineProc);
702begin
703end;
704
705procedure q_getscanlineproc (X1,X2,Y : smallint; var data);
706begin
707end;
708
709procedure q_setactivepageproc (page: word);
710begin
711end;
712
713procedure q_setvisualpageproc (page: word);
714begin
715end;
716
717
718procedure q_savestateproc;
719begin
720end;
721
722procedure q_restorestateproc;
723begin
724end;
725
726procedure q_setrgbpaletteproc(ColorNum, RedValue, GreenValue, BlueValue: smallint);
727begin
728  { vga is only 6 bits per channel, palette values go from 0 to 252 }
729  colorpalette[ColorNum,1]:=RedValue * (1.0/252.0);
730  colorpalette[ColorNum,2]:=GreenValue * (1.0/252.0);
731  colorpalette[ColorNum,3]:=BlueValue * (1.0/252.0);
732end;
733
734procedure q_getrgbpaletteproc (ColorNum: smallint; var RedValue, GreenValue, BlueValue: smallint);
735begin
736  RedValue:=trunc(colorpalette[ColorNum,1]*252.0);
737  GreenValue:=trunc(colorpalette[ColorNum,2]*252.0);
738  BlueValue:=trunc(colorpalette[ColorNum,3]*252.0);
739end;
740
741
742procedure InitColors(nrColors: longint);
743
744var
745  i: smallint;
746begin
747  for i:=0 to nrColors-1 do
748    q_setrgbpaletteproc(I,DefaultColors[i].red,
749      DefaultColors[i].green,DefaultColors[i].blue)
750end;
751
752procedure q_initmodeproc;
753const
754  myHIViewSpec  : EventTypeSpec = (eventClass: kEventClassControl; eventKind: kEventControlDraw);
755var
756 windowAttrs:   WindowAttributes;
757 contentRect:   Rect;
758 titleKey:      CFStringRef;
759 windowTitle:   CFStringRef;
760 err:           OSStatus;
761 hiviewbounds : HIRect;
762 b: boolean;
763begin
764  windowAttrs := kWindowStandardDocumentAttributes // 1
765                        or kWindowStandardHandlerAttribute
766                        or kWindowInWindowMenuAttribute
767                        or kWindowCompositingAttribute
768                        or kWindowLiveResizeAttribute
769                        or kWindowNoUpdatesAttribute;
770
771  SetRect (contentRect, 0,  0,
772                         MaxX+1, MaxY+1);
773
774  CreateNewWindow (kDocumentWindowClass, windowAttrs,// 3
775                         contentRect, myMainWindow);
776
777  SetRect (contentRect, 0,  50,
778                         MaxX+1, 51+MaxY);
779
780  SetWindowBounds(myMainWindow,kWindowContentRgn,contentrect);
781  titleKey    := CFSTR('Graph Window'); // 4
782  windowTitle := CFCopyLocalizedString(titleKey, nil); // 5
783  err := SetWindowTitleWithCFString (myMainWindow, windowTitle); // 6
784  CFRelease (titleKey); // 7
785  CFRelease (windowTitle);
786
787  with contentRect do
788    begin
789      top:=0;
790      left:=0;
791      bottom:=MaxY+1;
792      right:=MaxX+1;
793    end;
794
795  offscreen:=CreateBitmapContext(MaxX+1,MaxY+1);
796  if (offscreen = nil) then
797    begin
798      _GraphResult:=grNoLoadMem;
799      exit;
800    end;
801  CGContextSetShouldAntialias(offscreen,0);
802
803  if (CreateHIView(myMainWindow,contentRect,graphHIView) <> noErr) then
804    begin
805      DisposeBitmapContext(offscreen);
806      _GraphResult:=grError;
807      exit;
808    end;
809
810
811//   HIViewFindByID( HIViewGetRoot( myMainWindow ), kHIViewWindowContentID, graphHIView );
812
813  if InstallEventHandler (GetControlEventTarget (graphHIView),
814                          NewEventHandlerUPP (@MyDrawEventHandler),
815                          { GetEventTypeCount (myHIViewSpec)} 1,
816                          @myHIViewSpec,
817                          pointer(graphHIView),
818                          Nil) <> noErr then
819    begin
820      DisposeWindow(myMainWindow);
821      DisposeBitmapContext(offscreen);
822      _GraphResult:=grError;
823      exit;
824    end;
825
826  LastColor:=-1;
827  if (maxcolor=16) or (maxcolor=256) then
828    InitColors(maxcolor);
829
830  CGContextSetLineWidth(offscreen,1.0);
831
832  { start with a black background }
833  CGContextSetRGBStrokeColor(offscreen,0.0,0.0,0.0,1);
834  CGContextFillRect(offscreen,CGRectMake(0,0,MaxX+1,MaxY+1));
835  HIViewSetNeedsDisplay(graphHIView, true);
836
837  ShowWindow (myMainWindow);
838
839{
840  write('view is active: ',HIViewIsActive(graphHIView,@b));
841  writeln(', latent: ',b);
842  writeln('compositing enabled: ',HIViewIsCompositingEnabled(graphHIView));
843  writeln('visible before: ',HIViewIsVisible(graphHIView));
844  write('drawing enabled: ',HIViewIsDrawingEnabled(graphHIView));
845  writeln(', latent: ',b);
846  write('view is enabled: ',HIViewIsEnabled(graphHIView,@b));
847  writeln(', latent: ',b);
848
849  err := HIViewGetBounds(graphHIView,hiviewbounds);
850  writeln('err, ',err,' (',hiviewbounds.origin.x:0:2,',',hiviewbounds.origin.y:0:2,'),(',hiviewbounds.size.width:0:2,',',hiviewbounds.size.height:0:2,')');
851}
852end;
853
854
855{************************************************************************}
856{*                       General routines                               *}
857{************************************************************************}
858
859procedure q_donegraph;
860begin
861  If not isgraphmode then
862    begin
863      _graphresult := grnoinitgraph;
864      exit
865    end;
866  RestoreVideoState;
867  DisposeWindow(myMainWindow);
868  DisposeBitmapContext(offscreen);
869  isgraphmode := false;
870end;
871
872
873procedure CloseGraph;
874var
875  event : EventRef;
876  myQueue: EventQueueRef;
877begin
878  if (CreateEvent(nil, kEventClassFPCGraph, kEventCloseGraph, GetCurrentEventTime(), 0, event) <> noErr) then
879    begin
880      _GraphResult:=grError;
881      exit;
882    end;
883
884  myQueue := GetCurrentEventQueue;
885  if (SetEventParameter(event, FOUR_CHAR_CODE('Src '), typeVoidPtr, sizeof(EventQueueRef), @myQueue) <> noErr) then
886    begin
887      ReleaseEvent(event);
888      _GraphResult:=grError;
889    end;
890
891  if (PostEventToQueue(MainEventQueue,event,kEventPriorityStandard) <> noErr) then
892    begin
893      ReleaseEvent(event);
894      _GraphResult:=grError;
895      exit;
896    end;
897
898  if (ReceiveNextEvent(length(GraphClosedSpec),@GraphClosedSpec,kEventDurationForever,true,event) <> noErr) then
899    runerror(218);
900  ReleaseEvent(event);
901end;
902
903
904procedure SendInitGraph;
905var
906  event : EventRef;
907  myQueue: EventQueueRef;
908begin
909  if (CreateEvent(nil, kEventClassFPCGraph, kEventInitGraph, GetCurrentEventTime(), 0, event) <> noErr) then
910    begin
911      _GraphResult:=grError;
912      exit;
913    end;
914
915  myQueue := GetCurrentEventQueue;
916  if (SetEventParameter(event, FOUR_CHAR_CODE('Src '), typeVoidPtr, sizeof(EventQueueRef), @myQueue) <> noErr) then
917    begin
918      ReleaseEvent(event);
919      _GraphResult:=grError;
920      exit;
921    end;
922
923  if (PostEventToQueue(MainEventQueue,event,kEventPriorityStandard) <> noErr) then
924    begin
925      ReleaseEvent(event);
926      _GraphResult:=grError;
927      exit;
928    end;
929
930  if (ReceiveNextEvent(length(GraphInitedSpec),@GraphInitedSpec,kEventDurationForever,true,event) <> noErr) then
931    runerror(218);
932  ReleaseEvent(event);
933end;
934
935
936   procedure qaddmode(modenr,xres,yres,colors: longint);
937   var
938     mode: TModeInfo;
939   begin
940     InitMode(Mode);
941     With Mode do
942       begin
943         ModeNumber := modenr;
944         ModeName := ModeNames[modenr];
945         // Always pretend we are VGA.
946         DriverNumber := VGA;
947         // MaxX is number of pixels in X direction - 1
948         MaxX := xres-1;
949         // same for MaxY
950         MaxY := yres-1;
951         YAspect := 10000;
952         XAspect := 10000;
953         MaxColor := colors;
954         PaletteSize := MaxColor;
955         directcolor := colors>256;
956         HardwarePages := 0;
957         // necessary hooks ...
958         DirectPutPixel := @q_DirectPixelProc;
959         GetPixel       := @q_GetPixelProc;
960         PutPixel       := @q_PutPixelProc;
961         { May be implemented later: }
962         HLine          := @q_HLineProc;
963         VLine          := @q_VLineProc;
964  {           GetScanLine    := @q_GetScanLineProc;}
965         ClearViewPort  := @q_ClrViewProc;
966         SetRGBPalette  := @q_SetRGBPaletteProc;
967         GetRGBPalette  := @q_GetRGBPaletteProc;
968         { These are not really implemented yet:
969         PutImage       := @q_PutImageProc;
970         GetImage       := @q_GetImageProc;}
971  {          If you use the default getimage/putimage, you also need the default
972         imagesize! (JM)
973          ImageSize      := @q_ImageSizeProc; }
974         { Add later maybe ?
975         SetVisualPage  := SetVisualPageProc;
976         SetActivePage  := SetActivePageProc; }
977         Line           := @q_LineProc;
978  {
979         InternalEllipse:= @q_EllipseProc;
980         PatternLine    := @q_PatternLineProc;
981         }
982         InitMode       := @SendInitGraph;
983       end;
984     AddMode(Mode);
985   end;
986
987
988  function toval(const s: string): size_t;
989    var
990      err: longint;
991    begin
992      val(s,toval,err);
993      if (err<>0) then
994        begin
995          writeln('Error decoding mode: ',s,' ',err);
996          runerror(218);
997        end;
998    end;
999
1000
1001  function QueryAdapterInfo:PModeInfo;
1002  { This routine returns the head pointer to the list }
1003  { of supported graphics modes.                      }
1004  { Returns nil if no graphics mode supported.        }
1005  { This list is READ ONLY!                           }
1006   var
1007     colorstr: string;
1008     i, hpos, cpos : longint;
1009     xres, yres, colors,
1010     dispxres, dispyres: longint;
1011     dispcolors: int64;
1012   begin
1013     QueryAdapterInfo := ModeList;
1014     { If the mode listing already exists... }
1015     { simply return it, without changing    }
1016     { anything...                           }
1017     if assigned(ModeList) then
1018       exit;
1019     dispxres:=CGDisplayPixelsWide(kCGDirectMainDisplay);
1020     { adjust for the menu bar and window title height }
1021     { (the latter approximated to the same as the menu bar) }
1022     dispyres:=CGDisplayPixelsHigh(kCGDirectMainDisplay)-GetMBarHeight*2;
1023     dispcolors:=int64(1) shl CGDisplayBitsPerPixel(kCGDirectMainDisplay);
1024     SaveVideoState:=@q_savevideostate;
1025     RestoreVideoState:=@q_restorevideostate;
1026     for i := 1 to GLASTMODE do
1027       begin
1028         { get the mode info from the names }
1029         hpos:=2;
1030         while modenames[i][hpos]<>'x' do
1031           inc(hpos);
1032         inc(hpos);
1033         cpos:=hpos;
1034         while modenames[i][cpos]<>'x' do
1035           inc(cpos);
1036         inc(cpos);
1037         xres:=toval(copy(modenames[i],2,hpos-3));
1038         yres:=toval(copy(modenames[i],hpos,cpos-hpos-1));
1039         colorstr:=copy(modenames[i],cpos,255);
1040         if (colorstr='16') then
1041           colors:=16
1042         else if (colorstr='256') then
1043           colors:=256
1044{
1045         These don't work very well
1046         else if (colorstr='32K') then
1047           colors:=32768
1048         else if (colorstr='64K') then
1049           colors:=65536
1050}
1051         else
1052//           1/24/32 bit not supported
1053           continue;
1054         if (xres <= dispxres) and
1055            (yres <= dispyres) and
1056            (colors <= dispcolors) then
1057           qaddmode(i,xres,yres,colors);
1058       end;
1059   end;
1060
1061
1062{ ************************************************* }
1063
1064function GraphEventHandler (myHandler: EventHandlerCallRef;
1065                        event: EventRef; userData: pointer): OSStatus; mwpascal;
1066var
1067  source: EventQueueRef;
1068  newEvent: EventRef;
1069begin
1070//  writeln('in GraphEventHandler, event: ',FourCharArray(GetEventKind(event)));
1071  newEvent := nil;
1072  case GetEventKind(event) of
1073    kEventInitGraph:
1074      begin
1075        q_initmodeproc;
1076        if (GetEventParameter(event,FOUR_CHAR_CODE('Src '), typeVoidPtr, nil, sizeof(EventQueueRef), nil, @source) <> noErr) then
1077          runerror(218);
1078        if (CreateEvent(nil, kEventClassFPCGraph, kEventGraphInited, GetCurrentEventTime(), 0, newEvent) <> noErr) then
1079          runerror(218);
1080      end;
1081    kEventCloseGraph:
1082      begin
1083        q_donegraph;
1084        if (GetEventParameter(event,FOUR_CHAR_CODE('Src '), typeVoidPtr, nil, sizeof(EventQueueRef), nil, @source) <> noErr) then
1085          runerror(218);
1086        if (CreateEvent(nil, kEventClassFPCGraph, kEventGraphClosed, GetCurrentEventTime(), 0, newEvent) <> noErr) then
1087          runerror(218);
1088      end;
1089    kEventFlush:
1090      begin
1091        HIViewSetNeedsDisplay(graphHIView, true);
1092      end;
1093    kEventQuit:
1094      begin
1095        QuitApplicationEventLoop;
1096      end;
1097  end;
1098  if assigned(newEvent) then
1099    if PostEventToQueue(source,newEvent,kEventPriorityStandard) <> noErr then
1100      runerror(218);
1101  GraphEventHandler := noErr;
1102  ReleaseEvent(event);
1103end;
1104
1105
1106type
1107  pmainparas = ^tmainparas;
1108  tmainparas = record
1109    argc: cint;
1110    argv: ppchar;
1111    envp: ppchar;
1112  end;
1113
1114procedure FPCMacOSXGraphMain(argcpara: cint; argvpara, envppara: ppchar); cdecl; external;
1115
1116function wrapper(p: pointer): pointer; cdecl;
1117  var
1118    mainparas: pmainparas absolute p;
1119  begin
1120    FPCMacOSXGraphMain(mainparas^.argc, mainparas^.argv, mainparas^.envp);
1121    wrapper:=nil;
1122    { the main program should exit }
1123    fpexit(1);
1124  end;
1125
1126
1127{ this routine runs before the rtl is initialised, so don't call any }
1128{ rtl routines in it                                                 }
1129procedure main(argcpara: cint; argvpara, envppara: ppchar); cdecl; [public];
1130  var
1131    eventRec: eventrecord;
1132    graphmainthread: TThreadID;
1133    attr: TThreadAttr;
1134    ret: cint;
1135    mainparas: tmainparas;
1136  begin
1137    if InstallEventHandler (GetApplicationEventTarget,
1138                            NewEventHandlerUPP (@GraphEventHandler),
1139                            length(allGraphSpec),
1140                            @allGraphSpec,
1141                            nil,
1142                            nil) <> noErr then
1143      fpexit(1);
1144
1145    { main program has to be the first one to access the event queue, see }
1146    { http://lists.apple.com/archives/carbon-dev/2007/Jun/msg00612.html   }
1147    eventavail(0,eventRec);
1148    maineventqueue:=GetMainEventQueue;
1149    ret:=pthread_attr_init(@attr);
1150    if (ret<>0) then
1151      fpexit(1);
1152    ret:=pthread_attr_setdetachstate(@attr,1);
1153    if (ret<>0) then
1154      fpexit(1);
1155    mainparas.argc:=argcpara;
1156    mainparas.argv:=argvpara;
1157    mainparas.envp:=envppara;
1158    ret:=pthread_create(@graphmainthread,@attr,@wrapper,@mainparas);
1159    if (ret<>0) then
1160      fpexit(1);
1161    RunApplicationEventLoop;
1162  end;
1163
1164
1165initialization
1166  initcriticalsection(graphdrawing);
1167  InitializeGraph;
1168finalization
1169  donecriticalsection(graphdrawing);
1170end.
1171