{----------------------------------------------------------------------------- The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/NPL/NPL-1_1Final.html Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is: QmwDocument.pas, released December, 2001. The Initial Developer of the Original Code is Martin Waldenburg (Martin.Waldenburg@T-Online.de). Portions created by Martin Waldenburg are Copyright (C) 2001 Martin Waldenburg. All Rights Reserved. Alternatively, the contents of this file may be used under the terms of the GNU General Public License Version 2 or later (the "GPL"), in which case the provisions of the GPL are applicable instead of those above. If you wish to allow use of your version of this file only under the terms of the GPL and not to allow others to use your version of this file under the MPL, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the GPL. If you do not delete the provisions above, a recipient may use your version of this file under either the MPL or the GPL. Contributor(s): _______________________________________________________________. Last Modified: mm/dd/yyyy Current Version: 0.1 Notes: Unit implements a document container. Modification history: Known Issues: -----------------------------------------------------------------------------} unit QmwDocument; interface uses Qt, SysUtils, Types, Classes, QControls, QGraphics, TypInfo, mwStringStream; const WordDelimiters: set of Char = [#0..#64, #91..#96, #123..#127]; type TByteBits = (One, Two, Three, Four, Five, Six, Seven, Eight); TBitByte = set of TByteBits; TmwAlignment = ( alLeft, alCenter, alRight); TmwLineItem = packed record B: TBitByte; case Integer of 1: (CW: WideChar; I, W: Byte); 2: (CL, CT: Char; I2, W2: Byte); 3: (P: TPersistent); 4: (V1: Word; V2, V3: Byte); end; PmwCharList = ^TmwCharList; TmwCharList = packed array[1..1] of TmwLineItem; TmwLine = class(TPersistent) private fCount: Integer; fFontIndex: Byte; fList: PmwCharList; function GetAnsiText: String; function GetItems(Index: Integer): TmwLineItem; procedure SetCount(const Value: Integer); procedure SetItems(Index: Integer; const Value: TmwLineItem); function GetFontIndex(Index: Integer): Byte; procedure SetFontIndex(Index: Integer; const Value: Byte); function GetChar(Index: Integer): WideChar; procedure SetChar(Index: Integer; const Value: WideChar); function GetPersistent(Index: Integer): TPersistent; procedure SetPersistent(Index: Integer; const Value: TPersistent); function GetText: WideString; procedure SetText(const Value: WideString); procedure PrepareInsert(Index: Integer; Number: Integer = 1); function GetLastFontIndex: Byte; procedure SetAnsiText(const Value: String); function GetHidden: Boolean; procedure SetHidden(const Value: Boolean); function GetIsPersistent(Index: Integer): Boolean; protected Bits: TBitByte; procedure Add(const Value: TmwLineItem); overload; procedure CleanUp(Index, Number: Integer); procedure DisposeItem(Index: Integer); procedure Insert(Index: Integer; const Item: TmwLineItem); overload; procedure PadUp(Number: Integer); property Items[Index: Integer]: TmwLineItem read GetItems write SetItems; property List: PmwCharList read fList; public procedure Add(const aPersistent: TPersistent); overload; procedure Add(const aChar: Char); overload; procedure Add(const aString: String); overload; procedure Add(const aWideChar: WideChar); overload; procedure Add(const aWideString: WideString); overload; procedure Assign(Source: TPersistent); override; procedure AssignFontIndex(Index: Integer; aFontIndex: Byte; Number: Integer = 1); procedure AssignTo(Dest: TPersistent); override; function Clone: TPersistent; virtual; procedure Delete(Index: Integer; Number: Integer = 1); procedure Insert(Index: Integer; const aPersistent: TPersistent); overload; procedure Insert(Index: Integer; const AChar: Char); overload; procedure Insert(Index: Integer; const AWideChar: WideChar); overload; procedure Insert(Index: Integer; const AString: WideString); overload; property AnsiText: String read GetAnsiText write SetAnsiText; property Persistents[Index: Integer]: TPersistent read GetPersistent write SetPersistent; property Chars[Index: Integer]: WideChar read GetChar write SetChar; default; property Count: Integer read fCount write SetCount; property FontIndex[Index: Integer]: Byte read GetFontIndex write SetFontIndex; property Hidden: Boolean read GetHidden write SetHidden; property IsPersistent[Index: Integer]: Boolean read GetIsPersistent; property LastFontIndex: Byte read GetLastFontIndex; published property Text: WideString read GetText write SetText; end; TmwColumn = class(TmwLine) private FWidth: Integer; public property Width: Integer read FWidth write fWidth; end; TmwParagraph = class(TmwLine) public Position: Integer; end; TmwCharAlign = ( caNormal, caSubScript, caSuperScript); TmwTextAttribute = class(TPersistent) private FWeight: Integer; fBackGround: TColor; FColor: TColor; FCharSet: TFontCharSet; fName: TFontName; FPitch: TFontPitch; FStyle: TFontStyles; fID: Byte; FHeight: Integer; fAlign: TmwCharAlign; function GetText: String; procedure SetText(const aText: String); public constructor Create; procedure Assign(Source: TPersistent); override; procedure AssignTo(Dest: TPersistent); override; property Text: String read GetText write SetText; published property Align: TmwCharAlign read fAlign write fAlign; property BackGround: TColor read fBackGround write fBackGround; property CharSet: TFontCharSet read FCharSet write FCharSet; property Color: TColor read FColor write FColor; property Height: Integer read FHeight write FHeight; property Id: Byte read fID write fID; property Name: TFontName read fName write FName; property Pitch: TFontPitch read FPitch write FPitch; property Style: TFontStyles read FStyle write FStyle; property Weight: Integer read FWeight write FWeight; end; TmwCharItem = class Key: TmwLineItem; constructor Create(const aKey: TmwLineItem); end; PHashPointerList = ^THashPointerList; THashPointerList = array[1..1] of TObject; TmwBaseCharHashList = class(TObject) FList: PHashPointerList; fCapacity: Integer; protected function Get(Index: Integer): Pointer; procedure Put(Index: Integer; Item: Pointer); procedure SetCapacity(NewCapacity: Integer); public destructor Destroy; override; procedure Clear; function Compare(const Key1, Key2: TmwLineItem): Boolean; property Capacity: Integer read fCapacity; property Items[Index: Integer]: Pointer read Get write Put; default; end; TmwHashStrings = class(TmwBaseCharHashList) public procedure Add(const aKey: TmwLineItem); function HasKey(const aKey: TmwLineItem): Boolean; end; TmwHashItems = class(TmwBaseCharHashList) public procedure Add(const aKey: TmwLineItem); function ComputeKey(const aKey: TmwLineItem): integer; function HasKey(const aKey: TmwLineItem): Boolean; end; TmwCharHashList = class(TmwBaseCharHashList) public procedure Add(const aKey: TmwLineItem); function ComputeKey(const aKey: TmwLineItem): integer; function Hash(var aKey: TmwLineItem): Boolean; function HashEX(var aKey: TmwLineItem; HashValue: Integer): Boolean; function HasKey(const aKey: TmwLineItem): Boolean; end; TmwTextAttributeList = class(TPersistent) private fList: array[0..255] of TmwTextAttribute; fCount: Integer; fUnixStyle: Boolean; FFontHelper: TFont; FHelper: TmwTextAttribute; fFM: QFontMetricsH; fActive: Byte; FCharTable: TmwCharHashList; function GetAttribute(Index: Integer): TmwTextAttribute; procedure SetAttribute(Index: Integer; Value: TmwTextAttribute); function GetDefaultAttribute: TmwTextAttribute; procedure SetDefaultAttribute(const Value: TmwTextAttribute); function GetFull: Boolean; function GetFonts(Index: Integer): TFont; procedure SetFonts(Index: Integer; const Value: TFont); procedure SetActive(Value: Byte); protected procedure Activate(const Value: Byte); procedure ClearAll; virtual; function Equals(Attribute1, Attribute2: TmwTextAttribute): Boolean; property CharTable: TmwCharHashList read FCharTable; property FM: QFontMetricsH read fFM; property FontHelper: TFont read FFontHelper; property Helper: TmwTextAttribute read FHelper; public destructor Destroy; override; constructor Create; function Ascent(Index: Byte): Integer; function Descent(Index: Byte): Integer; function Height(Index: Byte): Integer; overload; function Height(Value: TmwLine): Integer; overload; function Height(Value: TmwLine; aWidth: Integer): Integer; overload; function Leading(Index: Byte): Integer; function LineSpacing(Index: Byte): Integer; function MinLeftBearing(Index: Byte): Integer; function MinRightBearing(Index: Byte): Integer; function MaxWidth(Index: Byte): Integer; function InFont(Index: Byte; p1: PWideChar): Boolean; function LeftBearing(Index: Byte; p1: PWideChar): Integer; function RightBearing(Index: Byte; p1: PWideChar): Integer; function Size(var Item: TmwLineItem): TSize; overload; function Size(Value: TmwLine): TSize; overload; function Width(var Item: TmwLineItem): Integer; overload; function Width(Index: Byte; p1: PWideString; len: Integer): Integer; overload; function Width(Index: Byte; WS: WideString): Integer; overload; function Width(Index: Byte; p1: PWideChar): Integer; overload; function Width(Index: Byte; WC: WideChar): Integer; overload; function Width(Index: Byte; c: char): Integer; overload; // procedure BoundingRect(retval: PRect; p1: PWideString; len: Integer); overload; // procedure BoundingRect(retval: PRect; p1: PWideChar); overload; // procedure BoundingRect(retval: PRect; x: Integer; y: Integer; w: Integer; h: Integer; flags: Integer; str: PWideString; len: Integer; tabstops: Integer; tabarray: PInteger; intern: PPAnsiChar); overload; // procedure Size(retval: PSize; flags: Integer; str: PWideString; len: Integer; tabstops: Integer; tabarray: PInteger; intern: PPAnsiChar); function UnderlinePos(Index: Byte): Integer; function StrikeOutPos(Index: Byte): Integer; function LineWidth(Index: Byte): Integer; procedure WrapAt(var Index, H, W: Integer; Line: TmwLine; aWidth: Integer); function Add(Item: TFont): Integer; overload; function Add(Item: TmwTextAttribute): Integer; overload; procedure Assign(Source: TPersistent); override; procedure Clear; virtual; procedure ClearCharTable; function FirstUnUsed: Integer; function IndexOfEqual(Item: TFont): Integer; overload; function IndexOfEqual(Item: TmwTextAttribute): Integer; overload; procedure InitChar(var Value: TmwLineItem); procedure InitLine(Value: TmwLine); procedure LoadFromStream(Stream: TStream); procedure LoadFromString(const aString: String; var Run: Integer); procedure Remove(Index: Integer); procedure SaveToStream(Stream: TStream); property Active: Byte read fActive write SetActive; property Count: Integer read fCount; property DefaultAttribute: TmwTextAttribute read GetDefaultAttribute write SetDefaultAttribute; property Fonts[Index: Integer]: TFont read GetFonts write SetFonts; property Full: Boolean read GetFull; property Items[Index: Integer]: TmwTextAttribute read GetAttribute write SetAttribute; default; property UnixStyle: Boolean read fUnixStyle write fUnixStyle; end; PmwParagraphList = ^TmwParagraphList; TmwParagraphList = array[1..1] of TmwParagraph; TQmwStrings = class; TmwTextIO = class(TComponent) private fList: TQmwStrings; public procedure BreakStringUP(const S: String); overload; virtual; abstract; procedure BreakStringUP(const S: WideString); overload; virtual; abstract; function Clone: TmwTextIO; virtual; function GetAnsiText: String; virtual; abstract; function GetString(Index: Integer): WideString; virtual; abstract; function GetText: WideString; virtual; abstract; procedure LoadFromFile(const FileName: String); virtual; abstract; procedure LoadFromStream(Stream: TStream); virtual; abstract; procedure SaveToStream(Stream: TStream); virtual; abstract; procedure SetAnsiString(Index: Integer; const Value: String); virtual; abstract; procedure SetAnsiText(const Value: String); virtual; abstract; procedure SetString(Index: Integer; const S: WideString); virtual; abstract; property List: TQmwStrings read fList write fList; end; TQmwStrings = class(TPersistent) private fTokenSize: Integer; fBuffCapacity: Integer; fTokenBuffer: PWideChar; fCount: Integer; FUpdateCount: Integer; FOnChanging: TNotifyEvent; FOnChange: TNotifyEvent; FCapacity: Integer; FList: PmwParagraphList; fIO: TmwTextIO; fLoading: Boolean; fReadOnly: Boolean; fUnicode: Boolean; fUnixStyle: Boolean; fWordWrap: Boolean; FWrapWidth: Integer; FAttributes: TmwTextAttributeList; fHeight: Integer; fInserting: Boolean; function GetToken: WideString; procedure SetBuffCapacity(const Value: Integer); function GetAnsiText: String; procedure SetAnsiText(const Value: String); function GetItems(Index: Integer): TmwParagraph; procedure SetIO(const Value: TmwTextIO); function GetPosition(Index: Integer): Integer; procedure SetWordWrap(const Value: Boolean); procedure SetWrapWidth(const Value: Integer); function GetItemHeight(Index: Integer): Integer; protected procedure AdjustPositions(Index, Delta: Integer); procedure BreakStringUP(const S: String); overload; procedure BreakStringUP(const S: WideString); overload; procedure Changed; virtual; procedure Changing; virtual; procedure CleanUp(Index, Number: Integer); procedure DisposeItem(Index: Integer); procedure Expand(Value: Integer); function GetString(Index: Integer): WideString; virtual; function GetCount: Integer; virtual; function GetObject(Index: Integer): TObject; virtual; function GetText: WideString; virtual; procedure PrepareInsert(Index: Integer; Number: Integer = 1); virtual; procedure RecalculateHeight; procedure SaveAnsiToStream(Stream: TStream); virtual; procedure SaveUniCodeToStream(Stream: TStream); virtual; procedure SetString(Index: Integer; const S: WideString); virtual; procedure SetAnsiString(Index: Integer; const S: String); virtual; procedure SetObject(Index: Integer; AObject: TObject); virtual; procedure SetCapacity(NewCapacity: Integer); virtual; procedure SetText(const Value: WideString); virtual; procedure SetUpdateState(Updating: Boolean); virtual; property Inserting: Boolean read fInserting write fInserting; property UpdateCount: Integer read FUpdateCount; public destructor Destroy; override; constructor Create; procedure WriteChar(C: WideChar); property BuffCapacity: Integer read FBuffCapacity write SetBuffCapacity; property TokenBuffer: PWideChar read fTokenBuffer write fTokenBuffer; property TokenSize: Integer read fTokenSize write fTokenSize; function Add(const S: String): Integer; overload; virtual; function Add(const S: WideString): Integer; overload; virtual; function AddObject(const S: WideString; AObject: TObject): Integer; virtual; procedure Assign(Source: TPersistent); override; procedure BeginUpdate; procedure Clear; virtual; function Clone: TQmwStrings; virtual; procedure Delete(Index: Integer; Number: Integer = 1); virtual; procedure EndUpdate; procedure Insert(Index: Integer; const S: String); overload; virtual; procedure Insert(Index: Integer; const S: WideString); overload; virtual; procedure InsertObject(Index: Integer; const S: WideString; AObject: TObject); virtual; procedure LoadFromFile(const FileName: String); virtual; procedure LoadFromStream(Stream: TStream); virtual; procedure SaveToFile(const FileName: WideString); virtual; procedure SaveToStream(Stream: TStream); virtual; property AnsiText: String read GetAnsiText write SetAnsiText; property Attributes: TmwTextAttributeList read FAttributes; property Capacity: Integer read FCapacity write SetCapacity; property Count: Integer read GetCount; property Height: Integer read fHeight; property ItemHeight[Index: Integer]: Integer read GetItemHeight; property Items[Index: Integer]: TmwParagraph read GetItems; property List: PmwParagraphList read FList; property Loading: Boolean read fLoading; property Objects[Index: Integer]: TObject read GetObject write SetObject; property Positions[Index: Integer]: Integer read GetPosition; property ReadOnly: Boolean read fReadOnly write fReadOnly; property Strings[Index: Integer]: WideString read GetString write SetString; default; property Text: WideString read GetText write SetText; property Token: WideString read GetToken; property Unicode: Boolean read fUnicode write fUnicode; property WordWrap: Boolean read fWordWrap write SetWordWrap; property WrapWidth: Integer read FWrapWidth write SetWrapWidth; property UnixStyle: Boolean read fUnixStyle write fUnixStyle; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; published property IO: TmwTextIO read fIO write SetIO; end; implementation { TmwLine } procedure TmwLine.Add(const Value: TmwLineItem); begin Insert(FCount +1, Value); end; procedure TmwLine.Add(const aPersistent: TPersistent); begin Insert(FCount +1, aPersistent); end; procedure TmwLine.Add(const aChar: Char); begin Insert(FCount +1, aChar); end; procedure TmwLine.Add(const aString: String); var Temp: TmwLineItem; I, J, OldCount, Len: Integer; begin if aString = '' then exit; OldCount:= fCount; Len:= Length(aString); Temp.CT := #0; Temp.I := GetFontIndex(OldCount); Temp.B := []; Temp.W := 0; SetCount(OldCount + Len); J:= 0; for I:= OldCount +1 to OldCount + Len do begin inc(J); Temp.CL:= aString[J]; fList[I]:= Temp; end; end; procedure TmwLine.Add(const aWideChar: WideChar); begin Insert(FCount +1, aWideChar); end; procedure TmwLine.Add(const aWideString: WideString); var Temp: TmwLineItem; I, J, OldCount, Len: Integer; begin if aWideString = '' then exit; OldCount:= fCount; Len:= Length(aWideString); Temp.I := GetFontIndex(OldCount); Temp.B := []; Temp.W := 0; SetCount(OldCount + Len); J:= 0; for I:= OldCount +1 to OldCount + Len do begin inc(J); Temp.CW:= aWideString[J]; fList[I]:= Temp; end; end; procedure TmwLine.Assign(Source: TPersistent); var BM: TBitMap; Col: TmwColumn; I, Len: Integer; begin if Source is TmwLine then begin fFontIndex:= TmwLine(Source).fFontIndex; Len:= TmwLine(Source).Count; SetCount(Len); for I := 1 to Len do case Eight in TmwLine(Source).Items[I].B of True: case TmwLine(Source).Items[I].P is TBitMap of True: begin BM:= TBitMap.Create; BM.Assign(TmwLine(Source).Items[I].P); fList[I].P:= BM; Include(fList[I].B, Eight); end; False: if TmwLine(Source).Items[I].P is TmwColumn then begin Col:= TmwColumn.Create; Col.Assign(TmwLine(Source).Items[I].P); fList[I].P:= Col; Include(fList[I].B, Eight); end else begin fList[I].CW:= #32; Exclude(fList[I].B, Eight); end; end; False: fList[I]:= TmwLine(Source).Items[I]; end; end else inherited Assign(Source); end; procedure TmwLine.AssignFontIndex(Index: Integer; aFontIndex: Byte; Number: Integer); var I: Integer; begin if Index = 0 then begin fFontIndex:= aFontIndex; for I:= 1 to fCount do if not GetIsPersistent(Index) then begin fList[Index].I:= aFontIndex; fList[Index].W:= 0; end; end else if Index <= fCount then for I:= Index to Index + Number -1 do if not GetIsPersistent(Index) then begin fList[Index].I:= aFontIndex; fList[Index].W:= 0; end; end; procedure TmwLine.AssignTo(Dest: TPersistent); begin if Dest is TmwLine then TmwLine(Dest).Assign(Self) else inherited AssignTo(Dest); end; procedure TmwLine.CleanUp(Index, Number: Integer); var I: Integer; begin for I := Index to Index + Number - 1 do DisposeItem(I); end; function TmwLine.Clone: TPersistent; begin Result := TmwLine.Create; Result.Assign(Self); end; procedure TmwLine.Delete(Index, Number: Integer); begin if Number = 0 then Exit; CleanUp(Index, Number); if (Index > 0) and (Index <= fCount) then begin if Index + Number > fCount then Number := fCount - Index +1; System.Move(fList[Index + Number], fList[Index], (fCount - Index - Number +1) * SizeOf(TmwLineItem)); SetCount(fCount - Number); end; end; procedure TmwLine.DisposeItem(Index: Integer); begin if GetIsPersistent(Index) then begin fList[Index].P.Free; Exclude(fList[Index].B, Eight); end; end; function TmwLine.GetAnsiText: String; var I: Integer; Len, Len2: Integer; begin Len:= fCount; SetLength(Result, Len*2); Len2:= 0; for I:= 1 to fCount do begin if not GetIsPersistent(I) then case fList[I].CT = #0 of True: begin inc(Len2); Result[Len2] := fList[I].CL; end; False: begin inc(Len2); Result[Len2] := fList[I].CL; inc(Len2); Result[Len2] := fList[I].CT; end; end; end; SetLength(Result, Len2); end; function TmwLine.GetChar(Index: Integer): WideChar; begin if GetIsPersistent(Index) then Result:= ' ' else Result:= GetItems(Index).CW; end; function TmwLine.GetFontIndex(Index: Integer): Byte; begin if Index > fCount then Index:= fCount; while IsPersistent[Index] do dec(Index); if (Index > 0) and (Index <= fCount) then Result:= fList[Index].I else Result:= fFontIndex; end; function TmwLine.GetHidden: Boolean; begin Result:= Eight in Bits; end; function TmwLine.GetIsPersistent(Index: Integer): Boolean; begin if (Index > 0) and (Index <= fCount) then Result:= Eight in fList[Index].B else Result:= False; end; function TmwLine.GetItems(Index: Integer): TmwLineItem; begin if (Index > 0) and (Index <= fCount) then Result:= fList[Index] else begin Result.CW:= ' '; Result.I:= 0; Result.W:= 0; Result.B:= []; end; end; function TmwLine.GetLastFontIndex: Byte; begin Result:= GetFontIndex(Count); end; function TmwLine.GetPersistent(Index: Integer): TPersistent; begin if GetIsPersistent(Index) then Result:= GetItems(Index).P else Result:= nil; end; function TmwLine.GetText: WideString; var I: Integer; Len: Integer; begin if fCount = 0 then begin Result:= ''; exit; end; SetLength(Result, fCount); Len:= 0; for I:= 1 to fCount do begin case GetIsPersistent(I) of False: begin inc(Len); Result[Len] := fList[I].CW; end; end; end; if Len < fCount then SetLength(Result, Len); end; procedure TmwLine.Insert(Index: Integer; const Item: TmwLineItem); begin if Index = 0 then Index := 1; PrepareInsert(Index); fList^[Index] := Item; end; procedure TmwLine.Insert(Index: Integer; const APersistent: TPersistent); var Temp: TmwLineItem; begin Temp.P:= APersistent; Include(Temp.B, Eight); Insert(Index, Temp); end; procedure TmwLine.Insert(Index: Integer; const AChar: Char); var Temp: TmwLineItem; begin Temp.Cl:= AChar; Temp.CT:= #0; Temp.I := GetFontIndex(Index); Temp.B := []; Temp.W := 0; Insert(Index, Temp); end; procedure TmwLine.Insert(Index: Integer; const AWideChar: WideChar); var Temp: TmwLineItem; begin Temp.CW:= AWideChar; Temp.I := GetFontIndex(Index); Temp.B := []; Temp.W := 0; Insert(Index, Temp); end; procedure TmwLine.Insert(Index: Integer; const AString: WideString); var I, J, Len: Integer; Temp: TmwLineItem; begin if aString = '' then exit; if Index = 0 then Index := 1; Len:= Length(AString); Temp.I := GetFontIndex(Index); Temp.B := []; Temp.W := 0; if Index <= FCount then begin PrepareInsert(Index, Len); J:= 0; for I:= Index to Index + Len - 1do begin inc(J); Temp.CW:= AString[J]; fList[I]:= Temp; end; end else begin if Index > FCount + 1 then PadUp(Index - FCount -1); Add(AString); end; end; procedure TmwLine.PadUp(Number: Integer); var Temp: TmwLineItem; I, OldCount: Integer; begin if Number = 0 then Exit; OldCount:= fCount; Temp.CW:= ' '; Temp.I := GetFontIndex(OldCount); Temp.B := []; Temp.W := 0; SetCount(OldCount + Number); for I:= OldCount +1 to OldCount + Number do fList[I]:= Temp; end; procedure TmwLine.PrepareInsert(Index: Integer; Number: Integer); var OldPlus: Integer; begin if Number > 0 then begin OldPlus:= FCount +1; SetCount(fCount + Number); if Index < OldPlus then System.Move(fList[Index], fList[Index + Number], (OldPlus - Index) * SizeOf(TmwLineItem)); end; end; procedure TmwLine.SetAnsiText(const Value: String); begin SetCount(0); if Value <> '' then Add(Value); end; procedure TmwLine.SetChar(Index: Integer; const Value: WideChar); var Temp: TmwLineItem; begin if Index < 1 then Index:= 1; if Index <= fCount then begin DisposeItem(Index); fList[Index].CW:= Value end else begin Temp.CW:= Value; Temp.I := GetFontIndex(Index); Temp.B := []; Temp.W := 0; Insert(Index, Temp); end; end; procedure TmwLine.SetCount(const Value: Integer); begin if value <> fCount then begin if Value < FCount then CleanUp(Value +1, fCount -Value); ReallocMem(fList, Value * SizeOf(TmwLineItem)); fCount := Value; end; end; procedure TmwLine.SetFontIndex(Index: Integer; const Value: Byte); begin if (Index > 0) and (Index <= fCount) then begin if not GetIsPersistent(Index) then begin fList[Index].I:= Value; fList[Index].W:= 0; end; end else fFontIndex:= Value; end; procedure TmwLine.SetHidden(const Value: Boolean); begin case Value of True: Include(Bits, Eight); False:Exclude(Bits, Eight); end; end; procedure TmwLine.SetItems(Index: Integer; const Value: TmwLineItem); begin if Index < 1 then Index:= 1; if Index <= fCount then begin DisposeItem(Index); fList[Index]:= Value end else Insert(Index, Value); end; procedure TmwLine.SetPersistent(Index: Integer; const Value: TPersistent); var Temp: TmwLineItem; begin if Index < 1 then Index:= 1; if Index <= fCount then begin if GetIsPersistent(Index) then fList[Index].P.Assign(Value) else fList[Index].P:= Value end else begin Temp.P := Value; Include(Temp.B, Eight); Insert(Index, Temp); end; end; procedure TmwLine.SetText(const Value: WideString); begin SetCount(0); if Value <> '' then Add(Value); end; { TmwTextAttribute } procedure TmwTextAttribute.Assign(Source: TPersistent); var Font: TFont; Attribute: TmwTextAttribute; begin if (Source is TmwTextAttribute) or (Source is TFont) then begin if Source is TmwTextAttribute then begin Attribute:= TmwTextAttribute(Source); Align:= Attribute.Align; BackGround := Attribute.BackGround; CharSet := Attribute.CharSet; Color := Attribute.Color; Height := Attribute.Height; Name := Attribute.Name; Pitch := Attribute.Pitch; Style := Attribute.Style; Weight := Attribute.Weight; end else begin Font:= TFont(Source); Align:= caNormal; BackGround := clBase; CharSet := Font.CharSet; Color := Font.Color; Height := Font.Height; Name := Font.Name; Pitch := Font.Pitch; Style := Font.Style; Weight := Font.Weight; end; end else inherited Assign(Source); end; procedure TmwTextAttribute.AssignTo(Dest: TPersistent); var Font: TFont; begin if Dest is TmwTextAttribute then Dest.Assign(Self) else if Dest is TFont then begin Font:= TFont(Dest); Font.Name := Name; Font.Height := Height; Font.CharSet := CharSet; Font.Color := Color; Font.Pitch := Pitch; Font.Style := Style; Font.Weight := Weight; end else inherited AssignTo(Dest); end; constructor TmwTextAttribute.Create; begin inherited Create; fBackGround := clBase; FCharSet := fcsDefaultCharSet; fAlign:= caNormal; end; function TmwTextAttribute.GetText: String; const PreFix = '/'; var aString: String; begin Result := 'mwAttribute'; Result := Result + PreFix + IntToStr(Id); Result := Result + PreFix + Name; Case Align of caNormal: Result := Result + PreFix + 'caNormal'; caSubScript : Result := Result + PreFix + 'caSubScript'; caSuperScript: Result := Result + PreFix + 'caSuperScript'; end; Result := Result + PreFix + IntToStr(BackGround); Result := Result + PreFix + GetEnumName(TypeInfo(TFontCharSet), Integer(Charset)); Result := Result + PreFix + IntToStr(Color); Result := Result + PreFix + IntToStr(Height); Case Pitch of fpDefault: Result := Result + PreFix + 'fpDefault'; fpVariable: Result := Result + PreFix + 'fpVariable'; fpFixed: Result := Result + PreFix + 'fpFixed'; end; aString := PreFix + '['; if fsBold in Style then aString := aString + 'fsBold' + ','; if fsItalic in Style then aString := aString + 'fsItalic' + ','; if fsUnderline in Style then aString := aString + 'fsUnderline' + ','; if fsStrikeOut in Style then aString := aString + 'fsStrikeOut' + ','; if aString[Length(aString)] = ',' then aString[Length(aString)] := ']' else aString := aString + ']'; Result := Result + aString + PreFix; end; procedure TmwTextAttribute.SetText(const aText: String); var Run, Start: Integer; aString: String; aStyle: TFontStyles; Token: String; procedure Next; begin Token:= ''; if aText[Run] = '/' then inc(Run); while aText[Run] <> '/' do begin Token:= Token + aText[Run]; if Run < Length(aText) then inc(Run) else break; end; end; begin if SameText(Copy(aText, 1, 11), 'mwAttribute') then try Run:= 12; Next; Id := StrToInt(Token); Next; Name := Token; Next; if SameText(Token, 'caNormal') then Align := caNormal else if SameText(Token, 'caSubScript') then Align := caSubScript else if SameText(Token, 'caSuperScript') then Align := caSuperScript; Next; BackGround := StrToInt(Token); Next; Charset := TFontCharSet(GetEnumValue(TypeInfo(TFontCharSet), Token)); Next; Color := StrToInt(Token); Next; Height := StrToInt(Token); Next; if SameText(Token, 'fpDefault') then Pitch := fpDefault else if SameText(Token, 'fpVariable') then Pitch := fpVariable else if SameText(Token, 'fpFixed') then Pitch := fpFixed; Next; Run := 2; Start := Run; aStyle := []; if Length(Token) > 2 then while Token[Run] <> ']' do begin while Token[Run] in ['A'..'Z', 'a'..'z'] do if Run < Length(Token) then inc(Run) else break; aString := Copy(Token, Start, Run - Start); if SameText(aString, 'fsBold') then Include(aStyle, fsBold) else if SameText(aString, 'fsItalic') then Include(aStyle, fsItalic) else if SameText(aString, 'fsUnderline') then Include(aStyle, fsUnderline) else if SameText(aString, 'fsStrikeOut') then Include(aStyle, fsStrikeOut); if Token[Run] = ',' then inc(Run); Start := Run; if Run > Length(Token) then break; end; Style := aStyle; except end; end; { TmwHashString } constructor TmwCharItem.Create(const aKey: TmwLineItem); begin inherited Create; Key:= aKey; end; { TmwBaseCharHashList } procedure TmwBaseCharHashList.Clear; var I: Integer; begin for I := 1 to fCapacity do if fList[I] <> nil then fList[I].Free; ReallocMem(FList, 0); fCapacity := 0; end; function TmwBaseCharHashList.Compare(const Key1, Key2: TmwLineItem): Boolean; begin Result:= True; if Key1.V1 <> Key2.V1 then Result:= False else if Key1.V2 <> Key2.V2 then Result:= False; end; destructor TmwBaseCharHashList.Destroy; begin Clear; inherited Destroy; end; function TmwBaseCharHashList.Get(Index: Integer): Pointer; begin Result := nil; if (Index > 0) and (Index <= fCapacity) then Result := fList[Index]; end; procedure TmwBaseCharHashList.Put(Index: Integer; Item: Pointer); begin if (Index > 0) and (Index <= fCapacity) then fList[Index] := Item; end; procedure TmwBaseCharHashList.SetCapacity(NewCapacity: Integer); var I, OldCapacity: Integer; begin if NewCapacity > fCapacity then begin ReallocMem(FList, (NewCapacity) * SizeOf(Pointer)); OldCapacity := fCapacity; FCapacity := NewCapacity; for I := OldCapacity + 1 to NewCapacity do Items[I] := nil; end; end; { TmwHashStrings } procedure TmwHashStrings.Add(const aKey: TmwLineItem); begin if HasKey(aKey) then exit; SetCapacity(Capacity + 1); fList[Capacity] := TmwCharItem.Create(aKey); end; function TmwHashStrings.HasKey(const aKey: TmwLineItem): Boolean; var I: Integer; begin Result:= False; for I:= 1 to fCapacity do if Compare(TmwCharItem(fList[I]).Key, aKey) then begin Result:= True; exit; end; end; { TmwHashItems } procedure TmwHashItems.Add(const aKey: TmwLineItem); var HashKey: TmwCharItem; HashStrings: TmwHashStrings; HashVal: Integer; begin HashVal := ComputeKey(aKey); SetCapacity(HashVal); if Items[HashVal] = nil then begin Items[HashVal] := TmwCharItem.Create(aKey); end else if fList[HashVal] is TmwHashStrings then begin TmwHashStrings(Items[HashVal]).Add(aKey); end else begin HashKey := Items[HashVal]; if not compare(HashKey.Key, aKey) then begin HashStrings := TmwHashStrings.Create; Items[HashVal] := HashStrings; HashStrings.Add(HashKey.Key); HashKey.Free; HashStrings.Add(aKey) end; end; end; function TmwHashItems.ComputeKey(const aKey: TmwLineItem): integer; var Temp: array[0..1] of Word; begin Temp[0]:= aKey.V1; Temp[1]:= aKey.V2; Result := Cardinal(Temp) mod 61 +1; end; function TmwHashItems.HasKey(const aKey: TmwLineItem): Boolean; var HashKey: TmwCharItem; HashVal: Integer; begin Result:= False; HashVal := ComputeKey(aKey); if HashVal > fCapacity then exit; if Items[HashVal] <> nil then begin if fList[HashVal] is TmwHashStrings then begin Result:= TmwHashStrings(Items[HashVal]).HasKey(aKey); end else begin HashKey := Items[HashVal]; Result:= compare(HashKey.Key, aKey); end; end; end; { TmwCharHashList } procedure TmwCharHashList.Add(const aKey: TmwLineItem); var HashKey: TmwCharItem; HashValue: Integer; HashItems: TmwHashItems; begin HashValue := ComputeKey(aKey); if HashValue >= fCapacity then SetCapacity(HashValue); if Items[HashValue] = nil then begin Items[HashValue] := TmwCharItem.Create(aKey); end else if fList[HashValue] is TmwHashItems then begin TmwHashItems(Items[HashValue]).Add(aKey); end else begin HashKey := Items[HashValue]; if not compare(HashKey.Key, aKey) then begin HashItems := TmwHashItems.Create; Items[HashValue] := HashItems; HashItems.Add(HashKey.Key); HashKey.Free; HashItems.Add(aKey); end; end; end; function TmwCharHashList.ComputeKey(const aKey: TmwLineItem): integer; begin Result := (aKey.V1 + aKey.V2) mod 256 +1; end; function TmwCharHashList.Hash(var aKey: TmwLineItem): Boolean; begin Result := HashEX(aKey, ComputeKey(aKey)); end; function TmwCharHashList.HashEX(var aKey: TmwLineItem; HashValue: Integer): Boolean; var Temp: TObject; HashKey: TmwCharItem; HashItems: TmwHashItems; I, ItemHash: Integer; begin Result := False; if HashValue < 1 then Exit; if HashValue > Capacity then Exit; if Items[HashValue] <> nil then begin if fList[HashValue] is TmwCharItem then begin HashKey := Items[HashValue]; Result := Compare(HashKey.Key, aKey); if Result then aKey.W := HashKey.Key.W; end else begin HashItems := Items[HashValue]; ItemHash := HashItems.ComputeKey(aKey); if ItemHash > HashItems.Capacity then Exit; Temp := HashItems[ItemHash]; if Temp <> nil then if Temp is TmwCharItem then begin Result := Compare(TmwCharItem(Temp).Key, aKey); if Result then aKey.W := TmwCharItem(Temp).Key.W; end else for I := 1 to TmwHashStrings(Temp).Capacity do begin HashKey := TmwHashStrings(Temp)[I]; Result := Compare(HashKey.Key, aKey); if Result then begin aKey.W := HashKey.Key.W; exit; end; end; end; end; end; function TmwCharHashList.HasKey(const aKey: TmwLineItem): Boolean; var HashKey: TmwCharItem; HashItems: TmwHashItems; HashValue: Integer; begin Result := False; HashValue:= ComputeKey(aKey); if HashValue < 1 then Exit; if HashValue > Capacity then Exit; if Items[HashValue] <> nil then begin if fList[HashValue] is TmwCharItem then begin HashKey := Items[HashValue]; Result := Compare(HashKey.Key, aKey); end else begin HashItems := Items[HashValue]; Result:= HashItems.HasKey(aKey); end; end; end; { TmwTextAttributeList } procedure TmwTextAttributeList.Activate(const Value: Byte); var Font: TFont; begin fActive:= Value; if fFM <> nil then QFontMetrics_destroy(fFM); Font:= TFont.Create; Items[Value].AssignTo(Font); fFM:= QFontMetrics_create(Font.Handle); Font.Free; end; function TmwTextAttributeList.Add(Item: TFont): Integer; begin FHelper.Assign(Item); Result:= Add(FHelper); end; function TmwTextAttributeList.Add(Item: TmwTextAttribute): Integer; var Attribute: TmwTextAttribute; begin Result := 0; if Full then exit else begin Result := IndexOfEqual(Item); if Result = -1 then begin Result:= FirstUnUsed; Attribute:= TmwTextAttribute.Create; Attribute.Assign(Item); Attribute.Id := Result; fList[Result] := Attribute; inc(fCount); end; end; end; function TmwTextAttributeList.Ascent(Index: Byte): Integer; begin if Index <> fActive then Activate(Index); Result:= QFontMetrics_Ascent(fFM); end; procedure TmwTextAttributeList.Assign(Source: TPersistent); var I: Integer; begin if Source is TmwTextAttributeList then begin try ClearAll; for I := 0 to 255 do if TmwTextAttributeList(Source)[I] <> nil then begin fList[I] := TmwTextAttribute.Create; fList[I].Assign(TmwTextAttributeList(Source)[I]); fList[I].Id:= I; end; except end; exit; end; inherited Assign(Source); end; procedure TmwTextAttributeList.Clear; var I: Integer; begin for I := 1 to 255 do if fList[I] <> nil then FreeAndNil(fList[I]); fCount := 1; end; procedure TmwTextAttributeList.ClearAll; begin Clear; if fList[0] <> nil then FreeAndNil(fList[0]); fCount := 0; end; procedure TmwTextAttributeList.ClearCharTable; begin CharTable.Clear; end; constructor TmwTextAttributeList.Create; var Attribute: TmwTextAttribute; begin inherited Create; FCharTable:= TmwCharHashList.Create; FFontHelper:= TFont.Create; FHelper:= TmwTextAttribute.Create; Attribute := TmwTextAttribute.Create; Attribute.BackGround := clBase; Attribute.Name := 'Courier'; Attribute.Height := 10; Attribute.Color := clWindowText; Attribute.Charset := fcsDefaultCharSet; Attribute.Style := []; Attribute.Id := 0; fList[0] := Attribute; Activate(0); fCount := 1; {$IFDEF LINUX} UnixStyle:= True; {$ENDIF} end; function TmwTextAttributeList.Descent(Index: Byte): Integer; begin SetActive(Index); Result:= QFontMetrics_Descent(fFM); end; destructor TmwTextAttributeList.Destroy; begin FCharTable.Free; FFontHelper.Free; FHelper.Free; ClearAll; if fFM <> nil then QFontMetrics_destroy(fFM); inherited Destroy; end; function TmwTextAttributeList.Equals(Attribute1, Attribute2: TmwTextAttribute): Boolean; begin Result := True; if Attribute1.Align <> Attribute2.Align then begin Result := False; exit; end else if Attribute1.Color <> Attribute2.Color then begin Result := False; exit; end else if Attribute1.BackGround <> Attribute2.BackGround then begin Result := False; exit; end else if Attribute1.Style <> Attribute2.Style then begin Result := False; exit; end else if Attribute1.Height <> Attribute2.Height then begin Result := False; exit; end else if Attribute1.Pitch <> Attribute2.Pitch then begin Result := False; exit; end else if Attribute1.Charset <> Attribute2.Charset then begin Result := False; exit; end else if Attribute1.Weight <> Attribute2.Weight then begin Result := False; exit; end else if AnsiCompareText(Attribute1.Name, Attribute2.Name) <> 0 then begin Result := False; exit; end; end; function TmwTextAttributeList.FirstUnUsed: Integer; var I: Integer; begin Result:= 256; for I:= 1 to 255 do if fList[I] = nil then begin Result := I; Exit; end; end; function TmwTextAttributeList.GetAttribute(Index: Integer): TmwTextAttribute; begin Result := fList[0]; if (Index >= 0) and (Index < 256) then if fList[Index] <> nil then Result := fList[Index]; end; function TmwTextAttributeList.GetDefaultAttribute: TmwTextAttribute; begin Result := Items[0]; end; function TmwTextAttributeList.GetFonts(Index: Integer): TFont; begin Items[Index].AssignTo(FFontHelper); Result:= FFontHelper; end; function TmwTextAttributeList.GetFull: Boolean; begin Result:= fCount = 256; end; function TmwTextAttributeList.Height(Index: Byte): Integer; begin Result:= Items[Index].Height; end; function TmwTextAttributeList.Height(Value: TmwLine): Integer; var I, H: Integer; Temp: TmwColumn; begin Result:= 0; if Value.Hidden then Exit; if Value.Count = 0 then Result:= Value.fFontIndex else for I:= 1 to Value.Count do case Value.GetIsPersistent(I) of False: begin if Result < Items[Value.GetFontIndex(I)].Height then Result:= Items[Value.GetFontIndex(I)].Height; end; True: case Value.Persistents[I] is TBitMap of True: begin if Result < TBitMap(Value.Persistents[I]).Height then Result:= TBitMap(Value.Persistents[I]).Height; end; False: if Value.Persistents[I] is TmwColumn then begin Temp:= TmwColumn(Value.Persistents[I]); H:= Height(Temp, Temp.Width); if Result < H then Result:= H; end; end; end; end; function TmwTextAttributeList.Height(Value: TmwLine; aWidth: Integer): Integer; var J, H, W: Integer; begin J:= 1; Result:= 0; if Value.Hidden then Exit; if Value.Count = 0 then Result:= Value.fFontIndex else while J <= Value.Count do begin WrapAt(J, H, W, Value, aWidth); inc(Result, H); end; end; function TmwTextAttributeList.IndexOfEqual(Item: TFont): Integer; begin FHelper.Assign(Item); Result := IndexOfEqual(FHelper); end; function TmwTextAttributeList.IndexOfEqual(Item: TmwTextAttribute): Integer; var I: Integer; begin Result := -1; for I := 0 to 255 do if fList[I] <> nil then begin if Equals(Item, fList[I]) then begin Result := I; exit; end; end; end; function TmwTextAttributeList.InFont(Index: Byte; p1: PWideChar): Boolean; begin SetActive(Index); Result:= QFontMetrics_InFont(fFM, P1); end; procedure TmwTextAttributeList.InitChar(var Value: TmwLineItem); begin case Eight in Value.B of False: if not CharTable.Hash(Value) then begin Value.W:= Width(Value.I, Value.CW); CharTable.Add(Value); end; end; end; procedure TmwTextAttributeList.InitLine(Value: TmwLine); var I: Integer; begin for I:= 1 to Value.Count do case Value.GetIsPersistent(I) of False: Value.List[I].W:= Width(Value.GetFontIndex(I), Value[I]); end; end; function TmwTextAttributeList.Leading(Index: Byte): Integer; begin SetActive(Index); Result:= QFontMetrics_Leading(fFM); end; function TmwTextAttributeList.LeftBearing(Index: Byte; p1: PWideChar): Integer; begin SetActive(Index); Result:= QFontMetrics_LeftBearing(fFM, P1); end; function TmwTextAttributeList.LineSpacing(Index: Byte): Integer; begin SetActive(Index); Result:= QFontMetrics_LineSpacing(fFM); end; function TmwTextAttributeList.LineWidth(Index: Byte): Integer; begin SetActive(Index); Result:= QFontMetrics_LineWidth(fFM); end; procedure TmwTextAttributeList.LoadFromStream(Stream: TStream); var C : Char; Run, Start, Temp: Integer; Token: String; Attribute: TmwTextAttribute; aString: String; StyleString: String; aStyle: TFontStyles; procedure Get; var Readed: Integer; begin Readed:= Stream.Read(C, 1); if Readed = 0 then C:= #0; end; procedure UnGet; begin Stream.Position:= Stream.Position -1; end; procedure Next; begin Token:= ''; Get; while C in [#10, #13, '/'] do Get; while (C <> '/') and (C <> #0) do begin Token:= Token + C; Get; end; end; begin SetLength(Token, 11); Temp:= Stream.Position; ClearAll; Stream.Read(Token[1], 11); while SameText(Token, 'mwAttribute') = True do begin Attribute := TmwTextAttribute.Create; Next; Attribute.ID := StrToInt(Token); Next; Attribute.Name := Token; Next; if SameText(Token, 'caNormal') then Attribute.Align := caNormal else if SameText(Token, 'caSubScript') then Attribute.Align := caSubScript else if SameText(Token, 'caSuperScript') then Attribute.Align := caSuperScript; Next; Attribute.BackGround := StrToInt(Token); Next; Attribute.Charset := TFontCharSet(GetEnumValue(TypeInfo(TFontCharSet), Token)); Next; Attribute.Color := StrToInt(Token); Next; Attribute.Height := StrToInt(Token); Next; aString := Token; if AnsiCompareText(aString, 'fpDefault') = 0 then Attribute.Pitch := fpDefault else if AnsiCompareText(aString, 'fpVariable') = 0 then Attribute.Pitch := fpVariable else if AnsiCompareText(aString, 'fpFixed') = 0 then Attribute.Pitch := fpFixed; Next; StyleString := Token; Run := 2; Start := Run; aStyle := []; if Length(StyleString) > 2 then while StyleString[Run] <> ']' do begin while StyleString[Run] in ['A'..'Z', 'a'..'z'] do inc(Run); aString := Copy(StyleString, Start, Run - Start); if AnsiCompareText(aString, 'fsBold') = 0 then Include(aStyle, fsBold) else if AnsiCompareText(aString, 'fsItalic') = 0 then Include(aStyle, fsItalic) else if AnsiCompareText(aString, 'fsUnderline') = 0 then Include(aStyle, fsUnderline) else if AnsiCompareText(aString, 'fsStrikeOut') = 0 then Include(aStyle, fsStrikeOut); if StyleString[Run] = ',' then inc(Run); Start := Run; end; Attribute.Style := aStyle; fList[Attribute.Id]:= Attribute; inc(FCount); Temp:= Stream.Position; Get; while C in [#10, #13, '/'] do Get; UnGet; SetLength(Token, 11); Stream.Read(Token[1], 11); if SameText(Token, 'mwAttribute') = False then begin Stream.Position := Temp; break; end; end; if Stream.Position - Temp = 11 then Stream.Position := Temp; end; procedure TmwTextAttributeList.LoadFromString(const aString: String; var Run: Integer); var Start, Temp: Integer; Origin: PChar; Token: String; Attribute: TmwTextAttribute; bString: String; StyleString: String; aStyle: TFontStyles; procedure Next; begin while Origin[Run] in [#10, #13, '/'] do inc(Run); Start := Run; while Origin[Run] <> '/' do inc(Run); SetLength(Token, Run - Start); StrLCopy(PChar(Token), (Origin + Start), Run - Start); end; begin Origin := PChar(aString); Run := 0; SetLength(Token, 11); StrLCopy(PChar(Token), (Origin + Run), 11); inc(Run, 11); ClearAll; while SameText(Token, 'mwAttribute') = True do begin Attribute := TmwTextAttribute.Create; Next; Attribute.ID := StrToInt(Token); Next; Attribute.Name := Token; Next; if SameText(Token, 'caNormal') then Attribute.Align := caNormal else if SameText(Token, 'caSubScript') then Attribute.Align := caSubScript else if SameText(Token, 'caSuperScript') then Attribute.Align := caSuperScript; Next; Attribute.BackGround := StrToInt(Token); Next; Attribute.Charset := TFontCharSet(GetEnumValue(TypeInfo(TFontCharSet), Token)); Next; Attribute.Color := StrToInt(Token); Next; Attribute.Height := StrToInt(Token); Next; bString := Token; if AnsiCompareText(bString, 'fpDefault') = 0 then Attribute.Pitch := fpDefault else if AnsiCompareText(bString, 'fpVariable') = 0 then Attribute.Pitch := fpVariable else if AnsiCompareText(bString, 'fpFixed') = 0 then Attribute.Pitch := fpFixed; Next; StyleString := Token; Temp:= Run; Run := 2; Start := Run; aStyle := []; if Length(StyleString) > 2 then while StyleString[Run] <> ']' do begin while StyleString[Run] in ['A'..'Z', 'a'..'z'] do inc(Run); bString := Copy(StyleString, Start, Run - Start); if AnsiCompareText(bString, 'fsBold') = 0 then Include(aStyle, fsBold) else if AnsiCompareText(bString, 'fsItalic') = 0 then Include(aStyle, fsItalic) else if AnsiCompareText(bString, 'fsUnderline') = 0 then Include(aStyle, fsUnderline) else if AnsiCompareText(bString, 'fsStrikeOut') = 0 then Include(aStyle, fsStrikeOut); if StyleString[Run] = ',' then inc(Run); Start := Run; end; Run:= Temp; Attribute.Style := aStyle; fList[Attribute.Id]:= Attribute; inc(FCount); while Origin[Run] in [#10, #13, '/'] do inc(Run); SetLength(Token, 11); StrLCopy(PChar(Token), (Origin + Run), 11); if SameText(Token, 'mwAttribute') = True then inc(Run, 11); end; end; function TmwTextAttributeList.MaxWidth(Index: Byte): Integer; begin SetActive(Index); Result:= QFontMetrics_MaxWidth(fFM); end; function TmwTextAttributeList.MinLeftBearing(Index: Byte): Integer; begin SetActive(Index); Result:= QFontMetrics_MinLeftBearing(fFM); end; function TmwTextAttributeList.MinRightBearing(Index: Byte): Integer; begin SetActive(Index); Result:= QFontMetrics_MinRightBearing(fFM); end; procedure TmwTextAttributeList.Remove(Index: Integer); begin if (Index > 0) and (Index < 256) then if fList[Index] <> nil then begin FreeAndNil(fList[Index]); dec(FCount); end; end; function TmwTextAttributeList.RightBearing(Index: Byte; p1: PWideChar): Integer; begin SetActive(Index); Result:= QFontMetrics_RightBearing(fFM, P1); end; procedure TmwTextAttributeList.SaveToStream(Stream: TStream); var LineEnd: String; aString: String; I: Integer; begin Case UnixStyle of True: LineEnd := #10; False: LineEnd := #13#10; end; for I := 0 to 255 do if fList[I] <> nil then begin aString:= Items[I].Text; Stream.Write(aString[1], Length(aString)); Stream.Write(LineEnd[1], Length(LineEnd)); end; end; procedure TmwTextAttributeList.SetActive(Value: Byte); begin if fList[Value] = nil then Value:= 0; if Value <> fActive then Activate(Value); end; procedure TmwTextAttributeList.SetAttribute(Index: Integer; Value: TmwTextAttribute); begin if Value = nil then exit; if (Index > 0) and (Index < 256) then begin if IndexOfEqual(Value) > -1 then exit; if fList[Index] = nil then begin fList[Index] := TmwTextAttribute.Create; fList[Index].Id:= Index; inc(fCount); end; fList[Index].Assign(Value); if fActive = Index then Activate(Index); CharTable.Clear; end; end; procedure TmwTextAttributeList.SetDefaultAttribute(const Value: TmwTextAttribute); begin if Value = nil then exit; Items[0].Assign(Value); if fActive = 0 then Activate(0); CharTable.Clear; end; procedure TmwTextAttributeList.SetFonts(Index: Integer; const Value: TFont); begin if Value = nil then exit; FHelper.Assign(Value); SetAttribute(Index, FHelper); end; function TmwTextAttributeList.Size(var Item: TmwLineItem): TSize; var Temp: TmwColumn; begin Result.cx:= 0; Result.cy:= 0; case Eight in Item.B of True: case Item.P is TBitMap of True: begin Result.cx:= TBitMap(Item.P).Width; Result.cy:= TBitMap(Item.P).Height; end; False: if Item.P is TmwColumn then begin Temp:= TmwColumn(Item.P); case Temp.Hidden of False: begin Result.cx:= Temp.Width; Result.cy:= Height(Temp, Temp.Width); end; True: begin Result.cx:= 0; Result.cy:= 0; end; end; end; end; False: begin Result.cy:= Items[Item.I].FHeight; case Item.W = 0 of False: Result.cx:= Item.W; True: begin if CharTable.Hash(Item) then Result.cx:= Item.W else begin Item.W:= Width(Item.I, Item.CW); Result.cx:= Item.W; CharTable.Add(Item); end; end; end; end; end; end; function TmwTextAttributeList.Size(Value: TmwLine): TSize; var I: Integer; Temp: TSize; begin Result.cx:= 0; Result.cy:= 0; for I:= 1 to Value.Count do begin Temp:= Size(Value.fList[I]); inc(Result.cx, Temp.cx); if Result.cy < Temp.cy then Result.cy:= Temp.cy; end; end; function TmwTextAttributeList.StrikeOutPos(Index: Byte): Integer; begin SetActive(Index); Result:= QFontMetrics_StrikeOutPos(fFM); end; function TmwTextAttributeList.UnderlinePos(Index: Byte): Integer; begin SetActive(Index); Result:= QFontMetrics_UnderlinePos(fFM); end; function TmwTextAttributeList.Width(var Item: TmwLineItem): Integer; begin Result:= Size(Item).cx; end; function TmwTextAttributeList.Width(Index: Byte; c: char): Integer; begin SetActive(Index); Result:= QFontMetrics_Width(fFM, C); end; function TmwTextAttributeList.Width(Index: Byte; p1: PWideString; len: Integer): Integer; begin SetActive(Index); Result:= QFontMetrics_Width(fFM, P1, Len); end; function TmwTextAttributeList.Width(Index: Byte; WS: WideString): Integer; begin SetActive(Index); Result:= QFontMetrics_Width(fFM, @WS, Length(WS)); end; function TmwTextAttributeList.Width(Index: Byte; p1: PWideChar): Integer; var Temp: WideString; begin SetActive(Index); Temp:= P1; // Result:= QFontMetrics_Width(fFM, P1); //Bug Result:= QFontMetrics_Width(fFM, @Temp, Length(Temp)); end; function TmwTextAttributeList.Width(Index: Byte; WC: WideChar): Integer; var Temp: WideString; begin SetActive(Index); Temp:= WC; // Result:= QFontMetrics_Width(fFM, @WC); //Bug Result:= QFontMetrics_Width(fFM, @Temp, 1); end; procedure TmwTextAttributeList.WrapAt(var Index, H, W: Integer; Line: TmwLine; aWidth: Integer); var S: TSize; Temp, Start: Integer; LastDelim, LastH, LastW: Integer; begin H:= 0; W:= 0; Start:= Index; LastDelim:= Index; while Index <= Line.Count do begin S:= Size(Line.fList[Index]); Temp:= S.cx; if W + Temp <= aWidth then begin inc(W, Temp); if H < S.cy then H:= S.cy; inc(Index); end else break; if Line.GetIsPersistent(Index) then begin LastDelim:= Index; LastH:= H; LastW:= W; end else if Line.Items[Index].CL in WordDelimiters then begin LastDelim:= Index; LastH:= H; LastW:= W; end; end; if Index <= Line.Count then if not (Line.Items[Index-1].CL in WordDelimiters) then if not (Line.Items[Index].CL in WordDelimiters) then if LastDelim > Start then begin Index:= LastDelim +1; H:= LastH; W:= LastW; end; end; { TmwTextIO } function TmwTextIO.Clone: TmwTextIO; begin Result:= nil; end; { TQmwStrings } function TQmwStrings.Add(const S: String): Integer; begin Insert(FCount +1, S); end; function TQmwStrings.Add(const S: WideString): Integer; begin Insert(FCount +1, S); end; function TQmwStrings.AddObject(const S: WideString; AObject: TObject): Integer; begin end; procedure TQmwStrings.AdjustPositions(Index, Delta: Integer); var I: Integer; Temp: TmwParagraph; begin if Delta = 0 then exit; inc(fHeight, Delta); if Index > fCount then Exit; for I:= Index to fCount do begin Temp:= fList[I]; inc(Temp.Position, Delta); end; end; procedure TQmwStrings.Assign(Source: TPersistent); begin inherited; end; procedure TQmwStrings.BeginUpdate; begin end; procedure TQmwStrings.BreakStringUP(const S: String); type TmwWideChar = array[0..1] of Char; var aRun: PChar; aEnd: PChar; Temp: TmwWideChar; PCW: PWideChar; CharStr: String; begin Clear; fLoading:= True; if Assigned(fIO) then fIO.BreakStringUP(S) else begin if Length(S) > 0 then begin New(PCW); aRun := PChar(S); aEnd := aRun + Length(S); TokenSize := 0; Temp[1]:= #0; SetLength(CharStr, 2); while aRun < aEnd do case aRun^ of #10: begin Add(Token); TokenSize := 0; inc(aRun); end; #13: begin Add(Token); TokenSize := 0; inc(aRun); if aRun^ = #10 then inc(aRun); end; else case aRun^ in LeadBytes of True: begin CharStr[1]:= aRun^; inc(aRun); CharStr[2]:= aRun^; inc(aRun); WriteChar(StringToWideChar(CharStr, PCW, 1)^); end; False: begin Temp[0]:= aRun^; WriteChar(WideChar(Temp)); inc(aRun); end; end; end; if TokenSize <> 0 then begin Add(Token); TokenSize := 0; end; BuffCapacity := 0; Dispose(PCW); end; end; fLoading:= False; end; procedure TQmwStrings.BreakStringUP(const S: WideString); var aRun: PWideChar; aEnd: PWideChar; begin Clear; fLoading:= True; if Assigned(fIO) then fIO.BreakStringUP(S) else begin if Length(S) > 0 then begin aRun := PWideChar(S); aEnd := aRun + Length(S); TokenSize := 0; while aRun < aEnd do case aRun^ of #10: begin Add(Token); TokenSize := 0; inc(aRun); end; #13: begin Add(Token); TokenSize := 0; inc(aRun); if aRun^ = #10 then inc(aRun); end; else WriteChar(aRun^); end; if TokenSize <> 0 then begin Add(Token); TokenSize := 0; end; BuffCapacity := 0; end; end; fLoading:= False; end; procedure TQmwStrings.Changed; begin end; procedure TQmwStrings.Changing; begin end; procedure TQmwStrings.CleanUp(Index, Number: Integer); var I: Integer; begin for I := Index to Index + Number - 1 do DisposeItem(I); end; procedure TQmwStrings.Clear; begin SetCapacity(0); fHeight:= 0; end; function TQmwStrings.Clone: TQmwStrings; begin Result:= TQmwStrings.Create; Result.UniCode:= UniCode; end; constructor TQmwStrings.Create; begin inherited Create; fAttributes:= TmwTextAttributeList.Create; fWrapWidth:= 1024; end; procedure TQmwStrings.Delete(Index, Number: Integer); var I, H: Integer; begin if Number = 0 then Exit; H:= 0; for I:= Index to Index + Number -1 do inc(H, GetItemHeight(I)); CleanUp(Index, Number); dec(FCount, Number); if (Index > 0) and (Index <= fCount) then begin if Index + Number > fCount then Number := fCount - Index +1; System.Move(fList[Index + Number], fList[Index], (fCount - Index - Number +1) * SizeOf(TmwParagraph)); end; SetCapacity(fCount); AdjustPositions(Index, -H); end; destructor TQmwStrings.Destroy; begin fAttributes.Free; inherited Destroy; end; procedure TQmwStrings.DisposeItem(Index: Integer); var Item: TPersistent; begin Item := GetItems(Index); if Item <> nil then Item.Free; end; procedure TQmwStrings.EndUpdate; begin end; procedure TQmwStrings.Expand(Value: Integer); begin SetCapacity(Value + fCount + fCount div 10); end; function TQmwStrings.GetAnsiText: String; var Stream: TmwStringStream; begin if Assigned(fIO) then Result:= fIO.GetAnsiText else begin Stream:= TmwStringStream.Create; try SaveAnsiToStream(Stream); Result:= Stream.DataString; finally Stream.Free; end; end; end; function TQmwStrings.GetCount: Integer; begin Result:= fCount; end; function TQmwStrings.GetItemHeight(Index: Integer): Integer; var Next, Cur: TmwParagraph; begin if (Index > 0) and (Index <= fCount) then begin Cur:= fList[Index]; if Cur.Hidden then Result:= 0 else begin Next:= Items[Index+1]; if Next <> nil then begin if Next.Position <> 0 then Result:= Next.Position - Cur.Position else case WordWrap of True: Result:= fAttributes.Height(Cur, WrapWidth); False: Result:= fAttributes.Height(Cur); end; end else case WordWrap of True: Result:= fAttributes.Height(Cur, WrapWidth); False: Result:= fAttributes.Height(Cur); end; end; end else Result:= 0; end; function TQmwStrings.GetItems(Index: Integer): TmwParagraph; begin if (Index > 0) and (Index <= fCount) then Result := FList^[Index] else Result:= nil; end; function TQmwStrings.GetObject(Index: Integer): TObject; begin end; function TQmwStrings.GetPosition(Index: Integer): Integer; var Temp: TmwParagraph; begin Temp:= Items[Index]; if Temp <> nil then Result:= Temp.Position else Result:= 0; end; function TQmwStrings.GetString(Index: Integer): WideString; begin if Assigned(fIO) then Result:= fIO.GetString(Index) else begin end; end; function TQmwStrings.GetText: WideString; var P: PChar; I, Len, LEL: Integer; S, LineEnd: WideString; begin if Assigned(fIO) then Result:= fIO.GetText else begin if UnixStyle then LineEnd := #10 else LineEnd := #13#10; LEL:= Length(LineEnd); Len:= 0; for I := 1 to fCount do inc(Len, Length(Items[I].Text) + LEL); SetLength(Result, Len); LEL:= LEL*2; P := Pointer(Result); for I := 1 to fCount do begin S:= Items[I].Text; Len:= Length(S)*2; if Len > 0 then begin System.Move(Pointer(S)^, P^, Len); inc(P, Len); end; System.Move(Pointer(LineEnd)^, P^, LEL); inc(P, LEL); end; end; end; function TQmwStrings.GetToken: WideString; begin SetLength(Result, fTokenSize); System.Move(fTokenBuffer[0], Pointer(Result)^, fTokenSize*2); end; procedure TQmwStrings.Insert(Index: Integer; const S: String); begin fInserting:= True; if Index < 1 then Index:= 1; if Index > fCount then Index:= FCount +1; PrepareInsert(Index, 1); if Assigned(fIO) then fIO.SetAnsiString(Index, S) else SetAnsiString(Index, S); fInserting:= False; end; procedure TQmwStrings.Insert(Index: Integer; const S: WideString); begin fInserting:= True; if Index < 1 then Index:= 1; if Index > fCount then Index:= FCount +1; PrepareInsert(Index, 1); if Assigned(fIO) then fIO.SetString(Index, S) else SetString(Index, S); fInserting:= False; end; procedure TQmwStrings.InsertObject(Index: Integer; const S: WideString; AObject: TObject); begin end; procedure TQmwStrings.LoadFromFile(const FileName: String); var WS: WideString; Len, Readed: Integer; FileStream: TFileStream; StringStream: TmwStringStream; begin if Assigned(fIO) then fIO.LoadFromFile(FileName) else case Unicode of True: begin FileStream:= TFileStream.Create(FileName, fmOpenRead); try Len:= FileStream.Size div 2; SetLength(WS, Len); Readed := FileStream.Read(Pointer(WS)^, Len*2); if Readed <> Len*2 then SetLength(WS, Readed div 2); BreakStringUp(WS); finally FileStream.Free; end; end; False: begin StringStream:= TmwStringStream.Create; try StringStream.LoadFromFile(FileName); BreakStringUp(StringStream.DataString); finally StringStream.Free; end; end; end; end; procedure TQmwStrings.LoadFromStream(Stream: TStream); begin if Assigned(fIO) then fIO.LoadFromStream(Stream) else begin end; end; procedure TQmwStrings.PrepareInsert(Index, Number: Integer); var I: Integer; begin if FCount + Number >= FCapacity then Expand(fCount + Number); if Index <= FCount then System.Move(fList[Index], fList[Index + Number], (FCount +1 - Index) * SizeOf(TmwLine)); inc(FCount, Number); for I:= Index to Index + Number -1 do fList[Index]:= TmwParagraph.Create; end; procedure TQmwStrings.RecalculateHeight; var I: Integer; Cur, Next: TmwParagraph; begin if fCount <> 0 then begin fList[1].Position:= 0; for I:= 1 to fCount -1 do begin Cur:= fList[I]; Next:= fList[I+1]; case WordWrap of True: Next.Position:= Cur.Position + fAttributes.Height(Cur, fWrapWidth); False: Next.Position:= Cur.Position + fAttributes.Height(Cur); end; end; end; end; procedure TQmwStrings.SaveAnsiToStream(Stream: TStream); var I, Len, LEL: Integer; Temp1: Integer; Temp2: Integer; S, LineEnd: string; begin Temp1 := Stream.Size; Temp2 := 0; if UnixStyle then LineEnd := #10 else LineEnd := #13#10; LEL:= Length(LineEnd); if not (Stream is TmwStringStream) then begin for I := 1 to fCount do inc(Temp2, Length(Items[I].AnsiText) + LEL); if Temp2 > Temp1 then Stream.Size := Temp2; end; for I := 1 to fCount do begin S:= Items[I].AnsiText; Len:= Length(S); if Len > 0 then Stream.Write(Pointer(S)^, Len); Stream.Write(Pointer(LineEnd)^, LEL); end; end; procedure TQmwStrings.SaveToFile(const FileName: WideString); var Stream: TmwStringStream; begin Stream:= TmwStringStream.Create; try SaveToStream(Stream); Stream.SaveToFile(FileName); finally Stream.Free; end; end; procedure TQmwStrings.SaveToStream(Stream: TStream); begin if Assigned(fIO) then fIO.SaveToStream(Stream) else case UniCode of True: SaveUniCodeToStream(Stream); False: SaveAnsiToStream(Stream); end; end; procedure TQmwStrings.SaveUniCodeToStream(Stream: TStream); var I, Len, LEL: Integer; Temp1: Integer; Temp2: Integer; S, LineEnd: WideString; begin Temp1 := Stream.Size; Temp2 := 0; if UnixStyle then LineEnd := #10 else LineEnd := #13#10; LEL:= Length(LineEnd)*2; if not (Stream is TmwStringStream) then begin for I := 1 to fCount do inc(Temp2, Length(Items[I].Text)*2 + LEL); if Temp2 > Temp1 then Stream.Size := Temp2; end; for I := 1 to fCount do begin S:= Items[I].Text; Len:= Length(S)*2; if Len > 0 then Stream.Write(Pointer(S)^, Len*2); Stream.Write(Pointer(LineEnd)^, LEL*2); end; end; procedure TQmwStrings.SetAnsiString(Index: Integer; const S: String); var OldH, Delta: Integer; Prev, Cur: TmwParagraph; begin if ReadOnly and not Loading then exit; if (Index > 0) and (Index <= fCount) then begin Cur:= fList[Index]; Prev:= Items[Index-1]; if (Cur.Position = 0) and (Prev <> nil) then case Prev.Hidden of True: Cur.Position:= Prev.Position; False: Cur.Position:= Prev.Position + GetItemHeight(Index-1); end; if Inserting then OldH:= 0 else OldH:= GetItemHeight(Index); if Assigned(fIO) then fIO.SetAnsiString(Index, S) else Cur.AnsiText := S; Delta:= GetItemHeight(Index) -OldH; AdjustPositions(Index+1, Delta); end; end; procedure TQmwStrings.SetAnsiText(const Value: String); begin BreakStringUP(Value); end; procedure TQmwStrings.SetBuffCapacity(const Value: Integer); begin end; procedure TQmwStrings.SetCapacity(NewCapacity: Integer); begin if NewCapacity <> FCapacity then begin if NewCapacity < FCount then begin CleanUp(NewCapacity, FCount - NewCapacity); fCount := NewCapacity; end; ReallocMem(FList, NewCapacity * SizeOf(TmwLine)); FCapacity := NewCapacity; end; end; procedure TQmwStrings.SetIO(const Value: TmwTextIO); begin fIO := Value; fIO.List := Self; end; procedure TQmwStrings.SetObject(Index: Integer; AObject: TObject); begin end; procedure TQmwStrings.SetString(Index: Integer; const S: WideString); var OldH, Delta: Integer; Prev, Cur: TmwParagraph; begin if ReadOnly and not Loading then exit; if (Index > 0) and (Index <= fCount) then begin Cur:= fList[Index]; Prev:= Items[Index-1]; if (Cur.Position = 0) and (Prev <> nil) then case Prev.Hidden of True: Cur.Position:= Prev.Position; False: Cur.Position:= Prev.Position + GetItemHeight(Index-1); end; if Inserting then OldH:= 0 else OldH:= GetItemHeight(Index); if Assigned(fIO) then fIO.SetString(Index, S) else Cur.Text := S; Delta:= GetItemHeight(Index) -OldH; AdjustPositions(Index+1, Delta); end; end; procedure TQmwStrings.SetText(const Value: WideString); begin BreakStringUP(Value); end; procedure TQmwStrings.SetUpdateState(Updating: Boolean); begin end; procedure TQmwStrings.SetWordWrap(const Value: Boolean); begin fWordWrap := Value; //ToDo end; procedure TQmwStrings.SetWrapWidth(const Value: Integer); begin FWrapWidth := Value; //ToDo end; procedure TQmwStrings.WriteChar(C: WideChar); begin if fTokenSize = fBuffCapacity then begin fBuffCapacity := fTokenSize + 64; ReallocMem(fTokenBuffer, (fBuffCapacity + 1)*2); end; fTokenBuffer[fTokenSize] := C; inc(fTokenSize); end; end.