PC Action 1997 July/CITE.ISO/menue/privat/97070049.txt

Text File | 1991-05-26 | 11.1 KB | 430 lines

99
Grafik unter TP 7.0
CHROME
PROGRAMMIEREN
  Hallo Leute ...

Heute habe ich mir mal
etwas Arbeit gemacht und
für die unter euch, die
sich noch nicht so gut
mit VGA Programmierung unter
DOS auskennen eine kleine
Unit geschrieben mit der
man den Modus 13h ( 320*200
mit 256 Farben ) ansprechen
kann.

Jetzt fragt ihr euch wie
ihr diese Datei von der CD
runterkriegt.

1. Wenn ihr den Norton
   Commander habt geht das
   ganz einfach.

 - Geht in das Verzeichnis
   \MENUE\PRIVAT auf der
   PCA CD
 - drückt Alt+F7 ( für Datei
   suchen )
 - gebt bei Dateien suchen
   "*.txt" ein und bei
   Enthält Text "MCGA"
 - nun drückt ihr Alt+N und
   dann Alt+S
 - nun müßten zwei Dateien
   gefunden werden
 - nun drückt ihr F und
   habt diese beiden Dateien
   in einem Fenster und
   könnt sie kopieren

2. Wenn ihr ihn nicht habt
   müßt ihr in eben diesem
   Verzeichnis nach einer
   Datei mit der Größe
   ca. 11.400 bytes suchen.

Nun ladet ihr diese Datei
mit eurem TP Editor und
schneidet den oberen Teil
ab. Die Datei muß nur
noch unter den Namen
"MCGA.PAS" abgespeichert
werden un schon könnt ihr
die Unit kompilieren und
verwenden wie sie ist oder
sie einfach ausschlachten,
wie ihr wollt.

  brought to ya by

       CHROME

-- nicht weiterscrollen ----
---- sonst ärgert ihr ------
------- euch noch ----------


------- cut here -----------
unit mcga;
interface
{$G+} (*  286-instructions  *)

const
  maxx   = 319;
  maxy   = 199;

  clipx1 : word = 0;
  clipy1 : word = 0;
  clipx2 : word = maxx;
  clipy2 : word = maxy;

type
  screen  = array[ 0..maxy, 0..maxx ] of byte;
  pscreen = ^screen;
  palette = array[ 0..255, 0..2 ] of byte;
  sprite = record
             width  : word;
             height : word;
             data   : pointer;
           end;

var
  vmem   : pscreen; (* real screen *)


procedure init13h;
procedure done13h;
procedure clearscreen( pscr  : pscreen; color  : byte );
procedure copyscreen( source, dest  : pscreen );
procedure setpalette( var new  : palette );
procedure getpalette( var pal  : palette );
procedure plotpixel( x, y  : word; color  : byte; pscr  : pscreen );
function getpixel(  x, y  : word; pscr  : pscreen ) :  byte;
function getsprite( var s  : sprite; xs, ys, width, height : word; pscr  : pscreen ) :  boolean;
procedure putsprite( s  : sprite; xs, ys  : integer; pscr  : pscreen );
procedure putspritemasked( s  : sprite; xs, ys  : integer; pscr : pscreen; maskcolor : byte );
procedure setclipping( x1, y1, x2, y2 : word );
procedure vsync;

function pcxshow( pcxname  : string; xs, ys  : word; pscr  : pscreen; truecolors  : boolean ) :  boolean;

implementation

procedure init13h;
begin
  asm
    mov  ax, 0013h
    int  10h
  end;
  vmem := ptr( $a000, 0 );
end;

procedure done13h; assembler;
asm
  mov  ax, 03
  int  10h
end;

procedure clearscreen( pscr  : pscreen; color  : byte ); assembler;
asm
  cld
  les  di, pscr
  mov  al, color
  mov  ah, color
  mov  cx, ( 320 * 200 ) / 2
  stosw
end;

procedure copyscreen( source, dest  : pscreen ); assembler;
asm
  push ds
  lds  si, source
  les  di, dest
  mov  cx, ( 320 * 200 ) / 4
db 66h
  rep  movsw  (* db 66h + rep movsw = rep movsd *)
  pop  ds
end;

procedure setpalette( var new  : palette ); assembler;
asm
  push ds
  xor  al, al
  mov  dx, 03c8h
  out  dx, al
  inc  dx
  cld
  mov  cx, 768
  lds  si, new
  rep  outsb
  pop  ds
end;

procedure getpalette( var pal  : palette ); assembler;
asm
  cld
  xor  al, al
  mov  dx, 03c7h
  out  dx, al
  mov  dx, 03c9h
  mov  cx, 768
  les  di, pal
  rep  insb
end;

procedure plotpixel( x, y  : word; color  : byte; pscr  : pscreen );
begin
  pscr^[ y, x ] := color;
end;

function getpixel(  x, y  : word; pscr  : pscreen ) :  byte;
begin
  getpixel := pscr^[ y, x ];
end;

{$I-}
function pcxshow( pcxname  : string; xs, ys  : word; pscr  : pscreen; truecolors  : boolean ) :  boolean;
var
  pcxfile     : file;
  pcxsize     : longint;  (*  filesize w/o the 256-color palette *)
  pcxfileptr  : longint;
  pcx         : record
                 id            : byte;    (*  0ah  *)
                 version       : byte;
                 compressed    : boolean;
                 bpp           : byte;    (*  bits per pixel *)
                 xstart        : word;
                 ystart        : word;
                 xend          : word;
                 yend          : word;
                 hdpi          : word;    (*  horizontal dots per inch *)
                 vdpi          : word;    (*  vertical dots per inch   *)
                 colors16      : array[ 0..15, 0..2 ] of byte;
                 reserved      : byte;
                 planes        : byte;
                 scanlinewidth : word;    (*  bytes per line *)
                 palettetype   : word;
                 fillup        : array[ 0..57 ] of byte;
                end;

  x, y        : word;
  w, h        : word;
  databyte    : byte;
  count       : byte;
  color       : byte;
  i           : byte;

  colors256   : palette;

  data        : pointer;
  datasize    : word;
  maxdatasize : word;
  dataptr     : word;

procedure readdata;
var
  dataread  :  word;
begin
  if pcxfileptr < pcxsize then
    begin
      datasize := maxdatasize;
      if ( pcxsize - pcxfileptr ) < datasize then datasize := pcxsize - pcxfileptr;
      blockread( pcxfile, data^, datasize, dataread );
      if ioresult <> 0 then begin pcxshow := false; exit; end;
      if dataread < datasize then datasize := dataread;
      inc( pcxfileptr, dataread );
      dataptr := 0;
    end else datasize := 0;
end;

begin
{ open the pcxfile  }
  assign( pcxfile, pcxname );
  reset( pcxfile, 1 );
  if ioresult <> 0 then begin pcxshow := false; exit; end;
  pcxsize := filesize( pcxfile );
{ read the header }
  blockread( pcxfile, pcx, sizeof( pcx ) );
  if ioresult <> 0 then begin pcxshow := false; exit; end;
{ look at header }
  with pcx do
    begin
      if (( id <> $0a ) or
          ( version <> 5 ) or
          ( not compressed ) or
          ( bpp <> 8 ) or
          ( planes <> 1 )) then
        begin
          pcxshow := false;
          exit;
        end;
{ read palette }
      if truecolors then
        begin
          seek( pcxfile, pcxsize - 769 );
          blockread( pcxfile, databyte, 1 );
          if ioresult <> 0 then begin pcxshow := false; exit; end;
          if databyte <> $0c then begin pcxshow := false; exit; end;
          blockread( pcxfile, colors256, sizeof( palette ) );
          if ioresult <> 0 then begin pcxshow := false; exit; end;
{ shrink palette ; i don't know why but it funx ( i read it anywhere ) }
          for color := 0 to 255 do
            for count := 0 to 2 do
              colors256[ color, count ] := colors256[ color, count ] shr 2;
          setpalette( colors256 );
          seek( pcxfile, 128 );
        end;
      pcxsize := pcxsize - 769;
      pcxfileptr := 128;
{ allocate memory }
      if (( pcxsize - pcxfileptr ) < 65536 ) then maxdatasize := pcxsize - pcxfileptr
      else maxdatasize := $ffff;
      if maxavail < maxdatasize then maxdatasize := maxavail;
      getmem( data, maxdatasize );
{ calculate some }
      y := ys;
      x := xs;
      w := xend - xstart + 1;
      h := yend - ystart + 1;
{ main loop }
      repeat
        readdata;
        if datasize = 0 then begin pcxshow := false; exit; end;
        repeat
          databyte := mem[ seg(data^):ofs(data^) + dataptr ];
          inc( dataptr );
          if ( databyte and 192 ) = 192 then
            begin
              if dataptr >= datasize then
                begin
                  readdata;
                  if datasize = 0 then begin pcxshow := false; exit; end;
                end;
              count := databyte and 63;
              color := mem[ seg(data^):ofs(data^) + dataptr ];
              inc( dataptr );
            end else
            begin
              count := 1;
              color := databyte;
            end;
          for i := 1 to count do
            begin
              plotpixel( x, y, color, pscr );
              inc( x );
              dec( w );
              if w = 0 then
                begin
                  x := xs;
                  w := xend - xstart + 1;
                  inc( y );
                  dec( h );
                  if h = 0 then dataptr := datasize;
                end;
            end;
        until dataptr >= datasize;
      until h = 0;
    end;
{ shutdown }
  freemem( data, maxdatasize );
  close( pcxfile );
  pcxshow := true;
end;
{$I+}

function getsprite( var s  : sprite; xs, ys, width, height : word; pscr  : pscreen ) :  boolean;
var p    : pointer;
    size : word;
    c    : word;
    y    : word;
begin
  size := width * height;
  if maxavail < size then begin getsprite := false; exit; end;
  getmem( p, size );
  c := 0;
  for y := ys to ys+height-1 do
    begin
      move( pscr^[y, xs], ptr( seg(p^), ofs(p^)+c)^, width );
      c := c + width;
    end;
  s.width   := width;
  s.height  := height;
  s.data    := p;
  getsprite := true;
end;

procedure putsprite( s  : sprite; xs, ys  : integer; pscr  : pscreen );
var c        : word;
    y        : word;
    rwidth   : word;
    rheight  : word;
    rxs, rys : word;
begin
  if xs < clipx1 then rxs := clipx1 else rxs := xs;
  if ys < clipy1 then rys := clipy1 else rys := ys;
  c := (( rys - ys ) * s.width) + ( rxs-xs );
  rwidth  := s.width - ( rxs - xs );
  rheight := s.height - ( rys - ys );
  if ( rxs+rwidth-1 )  > clipx2 then rwidth  := clipx2-rxs+1;
  if ( rys+rheight-1 ) > clipy2 then rheight := clipy2-rys+1;
  for y := rys to rys+rheight-1 do
    begin
      move( ptr( seg(s.data^), ofs(s.data^)+c)^, pscr^[y, rxs], rwidth );
      c := c + s.width;
    end;
end;

procedure putspritemasked( s  : sprite; xs, ys  : integer; pscr : pscreen; maskcolor : byte );
var x        : word;
    y        : word;
    c, d     : word;
    rwidth   : word;
    rheight  : word;
    rxs, rys : word;
begin
  if xs < clipx1 then rxs := clipx1 else rxs := xs;
  if ys < clipy1 then rys := clipy1 else rys := ys;
  c := (( rys - ys ) * s.width) + ( rxs-xs );
  rwidth  := s.width - ( rxs - xs );
  rheight := s.height - ( rys - ys );
  if ( rxs+rwidth-1 )  > clipx2 then rwidth  := clipx2-rxs+1;
  if ( rys+rheight-1 ) > clipy2 then rheight := clipy2-rys+1;
  for y := rys to rys+rheight-1 do
    begin
      d := 0;
      for x := rxs to rxs+rwidth-1 do
        begin
          if mem[ seg(s.data^):ofs(s.data^)+c ] <> maskcolor then pscr^[ y, x ] := mem[ seg(s.data^):ofs(s.data^)+c ];
          inc( c );
          inc( d );
        end;
      c := c + ( s.width - d );
    end;
end;

procedure setclipping( x1, y1, x2, y2  : word );
begin
  clipx1 := x1;
  clipy1 := y1;
  clipx2 := x2;
  clipy2 := y2;
end;

procedure vsync; assembler;
label _loop_one, _loop_two;
asm
  mov  dx, 3dah
_loop_one :
  in   al, dx
  test al, 08
  jnz  _loop_one
_loop_two :
  in   al, dx
  test al, 08
  jz   _loop_two
end;

end.