Unité postscriptcanvasunit.pas; unité common.pas

Commenter

Contenu du snippet

PostScriptCanvasUnit.pas:

Cette unité permet de générer du PostScript en dessinant dans une sorte de canevas.

Les routines de dessin utilisables sont similaires à TCanvas.

Common.pas:

Unité de déclarations générales

Contient des fonctions intéressantes (couleurs, IIF, etc...)

Source / Exemple : 


// unité standard
unit Common;
{$INCLUDE SelectionLangue.inc}
{$A-}

// Fonctions communes

interface
uses
  SysUtils, Classes,
  Math,
  {$IFDEF MSWINDOWS}
    OpenGLx,
    Windows,
    Graphics,
    //dlgProgressBar, // pour la barre de progression volante
    dlgProcessings;
  {$ENDIF}
  {$IFDEF LINUX}
    QGraphics;
  {$ENDIF}

//****************************
// types communs
//****************************

{$IFDEF LINUX}
   const NB_PIXELS_PER_INCH = 81;
{$ENDIF}
const ANNEE_PIVOT_4D=1950;
const ANNEE_PIVOT   = 50;
// constantes pout types de galeries
const
  tgDEFAULT   = 0;
  tgENTRANCE  = 1;
  tgFOSSILE   = 2;
  tgVADOSE    = 3;
  tgENNOYABLE = 4;
  tgSIPHON    = 5;
  tgFIXPOINT  = 6;
  tgSURFACE   = 7;
  tgTUNNEL    = 8;
  tgMINE      = 9;
//----------------------------------

const DFT_SPELEOMETRE  = 'CASSOU JP';
const DFT_SPELEOGRAPHE = 'CASSOU JP';
const DFT_REPORTER = 'SiliconCavings';

// types de galerie

type TModeSaveTAB =(mtabEXTENDEDTAB,mtabTOPOROBOT);
type TTextFileFormat=(tfWINDOWS, tfUNIX, tfMAC);
type TFloat = type Double;
// couleurs OpenGL
type TGLColor = record
  R: GLFloat;
  G: GLFloat;
  B: GLFloat;
  A: GLFloat;
end;
// couleurs 24 bits
type TColor3b = record
  R: byte;
  G: byte;
  B: byte;
end;

// point2D
type TPoint2Df = record
  X: TFloat;
  Y: TFloat;
end;
// point 3D
type TPoint3Df = record
  X: TFloat;
  Y: TFloat;
  Z: TFloat;
  T: TFloat;
end;
// Couleurs Macintosh
type TMacintoshColor = record
  R : word;
  G : word;
  B : word;
end;
//****************************
// Types de données TOPOROBOT
//****************************
Type TStation = record
  Date                :TDateTime;
   Couleur             : TColor;
   TypeGalerie         : byte;
   NumPoint            : smallint;    //'Numéro du point
   PtDepart            : smallint;    //        'Départ visée
   PtArrivee           : smallint;    //        'Arrivée visée
   Longueur            : TFloat;      //         'Longueur
   Azimut              : TFloat;      //         'Azimut
   Pente               : TFloat;      //         'Pente
   LD                  : TFloat;      //         'Distance à droite
   LG                  : TFloat;      //         'Distance à gauche
   HZ                  : TFloat;      //         'Hauteur au-dessus
   HN                  : TFloat;      //         'Hauteur du point
   //Commentaire         : array[0..24] of char; // Commentaire
   //Commentaire         : array[0..79] of char; // Commentaire
   //IDTerrainStation    : array[0..20] of Char; // ID terrain de la station
   IDTerrainStation    : string;
   Commentaire         : string;
   X                   : TFloat;      //         'X
   Y                   : TFloat;      //         'Y cheminement
   Z                   : TFloat;      //         'Z
End;

// stations
type
  pUneVisee = ^TUneVisee;
  TUneVisee = record
    NoVisee   : integer;
    NoViseeSer: integer;
    Code      : integer;
    Expe      : integer;
    Longueur  : TFloat;
    Azimut    : TFloat;
    Pente     : TFloat;
    LD        : TFloat;
    LG        : TFloat;
    HZ        : TFloat;
    HN        : TFloat;
    Commentaires    : string;
    IDTerrainStation: string;
    TypeGalerie     : byte;
    X         : TFloat;
    Y         : TFloat;
    Z         : TFloat;
end;
// entrées
type TEntrance = record
  eNumEntree: integer;
  eNomEntree: string;
  eXEntree  : TFloat;
  eYEntree  : TFloat;
  eZEntree  : TFloat;
  eDeltaX   : TFloat;
  eDeltaY   : TFloat;
  eDeltaZ   : TFloat;

  eRefSer   : integer;
  eRefSt    : integer;
  eObserv   : string;
end;

// expés
type
  pExpe = ^TExpe;
  TExpe = record
    IDExpe      : integer;
    JourExpe    : byte;
    MoisExpe    : byte;
    AnneeExpe   : word;
    Speleometre : String;
    Speleographe: string;
    ModeDecl    : byte;
    Declinaison : TFloat;
    Inclinaison : TFloat;
    Couleur     : Integer;
    Commentaire : string;
end;
// codes
type
  pCode = ^TCode;
  TCode = record
    IDCode      : integer;
    GradAz      : TFloat;
    GradInc     : TFloat;
    PsiL        : TFloat;
    PsiAz       : TFloat;
    PsiP        : TFloat;
    FactLong    : TFloat; // pour compatibilité ascendante
    AngLimite   : TFloat;
    TypeGalerie : byte;   // type de galerie
    Commentaire : string;
end;

// **********************************************
//  Types de données pour les outils graphiques
// **********************************************
// **********************************************
//  Types de données pour les outils graphiques
// **********************************************
// Fontes
type TFontPSProperties = record
  Name  : string;
  Size  : integer;
  Height: integer;
  Color : TColor;
  Style : TFontStyles;
end;
type TPenPSProperties = record
  Name    : string;
  Color   : TColor;
  fWidth  : double;
  nWidth  : integer;
end;
type TBrushPSProperties = record
  Color   : TColor;
  Alpha   : integer;
end;

// Entités
type TEntite = record
   //UID_Entite        : integer;                 // Couleur ID unique de l'entité
   ColorEntite       : TColor;
   Drawn             : boolean;                 // dessinée ?
   Type_Entite       : byte;                    // Type d'entité
   DateLeve          : TDateTime;
   Sub_System        : integer;                 // Sous-réseau, cavité, etc...
   Une_Station_1_X   : TFloat;                  // Extrémités des visées
   Une_Station_1_Y   : TFloat;
   Une_Station_1_Z   : TFloat;

   Une_Station_2_X   : TFloat;                // Extrémités des visées
   Une_Station_2_Y   : TFloat;
   Une_Station_2_Z   : TFloat;
   //LongVisee         : TFloat;
   X1PD                 : TFloat;      //         'X point droit contour
   Y1PD                 : TFloat;      //         'Y point gauche contour
   X1PG                 : TFloat;      //         'X point droit contour
   Y1PG                 : TFloat;      //         'Y point gauche contour

   X2PD                 : TFloat;      //         'X point droit contour
   Y2PD                 : TFloat;      //         'Y point gauche contour
   X2PG                 : TFloat;      //         'X point droit contour
   Y2PG                 : TFloat;      //         'Y point gauche contour

   Z1PH                 : TFloat;      //         'Z point haut contour
   Z1PB                 : TFloat;      //         'Z point bas contour
   Z2PH                 : TFloat;      //         'Z point haut contour
   Z2PB                 : TFloat;      //         'Z point bas contour

   ID_Litteral_Pt       : array[0..15] of char;    // ID alphanum. de l'entité
end;
type TDatesTopo = record
  //Displayed: Boolean;
  DateTopo : TDateTime;
end;
type TColorGaleries = record
  //Displayed : boolean;
  Color     : TColor;
end;
// descro des couches
type TLayer = record
  Name    :  string;
  Color   : TColor;
end;
// annotations
type TAnnotation = record
  FichierNOT    : string;
  X             : Double;
  Y             : Double;
  Color         : TColor;
  FontColor     : TColor; // Couleur de la fonte
  Caption       : String;
  FontName      : String;
  FontSize      : Byte;
  Accrochage    : Byte;
  FontBold      : boolean;
  FontItalic    : boolean;
  FontUnderline : boolean;
end;

//-----------------------------------------------
// définition des classes
//----------------------------------------------
// Classe pour la table des expés
type TTableExpes = class(TList);
// Classe pour la table des séries
type TTableSeries = class(TList);
//Classe pour la table des codes
type TTableCodes = class(TList);

//****************************
// fonctions communes
//****************************
function IsInRange(const Value: Extended;
                   const MinValue, MaxValue: Extended): Boolean; overload;
function IsInRange(const Value: integer;
                   const MinValue, MaxValue: integer): Boolean; overload;

function IIF(const Condition: boolean; const V1, V2: boolean): boolean; overload;
function IIF(const Condition: boolean; const V1, V2: integer): integer; overload;
function IIF(const Condition: boolean; const V1, V2: Extended): Extended; overload;
function IIF(const Condition: boolean; const V1, V2: String): String; overload;

function ProduitVectoriel(const Vect1, Vect2: TPoint3Df;
                          const Normalized: Boolean):TPoint3Df;
function CalculerAngles(const X1, Y1,
                              X2, Y2: TFloat): TFloat;
function Hypot2D(const DX, DY: Double): Double;
function Hypot3D(const DX, DY, DZ: Double): Double;

// définition des fonctions existant sous Linux mais absentes sous Zin
{$IFDEF MSWINDOWS}
  function StrToFloatDef(const S: string; const Default: Extended):Extended;
  function StrToIntDef  (const S: string; const Default: Integer): Integer;

{$ENDIF}

function GetAzimut(const dx, dy: Double; const Unite: double): double;

procedure GetBearingInc(const dx, dy, dz: double;
                        var Dist, Az, Inc: double;
                        const fUB, fUC: Double);
//*****************************************
//-------------------------------------
function RGB(const R, G, B: byte): integer;
function GetRValue(const Coul: TColor): Byte;
function GetGValue(const Coul: TColor): Byte;
function GetBValue(const Coul: TColor): Byte;
function GetFloatRValue(const C: TColor): TFloat;
function GetFloatGValue(const C: TColor): TFloat;
function GetFloatBValue(const C: TColor): TFloat;

//-------------------------------------
// routines de couleurs

function GetPCColor(const MC: TMacintoshColor): TColor; overload;
function GetPCColor(const mR, mG, mB: word):TColor; overload;

function GetMacColor(const PCC: TColor): TMacintoshColor;
function GetPASColor(const Coul: TGLColor): TColor;
function GetGLColor(const Coul: TColor): TGLColor;
function GetBYTEColor(const Coul: TColor): TColor3b;

function GetColorDegrade(const z: Double;
                         const zmin, zmax: Double;
                         const Coul1, Coul2: TColor): TColor;
function GetNTSCGrayScale(const C: TColor): Byte;
//*************

function EnlevePerluete(const s: string): string;
function IndexOfString(const S: string; const Strs: array of string): integer;
function ChooseString(const Index: integer; const Strs: array of string): string;
function SafeTruncateString(const Str: string; const L: integer): String;

procedure AfficherMessage(const Msg: string);

procedure DrawTriangleWithDegrade(const V1, V2, V3: TPoint3DF;
                                  const C1, C2, C3: TColor);

function GetDeclimag(const InitialDate, CurrentDate: TDateTime;
                     const InitialDeclimag, Variation: Double):Double;

// Convertir un fichier texte vers le format désiré
function ConvertTextFile(const InputFileName, OutputFilename: string;
                         const InputFormat, OutputFormat: TTextFileFormat): boolean;
implementation
{$IFDEF MSWINDOWS}
uses
  MainForm;  // pour la console de contrôle
{$ENDIF}
// calcul de déclinaison magnétique
function GetDeclimag(const InitialDate, CurrentDate: TDateTime;
                     const InitialDeclimag, Variation: Double):Double;
const INTERVALYEARS=10;
var
  y,m,d: word;
  d10a: TDateTime;
  d10d: double;
  p: double;
begin
  AfficherMessage(Format('GetDeclimag(%s, %s, %f, %f)',
                         [DateToStr(InitialDate),
                          DateToStr(CurrentDate),
                          InitialDeclimag, Variation]));
  DecodeDate(InitialDate,Y,M,D);
  d10a:=Encodedate(Y+INTERVALYEARS, M, D);
  d10a:=d10a - InitialDate;
  //d:=CurrentDate - InitialDate;
  d10d:=INTERVALYEARS * Variation;
  p:=d10d / d10a;

  Result:=InitialDeclimag + p * (CurrentDate - InitialDate);
end;

// définition des fonctions existant sous Linux mais absentes sous Zin
{$IFDEF MSWINDOWS}
function StrToFloatDef(const S: string; const Default: Extended):Extended;
begin
  try
    Result:=StrToFloat(S);
  except
    Result:=Default;
  end;
end;
function StrToIntDef(const S: string; const Default: Integer): Integer;
begin
  try
    Result:=StrToInt(S);
  except
    Result:=Default;
  end;
end;
{$ENDIF}

// afficher un message de contrôle
procedure AfficherMessage(const Msg: string);
begin
 {$IFDEF MSWINDOWS}
  try
   with dlgProcessing.ListBox1 do begin
      if Items.Count > 250 then
        Items.Delete(0);
      Items.Add(Msg);
      ItemIndex:=dlgProcessing.ListBox1.Items.Count-1;
      Refresh;
    end;
   except
   end;
 {$ENDIF}
 {$IFDEF LINUX}
    WriteLn(Msg);
 {$ENDIF}

end;

// choisir une chaine en fonction d'une valeur
function ChooseString(const Index: integer; const Strs: array of string): string;
begin
  try
    if (Index<0) or (Index>High(Strs)) then begin
      Result:=Format('** Erroneous index: %d **',[Index]);
      Exit;
    end;
    Result:=Strs[Index];
  finally
  end;
end;
function IndexOfString(const S: string; const Strs: array of string): integer;
var
  i: integer;
begin
  Result:=-1;
  try
    for i:=Low(Strs) to High(Strs) do
      if Pos(S, Strs[i])>0 then begin
        Result:=i;
        Exit;
      end;

  except
    Result:=-1;
  end;
end;
function Hypot3D(const DX, DY, DZ: Double): Double;
begin
  Result:=Sqrt(dx*dx+dy*dy+dz*dz);
end;
function Hypot2D(const DX, DY: Double): Double;
begin
  Result:=Sqrt(dx*dx+dy*dy);
end;
// retourne un azimut
function GetAzimut(const dx, dy: Double; const Unite: double): double;
var
  a: double;
begin
  a:=ArcTan2(dy, dx+1e-12);
  if a<0 then a:=a+2*PI;
  a:=0.50*PI-a;
  if a<0 then a:=a+2*PI;
  Result:=a*0.50*Unite/pi;
end;

// retourne la longueur, direction et pente pour dx, dy, dz
procedure GetBearingInc(const dx, dy, dz: double;
                        var Dist, Az, Inc: double;
                        const fUB, fUC: Double);
var
  dp: Double;
begin;
  dp  :=Hypot2D(dx, dy);
  Dist:=Hypot2D(dp,dz);
  Inc :=ArcTan2(dz, dp)*0.5*fUC/pi;
  //Az  :=(0.5*PI-ArcTan2(dY,dx))*0.5*fUB/pi;
  Az:=GetAzimut(dx,dy, fUB);
end;

// enlève les perluettes
function EnlevePerluete(const s: string): string;
var
  p: integer;
  st: string;
begin
  st:=s;
  p:=Pos('&',st);
  if p=0 then
  begin
    Result:=st;
    Exit;
  end;
  Delete(st,p,1);
  Result:=st;
end;
function ProduitVectoriel(const Vect1, Vect2: TPoint3Df;
                          const Normalized: Boolean):TPoint3Df;
var
  v: TPoint3Df;
  r: Extended;
begin
  v.X:=Vect1.Y*Vect2.Z-Vect1.Z*Vect2.Y;
  v.Y:=Vect1.Z*Vect2.X-Vect1.X*Vect2.Z;
  v.Z:=Vect1.X*Vect2.Y-Vect1.Y*Vect2.X;
  if Normalized then begin
    r:=sqrt(Sqr(v.x)+sqr(v.y)+sqr(v.z))+1e-12;
    v.X:=v.x/r;
    v.y:=v.y/r;
    v.z:=v.z/r;

  end;
  Result:=v;

end;
function CalculerAngles(const X1, Y1,
                              X2, Y2: TFloat): TFloat;
var
  V1, V2, W: TPoint3Df;
begin
  // vecteur V1           vecteur V2        vecteur w
  V1.X:=X1;               V2.X:=X2;         W.X :=0;
  V1.Y:=Y1;               V2.Y:=Y2;         W.Y :=0;
  V1.Z:=0;                V2.Z:=0;          W.Z :=1;
  // produits vectoriels
  v1:=ProduitVectoriel(v1,w,True);
  v2:=ProduitVectoriel(v2,w,True);
  //composition vectorielle
  w.x:=v1.x+v2.X;
  w.y:=v1.y+v2.Y;
  w.z:=v1.z+v2.z;
  // angles
  Result:=ArcTan2(w.y+1e-12, w.x+1e-12);
end;
//****************************************************************************
// fonctions de couleurs
function GetFloatRValue(const C: TColor): TFloat;
begin
  Result:=GetRValue(C) / 256;
end;
function GetFloatGValue(const C: TColor): TFloat;
begin
  Result:=GetGValue(C) / 256;
end;
function GetFloatBValue(const C: TColor): TFloat;
begin
  Result:=GetBValue(C) / 256;
end;
//*****************************************
// Conversions couleurs PC<>Mac
function GetPCColor(const MC: TMacintoshColor): TColor; overload;
begin
  Result:=RGB(MC.R shr 8,
              MC.G shr 8,
              MC.B shr 8);

end;
function GetPCColor(const mR, mG, mB: word):TColor; overload;
begin
  Result:=RGB(mR shr 8,
              mG shr 8,
              mB shr 8);
end;

function GetMacColor(const PCC: TColor): TMacintoshColor;
var M: TMacintoshColor;
begin
  M.R:=GetRValue(PCC) * 256;
  M.G:=GetGValue(PCC) * 256;
  M.B:=GetBValue(PCC) * 256;
  Result:=M;
end;
//-------------------------------------
//-------------------------------------
function GetBYTEColor(const Coul: TColor): TColor3b;
var
  c: TColor3b;
begin
  c.R:=GetRValue(Coul);
  c.G:=GetGValue(Coul);
  c.B:=GetBValue(Coul);
  Result:=c;

end;
// Retourne sous forme de couleur OpenGL la couleur passée en argument
function GetGLColor(const Coul: TColor): TGLColor;
const
  m = 1/256;
var
  c: TGLColor;
begin
  c.R:=GetRValue(Coul)* m;
  c.G:=GetGValue(Coul)* m;
  c.B:=GetBValue(Coul)* m;
  c.A:=1.00;
  Result:=c;
end;

//-------------------------------------
// Conversion Couleur OPENGL>Couleur Pascal
function GetPASColor(const Coul: TGLColor): TColor;
const
  m = 256;
var
  c: TColor;
begin
  c:=RGB(Round(Coul.R * m),
         Round(Coul.G * m),
         Round(Coul.B * m));
  Result:=c;
end;
//----------------------------------------------------------------
// dégradé de couleurs
function GetColorDegrade(const z: Double;
                         const zmin, zmax: Double;
                         const Coul1, Coul2: TColor): TColor;
var
  D: Double;
  H: Double;
  C1, C2, C: TColor3b;
  //DC       : TColor3b;
  DR, DG, DB : SmallInt;
begin
  D:=zmax-zmin;
  if Abs(D)<1e-8 then
  begin
    Result:=Coul1;
    Exit;
  end;
  H:=(z-zmin)/D;

  c1:=GetBYTEColor(Coul1);
  c2:=GetBYTEColor(Coul2);
  DR:=C2.R-C1.R;
  DG:=C2.G-C1.G;
  DB:=C2.B-C1.B;

  C.R:=Round(C1.R + H * DR);
  C.G:=Round(C1.G + H * DG);
  C.B:=Round(C1.B + H * DB);

  Result:=RGB(C.R, C.G, C.B);
end;
//-------------------------------------------------------
//Convertit une couleur en niveaux de gris; méthode NTSC.
function GetNTSCGrayScale(const C: TColor): Byte;
var
  cl: TColor3b;
begin
  cl:=GetBYTEColor(C);
  Result:=round(0.30 * cl.R + 0.59 * cl.G + 0.11 * cl.B);
end;

//-------------------------------------
function RGB(const R, G, B: byte): integer;
begin
  Result:=(R or (G shl 8) or (B shl 16));
end;
function GetRValue(const Coul: TColor): Byte;
begin
  Result:= Coul;
end;
function GetGValue(const Coul: TColor): Byte;
begin
  Result:= Coul shr 8;
end;
function GetBValue(const Coul: TColor): Byte;
begin
  Result:= Coul shr 16;
end;
//-------------------------------------
function IsInRange(const Value: Extended;
                   const MinValue, MaxValue: Extended): Boolean; overload;
begin
  if (Value >= MinValue) and
     (Value < MaxValue) then
    Result:=True
  else
    Result:=False;
  AfficherMessage(Format('%f %f %f %d',[Value, MinValue, MaxValue,
                                        IIf(Result, 1, 0)]));
end;
function IsInRange(const Value: integer;
                   const MinValue, MaxValue: integer): Boolean; overload;
begin
  if (Value >= MinValue) and
     (Value < MaxValue) then
    Result:=True
  else
    Result:=False;
end;

//-------------------------------------
function IIF(const Condition: boolean; const V1, V2: integer): integer; overload;
begin
  if Condition then Result:=V1 else Result:=V2;
end;
function IIF(const Condition: boolean; const V1, V2: Extended): Extended; overload;
begin
  if Condition then Result:=V1 else Result:=V2;
end;
function IIF(const Condition: boolean; const V1, V2: boolean): boolean; overload;
begin
  if Condition then Result:=V1 else Result:=V2;
end;
function IIF(const Condition: boolean; const V1, V2: String): String; overload;
begin
  if Condition then Result:=V1 else Result:=V2;
end;

// dessiner un triangle dégradé
procedure DrawTriangleWithDegrade(const V1, V2, V3: TPoint3DF;
                                  const C1, C2, C3: TColor);

begin
;
end;

// Convertir un fichier texte vers le format désiré
// cette variante utilise un TStringList
function ConvertTextFile(const InputFileName, OutputFilename: string;
                         const InputFormat, OutputFormat: TTextFileFormat): boolean;
var
  FI: File;
  FO  : TextFile;
  ENDL: string;   // fin de ligne
  ALine: string;
  i,j: integer;
begin
  Result:=False;
  if Not(FileExists(InputFileName)) then Exit;
  case OutputFormat of
    tfWINDOWS: ENDL:=#13+#10;
    tfUNIX   : ENDL:=#10;
    tfMAC    : ENDL:=#13;
  end;
  with TStringList.Create do begin
  try
    Clear;
    LoadFromFile(InputFileName);
    AssignFile(FO, OutputFilename);
    ReWrite(FO);
    try
      try
        for i:=0 to Count-1 do begin
          ALine:=Trim(Strings[i])+ENDL;
          Write(FO, ALine);
        end;
        Result:=True;
      except
      end;
    finally
      CloseFile(FO);
    end;
  finally // with TStringList
    Clear;
    Free;
  end;
  end;
end;
(*
for w1:=0 to Length(Lin) do if Lin[w1]=#136 then Lin[w1]:='à';
    for w1:=0 to Length(Lin) do if Lin[w1]=#142 then Lin[w1]:='é';
    for w1:=0 to Length(Lin) do if Lin[w1]=#143 then Lin[w1]:='è';
    for w1:=0 to Length(Lin) do if Lin[w1]=#148 then Lin[w1]:='î';
    for w1:=0 to Length(Lin) do if Lin[w1]=#137 then Lin[w1]:='â';
    for w1:=0 to Length(Lin) do if Lin[w1]=#144 then Lin[w1]:='ê';
    for w1:=0 to Length(Lin) do if Lin[w1]=#144 then Lin[w1]:='ë';
    for w1:=0 to Length(Lin) do if Lin[w1]=#141 then Lin[w1]:='ç';
//*)
function SafeTruncateString(const Str: string; const L: integer): String;
begin
 if Length(Str)>L then
   Result:=Trim(Copy(Str, 1, L))
 else
   Result:=Trim(Str);
end;
end.

//------------------------
//----------------------------------
unit PostScriptCanvasUnit;

interface
uses
  SysUtils,
  Classes,
  Common,
  Graphics;
type TPostScriptCanvas = class
    constructor Create;
    destructor  Destroy; override;
  private
    FPSFile: string;
    FCommentaire: string;
    FNbWrittenLines: integer;
    FScale: double;

    FFont : TFontPSProperties;
    FPen  : TPenPSProperties;
    FBrush: TBrushPSProperties;
    FXMin,
    FXMax,
    FYMin,
    FYMax : Double;
  public
    function  InitializeDocument: boolean;
    procedure FinalizeDocument;
    // limites du dessin
    procedure SetDrawingBounds(const X1, Y1, X2, Y2: Double);
    // définition des couleurs et fontes
    procedure SetPen(const Value: TPenPSProperties);
    procedure SetDefaultPen(const Value: TPenPSProperties);
    procedure SetDefaultBrush(const Value: TBrushPSProperties);

    function  GetPen: TPenPSProperties;
    procedure SetBrush(const Value: TBrushPSProperties);
    function  GetBrush: TBrushPSProperties;
    procedure SetFont(const Value: TFontPSProperties);

    //****************************
    procedure SaveToFile;
    // définition de commentaire
    procedure WriteCommentaire(const s: string);
    procedure WriteCommand(const s: string);
    // définition de couches
    procedure BeginLayer(const LayerName: string);
    procedure EndLayer(const LayerName: string);
    // routines de dessin
    procedure MoveTo(const X,Y: Double);
    procedure LineTo(const X,Y: Double);
    procedure DrawPoint(const X,Y: Double);
    procedure DrawLine(const X1, Y1, X2, Y2: Double);
    procedure DrawCircle(const XC, YC, R: double);
    procedure DrawPolylign(const Points: array of TPoint2Df);
    procedure DrawPolygon(const Points: array of TPoint2Df);
    procedure DrawBorderedPolygon(const Points: array of TPoint2Df);
    procedure TextOut(const X,Y: Double; const Text: string);
    //*******************
    property PSFile: string read FPSFile write FPSFile;
    property Commentaire: string read FCommentaire write FCommentaire;
    property Scale: double read FScale write FScale;
    property Font : TFontPSProperties  read FFont  write FFont;
    //property Pen  : TPenPSProperties   read GetPen write FPen index;//SetPen;
    property Brush: TBrushPSProperties read FBrush write FBrush;

end;

implementation
var
  pPSFILE: TextFile;

procedure DisplayMsg(const Str: string);
begin
  ;//WriteLn(Str);
end;
procedure WriteLine(const S: string);
begin
  WriteLn(pPSFILE, s);
end;

constructor TPostScriptCanvas.Create;
begin
 inherited Create;
 DisplayMsg(Format('%s.Create',[ClassName]));
 try

 except
 end;
end;
destructor TPostScriptCanvas.Destroy;
begin
 DisplayMsg(Format('%s.Free',[ClassName]));
 inherited Destroy;
end;
//**** Définition des pinceaux et couleurs
function TPostScriptCanvas.GetPen: TPenPSProperties;
begin
  Result:=FPen;
end;
procedure TPostScriptCanvas.SetPen(const Value: TPenPSProperties);
begin
  FPen:=Value;
end;
procedure TPostScriptCanvas.SetBrush(const Value: TBrushPSProperties);
begin
  FBrush:=Value;
end;
function  TPostScriptCanvas.GetBrush: TBrushPSProperties;
begin
  Result:=FBrush;
end;

procedure TPostScriptCanvas.SetFont(const Value: TFontPSProperties);
begin
  WriteLine('/Helvetica findfont');
  WriteLine(Format('%d scalefont setfont',[Value.Size]));

end;
procedure TPostScriptCanvas.SetDefaultPen(const Value: TPenPSProperties);
begin
  WriteLine(Format('%f %f %f srgb',[GetFloatRValue(FPen.Color),
                                    GetFloatGValue(FPen.Color),
                                    GetFloatBValue(FPen.Color)]));
  WriteLine(Format('%f setlinewidth',[FPen.fWidth]));
end;
procedure TPostScriptCanvas.SetDefaultBrush(const Value: TBrushPSProperties);
begin
;
end;

//*******************
procedure TPostScriptCanvas.SetDrawingBounds(const X1, Y1, X2, Y2: Double);
begin
  FXMin:=X1;
  FYMin:=Y1;
  FXMax:=X2;
  FYMax:=Y2;
end;
procedure TPostScriptCanvas.WriteCommand(const s: string);
begin
  WriteLine(Trim(S));
end;
//****************************
procedure TPostScriptCanvas.WriteCommentaire(const s: string);
begin
  WriteLine(Format('%% %s %%',[s]));
end;
//****************************
function TPostScriptCanvas.InitializeDocument: boolean;
  procedure DefinePSMacro(const Alias, Instrs, Comments: string);
  begin
    WriteLine(Format('/%s {%s} def %% %s',[Alias, Instrs, Comments]));
  end;
begin
  Result:=False;
  FNbWrittenLines:=0;
  assignFile(pPSFILE, FPSFile);
  try
    ReWrite(pPSFILE);
    //-------------------------------
    // écriture de l'en tête ici
    // ------------------------------
    WriteLine('%!PS-Adobe-3.0');
    WriteLine('%% PostScript File generated by GHTopo %%');
    WriteLine(Format('%%%% File    : %s %%%%',[FPSFile]));
    WriteLine(Format('%%%% Date    : %s %%%%',[DateToStr(Now)]));
    WriteLine(Format('%%%% Comments: %s %%%%',[FCommentaire]));

    WriteLine(Format('%%%%%s%%%%',[StringOfChar('=',80)]));
    // écriture des alias
    WriteLine('% Alias list');
    DefinePSMacro('m', 'moveto', '');
    DefinePSMacro('l', 'lineto', '');
    DefinePSMacro('srgb', 'setrgbcolor', '');

    // le dessin
    WriteLine('');
    WriteLine('%% Drawing %%');
    WriteLine('');
    Result:=True;
  except
    DisplayMsg('Error initializing text file');
    CloseFile(pPSFILE);
  end;
end;
procedure TPostScriptCanvas.FinalizeDocument;
begin
  try
    writeLine('showpage');
    WriteLine('%EOF');
  finally
    CloseFile(pPSFILE);
  end;
end;
// définition de couches
procedure TPostScriptCanvas.BeginLayer(const LayerName: string);
begin
  WriteLine(Format('%% Begin Layer: %s %%',[LayerName]));
  WriteLine('%AI5_BeginLayer');

end;
procedure TPostScriptCanvas.EndLayer(const LayerName: string);
begin
  WriteLine('%AI5_EndLayer--');
  WriteLine(Format('%% End Layer: %s %%',[LayerName]));
end;
//********* routines de dessin
procedure TPostScriptCanvas.MoveTo(const X,Y: Double);
begin
  WriteLine('newpath');
  WriteLine(Format('  %f %f m',[X,Y]));
end;

procedure TPostScriptCanvas.LineTo(const X,Y: Double);  (* peu utilisé *)
begin
  WriteLine(Format('  %f %f l',[X,Y]));
end;

procedure TPostScriptCanvas.DrawPoint(const X,Y: Double);
begin
;
end;
procedure TPostScriptCanvas.DrawCircle(const XC, YC, R: double);
begin
  WriteLine('newpath');
  WriteLine(Format('%f %f %f 0 360 arc',[XC, YC, R]));
  WriteLine(Format('%f %f %f srgb',[GetFloatRValue(FPen.Color),
                                    GetFloatGValue(FPen.Color),
                                    GetFloatBValue(FPen.Color)]));
  WriteLine(Format('%f setlinewidth',[FPen.fWidth]));
  WriteLine('stroke');
end;

procedure TPostScriptCanvas.DrawLine(const X1, Y1, X2, Y2: Double);
begin
  WriteLine('newpath');
  WriteLine(Format('  %f %f m',[X1,Y1]));
  WriteLine(Format('  %f %f l',[X2,Y2]));
  WriteLine(Format('%f %f %f srgb',[GetFloatRValue(FPen.Color),
                                    GetFloatGValue(FPen.Color),
                                    GetFloatBValue(FPen.Color)]));
  WriteLine(Format('%f setlinewidth',[FPen.fWidth]));
  WriteLine('stroke');
end;

procedure TPostScriptCanvas.DrawPolylign(const Points: array of TPoint2Df);
var
  i: integer;
begin
  if (High(Points)<1) then Exit;
  WriteLine('newpath');
  WriteLine(Format('  %f %f m',[Points[0].X, Points[0].Y]));
  for i:=1 to High(Points) do
    WriteLine(Format('  %f %f l',[Points[i].X, Points[i].Y]));
  WriteLine(Format('%f %f %f srgb',[GetFloatRValue(FPen.Color),
                                    GetFloatGValue(FPen.Color),
                                    GetFloatBValue(FPen.Color)]));
  WriteLine(Format('%f setlinewidth',[FPen.fWidth]));
  WriteLine('stroke');
end;

procedure TPostScriptCanvas.DrawPolygon(const Points: array of TPoint2Df);
var
  i: integer;
begin
  if (High(Points)<1) then Exit;
  //WriteLine('newpath');
  WriteLine(Format('  %f %f m',[Points[0].X, Points[0].Y]));
  for i:=1 to High(Points) do
    WriteLine(Format('  %f %f l',[Points[i].X, Points[i].Y]));
  WriteLine(Format('%f %f %f srgb',[GetFloatRValue(FBrush.Color),
                                    GetFloatGValue(FBrush.Color),
                                    GetFloatBValue(FBrush.Color)]));

  WriteLine('fill');
end;
procedure TPostScriptCanvas.DrawBorderedPolygon(const Points: array of TPoint2Df);
var
  i: integer;
begin
  if (High(Points)<1) then Exit;
  WriteLine('newpath');
  WriteLine(Format('  %f %f m',[Points[0].X, Points[0].Y]));
  for i:=1 to High(Points) do
    WriteLine(Format('  %f %f l',[Points[i].X, Points[i].Y]));
  WriteLine('gsave');
  WriteLine(Format('%f %f %f srgb',[GetFloatRValue(FBrush.Color),
                                    GetFloatGValue(FBrush.Color),
                                    GetFloatBValue(FBrush.Color)]));
  WriteLine('fill');
  WriteLine('grestore');
  WriteLine(Format('%f %f %f srgb',[GetFloatRValue(FPen.Color),
                                    GetFloatGValue(FPen.Color),
                                    GetFloatBValue(FPen.Color)]));
  WriteLine(Format('%f setlinewidth',[FPen.fWidth]));
  WriteLine('closepath');
  WriteLine('stroke');
end;

procedure TPostScriptCanvas.TextOut(const X,Y: Double; const Text: string);
begin
   WriteLine(Format('%f %f moveto (%s) show',[X,Y,Text]));
end;
//*****************************
procedure TPostScriptCanvas.SaveToFile;
begin
;
end;

end.

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (speletux)