Unit RichTextLayoutUnit; {$mode objfpc}{$H+} // Dynamically created layout class. // Represents a laid out rich text document Interface Uses Classes, CanvasFontManager, RichTextDocumentUnit, RichTextStyleUnit, fpg_imagelist; Type TLayoutLine = record Text: PChar; Length: longint; Height: longint; Width: longint; MaxDescender: longint; MaxTextHeight: longint; // maximum height of text, doesn't include images LinkIndex: longint; // link index at start of line, if any Style: TTextDrawStyle; Wrapped: boolean; end; TLinesArray = array[ 0..0 ] of TLayoutLine; TTextPosition = ( tpAboveTextArea, tpAboveText, tpWithinText, tpBelowText, tpBelowTextArea ); // forward declaration TRichTextLayout = class; // TLinkEvent = procedure( Sender: TRichTextLayout; Link: string ) of object; TRichTextLayout = class(TObject) Protected FFontManager: TCanvasFontManager; FText: PChar; FImages: TfpgImageList; FAllocatedNumLines: Longint; FLayoutWidth: longint; // The target width for the layout. Used for centreing/right align FWidth: longint; // The actual width of the text. May be wider due to unaligned // parts or bitmaps or width so small individual characters don't fit. FHeight: longint; FLinks: TStringList; FHorizontalImageScale: double; FVerticalImageScale: double; public // Internal layout data FLines: ^TLinesArray; FNumLines: longint; FRichTextSettings: TRichTextSettings; // Drawing functions Procedure PerformStyleTag( Const Tag: TTag; Var Style: TTextDrawStyle; const X: longint ); function GetElementWidth( Element: TTextElement ): longint; // Queries Function GetStartX( Style: TTextDrawStyle; Line: TLayoutLine ): longint; Procedure GetXFromOffset( const Offset: longint; const LineIndex: longint; Var X: longint ); Procedure GetOffsetFromX( const XToFind: longint; const LineIndex: longint; Var Offset: longint; Var Link: string ); function FindPoint( XToFind, YToFind: longint; Var LineIndex: longint; Var Offset: longint; Var Link: string ): TTextPosition; function GetLineFromCharIndex( Index: longint ): longint; function GetOffsetFromCharIndex( Index: longint; Line: longint ): longint; function GetLinePosition( Line: longint ): longint; function GetLineFromPosition( YToFind: longint; Var LineIndex: longint; Var Remainder: longint ): TTextPosition; // Layout functions Procedure AddLineStart( Const Line: TLayoutLine ); Procedure CheckFontHeights( Var Line: TLayoutLine ); Procedure Layout; function IsValidBitmapIndex( Index: longint ): boolean; // property handlers Function GetCharIndex( P: PChar ): longint; Function GetTextEnd: longint; Public constructor Create(Text: PChar; Images: TfpgImageList; RichTextSettings: TRichTextSettings; FontManager: TCanvasFontManager; AWidth: longint); destructor Destroy; Override; function LinkFromIndex( const CharIndexToFind: longint): string; property TextEnd: longint read GetTextEnd; property Images: TfpgImageList read FImages; property Width: longint read FWidth; property Height: longint read FHeight; property HorizontalImageScale: double read FHorizontalImageScale; property VerticalImageScale: double read FVerticalImageScale; End; Implementation Uses SysUtils ,ACLStringUtility ,nvUtilities ,fpg_main ; Function TRichTextLayout.GetTextEnd: longint; begin Result := StrLen( FText ); end; // Create a layout of the specified rich text. constructor TRichTextLayout.Create(Text: PChar; Images: TfpgImageList; RichTextSettings: TRichTextSettings; FontManager: TCanvasFontManager; AWidth: longint); var DefaultFontSpec: TFontSpec; Begin ProfileEvent('DEBUG: TRichTextLayout.Create >>>>'); inherited Create; FRichTextSettings := RichTextSettings; FImages := Images; FText := Text; FAllocatedNumLines := 10; ProfileEvent('DEBUG: TRichTextLayout.Create 1 of 4'); GetMem( FLines, FAllocatedNumLines * sizeof( TLayoutLine ) ); FNumLines := 0; FLinks := TStringList.Create; FLinks.Duplicates := dupIgnore; FFontManager := FontManager; FLayoutWidth := AWidth; ProfileEvent('DEBUG: TRichTextLayout.Create 2'); FHorizontalImageScale := 1; FVerticalImageScale := 1; //FHorizontalImageScale := FFontManager.Canvas.HorizontalResolution // / Screen.Canvas.HorizontalResolution; //FVerticalImageScale := FFontManager.Canvas.VerticalResolution // / Screen.Canvas.VerticalResolution; // use normal font for default font when specified fonts can't be found FPGuiFontToFontSpec( RichTextSettings.NormalFont, DefaultFontSpec ); ProfileEvent('DEBUG: TRichTextLayout.Create 3'); FFontManager.DefaultFontSpec := DefaultFontSpec; ProfileEvent('DEBUG: TRichTextLayout.Create 4'); Layout; ProfileEvent('DEBUG: TRichTextLayout.Create <<<<'); End; Destructor TRichTextLayout.Destroy; Begin FreeMem( Flines, FAllocatedNumLines * sizeof( TLayoutLine ) ); FLines := nil; FLinks.Free; Inherited Destroy; End; Procedure TRichTextLayout.AddLineStart( Const Line: TLayoutLine ); var NewAllocation: longint; begin if FNumLines >= FAllocatedNumLines then begin // reallocate the array twice the size NewAllocation := FAllocatedNumLines * 2; FLines := ReAllocMem( FLines, // FAllocatedNumLines * sizeof( TLayoutLine ), NewAllocation * sizeof( TLayoutLine ) ); FAllocatedNumLines := NewAllocation; end; FLines^[ FNumLines ] := Line; inc( FNumLines ); ProfileEvent(' DEBUG: TRichTextLayout.AddLineStart: FNumLines =' + intToStr(FNumLines)); end; Procedure TRichTextLayout.PerformStyleTag( Const Tag: TTag; Var Style: TTextDrawStyle; const X: longint ); begin ProfileEvent('DEBUG: TRichTextLayout.PerformStyleTag >>>'); ApplyStyleTag( Tag, Style, FFontManager, FRichTextSettings, X ); ProfileEvent('DEBUG: TRichTextLayout.PerformStyleTag <<<'); end; // Check the current font specifications and see if the // give line needs updating for max height/descender Procedure TRichTextLayout.CheckFontHeights( Var Line: TLayoutLine ); var FontHeight: longint; Descender: longint; begin FontHeight := FFontManager.CharHeight; Descender := FFontManager.CharDescender; if FontHeight > Line.Height then Line.Height := FontHeight; if FontHeight > Line.MaxTextHeight then Line.MaxTextHeight := FontHeight; if Descender > Line.MaxDescender then Line.MaxDescender := Descender; end; function TRichTextLayout.IsValidBitmapIndex( Index: longint ): boolean; begin if FImages = nil then Result := false else if FImages.Count = 0 then Result := false else Result := Between( Index, 0, FImages.Count - 1 ); end; // Main procedure: reads through the whole text currently stored // and breaks up into lines - each represented as a TLayoutLine in // the array FLines[ 0.. FNumLines ] Procedure TRichTextLayout.Layout; Var CurrentLine: TLayoutLine; CurrentLinkIndex: longint; WrapX: longint; // X to wrap at WordX: longint; // width of word so far P: PChar; NextP: PChar; NextP2: PChar; WordStart: PChar; WordStarted: boolean; // if false, just skipping spaces.. WordStartX: longint; // X position of word start LineWordsCompleted: longint; // how many words draw so far this line CurrentElement: TTextElement; NextElement: TTextElement; CurrentCharWidth: longint; Style: TTextDrawStyle; DisplayedCharsSinceFontChange: boolean; BitmapIndex: longint; Bitmap: TfpgImage; BitmapHeight: longint; OnBreak: boolean; DoWrap: boolean; // Nested procedure Procedure DoLine( EndPoint: PChar; NextLine: PChar; EndX: longint ); begin // check if the max font // height needs updating for the last string of the line CheckFontHeights( CurrentLine ); inc( FHeight, CurrentLine.Height ); CurrentLine.Length := PCharDiff( EndPoint, CurrentLine.Text ); CurrentLine.Width := EndX; if CurrentLine.Width > FWidth then FWidth := CurrentLine.Width; assert( CurrentLine.Height > 0 ); // we must have set the line height! AddLineStart( CurrentLine ); CurrentLine.Text := NextLine; CurrentLine.Style := Style; CurrentLine.Height := 0; CurrentLine.MaxDescender := 0; CurrentLine.MaxTextHeight := 0; CurrentLine.Width := 0; CurrentLine.LinkIndex := CurrentLinkIndex; CurrentLine.Wrapped := false; assert( CurrentLinkIndex >= -1 ); assert( CurrentLinkIndex < FLinks.Count ); WordStartX := Style.LeftMargin; // next line // reset words completed count LineWordsCompleted := 0; WordStarted := false; end; begin ProfileEvent('DEBUG: TRichTextLayout.Layout >>>>'); FNumLines := 0; FWidth := FRichTextSettings.Margins.Left; FHeight := FRichTextSettings.Margins.Top; Style := GetDefaultStyle( FRichTextSettings ); ApplyStyle( Style, FFontManager ); CurrentLinkIndex := -1; P := FText; // P is the current search position CurrentLine.Text := P; CurrentLine.Style := Style; CurrentLine.Height := 0; CurrentLine.MaxDescender := 0; CurrentLine.MaxTextHeight := 0; CurrentLine.Width := 0; CurrentLine.LinkIndex := -1; CurrentLine.Wrapped := false; WordStartX := Style.LeftMargin; WordX := 0; WrapX := FLayoutWidth - FRichTextSettings.Margins.Right; LineWordsCompleted := 0; WordStarted := false; DisplayedCharsSinceFontChange := false; repeat CurrentElement := ExtractNextTextElement( P, NextP ); assert( NextP > P ); OnBreak := false; case CurrentElement.ElementType of teWordBreak: begin CurrentCharWidth := FFontManager.CharWidth( ' ' ); OnBreak := true; end; teLineBreak: begin DoLine( P, NextP, WordStartX + WordX ); // remember start of line WordStart := NextP; WordX := 0; P := NextP; continue; end; teTextEnd: begin DoLine( P, NextP, WordStartX + WordX ); // end of text, done break; end; teImage: begin BitmapHeight := 0; try BitmapIndex := StrToInt( CurrentElement.Tag.Arguments ); except BitmapIndex := -1; end; Bitmap := nil; if IsValidBitmapIndex( BitmapIndex ) then begin Bitmap := FImages.Item[BitmapIndex].Image; CurrentCharWidth := Trunc(Bitmap.Width * FHorizontalImageScale); WordStarted := true; BitmapHeight := Trunc(Bitmap.Height * FVerticalImageScale); end; end; teText: begin // Normal (non-leading-space) character CurrentCharWidth := FFontManager.CharWidth( CurrentElement.Character ); WordStarted := true; end; teStyle: begin case CurrentElement.Tag.TagType of ttBeginLink: begin CurrentLinkIndex := FLinks.Add( CurrentElement.Tag.Arguments ); P := NextP; continue; end; ttEndLink: begin CurrentLinkIndex := -1; P := NextP; continue; end; ttSetLeftMargin: // SPECIAL CASE... could affect display immediately begin PerformStyleTag( CurrentElement.Tag, Style, WordstartX + WordX ); if Style.LeftMargin < WordStartX then begin // we're already past the margin being set if pos( 'breakifpast', CurrentElement.Tag.Arguments ) > 0 then begin // this argument means, do a line break // if the margin is already past // Seems unusual for most purposes, but needed for IPF rendering. DoLine( P, NextP, WordStartX + WordX ); // remember start of line WordStart := NextP; WordX := 0; P := NextP; continue; end; // so ignore it for now. P := NextP; continue; end; // skip across to the new margin CurrentCharWidth := Style.LeftMargin - WordStartX - WordX; // BUT! Don't treat it as a space, because you would not // expect wrapping to take place in a margin change... // at least not for IPF :) end; { teSetLeftMargin } else begin // before processing the tag see if font height needs updating if DisplayedCharsSinceFontChange then CheckFontHeights( CurrentLine ); if ( CurrentElement.Tag.TagType = ttItalicOff ) and ( faItalic in Style.Font.Attributes ) then begin if not FFontManager.IsFixed then begin // end of italic; add a space // inc( WordX, FFontManager.CharWidth( ' ' ) ); end; end; PerformStyleTag( CurrentElement.Tag, Style, WordX ); DisplayedCharsSinceFontChange := false; P := NextP; continue; // continue loop end; end; end end; if OnBreak then begin // we just processed a space if WordStarted then begin DisplayedCharsSinceFontChange := true; // remember that we have now completed a word on this line inc( LineWordsCompleted ); WordStarted := false; // Add the word width, and the space width, // to get the start of the next word inc( WordStartX, WordX + CurrentCharWidth ); WordX := 0; // remember the start of the next word WordStart := NextP; P := NextP; continue; end; // else - starting spaces - fall through like normal char end; // if we're still going here we have a normal char // (or leading spaces) if not Style.Wrap then begin // No alignment // We don't care about how wide it gets inc( WordX, CurrentCharWidth ); DisplayedCharsSinceFontChange := true; if CurrentElement.ElementType = teImage then if Bitmap <> nil then if BitmapHeight > CurrentLine.Height then CurrentLine.Height := BitmapHeight; P := NextP; continue; end; DoWrap := false; // Calculate position of end of character // see if char would exceed width if (WordStartX + WordX + CurrentCharWidth) >= WrapX then begin // reached right hand side before finding end of word if LineWordsCompleted > 0 then // always wrap after at least one word displayed DoWrap := true else if not FRichTextSettings.AtLeastOneWordBeforeWrap then // only wrap during the first word, if the "at least 1 word" flag is not set. DoWrap := true; end; if DoWrap then begin if LineWordsCompleted = 0 then begin // the first word did not fit on the line. so draw // as much as will fit if WordX = 0 then begin // even the first char doesn't fit, // but draw it anyway (otherwise, infinite loop) NextElement := ExtractNextTextElement( NextP, NextP2 ); if NextElement.ElementType <> teLineBreak then // there is still more on the line... CurrentLine.Wrapped := true else // the line ends after this one char or image, we can skip the line end NextP := NextP2; if CurrentElement.ElementType = teImage then begin // the only thing on the line is the image. so check height if Bitmap <> nil then if BitmapHeight > CurrentLine.Height then CurrentLine.Height := BitmapHeight; end; DoLine( NextP, NextP, WordStartX + WordX + CurrentCharWidth ); WordStart := NextP; WordX := 0; end else begin CurrentLine.Wrapped := true; // at least 1 char fits // so draw up to, but not including this char DoLine( P, P, WordStartX + WordX ); WordStart := P; WordX := CurrentCharWidth; end; end else begin // Normal wrap; at least one word fitted on the line CurrentLine.Wrapped := true; // take the width of the last space of the // previous word off the line width DoLine( WordStart, // current line ends at start of this word WordStart, // next line starts at start of this word WordStartX - FFontManager.CharWidth( ' ' ) ); if CurrentElement.ElementType = teImage then if Bitmap <> nil then if BitmapHeight > CurrentLine.Height then CurrentLine.Height := BitmapHeight; // do NOT reset WordX to zero; as we are continuing // from partway thru the word on the next line. inc( WordX, CurrentCharWidth ); end; WordStarted := true; // by definition, for wrapping end else begin // Character fits. inc( WordX, CurrentCharWidth ); DisplayedCharsSinceFontChange := true; if CurrentElement.ElementType = teImage then if Bitmap <> nil then if BitmapHeight > CurrentLine.Height then CurrentLine.Height := BitmapHeight; end; P := NextP; until false; // loop is exited by finding end of text inc( FHeight, FRichTextSettings.Margins.Bottom ); ProfileEvent('DEBUG: TRichTextLayout.Layout <<<<'); End; Function TRichTextLayout.GetStartX( Style: TTextDrawStyle; Line: TLayoutLine ): longint; var SpaceOnLine: longint; begin case Style.Alignment of taLeft: Result := Style.LeftMargin; taRight: Result := Style.LeftMargin + FLayoutWidth - Style.RightMargin - Line.Width; taCenter: begin // |<------layout width------------------>| // | | // |<-lm->[aaaaaaaaaaaaaaa]<-space-><-rm->| // |<-----line width------> | // space = layoutw-rm-linew SpaceOnLine := FLayoutWidth - Style.RightMargin - Line.Width; // Note: line width includes left margin Result := Style.LeftMargin + (SpaceOnLine div 2); end; end; end; Procedure TRichTextLayout.GetOffsetFromX( const XToFind: longint; const LineIndex: longint; Var Offset: longint; Var Link: string ); Var X: longint; P: PChar; NextP: PChar; EndP: PChar; Element: TTextElement; CurrentLink: string; Line: TLayoutLine; Style: TTextDrawStyle; NewMarginX: longint; StartedDrawing: boolean; begin Line := TLayoutLine(FLines[ LineIndex ]); P := Line.Text; EndP := Line.Text + Line.Length; Style := Line.Style; FFontManager.SetFont( Style.Font ); StartedDrawing := false; Link := ''; if Line.LinkIndex <> -1 then CurrentLink := FLinks[ Line.LinkIndex ] else CurrentLink := ''; while P < EndP do begin Element := ExtractNextTextElement( P, NextP ); case Element.ElementType of teWordBreak, teText, teImage: begin if not StartedDrawing then begin // we haven't yet started drawing: // so work out alignment X := GetStartX( Style, Line ); if X > XToFind then begin // found before the start of the line // don't set link Offset := 0; exit; end; StartedDrawing := true; end; // Now find out how wide the thing is inc( X, GetElementWidth( Element ) ); if X > XToFind then begin // found Offset := PCharDiff( P, Line.Text ); Link := CurrentLink; exit; end; end; teStyle: case Element.Tag.TagType of ttBeginLink: CurrentLink := Element.Tag.Arguments; ttEndLink: CurrentLink := ''; else begin if ( Element.Tag.TagType = ttItalicOff ) and ( faItalic in Style.Font.Attributes ) and ( not FFontManager.IsFixed ) then // end of italic; add a space // inc( X, FFontManager.CharWidth( ' ' ) ); PerformStyleTag( Element.Tag, Style, X ); NewMarginX := Style.LeftMargin; if NewMarginX > X then begin //skip across... X := NewMarginX; end; end; end; end; P := NextP; end; Offset := Line.Length; end; Procedure TRichTextLayout.GetXFromOffset( const Offset: longint; const LineIndex: longint; Var X: longint ); Var P: PChar; NextP: PChar; EndP: PChar; Element: TTextElement; StartedDrawing: boolean; Line: TLayoutLine; Style: TTextDrawStyle; NewMarginX: longint; begin Line := TLayoutLine(FLines[ LineIndex ]); P := Line.Text; EndP := Line.Text + Line.Length; Style := Line.Style; FFontManager.SetFont( Style.Font ); StartedDrawing := false; while P < EndP do begin Element := ExtractNextTextElement( P, NextP ); case Element.ElementType of teWordBreak, teText, teImage: begin if not StartedDrawing then begin // we haven't yet started drawing: // so work out alignment X := GetStartX( Style, Line ); StartedDrawing := true; end; if GetCharIndex( P ) - GetCharIndex( Line.Text ) >= Offset then begin X := X; // found exit; end; // Now find out how wide the thing is inc( X, GetElementWidth( Element ) ); end; teStyle: begin if ( Element.Tag.TagType = ttItalicOff ) and ( faItalic in Style.Font.Attributes ) and ( not FFontManager.IsFixed ) then // end of italic; add a space // inc( X, FFontManager.CharWidth( ' ' ) ); PerformStyleTag( Element.Tag, Style, X ); NewMarginX := Style.LeftMargin; if NewMarginX > X then begin //skip across... X := NewMarginX; end; end; end; P := NextP; end; // went thru the whole line without finding the point, if not StartedDrawing then X := GetStartX( Style, Line ); X := X; end; function TRichTextLayout.GetLineFromPosition( YToFind: longint; Var LineIndex: longint; Var Remainder: longint ): TTextPosition; var Y: longint; LineHeight: longint; begin LineIndex := 0; Remainder := 0; Y := FRichTextSettings.Margins.Top; if YToFind < Y then begin Result := tpAboveText; exit; end; while LineIndex < FNumLines do begin LineHeight := TLayoutLine(FLines[ LineIndex ]).Height; if ( YToFind >= Y ) and ( YToFind < (Y + LineHeight)) then begin // YToFind is within the line Result := tpWithinText; Remainder := YToFind - Y; exit; end; inc( Y, LineHeight ); inc( LineIndex ); end; LineIndex := FNumLines - 1; Remainder := TLayoutLine(FLines[ LineIndex ]).Height; Result := tpBelowText; end; function TRichTextLayout.FindPoint( XToFind, YToFind: longint; Var LineIndex: longint; Var Offset: longint; Var Link: string ): TTextPosition; var Remainder: longint; begin Link := ''; Result := GetLineFromPosition( YToFind, LineIndex, Remainder ); case Result of tpAboveText: begin Offset := 0; exit; end; tpBelowText: begin Offset := TLayoutLine(FLines[ LineIndex ]).Length; exit; end; end; // found the line GetOffsetFromX( XToFind, LineIndex, Offset, Link ); end; function TRichTextLayout.GetLineFromCharIndex( Index: longint ): longint; var LineCharIndex: longint; LineLength: longint; begin Result := 0; if Index <= 0 then exit; while Result < FNumLines do begin LineCharIndex := GetCharIndex( TLayoutLine(FLines[ Result ]).Text ); LineLength := TLayoutLine(FLines[ Result ]).Length; if LineCharIndex + LineLength > Index then begin // found exit; end; inc( Result ); end; Result := FNumLines - 1; end; function TRichTextLayout.GetOffsetFromCharIndex( Index: longint; Line: longint ): longint; begin Result := Index - GetCharIndex( TLayoutLine( FLines[ Line ] ).Text ); end; function TRichTextLayout.GetElementWidth( Element: TTextElement ): longint; var Bitmap: TfpgImage; BitmapIndex: longint; begin // Now find out how wide the thing is case Element.ElementType of teImage: begin try BitmapIndex := StrToInt( Element.Tag.Arguments ); except BitmapIndex := -1; end; if IsValidBitmapIndex( BitmapIndex ) then begin Bitmap := FImages.Item[BitmapIndex].Image; Result := Trunc(Bitmap.Width * FHorizontalImageScale); end; end; teText, teWordBreak: Result := FFontManager.CharWidth( Element.Character ); else Assert( False ); // should never be trying to find the width of a style, etc end; end; Function TRichTextLayout.GetCharIndex( P: PChar ): longint; begin Result := PCharDiff( P, FText ); end; function TRichTextLayout.GetLinePosition( Line: longint ): longint; begin Result := FRichTextSettings.Margins.Top; dec( line ); while line >= 0 do begin inc( Result, TLayoutLine(Flines[ Line ]).Height ); dec( line ); end; end; function TRichTextLayout.LinkFromIndex( const CharIndexToFind: longint): string; Var P: PChar; NextP: PChar; EndP: PChar; Element: TTextElement; LineIndex: longint; Line: TLayoutLine; begin if FNumLines = 0 then begin Result := ''; exit; end; LineIndex := GetLineFromCharIndex( CharIndexToFind ); Line := TLayoutLine(FLines[ LineIndex ]); P := Line.Text; EndP := Line.Text + Line.Length; if Line.LinkIndex <> -1 then Result := FLinks[ Line.LinkIndex ] else Result := ''; while P < EndP do begin if GetCharIndex( P ) >= CharIndexToFind then exit; Element := ExtractNextTextElement( P, NextP ); case Element.ElementType of teStyle: case Element.Tag.TagType of ttBeginLink: Result := Element.Tag.Arguments; ttEndLink: Result := ''; end; end; P := NextP; end; end; Initialization End.