1 unit Unit1;
2 
3 {$mode objfpc}{$H+}
4 
5 interface
6 
7 uses
8   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
9   StdCtrls, Spin, ComCtrls, BGRAVirtualScreen, BGRABitmap, BGRABitmapTypes,
10   BGRATextBidi, BGRAFreeType, EasyLazFreeType, LazFreeTypeFontCollection,
11   fgl, Types;
12 
13 const
14   CaretBlinkTimeMs = 500;
15   ssShortcut = {$IFDEF DARWIN}ssMeta{$ELSE}ssCtrl{$ENDIF};
16 
17 type
18   TRenderedBrokenLineList = specialize TFPGObjectList<TBGRABitmap>;
19 
20   { TForm1 }
21 
22   TForm1 = class(TForm)
23     BGRAVirtualScreen1: TBGRAVirtualScreen;
24     CheckBox_ClearType: TCheckBox;
25     CheckBox_FreeType: TCheckBox;
26     ImageList1: TImageList;
27     Label2: TLabel;
28     Panel1: TPanel;
29     ScrollBar1: TScrollBar;
30     SpinEdit_FontSize: TSpinEdit;
31     TimerBlinkCaret: TTimer;
32     ToolBar1: TToolBar;
33     ToolButtonLeftAlign: TToolButton;
34     ToolButtonCenterAlign: TToolButton;
35     ToolButtonRightAlign: TToolButton;
36     procedure BGRAVirtualScreen1MouseDown(Sender: TObject;
37       Button: TMouseButton; {%H-}Shift: TShiftState; X, Y: Integer);
38     procedure BGRAVirtualScreen1MouseMove(Sender: TObject; Shift: TShiftState;
39       X, Y: Integer);
40     procedure BGRAVirtualScreen1MouseWheel(Sender: TObject; Shift: TShiftState;
41       WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
42     procedure BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
43     procedure CheckBox_ClearTypeChange(Sender: TObject);
44     procedure CheckBox_FreeTypeChange(Sender: TObject);
45     procedure FormCreate(Sender: TObject);
46     procedure FormDestroy(Sender: TObject);
47     procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
48     procedure FormKeyUp(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState);
49     procedure FormKeyPress(Sender: TObject; var Key: char);
50     procedure ScrollBar1Change(Sender: TObject);
51     procedure SpinEdit_FontSizeChange(Sender: TObject);
52     procedure TimerBlinkCaretTimer(Sender: TObject);
53     procedure ToolButtonCenterAlignClick(Sender: TObject);
54     procedure ToolButtonLeftAlignClick(Sender: TObject);
55     procedure ToolButtonRightAlignClick(Sender: TObject);
56   private
57     FFontRenderer: TBGRACustomFontRenderer;
58     FTextLayout: TBidiTextLayout;
59     FRenderedParagraphs: array of TRenderedBrokenLineList;
60     FBlinkCaretTime: TDateTime;
61     FBlinkCaretState: boolean;
62     FSelStart,FSelLength: integer;
63     FSelFirstClick,FSelLastClick: integer;
64     FCurFirstParagraph,FCurLastParagraph: integer;
65     FTestText: string;
66     FInUnicode: boolean;
67     FUnicodeValue: LongWord;
GetLayoutReadynull68     function GetLayoutReady: boolean;
GetSelLastClicknull69     function GetSelLastClick: integer;
70     procedure LayoutBrokenLinesChanged({%H}ASender: TObject;
71       AParagraphIndex: integer; ASubBrokenStart, ASubBrokenChangedCountBefore,
72       ASubBrokenChangedCountAfter: integer; ASubBrokenTotalCountBefore,
73       {%H}ASubBrokenTotalCountAfter: integer);
74     procedure LayoutParagraphDeleted({%H}ASender: TObject; AParagraphIndex: integer);
75     procedure LayoutParagraphMergedWithNext(ASender: TObject;
76       AParagraphIndex: integer);
77     procedure LayoutParagraphSplit({%H}ASender: TObject; AParagraphIndex: integer;
78       ASubBrokenIndex, {%H-}ACharIndex: integer);
79     procedure SetSelLastClick(AValue: integer);
80     procedure SetSelLength(AValue: integer);
81     procedure SetSelStart(AValue: integer);
82     procedure FlushUnicode;
83     procedure DiscardRenderedBrokenLines;
84     procedure LayoutCompletelyChanged;
85   public
86     procedure UpdateCurrentParagraph;
87     procedure UpdateSelectionFromFirstLastClick;
88     procedure SetCurrentParagraphAlign(AAlign: TAlignment);
89     procedure DeleteSelection;
90     procedure InsertText(AText: string);
91     procedure ShowCaret;
92     property SelStart: integer read FSelStart write SetSelStart;
93     property SelLength: integer read FSelLength write SetSelLength;
94     property SelLastClick: integer read GetSelLastClick write SetSelLastClick;
95     property LayoutReady: boolean read GetLayoutReady;
96   end;
97 
98 var
99   Form1: TForm1;
100 
101 implementation
102 
103 uses BGRAText, LCLType, BGRAUTF8, Clipbrd, LCLIntf, math;
104 
105 {$R *.lfm}
106 
107 procedure SetClipboardAsText(Value: string);
108 var
109   strStream: TStringStream;
110 begin
111   strStream := TStringStream.Create(Value);
112   Clipboard.SetFormat(PredefinedClipboardFormat(pcfText), strStream);
113   strStream.Free;
114 end;
115 
116 { TForm1 }
117 
118 procedure TForm1.FormCreate(Sender: TObject);
119 begin
120   FTextLayout := nil;
121   FFontRenderer := nil;
122   FSelStart:= 0;
123   FSelLength:= 0;
124   FSelFirstClick := -1;
125   FSelLastClick:= -1;
126   TimerBlinkCaret.Interval := CaretBlinkTimeMs;
127   FCurFirstParagraph:= -1;
128   FCurLastParagraph:= -1;
129 
130   BGRAVirtualScreen1.OnKeyDown:= @FormKeyDown;
131   BGRAVirtualScreen1.OnKeyUp:= @FormKeyUp;
132   BGRAVirtualScreen1.OnKeyPress:= @FormKeyPress;
133   BGRAVirtualScreen1.Cursor := crIBeam;
134   BGRAVirtualScreen1.BitmapAutoScale:= false;
135 
136   FTestText := 'تحتوي العربية على 28 حرفاً مكتوباً. ويرى بعض اللغويين أنه يجب إضافة حرف الهمزة إلى حروف العربية، ليصبح عدد الحروف 29. تُكتب العربية من اليمين إلى اليسار - ومثلها اللغة الفارسية والعبرية على عكس كثير من اللغات العالمية - ومن أعلى الصفحة إلى أسفلها.'+LineEnding+
137              'Arabic reversed "' + UTF8OverrideDirection('صباح الخير',false)+'". Arabic marks: "لاٍُ لٍُإ بًٍّ  ةُِ ںْ رُ ٮَ  بٔ".'+ LineEnding +
138              #9'Le français est une langue indo-européenne de la famille des langues romanes. Le français s''est formé en France (variété de la « langue d''oïl », qui est la langue de la partie septentrionale du pays).'+LineEnding+
139              'Glorious finds itself reversed as '+ UTF8OverrideDirection('"glorious"',True) + '. ' +
140                '"Hello!" is '+ UTF8EmbedDirection('"مرحبا!"',True) + ' in arabic.' + LineEnding +
141              'देवनागरी एक भारतीय लिपि है जिसमें अनेक भारतीय भाषाएँ तथा कई विदेशी भाषाएँ लिखी जाती हैं। यह बायें से दायें लिखी जाती है।' + LineEnding +
142              '对于汉语的分支语言，学界主要有两种观点，一种观点将汉语定义为语言，并将官话、贛語、闽语、粤语、客家语、吴语、湘语七大语言定义为一级方言.'+LineEnding+
143              'עִבְרִית היא שפה שמית, ממשפחת השפות האפרו-אסיאתיות, הידועה כשפתם של היהודים ושל השומרונים, אשר ניב מודרני שלה (עברית ישראלית) משמש כשפה הרשמית והעיקרית של מדינת ישראל.';
144 
145 end;
146 
147 procedure TForm1.FormDestroy(Sender: TObject);
148 begin
149   DiscardRenderedBrokenLines;
150   FTextLayout.Free;
151   FFontRenderer.Free;
152 end;
153 
154 procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
155 
156   procedure MoveTo(ANewPos: integer);
157   begin
158     if ssShift in Shift then
159     begin
160       if ANewPos <> -1 then
161         SelLastClick := ANewPos;
162     end else
163     begin
164       if ANewPos <> -1 then
165         SelStart := ANewPos;
166       SelLength:= 0;
167     end;
168   end;
169 
170 var
171   idxPara, newPos: Integer;
172 begin
173   if not LayoutReady then exit;
174 
175   if (Key = VK_U) and ([ssCtrl,ssShift] <= Shift) then
176   begin
177     FlushUnicode;
178     FInUnicode := true;
179     FUnicodeValue:= 0;
180     Key := 0;
181   end else
182   if FInUnicode then
183   begin
184     case Key of
185       VK_DELETE: begin
186           FUnicodeValue := FUnicodeValue shr 4;
187         end;
188       VK_0..VK_9: begin
189           FUnicodeValue := (FUnicodeValue shl 4) + (Key - VK_0);
190         end;
191       VK_NUMPAD0..VK_NUMPAD9: begin
192           FUnicodeValue := (FUnicodeValue shl 4) + (Key - VK_NUMPAD0);
193         end;
194       VK_A..VK_F: begin
195           FUnicodeValue := (FUnicodeValue shl 4) + (Key - VK_A + 10);
196         end;
197     else
198       FlushUnicode;
199     end;
200     if (FUnicodeValue >= $10FFF0) or
201        (FUnicodeValue >= $11000) then
202       FlushUnicode;
203     Key := 0;
204   end else
205   if KEY = VK_DELETE then
206   begin
207     if SelLength > 0 then DeleteSelection
208     else
209     begin
210       FTextLayout.DeleteText(SelStart, 1);
211       SelStart := SelStart + FTextLayout.IncludeNonSpacingChars(SelStart, 0);
212       ShowCaret;
213     end;
214     Key := 0;
215   end else
216   if (Key = VK_LEFT) or (Key = VK_RIGHT) then
217   begin
218     if (Key = VK_LEFT) xor FTextLayout.ParagraphRightToLeft[FTextLayout.GetParagraphAt(SelLastClick)] then
219     begin
220       if SelLastClick > 0 then
221         newPos := SelLastClick - FTextLayout.IncludeNonSpacingCharsBefore(SelLastClick,1)
222       else newPos := -1;
223 
224       MoveTo(newPos);
225     end else
226     begin
227       if SelLastClick < FTextLayout.CharCount then
228         newPos := SelLastClick + FTextLayout.IncludeNonSpacingChars(SelLastClick,1)
229       else newPos := -1;
230 
231       MoveTo(newPos);
232     end;
233     Key := 0;
234   end else
235   if (Key = VK_UP) or (Key = VK_DOWN) then
236   begin
237     if Key = VK_UP then
238       newPos := FTextLayout.FindTextAbove(SelLastClick)
239     else
240       newPos := FTextLayout.FindTextBelow(SelLastClick);
241 
242     MoveTo(newPos);
243     Key := 0;
244   end else
245   if Key = VK_HOME then
246   begin
247     idxPara := FTextLayout.GetParagraphAt(SelLastClick);
248     if ssCtrl in Shift then newPos := 0 else
249       newPos := FTextLayout.ParagraphStartIndex[idxPara];
250     MoveTo(newPos);
251     Key := 0;
252   end else
253   if Key = VK_END then
254   begin
255     idxPara := FTextLayout.GetParagraphAt(SelLastClick);
256     if ssCtrl in Shift then newPos := FTextLayout.CharCount else
257       newPos := FTextLayout.ParagraphEndIndexBeforeParagraphSeparator[idxPara];
258     MoveTo(newPos);
259     Key := 0;
260   end else
261   if Key = VK_RETURN then
262   begin
263     if SelLength > 0 then DeleteSelection;
264     if ssShift in Shift then
265     begin
266       SelStart := SelStart + FTextLayout.InsertLineSeparator(SelStart);
267     end else
268       InsertText(LineEnding);
269     Key := 0;
270   end else
271   if Key = VK_TAB then
272   begin
273     if SelLength > 0 then DeleteSelection;
274     InsertText(#9);
275     Key := 0;
276   end else
277   If (Key = VK_C) and (ssShortcut in Shift) then
278   begin
279     if SelLength> 0 then
280       SetClipboardAsText(FTextLayout.CopyText(SelStart, SelLength));
281     Key := 0;
282   end else
283   If (Key = VK_X) and (ssShortcut in Shift) then
284   begin
285     if SelLength > 0 then
286     begin
287       SetClipboardAsText(FTextLayout.CopyText(SelStart, SelLength));
288       DeleteSelection;
289     end;
290     Key := 0;
291   end else
292   If (Key = VK_V) and (ssShortcut in Shift) then
293   begin
294     InsertText(Clipboard.AsText);
295     Key := 0;
296   end else
297   If (Key = VK_A) and (ssShortcut in Shift) then
298   begin
299     SelStart:= 0;
300     SelLength:= FTextLayout.CharCount;
301     Key := 0;
302   end;
303 end;
304 
305 procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
306 begin
307   if FInUnicode then
308   begin
309     if (Key = VK_CONTROL) or (Key = VK_SHIFT) then
310       FlushUnicode;
311   end;
312 end;
313 
314 procedure TForm1.FormKeyPress(Sender: TObject; var Key: char);
315 var
316   delCount: Integer;
317 begin
318   if not LayoutReady then exit;
319 
320   if Key = #8 then
321   begin
322     if SelLength > 0 then DeleteSelection
323     else
324     begin
325       if SelStart > 0 then
326       begin
327         delCount := FTextLayout.DeleteTextBefore(SelStart, 1);
328         SelStart := SelStart - delCount;
329         SelStart := SelStart + FTextLayout.IncludeNonSpacingChars(SelStart, 0);
330       end;
331     end;
332   end
333   else
334   if Key = #13 then
335     InsertText(LineEnding)
336   else
337     InsertText(Key);
338   Key := #0
339 end;
340 
341 procedure TForm1.ScrollBar1Change(Sender: TObject);
342 begin
343   BGRAVirtualScreen1.DiscardBitmap;
344 end;
345 
346 procedure TForm1.SpinEdit_FontSizeChange(Sender: TObject);
347 begin
348   LayoutCompletelyChanged;
349 end;
350 
351 procedure TForm1.TimerBlinkCaretTimer(Sender: TObject);
352 begin
353   BGRAVirtualScreen1.DiscardBitmap;
354 end;
355 
356 procedure TForm1.ToolButtonCenterAlignClick(Sender: TObject);
357 begin
358   SetCurrentParagraphAlign(taCenter);
359 end;
360 
361 procedure TForm1.ToolButtonLeftAlignClick(Sender: TObject);
362 begin
363   SetCurrentParagraphAlign(taLeftJustify);
364 end;
365 
366 procedure TForm1.ToolButtonRightAlignClick(Sender: TObject);
367 begin
368   SetCurrentParagraphAlign(taRightJustify);
369 end;
370 
TForm1.GetLayoutReadynull371 function TForm1.GetLayoutReady: boolean;
372 begin
373   result := Assigned(FTextLayout) and Assigned(FFontRenderer);
374 end;
375 
GetSelLastClicknull376 function TForm1.GetSelLastClick: integer;
377 begin
378   if FSelLastClick = -1 then
379     result := FSelStart + FSelLength
380   else
381     result := FSelLastClick;
382 end;
383 
384 procedure TForm1.LayoutBrokenLinesChanged(ASender: TObject;
385   AParagraphIndex: integer; ASubBrokenStart, ASubBrokenChangedCountBefore,
386   ASubBrokenChangedCountAfter: integer; ASubBrokenTotalCountBefore,
387   ASubBrokenTotalCountAfter: integer);
388 var
389   i: Integer;
390 begin
391   if (AParagraphIndex < 0) or (AParagraphIndex > high(FRenderedParagraphs)) or
392     (FRenderedParagraphs[AParagraphIndex] = nil) then exit;
393   if ASubBrokenTotalCountBefore <> FRenderedParagraphs[AParagraphIndex].Count then
394     FreeAndNil(FRenderedParagraphs[AParagraphIndex])
395   else
396   begin
397     for i := 0 to ASubBrokenChangedCountBefore-1 do
398       FRenderedParagraphs[AParagraphIndex].Delete(ASubBrokenStart);
399     for i := 0 to ASubBrokenChangedCountAfter-1 do
400       FRenderedParagraphs[AParagraphIndex].Insert(ASubBrokenStart, nil);
401   end;
402 end;
403 
404 procedure TForm1.DiscardRenderedBrokenLines;
405 var
406   i: Integer;
407 begin
408   for i := 0 to high(FRenderedParagraphs) do
409     FreeAndNil(FRenderedParagraphs[i]);
410 end;
411 
412 procedure TForm1.LayoutCompletelyChanged;
413 begin
414   if Assigned(FTextLayout) then FTextLayout.InvalidateLayout;
415   DiscardRenderedBrokenLines;
416   BGRAVirtualScreen1.DiscardBitmap;
417 end;
418 
419 procedure TForm1.LayoutParagraphDeleted(ASender: TObject;
420   AParagraphIndex: integer);
421 var
422   i: Integer;
423 begin
424   if (AParagraphIndex >= 0) and (AParagraphIndex <= high(FRenderedParagraphs)) then
425   begin
426     FreeAndNil(FRenderedParagraphs[AParagraphIndex]);
427     for i := AParagraphIndex to high(FRenderedParagraphs)-1 do
428       FRenderedParagraphs[i] := FRenderedParagraphs[i+1];
429     setlength(FRenderedParagraphs, length(FRenderedParagraphs)-1);
430   end;
431 end;
432 
433 procedure TForm1.LayoutParagraphMergedWithNext(ASender: TObject;
434   AParagraphIndex: integer);
435 var
436   i, insertIndex: Integer;
437   renderedBrokenLine: TBGRABitmap;
438 begin
439   insertIndex := FRenderedParagraphs[AParagraphIndex].Count;
440   for i := FRenderedParagraphs[AParagraphIndex+1].Count-1 downto 0 do
441   begin
442     renderedBrokenLine := FRenderedParagraphs[AParagraphIndex+1].Items[i];
443     FRenderedParagraphs[AParagraphIndex].Insert(insertIndex, renderedBrokenLine);
444     FRenderedParagraphs[AParagraphIndex+1].Extract(renderedBrokenLine);
445   end;
446   LayoutParagraphDeleted(ASender, AParagraphIndex+1);
447 end;
448 
449 procedure TForm1.LayoutParagraphSplit(ASender: TObject;
450   AParagraphIndex: integer; ASubBrokenIndex, ACharIndex: integer);
451 var
452   i, j: Integer;
453   renderedBrokenLine: TBGRABitmap;
454 begin
455   if (AParagraphIndex >= 0) and (AParagraphIndex <= high(FRenderedParagraphs)) then
456   begin
457     setlength(FRenderedParagraphs, length(FRenderedParagraphs)+1);
458     for i := high(FRenderedParagraphs) downto AParagraphIndex+2 do
459       FRenderedParagraphs[i] := FRenderedParagraphs[i-1];
460     FRenderedParagraphs[AParagraphIndex+1] := TRenderedBrokenLineList.Create;
461     for j := FRenderedParagraphs[AParagraphIndex].Count-1 downto ASubBrokenIndex+1 do
462     begin
463       renderedBrokenLine := FRenderedParagraphs[AParagraphIndex].Items[j];
464       FRenderedParagraphs[AParagraphIndex+1].Insert(0, renderedBrokenLine);
465       FRenderedParagraphs[AParagraphIndex].Extract(renderedBrokenLine);
466     end;
467   end;
468 end;
469 
470 procedure TForm1.SetSelLastClick(AValue: integer);
471 begin
472   if FSelFirstClick = -1 then
473     FSelFirstClick := FSelStart;
474   FSelLastClick:= AValue;
475   UpdateSelectionFromFirstLastClick;
476 end;
477 
478 procedure TForm1.SetSelLength(AValue: integer);
479 begin
480   if FSelLength=AValue then Exit;
481   FSelLength:=AValue;
482   FSelFirstClick:=-1;
483   FSelLastClick:=-1;
484   ShowCaret;
485 end;
486 
487 procedure TForm1.SetSelStart(AValue: integer);
488 begin
489   if FSelStart=AValue then Exit;
490   FSelStart:=AValue;
491   if FSelStart + FSelLength > FTextLayout.CharCount then
492     FSelLength := FTextLayout.CharCount - FSelStart;
493   FSelFirstClick:=-1;
494   FSelLastClick:=-1;
495   ShowCaret;
496 end;
497 
498 procedure TForm1.FlushUnicode;
499 begin
500   if not FInUnicode then exit;
501   FInUnicode := false;
502   InsertText(UnicodeCharToUTF8(FUnicodeValue));
503 end;
504 
505 procedure TForm1.UpdateCurrentParagraph;
506 var curAlign: TAlignment;
507 begin
508   if not LayoutReady then exit;
509 
510   FCurFirstParagraph:= FTextLayout.GetParagraphAt(SelStart);
511   FCurLastParagraph:= FTextLayout.GetParagraphAt(SelStart+SelLength);
512   case FTextLayout.ParagraphAlignment[FCurFirstParagraph] of
513   btaCenter: curAlign := taCenter;
514   btaLeftJustify: curAlign := taLeftJustify;
515   btaRightJustify: curAlign:= taRightJustify;
516   btaOpposite: if FTextLayout.ParagraphRightToLeft[FCurFirstParagraph] then
517                  curAlign:= taLeftJustify else curAlign:= taRightJustify;
518   else
519     if FTextLayout.ParagraphRightToLeft[FCurFirstParagraph] then
520                curAlign:= taRightJustify else curAlign:= taLeftJustify;
521   end;
522   ToolButtonLeftAlign.Down := curAlign = taLeftJustify;
523   ToolButtonCenterAlign.Down := curAlign = taCenter;
524   ToolButtonRightAlign.Down := curAlign = taRightJustify;
525 end;
526 
527 procedure TForm1.UpdateSelectionFromFirstLastClick;
528 begin
529   if FSelLastClick < FSelFirstClick then
530   begin
531     FSelStart := FSelLastClick;
532     FSelLength:= FSelFirstClick-FSelLastClick;
533   end else
534   begin
535     FSelStart:= FSelFirstClick;
536     FSelLength:= FSelLastClick-FSelFirstClick;
537   end;
538   ShowCaret;
539 end;
540 
541 procedure TForm1.SetCurrentParagraphAlign(AAlign: TAlignment);
542 var
543   i: Integer;
544   newAlign: TBidiTextAlignment;
545 begin
546   if LayoutReady and (FCurFirstParagraph <> -1) then
547   begin
548     for i := FCurFirstParagraph to FCurLastParagraph do
549     begin
550       case AALign of
551         taLeftJustify: if FTextLayout.ParagraphRightToLeft[i] then
552                          newAlign := btaOpposite
553                          else newAlign := btaNatural;
554         taRightJustify: if FTextLayout.ParagraphRightToLeft[i] then
555                          newAlign := btaNatural
556                          else newAlign := btaOpposite;
557         else {taCenter:} newAlign := btaCenter;
558       end;
559       FTextLayout.ParagraphAlignment[i] := newAlign;
560     end;
561 
562     BGRAVirtualScreen1.DiscardBitmap;
563   end;
564 end;
565 
566 procedure TForm1.DeleteSelection;
567 begin
568   if SelLength <> 0 then
569   begin
570     FTextLayout.DeleteText(SelStart, SelLength);
571     SelStart := SelStart + FTextLayout.IncludeNonSpacingChars(SelStart, 0);
572     SelLength:= 0;
573     ShowCaret;
574   end;
575 end;
576 
577 procedure TForm1.InsertText(AText: string);
578 var
579   insertCount: Integer;
580 begin
581   if not LayoutReady then exit;
582   DeleteSelection;
583   insertCount := FTextLayout.InsertText(AText, SelStart);
584   SelStart := SelStart + insertCount;
585   SelStart := SelStart + FTextLayout.IncludeNonSpacingChars(SelStart, 0);
586   ShowCaret;
587 end;
588 
589 procedure TForm1.ShowCaret;
590 begin
591   FBlinkCaretState := true;
592   FBlinkCaretTime:= Now;
593   BGRAVirtualScreen1.DiscardBitmap;
594   TimerBlinkCaret.Enabled := false;
595   TimerBlinkCaret.Enabled := true;
596 end;
597 
598 procedure TForm1.BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
599 var
600   zoom, prevAvailWidth: single;
601   caretColor, selectionColor: TBGRAPixel;
602   newTime: TDateTime;
603   oldTopLeft: TPointF;
604   i: Integer;
605   startBroken, endBroken, j, countBroken: LongInt;
606   renderedBroken: TBGRABitmap;
607   renderRect: TRect;
608 begin
609   zoom := BGRAVirtualScreen1.BitmapScale * Screen.PixelsPerInch / 96;
610   if FFontRenderer = nil then
611   begin
612     if CheckBox_FreeType.Checked then
613     begin
614       FFontRenderer := TBGRAFreeTypeFontRenderer.Create;
615       FFontRenderer.FontName := 'Liberation Serif';
616     end else
617     begin
618       FFontRenderer := TLCLFontRenderer.Create;
619       FFontRenderer.FontName := {$IFDEF LINUX}'Liberation Serif'{$ELSE}'serif'{$ENDIF};
620     End;
621   end;
622   if CheckBox_ClearType.Checked then
623   begin
624     //force ClearType to RGB if disabled on the system
625     if fqFineClearType() = fqFineAntialiasing then
626       FFontRenderer.FontQuality:= fqFineClearTypeRGB
627     else
628       FFontRenderer.FontQuality:= fqSystemClearType;
629   end
630   else
631   begin
632     if CheckBox_FreeType.Checked then
633       FFontRenderer.FontQuality:= fqFineAntialiasing
634     else
635       FFontRenderer.FontQuality:= fqSystem;
636   end;
637   FFontRenderer.FontEmHeightF:= SpinEdit_FontSize.Value * zoom;
638 
639   if FTextLayout = nil then
640   begin
641     FTextLayout:= TBidiTextLayout.Create(FFontRenderer, FTestText);
642     FTextLayout.ParagraphSpacingBelow:= 0.25;
643     FTextLayout.ParagraphSpacingAbove:= 0.25;
644     FTextLayout.OnParagraphDeleted:=@LayoutParagraphDeleted;
645     FTextLayout.OnParagraphMergedWithNext:=@LayoutParagraphMergedWithNext;
646     FTextLayout.OnParagraphSplit:=@LayoutParagraphSplit;
647     FTextLayout.OnBrokenLinesChanged:=@LayoutBrokenLinesChanged;
648   end else
649     FTextLayout.FontRenderer := FFontRenderer;
650 
651   prevAvailWidth := FTextLayout.AvailableWidth;
652   FTextLayout.AvailableWidth := Bitmap.Width - 8*zoom;
653   FTextLayout.TopLeft := PointF(4*zoom,4*zoom);
654   if prevAvailWidth <> FTextLayout.AvailableWidth then
655     DiscardRenderedBrokenLines;
656   FTextLayout.ComputeLayoutIfNeeded;
657 
658   oldTopLeft := FTextLayout.TopLeft;
659   ScrollBar1.Min:= 0;
660   ScrollBar1.Max:= round(FTextLayout.TotalTextHeight + 8*zoom);
661   ScrollBar1.PageSize:= Bitmap.Height;
662   ScrollBar1.LargeChange:= Bitmap.Height*2 div 3;
663   ScrollBar1.SmallChange:= round(FTextLayout.LineHeight);
664   if ScrollBar1.Position > max(0, ScrollBar1.Max - ScrollBar1.PageSize) then
665     ScrollBar1.Position := max(0, ScrollBar1.Max - ScrollBar1.PageSize);
666 
667   caretColor := BGRA(0,0,255);
668   selectionColor := BGRA(0,0,255,128);
669 
670   newTime := Now;
671   if newTime > FBlinkCaretTime + (CaretBlinkTimeMs/1000/24/60/60) then
672   begin
673     FBlinkCaretTime:= newTime;
674     FBlinkCaretState:= not FBlinkCaretState;
675   end;
676 
677   FTextLayout.TopLeft := oldTopLeft + PointF(0, -ScrollBar1.Position);
678   if FBlinkCaretState and (SelLength = 0) and BGRAVirtualScreen1.Focused then
679     FTextLayout.DrawCaret(Bitmap, SelStart, BGRA(caretColor.red,caretColor.green,caretColor.blue,140), BGRA(caretColor.red,caretColor.green,caretColor.blue,100));
680 
681   for i := FTextLayout.ParagraphCount to high(FRenderedParagraphs) do
682     FreeAndNil(FRenderedParagraphs[i]);
683   setlength(FRenderedParagraphs, FTextLayout.ParagraphCount);
684 
685   for i := 0 to FTextLayout.ParagraphCount-1 do
686   begin
687     if FRenderedParagraphs[i] = nil then
688       FRenderedParagraphs[i] := TRenderedBrokenLineList.Create;
689     startBroken := FTextLayout.ParagraphStartBrokenLine[i];
690     endBroken := FTextLayout.ParagraphEndBrokenLine[i];
691     for j := startBroken to endBroken - 1 do
692     begin
693       if j - startBroken >= FRenderedParagraphs[i].Count then
694         FRenderedParagraphs[i].Add(nil);
695       if j - startBroken < FRenderedParagraphs[i].Count then
696       begin
697         renderRect := RectWithSize(0, round(oldTopLeft.y + FTextLayout.BrokenLineRectF[j].Top) - ScrollBar1.Position,
698                                    Bitmap.Width, ceil(FTextLayout.BrokenLineRectF[j].Height));
699         if renderRect.IntersectsWith(Bitmap.ClipRect) then
700         begin
701           if FRenderedParagraphs[i].Items[j - startBroken] = nil then
702           begin
703             renderedBroken := TBGRABitmap.Create(Bitmap.Width,
704             ceil(FTextLayout.BrokenLineRectF[j].Height), BGRAVirtualScreen1.Color);
705             FTextLayout.TopLeft := PointF(oldTopLeft.x, -FTextLayout.BrokenLineRectF[j].Top);
706             FTextLayout.DrawBrokenLines(renderedBroken, j, j+1);
707             FRenderedParagraphs[i].Items[j - startBroken] := renderedBroken;
708           end;
709           Bitmap.PutImage(renderRect.Left, renderRect.Top,
710             FRenderedParagraphs[i].Items[j - startBroken], dmSet);
711         end else
712           FRenderedParagraphs[i].Items[j - startBroken] := nil;
713       end;
714     end;
715     countBroken := endBroken - startBroken;
716     while FRenderedParagraphs[i].Count > countBroken do
717       FRenderedParagraphs[i].Delete(countBroken);
718   end;
719   FTextLayout.TopLeft := oldTopLeft + PointF(0, -ScrollBar1.Position);
720 
721   FTextLayout.DrawSelection(Bitmap, SelStart, SelStart+SelLength, selectionColor, BGRA(0,0,192),1);
722 
723   if FBlinkCaretState and (SelLength = 0) then
724     FTextLayout.DrawCaret(Bitmap, SelStart, BGRA(caretColor.red,caretColor.green,caretColor.blue,140), BGRA(caretColor.red,caretColor.green,caretColor.blue,100));
725 
726   UpdateCurrentParagraph;
727   FTextLayout.TopLeft := oldTopLeft;
728   //let some time for events
729   TimerBlinkCaret.Enabled := false;
730   TimerBlinkCaret.Enabled := true;
731 end;
732 
733 procedure TForm1.CheckBox_ClearTypeChange(Sender: TObject);
734 begin
735   LayoutCompletelyChanged;
736 end;
737 
738 procedure TForm1.CheckBox_FreeTypeChange(Sender: TObject);
739 begin
740   LayoutCompletelyChanged;
741   FreeAndNil(FFontRenderer);
742 end;
743 
744 procedure TForm1.BGRAVirtualScreen1MouseDown(Sender: TObject;
745   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
746 var
747   index: Integer;
748 begin
749   BGRAVirtualScreen1.SetFocus;
750   if Button = mbLeft then
751   begin
752     index := FTextLayout.GetCharIndexAt(PointF(X, Y) * BGRAVirtualScreen1.BitmapScale
753                + PointF(0,ScrollBar1.Position));
754     FSelFirstClick:= index;
755     FSelLastClick:= index;
756     UpdateSelectionFromFirstLastClick;
757   end;
758 end;
759 
760 procedure TForm1.BGRAVirtualScreen1MouseMove(Sender: TObject;
761   Shift: TShiftState; X, Y: Integer);
762 var
763   index: Integer;
764 begin
765   if (FSelFirstClick <> -1) and (ssLeft in Shift) then
766   begin
767     index := FTextLayout.GetCharIndexAt(PointF(X,Y) * BGRAVirtualScreen1.BitmapScale
768                + PointF(0,ScrollBar1.Position));
769     FSelLastClick:= index;
770     UpdateSelectionFromFirstLastClick;
771   end;
772 end;
773 
774 procedure TForm1.BGRAVirtualScreen1MouseWheel(Sender: TObject;
775   Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint;
776   var Handled: Boolean);
777 begin
778   ScrollBar1.Position := ScrollBar1.Position - (WheelDelta * ScrollBar1.SmallChange div 120);
779 end;
780 
781 initialization
782 
783   EasyLazFreeType.FontCollection := TFreeTypeFontCollection.Create;
784   EasyLazFreeType.FontCollection.AddFolder(ExtractFilePath(Application.ExeName)
785      {$IFDEF DARWIN} + '../../../' {$ENDIF});
786 
787 finalization
788 
789   FreeAndNil(EasyLazFreeType.FontCollection);
790 
791 end.
792 
793