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