home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 06 / dtp / eps.pas next >
Encoding:
Pascal/Delphi Source File  |  1990-04-09  |  6.3 KB  |  224 lines
  1. (* ------------------------------------------------------ *)
  2. (*                        EPS.PAS                         *)
  3. (*  macht PostScript-Grafik unter Turbo Pascal verfügbar  *)
  4. (*            (c) 1990 Cord Jastram & toolbox             *)
  5. (* ------------------------------------------------------ *)
  6.  
  7. UNIT  eps;
  8.  
  9. INTERFACE
  10.  
  11. USES  Dos, Crt, Graph, Fonts, Drivers;
  12.  
  13. CONST
  14.   MaxPunkt    = 400;
  15.   Offen       = FALSE;
  16.   Geschlossen = TRUE;
  17.  
  18. TYPE
  19.   PolygonZug = ARRAY [1..2, 1..MaxPunkt] OF REAL;
  20.  
  21. PROCEDURE GrafikEin(x, y : REAL; DateiName : STRING);
  22. PROCEDURE GrafikAus;
  23. PROCEDURE GehZu(x, y : REAL);
  24. PROCEDURE GehZuRel(DeltaX, DeltaY: REAL);
  25. PROCEDURE LinienDicke(Dicke : REAL);
  26. PROCEDURE LinienTyp(Art : INTEGER);
  27. PROCEDURE LinienEnde(Art : INTEGER);
  28. PROCEDURE Linie(x1, y1, x2, y2 : REAL);
  29. PROCEDURE LinienZug(Punkte : PolygonZug;
  30.                     Anzahl : INTEGER; gs: BOOLEAN);
  31. PROCEDURE Rechteck(x1, y1, x2, y2 : REAL);
  32. PROCEDURE ZeichenSatz(Name : STRING; Hoehe : REAL);
  33. PROCEDURE Schreiben(Wort : STRING);
  34. PROCEDURE SchreibenXY(x, y : REAL; Wort : STRING);
  35.  
  36. IMPLEMENTATION
  37. CONST
  38.   autor = 'C.J';                   { die eigenen Initialen }
  39.   fk    = 2.834645;       { Umrechnung von 1/72 inch in mm }
  40.  
  41. VAR
  42.   datei     : TEXT;
  43.   dx,dy,dh  : REAL;
  44.   xmax,ymax : WORD;
  45.  
  46. FUNCTION Tfx(x : REAL) : INTEGER;
  47.                          { Transformation der x-Koordinate }
  48. BEGIN
  49.   Tfx := Round(x*dx);
  50. END;
  51.  
  52. FUNCTION Tfy(y : REAL) : INTEGER;
  53.                          { Transformation der y-Koordinate }
  54. BEGIN
  55.   Tfy := Round(ymax - y*dy);
  56. END;
  57.  
  58. PROCEDURE GrafikEin(x, y : REAL; DateiName : STRING);
  59. VAR
  60.   GraphMode,GraphDriver        : INTEGER;
  61.   yr,mth,day,dow,ho,mi,se,hund : WORD;
  62.   AspectBild,AspectSchirm      : REAL;
  63. BEGIN
  64.   GetDate(yr,mth,day,dow);
  65.   GetTime(ho,mi,se,hund);
  66.   Assign(datei,DateiName);
  67.   Rewrite(datei);
  68.   Writeln(datei,'%!PS-ADOBE-2.0 EPSF-1.2');
  69.                                         { Header schreiben }
  70.   Write(datei,'%%BoundingBox ');
  71.   Writeln(datei,'0 0 ', x*fk:7:2,' ',y*fk:7:2);
  72.   Writeln(datei,'%%Creator ',autor);
  73.   Writeln(datei,'%%Title ',DateiName);
  74.   Write(datei,'%%CreationDate ');
  75.   Writeln(datei,day:2,'.',mth:2,'.',
  76.                 yr:4,' ',ho:2,'.', mi:2);
  77.   Writeln(datei,'%%EndComments');
  78.  
  79. {  IF RegisterBGIdriver(@CGADriverProc) < 0 THEN
  80.   IF RegisterBGIdriver(@EGAVGADriverProc) < 0 THEN
  81.   IF RegisterBGIdriver(@ATTDriverProc) < 0 THEN
  82.   IF RegisterBGIdriver(@PC3270DriverProc) < 0 THEN }
  83.            { Hier den passenden Grafiktreiber registrieren }
  84.   IF RegisterBGIDriver(@HercDriverProc) < 0 THEN BEGIN
  85.     Writeln('Grafikfehler => Grafikkarte');
  86.     Halt(0);
  87.   END;
  88.   IF RegisterBGIFont(@SansSerIFFontProc) < 0 THEN BEGIN
  89.     Writeln('Grafikfehler');
  90.     Halt(0);
  91.   END;
  92.   GraphDriver := Detect;
  93.   InitGraph(GraphDriver,GraphMode,' ');
  94.   xmax := GetMaxX;
  95.   ymax := GetMaxY;
  96.  { Seitenverhältnis von Bildschirm und Abbildung ermitteln }
  97.   AspectSchirm := xmax/ymax;
  98.   AspectBild := x/y;
  99.                    { Zeicheninkremente dx und dy bestimmen }
  100.   IF AspectBild < AspectSchirm THEN BEGIN
  101.     dx := xmax/x*AspectBild/AspectSchirm;
  102.     dy := ymax/y;
  103.   END ELSE BEGIN
  104.     dx := xmax/x;
  105.     dy := ymax/x*AspectSchirm/AspectBild;
  106.   END;
  107.   Rectangle(Tfx(0),Tfy(0),Tfx(x),Tfy(y));
  108.                             { Rechteck um die Bounding-Box }
  109. END;
  110.  
  111. PROCEDURE GrafikAus;
  112. BEGIN
  113.   REPEAT UNTIL KeyPressed;
  114.   CloseGraph;
  115.             { Für direkt ausführbare PostScript-Programme: }
  116.   { Writeln(datei,' showpage'}
  117.   Close(datei);
  118. END;
  119.  
  120. PROCEDURE GehZu(x,y : REAL);
  121. BEGIN
  122.   MoveTo(Tfx(x),Tfy(y));
  123.   Writeln(datei,x*fk:7:2,' ',y*fk:7:2,' moveto');
  124. END;
  125.  
  126. PROCEDURE GehZuRel(DeltaX,DeltaY : REAL);
  127. BEGIN
  128.   MoveRel(Tfx(DeltaX),Round(-dy*DeltaY));
  129.   Writeln(datei,DeltaX*fk:7:2,' ',
  130.   DeltaY*fk:7:2,' rmoveto');
  131. END;
  132.  
  133. PROCEDURE Linie(x1,y1,x2,y2 :  REAL);
  134. BEGIN
  135.   Line(Tfx(x1),Tfy(y1),Tfx(x2),Tfy(y2));
  136.   Writeln(datei,fk*x2:7:2,' ',fk*y2:7:2,' moveto');
  137.   Writeln(datei,fk*x1:7:2,' ',fk*y1:7:2,
  138.                           ' lineto stroke');
  139. END;
  140.  
  141. PROCEDURE LinienZug(Punkte : PolygonZug; Anzahl : INTEGER;
  142.           gs : BOOLEAN);
  143. VAR
  144.   i : INTEGER;
  145. BEGIN
  146.   Writeln(datei,' newpath');
  147.   Writeln(datei,fk*Punkte[1,1]:7:2,' ',
  148.   fk*Punkte[2,1]:7:2,' moveto');
  149.   MoveTo(Tfx(Punkte[1,1]),Tfy(Punkte[2,1]));
  150.   FOR i:=2 TO Anzahl DO BEGIN
  151.     LineTo(Tfx(Punkte[1,i]),Tfy(Punkte[2,i]));
  152.     Writeln(datei,fk*Punkte[1,i]:7:2,
  153.                   ' ',fk*Punkte[2,i]:7:2,' lineto');
  154.   END;
  155.   IF gs THEN BEGIN
  156.     LineTO(Tfx(Punkte[1,1]),Tfy(Punkte[2,1]));
  157.     Writeln(datei,'closepath');
  158.   END;
  159.   Writeln(datei,'stroke');
  160. END;
  161.  
  162. PROCEDURE Schreiben(wort : STRING);
  163. BEGIN
  164.   OutText(wort);
  165.   Writeln(datei,'(',wort,') show');
  166. END;
  167.  
  168. PROCEDURE SchreibenXY(x,y : REAL ; wort : STRING);
  169. BEGIN
  170.   GehZu(x,y);
  171.   Schreiben(wort);
  172. END;
  173.  
  174. PROCEDURE Zeichensatz(Name : STRING ; hoehe : REAL);
  175. BEGIN
  176.   Writeln(datei,'/',Name,' findfont ',
  177.   hoehe:6:2,' scalefont setfont');
  178. END;
  179.  
  180. PROCEDURE LinienDicke(Dicke : REAL);
  181. BEGIN
  182.   Writeln(datei,Dicke*fk:7:2,' setlinewidth');
  183. END;
  184.  
  185. PROCEDURE LinienTyp(Art : INTEGER);
  186. BEGIN
  187.   CASE Art OF
  188.     0 : Writeln(datei, '[] 0 setdash');     { durchgezogen }
  189.     1 : Writeln(datei, '[2] 0 setdash');
  190.     2 : Writeln(datei, '[5 2] 1 setdash');
  191.     3 : Writeln(datei, '[5 4] 1 setdash');
  192.     4 : Writeln(datei, '[6 4] 1 setdash');
  193.   END;
  194. END;
  195.  
  196. PROCEDURE LinienEnde(Art : INTEGER);
  197. BEGIN
  198.   CASE Art OF
  199.     0 : Writeln(datei, '0 setlinecap');
  200.                                  { 0 = rechtwinklige Enden }
  201.     1 : Writeln(datei, '1 setlinecap');
  202.                                    { 1 = abgerundete Enden }
  203.     2 : Writeln(datei, '2 setlinecap');
  204.                            { 2 = rechtwinklige Enden, aber }
  205.                    { Linien um die halbe Breite verlängert }
  206.   END;
  207. END;
  208.  
  209. PROCEDURE Rechteck(x1,y1,x2,y2 : Real);
  210. BEGIN
  211.   Rectangle(Tfx(x1),Tfy(y1),Tfx(x2),Tfy(y2));
  212.   Writeln(datei,'newpath');
  213.   Writeln(datei,x1*fk:7:2,' ',y1*fk:7:2,' moveto');
  214.   Writeln(datei,x1*fk:7:2,' ',y2*fk:7:2,' lineto');
  215.   Writeln(datei,x2*fk:7:2,' ',y2*fk:7:2,' lineto');
  216.   Writeln(datei,x2*fk:7:2,' ',y1*fk:7:2,' lineto');
  217.   Writeln(datei,x1*fk:7:2,' ',y1*fk:7:2,
  218.   ' lineto closepath stroke');
  219. END;
  220.  
  221. END.
  222. (* ------------------------------------------------------ *)
  223. (*                   Ende von EPS.TPU                     *)
  224.