From 70c99062d72f2e4f58960a150c763d0c65fbf13a Mon Sep 17 00:00:00 2001 From: mattias Date: Wed, 17 Mar 2004 11:28:35 +0000 Subject: [PATCH] fixed setting project LCLWidgetSet in defines git-svn-id: trunk@5313 - --- components/codetools/definetemplates.pas | 15 +- ide/compileroptions.pp | 10 +- ide/lazarusidestrconsts.pas | 1 - ide/main.pp | 39 +- ide/project.pp | 5 +- lcl/postscriptprinter.pas | 578 ++++++++++------------- 6 files changed, 292 insertions(+), 356 deletions(-) diff --git a/components/codetools/definetemplates.pas b/components/codetools/definetemplates.pas index 80917dca45..bd8287c9b4 100644 --- a/components/codetools/definetemplates.pas +++ b/components/codetools/definetemplates.pas @@ -2054,6 +2054,7 @@ var MacroParam: string; OldMacroLen: Integer; Handled: Boolean; + MacroVarName: String; begin Result:=false; MacroFuncNameEnd:=MacroEnd; @@ -2071,17 +2072,18 @@ var MacroStr:=ExecuteMacroFunction(MacroFuncName,MacroParam); end else begin // Macro variable - MacroStr:=copy(CurValue,MacroStart+2,MacroEnd-MacroStart-3); - //writeln('**** MacroStr=',MacroStr); + MacroVarName:=copy(CurValue,MacroStart+2,MacroEnd-MacroStart-3); + MacroStr:=MacroVarName; + //writeln('**** MacroVarName=',MacroVarName,' ',DirDef.Values.Variables[MacroVarName]); //writeln('DirDef.Values=',DirDef.Values.AsString); - if MacroStr=DefinePathMacroName then begin + if MacroVarName=DefinePathMacroName then begin MacroStr:=CurDefinePath; - end else if DirDef.Values.IsDefined(MacroStr) then begin - MacroStr:=DirDef.Values.Variables[MacroStr]; + end else if DirDef.Values.IsDefined(MacroVarName) then begin + MacroStr:=DirDef.Values.Variables[MacroVarName]; end else begin Handled:=false; if Assigned(FOnReadValue) then begin - MacroParam:=MacroStr; + MacroParam:=MacroVarName; MacroStr:=''; FOnReadValue(Self,MacroParam,MacroStr,Handled); end; @@ -2092,7 +2094,6 @@ var MacroStr:=''; end; end; - //writeln('**** NewValue MacroStr=',MacroStr); end; NewMacroLen:=length(MacroStr); GrowBuffer(BufferPos+NewMacroLen-OldMacroLen+ValueLen-ValuePos+1); diff --git a/ide/compileroptions.pp b/ide/compileroptions.pp index 034d687525..49f7f85438 100644 --- a/ide/compileroptions.pp +++ b/ide/compileroptions.pp @@ -329,6 +329,7 @@ type function ShortenPath(const SearchPath: string; MakeAlwaysRelative: boolean): string; function GetCustomOptions: string; + function GetEffectiveLCLWidgetType: string; public { Properties } property Owner: TObject read fOwner write fOwner; @@ -1644,6 +1645,13 @@ begin Result:=SpecialCharsToSpaces(Result); end; +function TBaseCompilerOptions.GetEffectiveLCLWidgetType: string; +begin + Result:=LCLWidgetType; + if (Result='') or (Result='default') then + Result:=GetDefaultLCLWidgetType; +end; + function TBaseCompilerOptions.ShortenPath(const SearchPath: string; MakeAlwaysRelative: boolean): string; begin @@ -4709,7 +4717,7 @@ begin Top:= y; Width:=Self.ClientWidth-28; Height:=45; - Caption:=dlgLCLWidgetType; + Caption:=lisLCLWidgetType; with Items do begin Add(Format(lisCOdefault, [GetDefaultLCLWidgetType])); Add('gnome'); diff --git a/ide/lazarusidestrconsts.pas b/ide/lazarusidestrconsts.pas index 922e4e8e98..6d0664439f 100644 --- a/ide/lazarusidestrconsts.pas +++ b/ide/lazarusidestrconsts.pas @@ -898,7 +898,6 @@ resourcestring lisCOScanForMakeMessages = 'Scan for Make messages'; lisCOShowAllMessages = 'Show all messages'; dlgUnitOutp = 'Unit output directory:'; - dlgLCLWidgetType = 'LCL Widget Type'; lisCOdefault = 'default (%s)'; dlgButApply = 'Apply'; dlgCOShowOptions = 'Show Options'; diff --git a/ide/main.pp b/ide/main.pp index 4da97c3201..01573ab48e 100644 --- a/ide/main.pp +++ b/ide/main.pp @@ -5180,7 +5180,7 @@ Begin Project1.Units[i].Modified:=false; Project1.Modified:=false; -writeln('TMainIDE.DoNewProject end ',CodeToolBoss.ConsistencyCheck); + writeln('TMainIDE.DoNewProject end '); Result:=mrOk; end; @@ -7295,115 +7295,95 @@ begin exit; end; MacroName:=lowercase(TheMacro.Name); + Handled:=true; if MacroName='save' then begin - Handled:=true; if (SourceNoteBook<>nil) and (SourceNoteBook.NoteBook<>nil) then Abort:=(DoSaveEditorFile(SourceNoteBook.NoteBook.PageIndex, [sfCheckAmbigiousFiles])<>mrOk); s:=''; end else if MacroName='saveall' then begin - Handled:=true; Abort:=(DoSaveAll([sfCheckAmbigiousFiles])<>mrOk); s:=''; end else if MacroName='edfile' then begin - Handled:=true; if (SourceNoteBook<>nil) and (SourceNoteBook.NoteBook<>nil) then s:=Project1.UnitWithEditorIndex(SourceNoteBook.NoteBook.PageIndex).Filename else s:=''; end else if MacroName='col' then begin - Handled:=true; if (SourceNoteBook<>nil) and (SourceNoteBook.NoteBook<>nil) then s:=IntToStr(SourceNoteBook.GetActiveSE.EditorComponent.CaretX); end else if MacroName='row' then begin - Handled:=true; if (SourceNoteBook<>nil) and (SourceNoteBook.NoteBook<>nil) then s:=IntToStr(SourceNoteBook.GetActiveSE.EditorComponent.CaretY); end else if MacroName='projfile' then begin - Handled:=true; if Project1<>nil then s:=Project1.MainFilename else s:=''; end else if MacroName='projpath' then begin - Handled:=true; if Project1<>nil then s:=Project1.ProjectDirectory else s:=''; end else if MacroName='projunitpath' then begin - Handled:=true; if Project1<>nil then s:=Project1.CompilerOptions.GetUnitPath(false) else s:=''; end else if MacroName='projincpath' then begin - Handled:=true; if Project1<>nil then s:=Project1.CompilerOptions.GetIncludePath(false) else s:=''; end else if MacroName='projsrcpath' then begin - Handled:=true; if Project1<>nil then s:=Project1.CompilerOptions.GetSrcPath(false) else s:=''; end else if MacroName='projpublishdir' then begin - Handled:=true; if Project1<>nil then s:=Project1.PublishOptions.DestinationDirectory else s:=''; end else if MacroName='curtoken' then begin - Handled:=true; if (SourceNoteBook<>nil) and (SourceNoteBook.NoteBook<>nil) then with SourceNoteBook.GetActiveSE.EditorComponent do s:=GetWordAtRowCol(CaretXY); end else if MacroName='lazarusdir' then begin - Handled:=true; s:=EnvironmentOptions.LazarusDirectory; end else if MacroName='lclwidgettype' then begin - Handled:=true; if Project1<>nil then s:=Project1.CompilerOptions.LCLWidgetType else s:=''; if (s='') or (s='default') then s:=GetDefaultLCLWidgetType; end else if MacroName='targetcpu' then begin - Handled:=true; if Project1<>nil then s:=lowercase(Project1.CompilerOptions.TargetCPU) else s:=''; if (s='') or (s='default') then s:=GetDefaultTargetCPU; end else if MacroName='targetos' then begin - Handled:=true; if Project1<>nil then s:=lowercase(Project1.CompilerOptions.TargetOS) else s:=''; if (s='') or (s='default') then s:=GetDefaultTargetOS; end else if MacroName='fpcsrcdir' then begin - Handled:=true; s:=EnvironmentOptions.FPCSourceDirectory; end else if MacroName='comppath' then begin - Handled:=true; s:=EnvironmentOptions.CompilerFilename; end else if MacroName='params' then begin - Handled:=true; if Project1<>nil then s:=Project1.RunParameterOptions.CmdLineParams else s:=''; end else if MacroName='targetfile' then begin - Handled:=true; if Project1<>nil then s:=GetProjectTargetFilename else s:=''; end else if MacroName='targetcmdline' then begin - Handled:=true; if Project1<>nil then begin s:=Project1.RunParameterOptions.CmdLineParams; if s='' then @@ -7413,27 +7393,24 @@ begin end else s:=''; end else if MacroName='testdir' then begin - Handled:=true; if Project1<>nil then s:=GetTestBuildDir else s:=''; end else if MacroName='runcmdline' then begin - Handled:=true; if Project1<>nil then s:=GetRunCommandLine else s:=''; end else if MacroName='projpublishdir' then begin - Handled:=true; if Project1<>nil then s:=GetProjPublishDir else s:=''; end else if MacroName='confdir' then begin - Handled:=true; s:=GetPrimaryConfigPath; - end; + end else + Handled:=false; end; function TMainIDE.OnSubstituteCompilerOption(Options: TParsedCompilerOptions; @@ -8371,7 +8348,7 @@ begin EnvironmentOptions.LazarusDirectory; Variables[ExternalMacroStart+'FPCSrcDir']:= EnvironmentOptions.FPCSourceDirectory; - Variables[ExternalMacroStart+'LCLWidgetType']:='gtk'; + Variables[ExternalMacroStart+'LCLWidgetType']:=GetDefaultLCLWidgetType; Variables[ExternalMacroStart+'ProjPath']:=VirtualDirectory; end; @@ -10273,7 +10250,7 @@ begin end else if (not (ALayout.WindowPlacement in [iwpDocked,iwpUseWindowManagerSetting])) then begin - // default position + // default window positions l:=NonModalIDEFormIDToEnum(ALayout.FormID); case l of nmiwMainIDEName: @@ -10329,7 +10306,6 @@ end; //----------------------------------------------------------------------------- initialization - { $I mainide.lrs} {$I images/laz_images.lrs} {$I images/mainicon.lrs} ShowSplashScreen:=true; @@ -10339,6 +10315,9 @@ end. { ============================================================================= $Log$ + Revision 1.717 2004/03/17 11:28:35 mattias + fixed setting project LCLWidgetSet in defines + Revision 1.716 2004/03/15 15:56:24 mattias fixed package ID string to ID conversion diff --git a/ide/project.pp b/ide/project.pp index 73afab419f..cfce5d021a 100644 --- a/ide/project.pp +++ b/ide/project.pp @@ -2818,7 +2818,7 @@ begin Changed:=false; Changed:=Changed or CodeToolBoss.SetGlobalValue( ExternalMacroStart+'LCLWidgetType', - Owner.CompilerOptions.LCLWidgetType); + Owner.CompilerOptions.GetEffectiveLCLWidgetType); if Owner.IsVirtual then NewProjectDir:=VirtualDirectory else @@ -2833,6 +2833,9 @@ end. { $Log$ + Revision 1.151 2004/03/17 11:28:35 mattias + fixed setting project LCLWidgetSet in defines + Revision 1.150 2004/03/15 15:56:24 mattias fixed package ID string to ID conversion diff --git a/lcl/postscriptprinter.pas b/lcl/postscriptprinter.pas index 6a88cbabd4..ee5a4f45b7 100644 --- a/lcl/postscriptprinter.pas +++ b/lcl/postscriptprinter.pas @@ -57,7 +57,7 @@ type TPSTileType = (ttConstant, ttNoDistortion, ttFast); TPostScriptCanvas = class; // forward reference - {Remember, modifying a pattern affects that pattern for the ENTIRE document!} + { Remember, modifying a pattern affects that pattern for the ENTIRE document! } TPSPattern = class(TObject) private FOldName: String; @@ -90,7 +90,7 @@ type property Name: String read FName write SetName; property Canvas: TPostScriptCanvas read FCanvas; property GetPS: TStringList read GetPostscript; - property OldName: string read FOldName write FOldName; // used when notifying that name changed + property OldName: string read FOldName write FOldName; // used when notifying that name Changed property OnChange: TNotifyEvent read FOnChange write FOnChange; end; PPSPattern = ^TPSPattern; // used for array @@ -155,7 +155,7 @@ type MPostScript: TPostScript; constructor Create(APostScript: TPostScript); destructor Destroy; override; - procedure clear; + procedure Clear; property PostScript: TStringList read FPostScript write FPostScript; property FontFace: String read FFontFace write SetFontFace; property FontSize: Integer read FFontSize write SetFontSize; @@ -170,7 +170,7 @@ type procedure Ellipse(const Rect: TRect); procedure Pie(x,y,width,mheight,angle1,angle2 : Integer); //procedure Pie(x,y,width,height,SX,SY,EX,EY : Integer); - procedure Writeln(AString: String); + procedure Writeln(const AString: String); procedure TextOut(X,Y: Integer; const Text: String); //procedure Chord(x,y,width,height,angle1,angle2 : Integer); //procedure Chord(x,y,width,height,SX,SY,EX,EY : Integer); @@ -219,7 +219,6 @@ type procedure PatternChanged(Sender: TObject); procedure InsertPattern(APattern: TPSPattern); // adds the pattern to the postscript procedure RemovePattern(APattern: TPSPattern); // remove the pattern from the postscript - public constructor Create; destructor Destroy; override; @@ -239,22 +238,22 @@ type procedure EndDoc; end; + implementation + { TPostScriptCanvas ----------------------------------------------------------} { Y coords in postscript are backwards... } function TPostScriptCanvas.TranslateY(Ycoord: Integer): Integer; begin - Result := FHeight - Ycoord; + Result := FHeight - Ycoord; end; { Adds a fill finishing line to any path we desire to fill } procedure TPostScriptCanvas.AddFill; begin - - FPostScript.Add('gsave '+FBrush.AsString+' fill grestore'); - + FPostScript.Add('gsave '+FBrush.AsString+' fill grestore'); end; { Sets the current font face} @@ -264,22 +263,19 @@ var begin if FFontFace=AValue then exit; if pos(' ',AValue) > -1 then - FFontFace := '('+AValue+')' + FFontFace := '('+AValue+')' else FFontFace:=AValue; - MyString := '/'+FFontFace+' '+inttostr(FFontSize)+' selectfont'; + MyString := '/'+FFontFace+' '+IntToStr(FFontSize)+' selectfont'; // set the pen info FPostScript.Add(MyString); - end; function TPostScriptCanvas.GetColor: TColor; begin - - Result := FColor; - + Result := FColor; end; procedure TPostScriptCanvas.SetBrush(const AValue: TPSPen); @@ -290,22 +286,19 @@ end; procedure TPostScriptCanvas.SetColor(const AValue: TColor); begin - - FColor := AValue; - - + FColor := AValue; end; procedure TPostScriptCanvas.SetFontSize(const AValue: Integer); begin if FFontSize=AValue then exit; FFontSize:=AValue; - FPostScript.Add('/'+FFontFace+' '+inttostr(AValue)+' selectfont'); + FPostScript.Add('/'+FFontFace+' '+IntToStr(AValue)+' selectfont'); end; procedure TPostScriptCanvas.SetPen(const AValue: TPSPen); begin - // change to ASSIGN method? + // change to ASSIGN method? if FPen=AValue then exit; FPen:=AValue; end; @@ -314,79 +307,74 @@ end; { Return to last moveto location } procedure TPostScriptCanvas.ResetPos; begin - // any routines that you specify a start location when calling such as - // textout, ellipse, etc. should not affect the default cursor location. - - FPostScript.Add(inttostr(LastX)+' '+inttostr(TranslateY(LastY))+' moveto'); + // any routines that you specify a start location when calling such as + // textout, ellipse, etc. should not affect the default cursor location. + FPostScript.Add(IntToStr(LastX)+' '+IntToStr(TranslateY(LastY))+' moveto'); end; -{ This is called when drawing pen is changed but NOT when brush changes } +{ This is called when drawing pen is Changed but NOT when brush changes } procedure TPostScriptCanvas.PenChanged(Sender: TObject); begin - if FPostScript[FPostScript.Count-2] = '%%PEN' then begin + if FPostScript[FPostScript.Count-2] = '%%PEN' then begin // last operation was a pen, so delete it FPostScript.Delete(FPostScript.Count-1); FPostScript.Delete(FPostScript.Count-1); - end; - FPostScript.Add('%%PEN'); - FPostScript.Add(FPen.AsString); - + end; + FPostScript.Add('%%PEN'); + FPostScript.Add(FPen.AsString); end; constructor TPostScriptCanvas.Create(APostScript: TPostScript); begin - MPostScript := APostScript; + MPostScript := APostScript; - FPostScript := TStringList.Create; - FHeight := 792; // length of page in points at 72 ppi + FPostScript := TStringList.Create; + FHeight := 792; // length of page in points at 72 ppi - // Choose a standard font in case the user doesn't - FFontFace := 'AvantGarde-Book'; - SetFontSize(10); + // Choose a standard font in case the user doesn't + FFontFace := 'AvantGarde-Book'; + SetFontSize(10); - if Assigned(MPostScript) then begin + if Assigned(MPostScript) then begin FLineSpacing := MPostScript.LineSpacing; - end; + end; - FPen := TPSPen.Create; - FPen.Width := 1; - FPen.Color := 0; - FPen.OnChange := @PenChanged; + FPen := TPSPen.Create; + FPen.Width := 1; + FPen.Color := 0; + FPen.OnChange := @PenChanged; - FBrush := TPSPen.Create; - FBrush.Width := 1; - FBrush.Color := -1; - // don't notify us that the brush changed... - + FBrush := TPSPen.Create; + FBrush.Width := 1; + FBrush.Color := -1; + // don't notify us that the brush Changed... end; destructor TPostScriptCanvas.Destroy; begin - FPostScript.Free; - FPen.Free; - FBrush.Free; + FPostScript.Free; + FPen.Free; + FBrush.Free; inherited Destroy; end; -{ Clear the postscript canvas AND the graphic canvas (add later) } +{ Clear the postscript canvas AND the graphic canvas (Add later) } procedure TPostScriptCanvas.clear; begin + // clear the canvas for the next page + FPostScript.Clear; + // Choose a standard font in case the user doesn't + FPostScript.Add('/AvantGarde-Book findfont'); + FPostScript.Add('10 scalefont'); + FPostScript.Add('setfont'); - // clear the canvas for the next page - FPostScript.Clear; - // Choose a standard font in case the user doesn't - FPostScript.Add('/AvantGarde-Book findfont'); - FPostScript.Add('10 scalefont'); - FPostScript.Add('setfont'); - - // also clear the canvas itself if we plan to embed the bitmap into - // the postscript - - // also grab the latest canvas height just in case it's changed - FHeight := 792; - if assigned(MPostScript) then FHeight := MPostScript.Height; + // also clear the canvas itself if we plan to embed the bitmap into + // the postscript + // also grab the latest canvas height just in case it's Changed + FHeight := 792; + if Assigned(MPostScript) then FHeight := MPostScript.Height; end; { Move draw location } @@ -394,10 +382,10 @@ procedure TPostScriptCanvas.MoveTo(X1, Y1: Integer); var Y: Integer; begin - Y := TranslateY(Y1); - FPostScript.Add(inttostr(X1)+' '+inttostr(Y)+' moveto'); - LastX := X1; - LastY := Y1; + Y := TranslateY(Y1); + FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y)+' moveto'); + LastX := X1; + LastY := Y1; end; { Draw a line from current location to these coords } @@ -405,46 +393,42 @@ procedure TPostScriptCanvas.LineTo(X1, Y1: Integer); var Y: Integer; begin - Y := TranslateY(Y1); - FPostScript.Add(inttostr(X1)+' '+inttostr(Y)+' lineto'); - LastX := X1; - LastY := Y1; - + Y := TranslateY(Y1); + FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y)+' lineto'); + LastX := X1; + LastY := Y1; end; procedure TPostScriptCanvas.Line(X1, Y1, X2, Y2: Integer); var Y12, Y22: Integer; begin + Y12 := TranslateY(Y1); + Y22 := TranslateY(Y2); - Y12 := TranslateY(Y1); - Y22 := TranslateY(Y2); - - FPostScript.Add('newpath '+inttostr(X1)+' '+inttostr(Y12)+' moveto '+ - inttostr(X2)+' '+inttostr(Y22)+' lineto closepath stroke'); - - // go back to last moveto position - ResetPos; + FPostScript.Add('newpath '+IntToStr(X1)+' '+IntToStr(Y12)+' moveto '+ + IntToStr(X2)+' '+IntToStr(Y22)+' lineto closepath stroke'); + // go back to last moveto position + ResetPos; end; procedure TPostScriptCanvas.Rectangle(X1, Y1, X2, Y2: Integer); var Y12, Y22: Integer; begin - Y12 := TranslateY(Y1); - Y22 := TranslateY(Y2); - - FPostScript.Add('stroke newpath'); - FPostScript.Add(inttostr(X1)+' '+inttostr(Y12)+' moveto'); - FPostScript.Add(inttostr(X2)+' '+inttostr(Y12)+' lineto'); - FPostScript.Add(inttostr(X2)+' '+inttostr(Y22)+' lineto'); - FPostScript.Add(inttostr(X1)+' '+inttostr(Y22)+' lineto'); - FPostScript.Add('closepath'); - if FBrush.Color > -1 then AddFill; - FPostScript.Add('stroke'); - ResetPos; + Y12 := TranslateY(Y1); + Y22 := TranslateY(Y2); + FPostScript.Add('stroke newpath'); + FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y12)+' moveto'); + FPostScript.Add(IntToStr(X2)+' '+IntToStr(Y12)+' lineto'); + FPostScript.Add(IntToStr(X2)+' '+IntToStr(Y22)+' lineto'); + FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y22)+' lineto'); + FPostScript.Add('closepath'); + if FBrush.Color > -1 then AddFill; + FPostScript.Add('stroke'); + ResetPos; end; { Draw a rectangle } @@ -452,19 +436,18 @@ procedure TPostScriptCanvas.Rectangle(const Rect: TRect); var Y12, Y22: Integer; begin - Y12 := TranslateY(Rect.Top); - Y22 := TranslateY(Rect.Bottom); - - FPostScript.Add('stroke newpath'); - FPostScript.Add(inttostr(Rect.Left)+' '+inttostr(Y12)+' moveto'); - FPostScript.Add(inttostr(Rect.Right)+' '+inttostr(Y12)+' lineto'); - FPostScript.Add(inttostr(Rect.Right)+' '+inttostr(Y22)+' lineto'); - FPostScript.Add(inttostr(Rect.Left)+' '+inttostr(Y22)+' lineto'); - FPostScript.Add('closepath'); - if FBrush.Color > -1 then AddFill; - FPostScript.Add('stroke'); - ResetPos; + Y12 := TranslateY(Rect.Top); + Y22 := TranslateY(Rect.Bottom); + FPostScript.Add('stroke newpath'); + FPostScript.Add(IntToStr(Rect.Left)+' '+IntToStr(Y12)+' moveto'); + FPostScript.Add(IntToStr(Rect.Right)+' '+IntToStr(Y12)+' lineto'); + FPostScript.Add(IntToStr(Rect.Right)+' '+IntToStr(Y22)+' lineto'); + FPostScript.Add(IntToStr(Rect.Left)+' '+IntToStr(Y22)+' lineto'); + FPostScript.Add('closepath'); + if FBrush.Color > -1 then AddFill; + FPostScript.Add('stroke'); + ResetPos; end; { Draw a series of lines } @@ -488,97 +471,86 @@ var YRatio: Real; centerX, centerY: Integer; begin - // set radius to half the width - radius := (x2 - x1) div 2; + radius := (x2 - x1) div 2; //calculate ratios - if radius <1 then exit; // do nothing - YRatio := real(Y2 - Y1) / (X2-X1); + if radius <1 then exit; // do nothing + YRatio := real(Y2 - Y1) / (X2-X1); // find center - CenterX := ((X2 - X1) div 2) + X1; - CenterY := ((Y2 - Y1) div 2) + Y1; + CenterX := ((X2 - X1) div 2) + X1; + CenterY := ((Y2 - Y1) div 2) + Y1; - FPostScript.Add('newpath '+inttostr(CenterX)+' '+inttostr(TranslateY(CenterY))+' translate'); + FPostScript.Add('newpath '+IntToStr(CenterX)+' '+IntToStr(TranslateY(CenterY))+' translate'); // move to edge - FPostScript.Add(inttostr(radius)+' 0 moveto'); + FPostScript.Add(IntToStr(radius)+' 0 moveto'); // now draw it - FPostScript.Add('gsave 1 '+format('%.3f',[YRatio])+' scale'); - FPostScript.Add('0 0 '+inttostr(radius)+' 0 360 arc'); - if FBrush.Color > -1 then AddFill; + FPostScript.Add('gsave 1 '+format('%.3f',[YRatio])+' scale'); + FPostScript.Add('0 0 '+IntToStr(radius)+' 0 360 arc'); + if FBrush.Color > -1 then AddFill; // reset scale for drawing line thickness so it doesn't warp - YRatio := 1 / YRatio; - FPostScript.Add('1 '+format('%.2f',[YRatio])+' scale stroke grestore'); + YRatio := 1 / YRatio; + FPostScript.Add('1 '+format('%.2f',[YRatio])+' scale stroke grestore'); // move origin back - FPostScript.Add(inttostr(-CenterX)+' '+inttostr(-TranslateY(CenterY))+' translate closepath stroke'); - ResetPos; - + FPostScript.Add(IntToStr(-CenterX)+' '+IntToStr(-TranslateY(CenterY))+' translate closepath stroke'); + ResetPos; end; procedure TPostScriptCanvas.Ellipse(const Rect: TRect); begin - - self.Ellipse(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom); - + self.Ellipse(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom); end; procedure TPostScriptCanvas.Pie(x, y, width, mheight, angle1, angle2: Integer); begin + // set zero at center + FPostScript.Add('newpath '+IntToStr(X)+' '+IntToStr(TranslateY(Y))+' translate'); - // set zero at center - FPostScript.Add('newpath '+inttostr(X)+' '+inttostr(TranslateY(Y))+' translate'); + // scale it + FPostScript.Add('gsave '+IntToStr(width)+' '+IntToStr(mheight)+' scale'); + //FPostScript.Add('gsave 1 1 scale'); - // scale it - FPostScript.Add('gsave '+inttostr(width)+' '+inttostr(mheight)+' scale'); - //FPostScript.Add('gsave 1 1 scale'); + // draw line to edge + FPostScript.Add('0 0 moveto'); + FPostScript.Add('0 0 1 '+IntToStr(angle1)+' '+IntToStr(angle2)+' arc closepath'); - // draw line to edge - FPostScript.Add('0 0 moveto'); - FPostScript.Add('0 0 1 '+inttostr(angle1)+' '+inttostr(angle2)+' arc closepath'); + if FBrush.Color > -1 then AddFill; - if FBrush.Color > -1 then AddFill; + // reset scale so we don't change the line thickness + // adding 0.01 to compensate for scaling error - there may be a deeper problem here... + FPostScript.Add(format('%.6f',[(real(1) / X)+0.01])+' '+format('%.6f',[(real(1) / Y)+0.01])+' scale stroke grestore'); - // reset scale so we don't change the line thickness - // adding 0.01 to compensate for scaling error - there may be a deeper problem here... - FPostScript.Add(format('%.6f',[(real(1) / X)+0.01])+' '+format('%.6f',[(real(1) / Y)+0.01])+' scale stroke grestore'); - - // close out and return origin - FPostScript.Add(inttostr(-X)+' '+inttostr(-TranslateY(Y))+' translate closepath stroke'); - - resetpos; + // close out and return origin + FPostScript.Add(IntToStr(-X)+' '+IntToStr(-TranslateY(Y))+' translate closepath stroke'); + ResetPos; end; { Writes text with a carriage return } -procedure TPostScriptCanvas.Writeln(AString: String); +procedure TPostScriptCanvas.Writeln(const AString: String); begin - - TextOut(LastX, LastY, AString); - LastY := LastY+FFontSize+FLineSpacing; - MoveTo(LastX, LastY); - + TextOut(LastX, LastY, AString); + LastY := LastY+FFontSize+FLineSpacing; + MoveTo(LastX, LastY); end; { Output text, restoring draw location } procedure TPostScriptCanvas.TextOut(X, Y: Integer; const Text: String); var - Y1: Integer; + Y1: Integer; begin - Y1 := TranslateY(Y); - FPostScript.Add(inttostr(X)+' '+inttostr(Y1)+' moveto'); - FPostScript.Add('('+Text+') show'); - ResetPos; // move back to last moveto location - + Y1 := TranslateY(Y); + FPostScript.Add(IntToStr(X)+' '+IntToStr(Y1)+' moveto'); + FPostScript.Add('('+Text+') show'); + ResetPos; // move back to last moveto location end; - - { TPostScript -------------------------------------------------------------- } procedure TPostScript.SetHeight(const AValue: Integer); @@ -605,7 +577,6 @@ begin // need to not hard-link these... FDocument[3] := '%%Title: '+AValue; - end; procedure TPostScript.SetWidth(const AValue: Integer); @@ -620,49 +591,46 @@ procedure TPostScript.GrabCanvas; var I: Integer; begin - // internally calls this at the end of a page... + // internally calls this at the end of a page... - I := 0; - while I < FCanvas.PostScript.Count do begin + I := 0; + while I < FCanvas.PostScript.Count do begin Document.Add(FCanvas.PostScript[I]); I := I+1; - end; - + end; end; { Take our sizes and change the boundingbox line } procedure TPostScript.UpdateBoundingBox; begin - - // need to not hard-link this to line 1 - FDocument[1] := '%%BoundingBox: 0 0 '+inttostr(FWidth)+' '+inttostr(FHeight); - + // need to not hard-link this to line 1 + FDocument[1] := '%%BoundingBox: 0 0 '+IntToStr(FWidth)+' '+IntToStr(FHeight); end; -{ Pattern changed so update the postscript code } +{ Pattern Changed so update the postscript code } procedure TPostScript.PatternChanged(Sender: TObject); begin - // called anytime a pattern changes. Update the postscript code. - // look for and delete the current postscript code for this pattern - // then paste the pattern back into the code before the first page - RemovePattern(Sender As TPSPattern); - InsertPattern(Sender As TPSPattern); + // called anytime a pattern changes. Update the postscript code. + // look for and delete the current postscript code for this pattern + // then paste the pattern back into the code before the first page + RemovePattern(Sender As TPSPattern); + InsertPattern(Sender As TPSPattern); end; { Places a pattern definition into the bottom of the header in postscript } procedure TPostScript.InsertPattern(APattern: TPSPattern); var - I, J: Integer; - MyStrings: TStringList; + I, J: Integer; + MyStrings: TStringList; begin - I := 0; - if FDocument.Count < 1 then begin + I := 0; + if FDocument.Count < 1 then begin // added pattern when no postscript exists - this shouldn't happen raise exception.create('Pattern inserted with no postscript existing'); exit; - end; + end; - for I := 0 to FDocument.count - 1 do begin + for I := 0 to FDocument.count - 1 do begin if (FDocument[I] = '%%Page: 1 1') then begin // found it! // insert into just before that @@ -672,29 +640,28 @@ begin end; exit; end; - end; - + end; end; {Remove a pattern from the postscript code } procedure TPostScript.RemovePattern(APattern: TPSPattern); var - I: Integer; - MyName: String; + I: Integer; + MyName: String; begin - // this does NOT destroy the object, just removes from postscript + // this does NOT destroy the object, just removes from postscript - if APattern.OldName <> '' then MyName := APattern.OldName - else MyName := APattern.name; + if APattern.OldName <> '' then MyName := APattern.OldName + else MyName := APattern.name; - I := 0; - if FDocument.Count < 1 then begin + I := 0; + if FDocument.Count < 1 then begin // added pattern when no postscript exists - this shouldn't happen raise exception.create('Pattern removed with no postscript existing'); exit; - end; + end; - for I := 0 to FDocument.Count - 1 do begin + for I := 0 to FDocument.Count - 1 do begin if (FDocument[I] = '%% PATTERN '+MyName) then begin // found it... // delete until gone @@ -707,37 +674,37 @@ begin end else FDocument.Delete(I); end; end; - end; + end; end; constructor TPostScript.Create; begin - inherited create; + inherited create; - FDocument := TStringList.Create; + FDocument := TStringList.Create; // Set some defaults - FHeight := 792; // 11 inches at 72 dpi - FWidth := 612; // 8 1/2 inches at 72 dpi - FCanvas := TPostScriptCanvas.Create(Self); + FHeight := 792; // 11 inches at 72 dpi + FWidth := 612; // 8 1/2 inches at 72 dpi + FCanvas := TPostScriptCanvas.Create(Self); - FDocument.Clear; - FDocument.Add('%!PS-Adobe-3.0'); - FDocument.Add('%%BoundingBox: 0 0 612 792'); - FDocument.Add('%%Creator: '+Application.ExeName); - FDocument.Add('%%Title: '+FTitle); - FDocument.Add('%%Pages: (atend)'); - FDocument.Add('%%PageOrder: Ascend'); + FDocument.Clear; + FDocument.Add('%!PS-Adobe-3.0'); + FDocument.Add('%%BoundingBox: 0 0 612 792'); + FDocument.Add('%%Creator: '+Application.ExeName); + FDocument.Add('%%Title: '+FTitle); + FDocument.Add('%%Pages: (atend)'); + FDocument.Add('%%PageOrder: Ascend'); // Choose a standard font in case the user doesn't - FDocument.Add('/AvantGarde-Book findfont'); - FDocument.Add('10 scalefont'); - FDocument.Add('setfont'); + FDocument.Add('/AvantGarde-Book findfont'); + FDocument.Add('10 scalefont'); + FDocument.Add('setfont'); // start our first page - FPageNumber := 1; - FDocument.Add('%%Page: 1 1'); // I'm still not sure why u put the page # twice - FDocument.Add('newpath'); + FPageNumber := 1; + FDocument.Add('%%Page: 1 1'); // I'm still not sure why u put the page # twice + FDocument.Add('newpath'); end; @@ -751,9 +718,9 @@ begin // destroy the patterns if NumPatterns > 0 then begin - for I := 0 to NuMPatterns-1 do begin + for I := 0 to NuMPatterns-1 do begin Patterns[i].Free; - end; + end; end; // free the pattern pointer memory @@ -763,17 +730,16 @@ begin end; -{ add a pattern to the array } +{ Add a pattern to the array } procedure TPostScript.AddPattern(APSPattern: TPSPattern); begin - // does NOT create the pattern, just insert in the array of patterns + // does NOT create the pattern, just insert in the array of patterns - NumPatterns := NumPatterns+1; + NumPatterns := NumPatterns+1; - reallocmem(Patterns, sizeof(TPSPattern) * NumPatterns); + reallocmem(Patterns, sizeof(TPSPattern) * NumPatterns); - Patterns[NumPatterns-1] := APSPattern; - + Patterns[NumPatterns-1] := APSPattern; end; { Find a pattern object by it's name } @@ -781,15 +747,14 @@ function TPostScript.FindPattern(AName: String): TPSPattern; var I: Integer; begin - Result := nil; - if NumPatterns < 1 then exit; - for I := 0 to NumPatterns-1 do begin + Result := nil; + if NumPatterns < 1 then exit; + for I := 0 to NumPatterns-1 do begin if Patterns[I].Name = AName then begin result := Patterns[i]; exit; end; - end; - + end; end; function TPostScript.DelPattern(AName: String): Boolean; @@ -801,24 +766,21 @@ begin Result:=false; end; - { Create a new pattern and inserts it into the array for safe keeping } function TPostScript.NewPattern(AName: String): TPSPattern; var MyPattern: TPSPattern; begin - - MyPattern := TPSPattern.Create; - AddPattern(MyPattern); - MyPattern.Name := AName; - MyPattern.OnChange := @PatternChanged; - MyPattern.OldName := ''; + MyPattern := TPSPattern.Create; + AddPattern(MyPattern); + MyPattern.Name := AName; + MyPattern.OnChange := @PatternChanged; + MyPattern.OldName := ''; - // add this to the postscript now... - - InsertPattern(MyPattern); - result := MyPattern; + // Add this to the postscript now... + InsertPattern(MyPattern); + result := MyPattern; end; { Start a new document } @@ -866,45 +828,41 @@ end; { Copy current page into the postscript and start a new one } procedure TPostScript.NewPage; begin + // dump the current page into our postscript first + GrabCanvas; - // dump the current page into our postscript first - GrabCanvas; - - // put end page definition... - FDocument.Add('stroke'); - FDocument.Add('showpage'); - FPageNumber := FPageNumber+1; - // start new page definition... - FDocument.Add('%%Page: '+inttostr(FPageNumber)+' '+inttostr(FPageNumber)); - FDocument.Add('newpath'); - FCanvas.Clear; - + // put end page definition... + FDocument.Add('stroke'); + FDocument.Add('showpage'); + FPageNumber := FPageNumber+1; + // start new page definition... + FDocument.Add('%%Page: '+IntToStr(FPageNumber)+' '+IntToStr(FPageNumber)); + FDocument.Add('newpath'); + FCanvas.Clear; end; { Finish off the document } procedure TPostScript.EndDoc; begin // dump the canvas into the postscript code - GrabCanvas; + GrabCanvas; // Start printing the document after closing out the pages - FDocument.Add('stroke'); - FDocument.Add('showpage'); - FDocument.Add('%%Pages: '+inttostr(FPageNumber)); + FDocument.Add('stroke'); + FDocument.Add('showpage'); + FDocument.Add('%%Pages: '+IntToStr(FPageNumber)); // okay, the postscript is all ready, so dump it to the text file // or to the printer - FPageNumber := 0; + FPageNumber := 0; end; { TPSObject } procedure TPSObject.Changed; begin - Assert(False, Format('Trace:[TgraphicsObject.Changed] %s', [ClassName])); if Assigned(FOnChange) then FOnChange(Self); - end; procedure TPSObject.Lock; @@ -923,47 +881,40 @@ procedure TPSPen.SetPattern(const AValue: TPSPattern); begin if FPattern=AValue then exit; FPattern:=AValue; - changed; + Changed; end; procedure TPSPen.SetColor(Value: TColor); begin - - FColor := Value; - changed; - + FColor := Value; + Changed; end; procedure TPSPen.Setwidth(value: Real); begin - - FWidth := Value; - changed; - + FWidth := Value; + Changed; end; constructor TPSPen.Create; begin - - FPattern := nil; - + FPattern := nil; end; destructor TPSPen.Destroy; begin - // Do NOT free the pattern object from here... + // Do NOT free the pattern object from here... inherited Destroy; end; procedure TPSPen.Assign(Source: TPSPen); begin - if source = nil then exit; + if source = nil then exit; - FWidth := Source.Width; - FColor := Source.Color; - FPattern := Source.Pattern; - + FWidth := Source.Width; + FColor := Source.Color; + FPattern := Source.Pattern; end; { Return the pen definition as a postscript string } @@ -971,10 +922,10 @@ function TPSPen.AsString: String; var MyOut: String; begin - MyOut := ''; + MyOut := ''; // set all the features of this pen... - if FPattern <> nil then begin + if FPattern <> nil then begin // we have a pattern // uh... let's make it work for both colored and uncolored patterns // first for colored: @@ -983,17 +934,16 @@ begin MyOut := '/Pattern setcolorspace '+FPattern.Name+' setcolor ' else begin // now for uncolored, use color from pen - MyOut := '[/Pattern /DeviceRGB] setcolorspace '+inttostr(GetRValue(FColor))+' '+inttostr(GetGValue(FColor))+' '+ - inttostr(GetBValue(FColor))+' '+FPattern.Name+' setcolor '; + MyOut := '[/Pattern /DeviceRGB] setcolorspace '+IntToStr(GetRValue(FColor))+' '+IntToStr(GetGValue(FColor))+' '+ + IntToStr(GetBValue(FColor))+' '+FPattern.Name+' setcolor '; end; - end else // no pattern do this: - MyOut := inttostr(GetRValue(FColor))+' '+inttostr(GetGValue(FColor))+' '+ - inttostr(GetBValue(FColor))+' setrgbcolor '; - - MyOut := MyOut + format('%f',[FWidth])+' setlinewidth '; - Result := MyOut; + end else // no pattern do this: + MyOut := IntToStr(GetRValue(FColor))+' '+IntToStr(GetGValue(FColor))+' '+ + IntToStr(GetBValue(FColor))+' setrgbcolor '; + MyOut := MyOut + format('%f',[FWidth])+' setlinewidth '; + Result := MyOut; end; { TPSPattern } @@ -1003,42 +953,41 @@ function TPSPattern.GetpostScript: TStringList; var I: Integer; begin - // If nothing in the canvas, error - if FCanvas.Postscript.Count < 1 then begin + if FCanvas.Postscript.Count < 1 then begin raise exception.create('Empty pattern'); exit; - end; + end; - FPostScript.Clear; - With FPostScript do begin - add('%% PATTERN '+FName); - add('/'+FName+'proto 12 dict def '+FName+'proto begin'); - add('/PatternType 1 def'); + FPostScript.Clear; + With FPostScript do begin + Add('%% PATTERN '+FName); + Add('/'+FName+'proto 12 dict def '+FName+'proto begin'); + Add('/PatternType 1 def'); case FPaintType of - ptColored: add('/PaintType 1 def'); - ptUncolored: add('/PaintType 2 def'); + ptColored: Add('/PaintType 1 def'); + ptUncolored: Add('/PaintType 2 def'); end; case FTilingType of - ttConstant: add('/TilingType 1 def'); - ttNoDistortion: add('/TilingType 2 def'); - ttFast: add('/TilingType 3 def'); + ttConstant: Add('/TilingType 1 def'); + ttNoDistortion: Add('/TilingType 2 def'); + ttFast: Add('/TilingType 3 def'); end; - add('/BBox ['+inttostr(FBBox.Left)+' '+inttostr(FBBox.Top)+' '+inttostr(FBBox.Right)+' '+inttostr(FBBox.Bottom)+'] def'); - add('/XStep '+format('%f',[FXStep])+' def'); - add('/YStep '+format('%f',[FYstep])+' def'); - add('/PaintProc { begin'); + Add('/BBox ['+IntToStr(FBBox.Left)+' '+IntToStr(FBBox.Top)+' '+IntToStr(FBBox.Right)+' '+IntToStr(FBBox.Bottom)+'] def'); + Add('/XStep '+format('%f',[FXStep])+' def'); + Add('/YStep '+format('%f',[FYstep])+' def'); + Add('/PaintProc { begin'); // insert the canvas for I := 0 to FCanvas.PostScript.Count - 1 do begin - add(FCanvas.PostScript[I]); + Add(FCanvas.PostScript[I]); end; - // add support for custom matrix later - add('end } def end '+FName+'proto [1 0 0 1 0 0] makepattern /'+FName+' exch def'); - add('%% END PATTERN '+FName); - end; - Result := FPostScript; + // Add support for custom matrix later + Add('end } def end '+FName+'proto [1 0 0 1 0 0] makepattern /'+FName+' exch def'); + Add('%% END PATTERN '+FName); + end; + Result := FPostScript; end; procedure TPSPattern.SetBBox(const AValue: TRect); @@ -1052,7 +1001,6 @@ end; procedure TPSPattern.SetName(const AValue: String); begin - FOldName := FName; if FName=AValue then exit; FName:=AValue; @@ -1068,45 +1016,43 @@ procedure TPSPattern.SetPaintType(const AValue: TPSPaintType); begin if FPaintType=AValue then exit; FPaintType:=AValue; - changed; + Changed; end; procedure TPSPattern.SetTilingType(const AValue: TPSTileType); begin if FTilingType=AValue then exit; FTilingType:=AValue; - changed; + Changed; end; procedure TPSPattern.SetXStep(const AValue: Real); begin if FXStep=AValue then exit; FXStep:=AValue; - changed; + Changed; end; procedure TPSPattern.SetYStep(const AValue: Real); begin if FYStep=AValue then exit; FYStep:=AValue; - changed; + Changed; end; constructor TPSPattern.Create; begin - - FPostScript := TStringList.Create; - FPaintType := ptColored; - FTilingType := ttConstant; - FCanvas := TPostScriptCanvas.Create(nil); - FName := 'Pattern1'; - + FPostScript := TStringList.Create; + FPaintType := ptColored; + FTilingType := ttConstant; + FCanvas := TPostScriptCanvas.Create(nil); + FName := 'Pattern1'; end; destructor TPSPattern.Destroy; begin - FPostScript.Free; - FCanvas.Free; + FPostScript.Free; + FCanvas.Free; inherited Destroy; end;