Power-Programmierung/CD1.mdf/pascal/library/dos/wct/xgraph.pas

Pascal/Delphi Source File | 1991-07-31 | 8.9 KB | 297 lines

unit xgraph;

{ Written by William C. Thompson ([e-mail]) - 1991 }

{ This unit was written for programs with heavy graphics usage.
  There are a number of procedures to make graphics more bearable.
  There are some procedures that do different drawings.
  There are some procedures that can save/recall a screen image. }

{ Designer's Notes:

  1. I have left some of the error checking, such as checking if
     a file exists or not, out of the procedures.  That is the
     responsibility of the programmer. }

interface

uses graph,math;

type
  imagebuffer=array[0..65534] of byte;
  image=record
    p: ^imagebuffer;   { buffer for image }
    size: word;   { size of image }
    end;
  { Instead of making p a generic pointer, I decided to make it
    point to an array, so the contents of the array could be examined
    more easily if the programmer so desired. }

var
  europeanfont,complexfont,triplexscriptfont,scriptfont,simplefont:integer;

procedure setfillcolor(col:word);
procedure setfillpatt(pat: word);
procedure settextfont(font:word);
procedure settextsize(size:word);
procedure settextdir(dir:word);
procedure settextall(font,dir,size,hor,ver:word);
procedure xouttextxy(x1,y1:word; spacing:byte; s:string);
procedure ngon(cx,cy,sides: word; r,ang: real);
procedure fline(x1,y1,x2,y2:word; warp,pixres:real);
procedure fbranch(fn:string ; warp,pixres:real);
procedure frip(fn: string; warp,pixres: real);
procedure writeimage(fn:string; var im:image);
procedure readimage(fn:string; var im:image);
procedure grabimage(x1,y1,x2,y2:word; var im:image);
procedure showimage(x1,y1: word; var im:image; bitblt:word);
procedure killimage(var im:image);

implementation

procedure setfillcolor(col:word);
var
  s: fillsettingstype;
begin
  getfillsettings(s);
  setfillstyle(s.pattern,col)
end;

procedure setfillpatt(pat: word);
var
  s: fillsettingstype;
begin
  getfillsettings(s);
  setfillstyle(pat,s.color)
end;

procedure settextfont(font:word);
var
  s: textsettingstype;
begin
  gettextsettings(s);
  settextstyle(font, s.direction, s.charsize)
end;

procedure settextsize(size:word);
var
  s: textsettingstype;
begin
  gettextsettings(s);
  settextstyle(s.font, s.direction, size)
end;

procedure settextdir(dir:word);
var
  s: textsettingstype;
begin
  gettextsettings(s);
  settextstyle(s.font, dir, s.charsize)
end;

procedure settextall(font,dir,size,hor,ver:word);
{ This is an EXTREMELY useful procedure to set all attributes of
  graphics text settings. }
begin
  settextstyle(font,dir,size);
  settextjustify(hor,ver)
end;

procedure xouttextxy(x1,y1:word; spacing:byte; s:string);
{ Writing text in graphics mode can be very tedious.  If you want
  to write line after line after line, you have to type OutTextXY
  about a million times and make quite a few mistakes doing it.
  This is usually a big headache for me and makes me not want to
  work on whatever I'm doing because it's so tedious.  And thus
  a procedure was born.  What this procedure does is start writing
  at (x1,y1) when it finds #13 in the string, it skips down Spacing
  pixels and writes until the next #13, and so on.  This lets you
  change the spacing and move the text around more easily.  You are
  still limited to 255 characters, but it's still worth it. }
var
  j: word;
  p: byte;
begin
  j:=y1;
  while s<>'' do begin
    { find #13 in string }
    p:=pos(#13,s);
    if p>0 then begin
      outtextxy(x1,j,copy(s,1,p-1));
      delete(s,1,p);
      j:=j+spacing
      end
    else begin
      outtextxy(x1,j,s);
      s:=''
      end
    end
end;

procedure ngon(cx,cy,sides: word; r,ang: real);
{ This procedure draws an n-sided polygon.  (Cx,Cy) is the center.
  Sides is obviously the number of sides.  R is the distance from
  the center to one of the elbows, and Ang is the angle of rotation.
  Ang must be given in radians. }
var
  i: word;
begin
  for i:=0 to sides-1 do
    line(round(cx+r*cos(i/sides*2*pi+ang-pi/2)),
         round(cy+r*sin(i/sides*2*pi+ang-pi/2)),
         round(cx+r*cos((i+1)/sides*2*pi+ang-pi/2)),
         round(cy+r*sin((i+1)/sides*2*pi+ang-pi/2)));
end;

procedure fline(x1,y1,x2,y2:word; warp,pixres:real);
{ Generates a fractal line from (x1,y1) bent by Warp % such that no
  two points are more than PixRes pixels apart.  A higher Warp means
  the line can deviate more.  Caution: a Warp above 1.0 is not good }
var
  d,ang:real;
  x3,y3:word;        { point of bend }
begin
  d:=distance(x1,y1,x2,y2);
  if d<=pixres then line(x1,y1,x2,y2)
  else begin
    ang:=random(65535)*9.5875262E-5;       { generate [0,2 pi) }
    x3:=round((x1+x2)/2+d/2*warp*sin(ang));
    y3:=round((y1+y2)/2+d/2*warp*cos(ang));
    fline(x1,y1,x3,y3,warp,pixres);
    fline(x3,y3,x2,y2,warp,pixres)
    end
end;

procedure fbranch(fn:string; warp,pixres:real);
{ reads a fractal branch file from disk and draws it with
  parameters warp and pixres, as described in fline.  There
  is a maximum of MaxNodes nodes, but only as much space as
  needed is allocated.  Define a branch as follows:

  number of nodes                         e.g.  5
  list of each node's coordinates               100 100
                                                ...
  list of connections from node to node         1 2
                                                ... }
const
  maxnodes=1000;
type
  nodelist=array[1..2*maxnodes] of word;
var
  f: text;
  i: word;
  a,b: word;             { node numbers }
  pts: word;             { number of nodes }
  nl: ^nodelist;         { pointer to list of nodes }
begin
  assign(f,fn);
  reset(f);
  { read in points }
  readln(f,pts);
  if pts<=maxnodes then getmem(nl,pts*4) else getmem(nl,maxnodes*4);
  for i:=1 to pts do
    if i<=maxnodes then readln(f,nl^[i*2-1],nl^[i*2]) else readln(f);
  while not eof(f) do begin
    readln(f,a,b);
    if [a,b]*[1..pts]=[a,b] then
      fline(nl^[a*2-1],nl^[a*2],nl^[b*2-1],nl^[b*2],warp,pixres)
    end;
  close(f);
end;

procedure frip(fn:string; warp,pixres:real);
{ Reads and draws a fractal rip (looks like a river)
  A rip file is defined as follows:

  List of coordinates to connect    e.g.    100 100
                                            150 120
                                            160 180
                                            ...

  This can be used to draw lakes, borders, etc.
  There is no limit on the number of nodes. }
var
  x1,y1,x2,y2: word;
  f: text;
begin
  assign(f,fn);
  reset(f);
  { read first point }
  readln(f,x1,y1);
  while not eof(f) do begin
    readln(f,x2,y2);
    fline(x1,y1,x2,y2,warp,pixres);
    x1:=x2;
    y1:=y2
    end;
  close(f)
end;

procedure writeimage(fn:string; var im:image);
{ This procedure writes an image to the specified file. }
var
  f: file;
  p: pointer;
  n: word;
begin
  assign(f,fn);
  rewrite(f,1);                    { objects are 1 byte large }
  blockwrite(f,im.p^,im.size,n);   { write image to disk }
  close(f);
end;

procedure readimage(fn:string; var im:image);
{ There is no error checking as to how much memory is available.  The
  size of an image is approximately the number of pixels divided by
  two (VGA mode).  A good use of this procedure is to write a program that
  draws a fairly complex image to be used in another program.  Then, use
  GrabImage to capture the smallest area containing the image you want
  and WriteImage to save it to disk.  Then use ReadImage and ShowImage to
  draw the image in another program.  That way the image doesn't have to be
  drawn at run-time. }
var
  f: file;
  n: word;
begin
  assign(f,fn);
  reset(f,1);
  im.size:=filesize(f);           { assumes entire file is image }
  getmem(im.p,im.size);           { allocate space }
  blockread(f,im.p^,im.size,n);   { read in image }
  close(f);
end;

procedure grabimage(x1,y1,x2,y2:word; var im:image);
{ This procedure captures the specified image into a buffer.  It also
  allocates enough memory, which can be released with KillImage.  This
  is very similar to GetImage, but I have hidden away the details and
  memory (de)allocation to make the procedures more complementary. }
begin
  im.size:=imagesize(x1,y1,x2,y2);
  getmem(im.p,im.size);
  getimage(x1,y1,x2,y2,im.p^)
end;

procedure showimage(x1,y1:word; var im:image; bitblt:word);
{ The only difference between this and PutImage is the programmer
  specifies an image instead of a buffer.  This helps to preserve
  consistency. }
begin
  putimage(x1,y1,im.p^,bitblt)
end;

procedure killimage(var im:image);
{ This procedure deallocates any memory used to store an image. }
begin
  freemem(im.p,im.size);
  im.size:=0;
end;

begin
  europeanfont:=installuserfont('euro');
  complexfont:=installuserfont('lcom');
  triplexscriptfont:=installuserfont('tscr');
  scriptfont:=installuserfont('scri');
  simplefont:=installuserfont('simp');
end.