home *** CD-ROM | disk | FTP | other *** search
/ PC-X 1997 October / pcx14_9710.iso / swag / delphi.swg / 0128_Code for 256 color DIBS.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-05-31  |  7.2 KB  |  229 lines
  1. {
  2. this is not complete but it may help someone
  3.  - code for 256 colour DIBs
  4.  
  5. I've nearly finished a little DIB demo that I'll upload to DSP soon
  6.  
  7. John B
  8. ===================================
  9. }
  10.  
  11. unit DIB_surface_object;
  12.  
  13. interface
  14.  
  15. uses
  16.   { Borland }
  17.   Windows,Sysutils,Graphics,Classes,
  18.   { Mine }
  19.   Palunit;
  20.  
  21. type
  22.   Pshape = ^shape;
  23.   shape  = array[0..0] of Tpoint;
  24.  
  25. type
  26.   DIBsurfaceobject = Class(TObject)
  27.     DIBheader    : TMyBitmapInfo;
  28.     DIBPalette   : TMyLogPalette;
  29.     DIBhpalette  : hPalette;
  30.     DIBpalsize   : integer;
  31.     DIBbits      : Pointer;
  32.     DIBhandle    : THandle;
  33.     DIBDC        : hDC;
  34.     Original_BMP : hBitmap;
  35.     Original_PAL : hPalette;
  36.     DIBWidth     : integer;
  37.     DIBHeight    : integer;
  38.     DIBWidth_b   : integer;
  39.     DIBSize      : integer;
  40.     constructor Create(palette:TMyLogPalette; newsize:TPoint);
  41.     destructor  destroy;  override;
  42.     procedure   change_size(newsize:TPoint; force:boolean);
  43.     procedure   change_palette(newpal:shortstring);
  44.     procedure   draw_horizontal_line(x1,x2,y:integer; b:byte);
  45.     procedure   set_pixel(x,y:integer; b:byte);
  46.     procedure   safe_set_pixel(x,y:integer; b:byte);
  47.     procedure   fill_polygon(n:integer; poly:Pshape; fillcol:byte);
  48.     procedure   copy_surface_to_screen(destDC:hDC);
  49.     procedure   copy_screen_to_surface(sourceDC:hDC);
  50.     procedure   clear_surface;
  51.   end;
  52.  
  53. implementation
  54.  
  55. { ------------------------------------------------------------------------ }
  56. {                             DIB surface object                           }
  57. { ------------------------------------------------------------------------ }
  58. constructor DIBsurfaceobject.Create(palette:TMyLogPalette; newsize:TPoint);
  59. var lp1 : integer;
  60. begin
  61.   inherited Create;
  62.   DIBbits      := nil;
  63.   DIBhandle    := 0;
  64.   DIBPalette   := palette;
  65.   DIBhpalette  := CreatePalette(PLogPalette(@palette)^);
  66.   DIBDC        := CreateCompatibleDC(0);
  67.   Original_PAL := SelectPalette(DIBDC,DIBhpalette,false);
  68.   with DIBheader do begin
  69.     with bmiHeader do begin
  70.       biSize          := sizeof(TBITMAPINFOHEADER);
  71.       biWidth         := newsize.x;
  72.       biHeight        := newsize.y;
  73.       biPlanes        := 1;
  74.       biBitCount      := 8;
  75.       biCompression   := BI_RGB;
  76.       biSizeImage     := 0;
  77.       biXPelsPerMeter := 0;
  78.       biYPelsPerMeter := 0;
  79.       biClrUsed       := 0;
  80.       biClrImportant  := 0;
  81.     end;
  82.     for lp1:=0 to 255 do BMIcolors[lp1] := (lp1+0) and 255; { Pal_indices - no offset }
  83.   end;
  84.   Original_BMP := 0;
  85.   DIBWidth     := 0;
  86.   DIBHeight    := 0;
  87.   change_size(newsize,false);
  88. end;
  89.  
  90. destructor DIBsurfaceobject.destroy;
  91. begin
  92.   if Original_BMP<>0 then SelectObject(DIBDC,Original_BMP);
  93.   if Original_PAL<>0 then SelectPalette(DIBDC,Original_PAL,false);
  94.   if DIBhandle<>0    then DeleteObject(DIBhandle);
  95.   if DIBhpalette<>0  then DeleteObject(DIBhpalette);
  96.   DeleteDC(DIBDC);
  97.   inherited destroy;
  98. end;
  99.  
  100. procedure DIBsurfaceobject.change_size(newsize:TPoint; force:boolean);
  101. begin
  102.   if (not force) and (newsize.x=DIBWidth) and (newsize.y=DIBHeight) then exit;
  103.   DIBWidth   := newsize.x;
  104.   DIBHeight  := newsize.y;
  105.   DIBWidth_b := ((DIBWidth+3)shr 2)shl 2;
  106.   DIBSize    := DIBWidth_b*DIBHeight;
  107.   if Original_BMP<>0 then SelectObject(DIBDC,Original_BMP);
  108.   if DIBhandle<>0 then DeleteObject(DIBhandle);
  109.   DIBheader.BMIheader.biWidth  := DIBWidth;
  110.   DIBheader.BMIheader.biHeight :=-DIBHeight; { Top down for me please...}
  111.   DIBhandle    := CreateDIBSection(DIBDC,pBitmapInfo(@DIBheader)^,DIB_PAL_COLORS,DIBbits,nil,0);
  112.   Original_BMP := SelectObject(DIBDC,DIBhandle);
  113. end;
  114.  
  115. procedure DIBsurfaceobject.change_palette(newpal:shortstring);
  116. begin
  117.   SelectPalette(DIBDC,Original_PAL,false);
  118.   create_256_identity_palette_from_file(DIBpalette,DIBhpalette,newpal);
  119.   Original_PAL := SelectPalette(DIBDC,DIBhpalette,false);
  120.   change_size(Point(DIBwidth,DIBheight),true);
  121. end;
  122.  
  123. procedure DIBsurfaceobject.draw_horizontal_line(x1,x2,y:integer; b:byte);
  124. var lp1,offset : integer;
  125. begin
  126.   offset:=integer(DIBbits)+ y*DIBWidth_b;
  127.   for lp1:=x1 to x2 do Pbyte( offset+lp1 )^ := b;
  128. end;
  129.  
  130. procedure DIBsurfaceobject.set_pixel(x,y:integer; b:byte);
  131. begin
  132.   Pbyte( integer(DIBbits) + y*DIBWidth_b + x )^ := b;
  133. end;
  134.  
  135. procedure DIBsurfaceobject.safe_set_pixel(x,y:integer; b:byte);
  136. begin
  137.   if (x<DIBWidth) and (x>=0) then begin
  138.     if (y<DIBHeight) and (y>=0) then begin
  139.       Pbyte( integer(DIBbits) + y*DIBWidth_b + x )^ := b;
  140.     end;
  141.   end;
  142. end;
  143.  
  144. procedure DIBsurfaceobject.fill_polygon(n:integer; poly:Pshape; fillcol:byte);
  145. var loop1                   : integer;
  146.     yval,ymax,ymin          : integer;
  147.     yval0,yval1,yval2,yval3 : integer;
  148.     ydifl,ydifr             : integer;
  149.     xval0,xval1,xval2,xval3 : integer;
  150.     xleft,xright            : integer;
  151.     mu                      : integer;
  152.     minvertex               : integer;
  153.     vert0,vert1,vert2,vert3 : integer;
  154. begin
  155.   ymax:=-99999; ymin:=99999;
  156.   { get top & bottom scan lines to work with }
  157.   for loop1:=0 to n-1 do begin
  158.     yval:=poly^[loop1].y;
  159.     if yval>ymax then ymax:=yval;
  160.     if yval<ymin then begin ymin:=yval; minvertex:=loop1; end;
  161.   end;
  162.   vert0 := minvertex;      vert1 :=(minvertex+1) mod n-1;
  163.   vert2 := minvertex;      vert3 :=(minvertex-1) mod n-1;
  164.   yval0 := poly^[vert0].y; yval1 := poly^[vert1].y;
  165.   yval2 := poly^[vert2].y; yval3 := poly^[vert3].y;
  166.   ydifl := yval1-yval0;    ydifr := yval3-yval2;
  167.   xval0 := poly^[vert0].x; xval1 := poly^[vert1].x;
  168.   xval2 := poly^[vert2].x; xval3 := poly^[vert3].x;
  169.  
  170.   for loop1:=ymin to ymax do begin
  171.  
  172.     {intersection on left hand side }
  173.     mu:=(loop1-yval0);
  174.     if mu>ydifl then begin
  175.       vert0:=vert1; vert1:=(vert1+1) mod n-1;
  176.       yval0 := poly^[vert0].y; yval1 := poly^[vert1].y;
  177.       xval0 := poly^[vert0].x; xval1 := poly^[vert1].x;
  178.       ydifl := yval1-yval0;
  179.       mu:=(loop1-yval0)
  180.     end;
  181.     if ydifl<>0 then xleft:=xval0 - (mu*integer(xval0-xval1) div ydifl)
  182.     else             xleft:=xval0;
  183.  
  184.     {intersection on right hand side }
  185.     if ydifr<>0 then mu:=(loop1-yval2)
  186.     else mu:=ydifr;
  187.     if mu>ydifr then begin
  188.       vert2:=vert3; vert3:=(vert3-1) mod n-1;
  189.       yval2 := poly^[vert2].y; yval3 := poly^[vert3].y;
  190.       xval2 := poly^[vert2].x; xval3 := poly^[vert3].x;
  191.       ydifr := yval3-yval2;
  192.       if ydifr<>0 then mu:=(loop1-yval2)
  193.       else mu:=ydifr;
  194.     end;
  195.     if ydifr<>0 then xright:=xval2 + (mu*integer(xval3-xval2) div ydifr)
  196.     else             xright:=xval2;
  197.     draw_horizontal_line(xleft,xright,loop1,fillcol);
  198.   end;
  199. end;
  200.  
  201. procedure DIBsurfaceobject.copy_surface_to_screen(destDC:hDC);
  202. begin
  203.   SelectPalette(destDC,DIBhpalette,false);
  204.   BitBlt(destDC,0,0,DIBWidth,DIBHeight,DIBDC,0,0,SRCCOPY);
  205. end;
  206.  
  207. procedure DIBsurfaceobject.copy_screen_to_surface(sourceDC:hDC);
  208. begin
  209.   BitBlt(DIBDC,0,0,DIBWidth,DIBHeight,sourceDC,0,0,SRCCOPY);
  210. end;
  211.  
  212. procedure DIBsurfaceobject.clear_surface;
  213. var DWORDptr : Plongint;
  214.     lp1      : integer;
  215. begin
  216.   for lp1:=0 to DIBheight-1 do
  217.     draw_horizontal_line(0,DIBwidth,lp1,lp1);
  218.   exit;
  219.  
  220.   DWORDptr:=DIBbits;
  221.   for lp1:=0 to (DIBsize div 4)-1 do begin
  222.     Plongint(DWORDptr)^:=$00000000;
  223.     inc(DWORDptr);
  224.   end;
  225. end;
  226.  
  227. initialization
  228. end.
  229.