+ Initial implementation of graph unit on ptc

git-svn-id: trunk@6929 -

.gitattributes

@@ -797,6 +797,7 @@ packages/base/graph/inc/gtext.inc svneol=native#text/plain
 packages/base/graph/inc/makefile.inc svneol=native#text/plain
 packages/base/graph/inc/modes.inc svneol=native#text/plain
 packages/base/graph/inc/palette.inc svneol=native#text/plain
+packages/base/graph/ptcgraph.pp svneol=native#text/x-pascal
 packages/base/graph/unix/ggigraph.pp svneol=native#text/plain
 packages/base/graph/unix/graph.pp svneol=native#text/plain
 packages/base/graph/unix/graph16.inc svneol=native#text/plain

packages/base/graph/ptcgraph.pp

@@ -0,0 +1,537 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2007 by Daniel Mantione
+      member of the Free Pascal development team
+
+    This file implements the PTC support for the graph unit
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit ptcgraph;
+
+{$define logging}
+
+{******************************************************************************}
+                                    interface
+{******************************************************************************}
+
+{$i graphh.inc}
+
+{Driver number for PTC.}
+const	PTC=22;
+
+{******************************************************************************}
+                                 implementation
+{******************************************************************************}
+
+uses
+  termio,x86,ptc;
+
+const
+  InternalDriverName = 'PTCPas';
+
+{$i graph.inc}
+
+  type
+    PByte = ^Byte;
+    PLongInt = ^LongInt;
+
+    PByteArray = ^TByteArray;
+    TByteArray = array [0..MAXINT - 1] of Byte;
+
+
+
+{ ---------------------------------------------------------------------
+   SVGA bindings.
+
+  ---------------------------------------------------------------------}
+
+Const
+  { Text }
+
+  WRITEMODE_OVERWRITE = 0;
+  WRITEMODE_MASKED    = 1;
+  FONT_EXPANDED       = 0;
+  FONT_COMPRESSED     = 2;
+
+ { Types }
+ type
+   pvga_modeinfo = ^vga_modeinfo;
+   vga_modeinfo = record
+     width,
+     height,
+     bytesperpixel,
+     colors,
+     linewidth,          { scanline width in bytes }
+     maxlogicalwidth,    { maximum logical scanline width }
+     startaddressrange,  { changeable bits set }
+     maxpixels,          { video memory / bytesperpixel }
+     haveblit,           { mask of blit functions available }
+     flags: Longint;     { other flags }
+    { Extended fields: }
+     chiptype,           { Chiptype detected }
+     memory,             { videomemory in KB }
+     linewidth_unit: Longint;    { Use only a multiple of this as parameter for                                   set_displaystart }
+     linear_aperture: PChar;     { points to mmap secondary mem aperture of card }
+     aperture_size: Longint;     { size of aperture in KB if size>=videomemory.}
+
+     set_aperture_page: procedure (page: Longint);
+            { if aperture_size<videomemory select a memory page }
+     extensions: Pointer;        { points to copy of eeprom for mach32 }
+            { depends from actual driver/chiptype.. etc. }
+     end;
+
+  PGraphicsContext = ^TGraphicsContext;
+  TGraphicsContext = record
+                       ModeType: Byte;
+                       ModeFlags: Byte;
+                       Dummy: Byte;
+                       FlipPage: Byte;
+                       Width: LongInt;
+                       Height: LongInt;
+                       BytesPerPixel: LongInt;
+                       Colors: LongInt;
+                       BitsPerPixel: LongInt;
+                       ByteWidth: LongInt;
+                       VBuf: pointer;
+                       Clip: LongInt;
+                       ClipX1: LongInt;
+                       ClipY1: LongInt;
+                       ClipX2: LongInt;
+                       ClipY2: LongInt;
+                       ff: pointer;
+                     end;
+
+var
+  OldIO : TermIos;
+
+  ptcconsole:TPTCconsole;
+  ptcsurface:TPTCSurface;
+  ptcformat:TPTCFormat;
+
+Procedure SetRawMode(b:boolean);
+Var
+  Tio : Termios;
+Begin
+  if b then
+   begin
+     TCGetAttr(1,Tio);
+     OldIO:=Tio;
+     CFMakeRaw(Tio);
+   end
+  else
+   Tio:=OldIO;
+  TCSetAttr(1,TCSANOW,Tio);
+End;
+
+
+{ ---------------------------------------------------------------------
+    Required procedures
+  ---------------------------------------------------------------------}
+
+var
+  LastColor: smallint;   {Cache the last set color to improve speed}
+
+
+procedure ptc_savevideostate;
+begin
+end;
+
+procedure ptc_restorevideostate;
+begin
+{  vga_setmode(0);}
+end;
+
+{
+const
+  BgiColors: array[0..15] of LongInt
+    = ($000000, $000020, $002000, $002020,
+       $200000, $200020, $202000, $303030,
+       $202020, $00003F, $003F00, $003F3F,
+       $3F0000, $3F003F, $3F3F00, $3F3F3F);
+}
+
+procedure InitColors(nrColors: longint);
+
+var
+  i: smallint;
+begin
+{  for i:=0 to nrColors do
+    vga_setpalette(I,DefaultColors[i].red shr 2,
+      DefaultColors[i].green shr 2,DefaultColors[i].blue shr 2)}
+end;
+
+procedure ptc_initmodeproc;
+
+begin
+  writeln('Initializing mode');
+  { create format }
+  ptcformat:=TPTCFormat.Create(16,$f800,$07e0,$001f);
+  { open the console }
+  ptcconsole.open(paramstr(0),ptcformat);
+  { create surface matching console dimensions }
+  ptcsurface:=TPTCSurface.Create(ptcconsole.width,ptcconsole.height,ptcformat);
+end;
+
+Function ClipCoords (Var X,Y : smallint) : Boolean;
+{ Adapt to viewport, return TRUE if still in viewport,
+  false if outside viewport}
+
+begin
+  X:= X + StartXViewPort;
+  Y:= Y + StartYViewPort;
+  ClipCoords:=Not ClipPixels;
+  if ClipPixels then
+    Begin
+    ClipCoords:=(X < StartXViewPort) or (X > (StartXViewPort + ViewWidth));
+    ClipCoords:=ClipCoords or
+               ((Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)));
+    ClipCoords:=Not ClipCoords;
+    end;
+end;
+
+
+procedure ptc_directpixelproc_16bpp(X,Y: smallint);
+
+var color:word;
+    pixels:Pword;
+
+begin
+  case CurrentWriteMode of
+    XORPut:
+      begin
+      { getpixel wants local/relative coordinates }
+      Color := GetPixel(x-StartXViewPort,y-StartYViewPort);
+      Color := CurrentColor Xor Color;
+      end;
+    OrPut:
+      begin
+      { getpixel wants local/relative coordinates }
+      Color := GetPixel(x-StartXViewPort,y-StartYViewPort);
+      Color := CurrentColor Or Color;
+      end;
+    AndPut:
+      begin
+      { getpixel wants local/relative coordinates }
+      Color := GetPixel(x-StartXViewPort,y-StartYViewPort);
+      Color := CurrentColor And Color;
+      end;
+    NotPut:
+      begin
+      Color := Not Color;
+      end
+  else
+    Color:=CurrentColor;
+  end;
+  pixels:=ptcsurface.lock;
+  {Plot the pixel on the surface.}
+  pixels[x+y*ptcsurface.width]:=color;
+  ptcsurface.unlock;
+  { copy to console }
+  ptcsurface.copy(ptcconsole);
+  { update console }
+  ptcconsole.update;
+end;
+
+procedure ptc_putpixelproc_16bpp(X,Y:smallint;Color:Word);
+
+var pixels:Pword;
+
+begin
+  if clipcoords(X,Y) then
+    begin
+      pixels:=ptcsurface.lock;
+{      pixels:=ptcconsole.lock;}
+      {Plot the pixel on the surface.}
+      pixels[x+y*ptcsurface.width]:=color;
+      ptcsurface.unlock;
+      { copy to console }
+      ptcsurface.copy(ptcconsole);
+      { update console }
+      ptcconsole.update;
+    end;
+end;
+
+function ptc_getpixelproc_16bpp(X,Y: smallint):word;
+
+var pixels:Pword;
+
+begin
+  if clipcoords(X,Y) then
+    begin
+      pixels:=ptcsurface.lock;
+      {Get the pixel from the surface.}
+      ptc_getpixelproc_16bpp:=pixels[x+y*ptcsurface.width];
+      ptcsurface.unlock;
+    end;
+end;
+
+
+{ Bitmap utilities }
+{type
+  PBitmap = ^TBitmap;
+  TBitmap = record
+            Width, Height: smallint;
+            Data: record end;
+            end;
+}
+
+procedure ptc_putimageproc (X,Y: smallint; var Bitmap; BitBlt: Word);
+begin
+end;
+
+procedure ptc_getimageproc (X1,Y1,X2,Y2: smallint; Var Bitmap);
+begin
+end;
+
+function  ptc_imagesizeproc (X1,Y1,X2,Y2: smallint): longint;
+begin
+end;
+
+procedure ptc_hlineproc_16bpp(x, x2,y : smallint);
+
+var pixels:Pword;
+    i:word;
+
+begin
+  {Clip.}
+  if (y<0) or (y>viewheight) then
+    exit;
+  if x<0 then
+    x:=0;
+  if x>viewwidth then
+    x:=viewwidth;
+  if x2<0 then
+    x2:=0;
+  if x>viewwidth then
+    x2:=viewwidth;
+  pixels:=ptcsurface.lock;
+  inc(x,StartXViewPort);
+  inc(x2,StartXViewPort);
+  inc(y,StartXViewPort);
+  {Plot the pixel on the surface.}
+  for i:=x to x2 do
+    pixels[i+y*ptcsurface.width]:=$ffff;
+  ptcsurface.unlock;
+  { copy to console }
+  ptcsurface.copy(ptcconsole);
+  { update console }
+  ptcconsole.update;
+end;
+
+procedure ptc_vlineproc (x,y,y2: smallint);
+begin
+end;
+
+procedure ptc_clrviewproc_16bpp;
+
+Var I,Xmax : longint;
+
+begin
+  Xmax:=StartXViewPort+ViewWidth-1;
+  For i:=StartYViewPort to StartYViewPort+ViewHeight-1 do
+    ptc_hlineproc_16bpp(0,viewwidth,i);
+  { reset coordinates }
+  CurrentX := 0;
+  CurrentY := 0;
+end;
+
+procedure ptc_patternlineproc (x1,x2,y: smallint);
+begin
+end;
+
+procedure ptc_ellipseproc  (X,Y: smallint;XRadius: word;
+  YRadius:word; stAngle,EndAngle: word; fp: PatternLineProc);
+begin
+end;
+
+procedure ptc_lineproc (X1, Y1, X2, Y2 : smallint);
+begin
+end;
+
+procedure ptc_getscanlineproc (X1,X2,Y : smallint; var data);
+begin
+end;
+
+procedure ptc_setactivepageproc (page: word);
+begin
+end;
+
+procedure ptc_setvisualpageproc (page: word);
+begin
+end;
+
+
+procedure ptc_savestateproc;
+begin
+end;
+
+procedure ptc_restorestateproc;
+begin
+end;
+
+procedure ptc_setrgbpaletteproc(ColorNum, RedValue, GreenValue, BlueValue: smallint);
+begin
+{  vga_setpalette(ColorNum,RedValue shr 2,GreenValue shr 2,BlueValue shr 2);}
+end;
+
+procedure ptc_getrgbpaletteproc (ColorNum: smallint;
+                                    var RedValue, GreenValue, BlueValue: smallint);
+
+Var R,G,B : longint;
+
+begin
+{  vga_getpalette(ColorNum,R,G,B);}
+  RedValue:=R * 255 div 63;
+  GreenValue:=G * 255 div 63;
+  BlueValue:=B * 255 div 63;
+end;
+
+{************************************************************************}
+{*                       General routines                               *}
+{************************************************************************}
+
+ procedure CloseGraph;
+ Begin
+    If not isgraphmode then
+      begin
+        _graphresult := grnoinitgraph;
+        exit
+      end;
+    SetRawMode(False);
+    RestoreVideoState;
+    isgraphmode := false;
+ end;
+
+  function QueryAdapterInfo:PModeInfo;
+  { This routine returns the head pointer to the list }
+  { of supported graphics modes.                      }
+  { Returns nil if no graphics mode supported.        }
+  { This list is READ ONLY!                           }
+   var
+    graphmode:Tmodeinfo;
+    ptcmode: PPTCmode;
+    d,i : longint;
+    ws,hs:string[5];
+
+   const depths:array[0..3] of byte=(8,16,24,32);
+         colours:array[0..3] of longint=(256,65536,16777216,16777216);
+         depth_names:array[0..3] of string[5]=('256','64K','16M','16M32');
+
+   begin
+     QueryAdapterInfo := ModeList;
+     { If the mode listing already exists... }
+     { simply return it, without changing    }
+     { anything...                           }
+     if assigned(ModeList) then
+       exit;
+     SaveVideoState:=@ptc_savevideostate;
+     RestoreVideoState:=@ptc_restorevideostate;
+     ptcconsole:=TPTCconsole.create;
+     ptcmode:=ptcconsole.modes;
+     i:=0;
+     initmode(graphmode);
+     with graphmode do
+       begin
+         modenumber:=0;
+         drivernumber:=ptcgraph.ptc;
+         maxx:=639;
+         maxy:=479;
+         modename:='PTC_640x480x64K';
+         maxcolor:=65536;
+         palettesize:=65536;
+         hardwarepages:=0;
+         InitMode       := @ptc_InitModeProc;
+         DirectPutPixel := @ptc_DirectPixelProc_16bpp;
+         GetPixel       := @ptc_GetPixelProc_16bpp;
+         PutPixel       := @ptc_PutPixelProc_16bpp;
+         SetRGBPalette  := @ptc_SetRGBPaletteProc;
+         GetRGBPalette  := @ptc_GetRGBPaletteProc;
+       end;
+     addmode(graphmode);
+(*
+     writeln('processing modes');
+     while ptcmode^.valid do
+       begin
+         for d:=low(depths) to high(depths) do
+           begin
+             InitMode(graphmode);
+             with graphmode do
+               begin
+                 ModeNumber:=I;
+                 DriverNumber:=ptcgraph.PTC;
+                 { MaxX is number of pixels in X direction - 1}
+                 MaxX:=ptcmode^.width-1;
+                 { same for MaxY}
+                 MaxY:=ptcmode^.height-1;
+                 str(ptcmode^.width,ws);
+                 str(ptcmode^.height,hs);
+                 modename:='PTC_'+ws+'x'+hs+'x'+depth_names[d];
+                 MaxColor := 1 shl ptcmode^.format.r * 1 shl ptcmode^.format.g *1 shl ptcmode^.format.b;
+                 writeln('mode ',modename,' ',maxcolor,'kleuren');
+                 PaletteSize := MaxColor;
+                 HardwarePages := 0;
+*)
+                 { necessary hooks ...}
+(*
+                 if (MaxColor = 16) and
+                   (LongInt(ModeInfo.Width) * LongInt(ModeInfo.Height) < 65536*4*2) then
+                  begin
+                   {Use optimized graphics routines for 4 bit EGA/VGA modes.}
+                   ScrWidth := ModeInfo.Width div 8;
+                   DirectPutPixel := @DirectPutPixel16;
+                   PutPixel := @PutPixel16;
+                   GetPixel := @GetPixel16;
+                   HLine := @HLine16;
+                   VLine := @VLine16;
+                   GetScanLine := @GetScanLine16;
+                 end
+               else
+*)
+(*
+                 begin
+                   DirectPutPixel := @ptc_DirectPixelProc;
+                   GetPixel       := @ptc_GetPixelProc;
+                   PutPixel       := @ptc_PutPixelProc;
+                   { May be implemented later:
+                   HLine          := @libvga_HLineProc;
+                   VLine          := @libvga_VLineProc;
+                   GetScanLine    := @libvga_GetScanLineProc;}
+                   ClearViewPort  := @ptc_ClrViewProc;
+                 end;
+                 SetRGBPalette  := @ptc_SetRGBPaletteProc;
+                 GetRGBPalette  := @ptc_GetRGBPaletteProc;
+                 { These are not really implemented yet:
+                 PutImage       := @libvga_PutImageProc;
+                 GetImage       := @libvga_GetImageProc;}
+{                If you use the default getimage/putimage, you also need the default
+                 imagesize! (JM)
+                 ImageSize      := @libvga_ImageSizeProc; }
+                 { Add later maybe ?
+                 SetVisualPage  := SetVisualPageProc;
+                 SetActivePage  := SetActivePageProc;
+                 Line           := @libvga_LineProc;
+                 InternalEllipse:= @libvga_EllipseProc;
+                 PatternLine    := @libvga_PatternLineProc;
+                 }
+                 InitMode       := @ptc_InitModeProc;
+               end;
+           AddMode(graphmode);
+           inc(i);
+         end;
+     end;
+*)
+  end;
+
+initialization
+  ptcconsole:=TPTCconsole.create;
+  InitializeGraph;
+finalization
+  ptcconsole.destroy;
+end.