Discussion :

[Andnotor]

Salut à tous !

J'avais dernièrement besoin de lancer des tâches et pour plus de clarté envie de mettre un retour couleur dans la console.
Je me suis donc amusé à coder une petite unité à cette fin, et de fil en aiguille c'est devenu un truc assez sympa, enfin je trouve

Outre la couleur, les tâches peuvent être mono ou multithreads. Incluse également la gestion des entrées claviers.

Démo :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
program Project1;
 
{$APPTYPE CONSOLE}
 
{$R *.res}
 
uses
  System.SysUtils, System.Threading, System.SyncObjs, AppConsole;
 
const
  Restart :TSelectOption = (Text:'Recommencer Parallèle ? [O/N]'; Options:['O', 'N']; Color:Console.White);
 
begin
  Randomize;
 
  //--------------------------------------------------------------------------------------------------
  // Séquentiel
  Console.WriteHeader('Exécution séquentielle');
 
  Console.Write('Test1:', Console.Purple);
  Console.WriteTask('Execution Sync 1',
                    function :boolean
                    begin
                      Console.WriteLn('Ceci est un avertissement', Console.DarkYellow);
                      Result := TRUE;
                    end);
 
  Console.Write('Test2:', Console.Purple);
  Console.WriteTask('Execution Sync 2',
                    function :boolean
                    begin
                      Console.WriteLn('Ceci est une erreur', Console.Red);
                      Result := FALSE;
                    end);
 
  //--------------------------------------------------------------------------------------------------
  // Parallèle
  while True do
  begin
    Console.WriteHeader('Exécution Parallèle');
 
    var Error := 0;
 
    TParallel.For(1, 10,
                  procedure(aID :integer)
                  begin
                    if not Console.WriteTask('Execution du job N°' +aID.ToString,
                                             function :boolean
                                             begin
                                               // Travail
                                               Sleep(Random(10) *1000);
 
                                               // Erreur ?
                                               Result := Random(15) <> 0;
                                             end) then TInterlocked.Increment(Error);
                  end);
 
    WriteLn;
 
    if Error > 0
    then Console.WriteLn('Exécution parallèle terminée avec erreur', Console.Red)
    else Console.WriteLn('Exécution parallèle terminée sans erreur', Console.Green);
 
    WriteLn;
    Console.WriteRule;
    WriteLn;
 
    if Console.WaitInput(Restart) = 'N' then Exit;
 
    Console.Clear;
  end;
end.

Et le résultat :



Limitations :
Gardez à l'esprit que seules les lignes visibles à l'écran auront leur status mis à jour par WriteTask. En effet, la première ligne visible à toujours l'indice 0 et il n'est pas possible d'en utiliser des négatifs.
Même chose pour Clear qui n'effacera que la zone visible.

Sur ce, amusez-vous bien !

[ShaiLeTroll]

Ce sujet tombe parfaitement à pic, j'ai des applications VCL avec ProgressBar ..., j'en ai passé en mode texte mais c'est bien tristounette (surtout à coté des Docker Compose)





Je ne sais pas la version de ton Delphi, en Seattle soit D10, cela ne passe pas du tout, alors je me suis permis de porter l'unité, il serait intéressant peut-être d'aller encore plus loin dans la rétrocompatibilité

Par contre que la tache soit lancée par l'objet console, ce choix me déroutant un peu, j'ai préféré externaliser cela.

DPR

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
program ConsoleColored;
 
{$APPTYPE CONSOLE}
 
{$R *.res}
 
uses
  System.SysUtils, System.Threading, System.SyncObjs,
  System.StrUtils,
  Ext.Winapi.Console;
 
var
  Console: TColoredConsole;
  TaskID: TColoredConsole.TTaskID;
  ParallelLoop, ParallelProgres: Boolean;
  ParallelError: Integer;
begin
  Randomize();
 
  Console := TColoredConsole.Create();
  try
    Console.Title := 'Colored Console';
    ParallelProgres := Console.ReadInput(['O', 'N'], 'Progression ? [O/N]', tcWhite) = 'O';
    if ParallelProgres then
      Console.Title := Console.Title + ' with Progression';
 
  //------------------------------------------------------------------------------
  // Séquentiel
    Console.WriteTitle('Exécution séquentielle');
 
    Console.Write('Test N°1:', TColoredConsole.TTextColor.tcPurple);
    TaskID := Console.WriteTaskStart('Exécution Test N°1');
    Console.WriteLn('Avertissement pour Test N°1', TColoredConsole.TTextColor.tcDarkYellow);
    Console.WriteTaskStep(TaskID, TColoredConsole.TStatus.sSuccess);
 
 
    Console.Write('Test N°2:', TColoredConsole.TTextColor.tcPurple);
    TaskID := Console.WriteTaskStart('Exécution Test N°2');
    Console.WriteLn('Erreur du Test N°2',  TColoredConsole.TTextColor.tcRed);
    Console.WriteTaskStep(TaskID, TColoredConsole.TStatus.sError);
 
 
    //--------------------------------------------------------------------------------------------------
    // Parallèle
    ParallelLoop := True;
    while ParallelLoop do
    begin
      Console.WriteTitle('Exécution Parallèle');
 
      ParallelError := 0;
 
      TParallel.For(
        1, 10,
        procedure(AJobNumber: Integer)
        var
          ParallelTaskID: TColoredConsole.TTaskID;
          I: Integer;
        begin
          ParallelTaskID := Console.WriteTaskStart('Exécution du job N°' + AJobNumber.ToString);
          // Travail
          for I := 1 to 10 do
          begin
            Sleep(Random(100));
            if ParallelProgres then
              Console.WriteTaskStep(ParallelTaskID, I);
          end;
          for I := 1 to 9 do
          begin
            Sleep(Random(10) * 10);
            if ParallelProgres then
              Console.WriteTaskStep(ParallelTaskID, 9 + I * 10);
          end;
          if ParallelProgres then
            Console.WriteTaskStep(ParallelTaskID, 100);
          Sleep(Random(100) * 10);
 
          // Erreur ?
          if Random(5) = 0 then
          begin
            TInterlocked.Increment(ParallelError);
            Console.WriteTaskStep(ParallelTaskID, TColoredConsole.TStatus.sError);
          end
          else
            Console.WriteTaskStep(ParallelTaskID, TColoredConsole.TStatus.sSuccess);
        end
      );
 
      WriteLn;
      Console.WriteLn(Format('Exécution parallèle terminée %s erreur', [IfThen(ParallelError > 0, 'avec', 'sans')]), Console.IfThen(ParallelError > 0, tcRed, tcGreen));
 
 
      WriteLn;
      Console.WriteSeparator();
      WriteLn;
 
      ParallelLoop := Console.ReadInput(['O', 'N'], 'Recommencer Parallèle ? [O/N]', tcWhite) = 'O';
 
      Console.Clear;
    end;
  finally
    Console.Free();
  end;
end.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
unit Ext.Winapi.Console;
 
interface
 
uses Winapi.Windows, System.SysUtils, System.Classes, System.StrUtils, System.Math, System.SyncObjs, System.Generics.Collections;
 
type
  TConsole = class(TObject)
  strict private
    FStdHandle: record
      Input: THandle;
      Output: THandle;
    end;
    FLock: TCriticalSection;
  protected
    FScreenSize: DWORD;
    FScreenTopLeft: TCoord;
    FLineLength: Integer;
  strict private
    function GetBufferInfo(): TConsoleScreenBufferInfo; inline;
 
    function GetTitle(): string;
    procedure SetTitle(const Value: string);
  protected
    procedure Lock(); inline;
    procedure UnLock(); inline;
 
    class function Coord(const AX, AY: SHORT): TCoord; inline;
 
    function GetCursorPosition(): TCoord;
    function SetCursorPosition(ACursorPosition: TCoord): TCoord;
  public
    constructor Create();
    destructor Destroy(); override;
 
    procedure Clear(); virtual;
 
    function ReadInput(AOptions: TSysCharSet; const AText: string = ''): AnsiChar;
 
    property StdHandleInput: THandle read FStdHandle.Input;
    property StdHandleOutput: THandle read FStdHandle.Output;
 
    property Title: string read GetTitle write SetTitle;
    property LineLength: Integer read FLineLength write FLineLength;
  end;
 
  TColoredConsole = class(TConsole)
  public
    type
      TTextColor = (
        tcDefault       = FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_BLUE,
        tcWhite         = FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_BLUE or FOREGROUND_INTENSITY,
        tcRed           = FOREGROUND_RED or FOREGROUND_INTENSITY,
        tcDarkRed       = FOREGROUND_RED,
        tcGreen         = FOREGROUND_GREEN or FOREGROUND_INTENSITY,
        tcDarkGreen     = FOREGROUND_GREEN,
        tcBlue          = FOREGROUND_BLUE or FOREGROUND_INTENSITY,
        tcDarkBlue      = FOREGROUND_BLUE,
        tcYellow        = FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_INTENSITY,
        tcDarkYellow    = FOREGROUND_RED or FOREGROUND_GREEN,
        tcPurple        = FOREGROUND_RED or FOREGROUND_BLUE or FOREGROUND_INTENSITY,
        tcDarkPurple    = FOREGROUND_RED or FOREGROUND_BLUE,
        tcSkyBlue       = FOREGROUND_GREEN or FOREGROUND_BLUE or FOREGROUND_INTENSITY,
        tcDarkSkyBlue   = FOREGROUND_GREEN or FOREGROUND_BLUE
      );
      TBackgroundColor = (
        bcDefault     = 0,
        bcWhite       = BACKGROUND_RED or BACKGROUND_GREEN or BACKGROUND_BLUE or BACKGROUND_INTENSITY,
        bcSilver      = BACKGROUND_RED or BACKGROUND_GREEN or BACKGROUND_BLUE,
        bcRed         = BACKGROUND_RED or BACKGROUND_INTENSITY,
        bcDarkRed     = BACKGROUND_RED,
        bcGreen       = BACKGROUND_GREEN or BACKGROUND_INTENSITY,
        bcDarkGreen   = BACKGROUND_GREEN,
        bcBlue        = BACKGROUND_BLUE or BACKGROUND_INTENSITY,
        bcDarkBlue    = BACKGROUND_BLUE,
        bcYellow      = BACKGROUND_RED or BACKGROUND_GREEN or BACKGROUND_INTENSITY,
        bcDarkYellow  = BACKGROUND_RED or BACKGROUND_GREEN,
        bcPurple      = BACKGROUND_RED or BACKGROUND_BLUE or BACKGROUND_INTENSITY,
        bcDarkPurple  = BACKGROUND_RED or BACKGROUND_BLUE,
        bcSkyBlue     = BACKGROUND_GREEN or BACKGROUND_BLUE or BACKGROUND_INTENSITY,
        bcDarkSkyBlue = BACKGROUND_GREEN or BACKGROUND_BLUE
      );
 
      TStatus = (sPending, sSuccess, sError);
      TStatusLabels = array[TStatus] of string;
      TStatusColors = array[TStatus] of TTextColor;
      TTaskID = Int64;
    const
      DEFAULT_STATUS: TStatusLabels = ('PENDING', 'SUCCESS', 'ERROR');
      DEFAULT_STATUS_COLORS: TStatusColors = (TTextColor.tcDarkYellow, TTextColor.tcDarkGreen,TTextColor.tcDarkRed);
  strict private
    type
      TCoordByID = class(TDictionary<TTaskID, TCoord>)
      private
        FLock: TCriticalSection;
      public
        constructor Create();
        destructor Destroy(); override;
 
        procedure Add(ATaskID: TTaskID; const ACoord: TCoord);
        procedure ApplyDelta(ADelta: Integer);
        function ContainsTask(ATaskID: TTaskID): Boolean;
        function ExtractTask(ATaskID: TTaskID): TCoord;
        function TryGetCoord(ATaskID: TTaskID; out ACoord: TCoord): Boolean;
      end;
 
  strict private
    FStepCoords: TCoordByID;
    FCounter: TTaskID;
 
    FStatus: TStatusLabels;
    FStatusColors: TStatusColors;
    FStatusLength: array[TStatus] of Integer;
    FStatusLengthMax: Integer;
    FStatusLengthMin: Integer;
  private
    function GetStatus(Index: TStatus): string;
    procedure SetStatus(Index: TStatus; const Value: string);
  public
    constructor Create();
    destructor Destroy(); override;
 
    procedure Clear(); override;
 
    function ReadInput(AOptions: TSysCharSet; const AText: string = ''; ATextColor: TTextColor = tcDefault; ABackgroundColor: TBackgroundColor = bcDefault): AnsiChar; overload;
 
    procedure Write(const AText: string = ''; ATextColor: TTextColor = tcDefault; ABackgroundColor: TBackgroundColor = bcDefault);
    procedure WriteLn(const AText: string = ''; ATextColor: TTextColor = tcDefault; ABackgroundColor: TBackgroundColor = bcDefault); overload;
    procedure WriteLn(const ATexts: TArray<string>; ATextColor: TTextColor = tcDefault; ABackgroundColor: TBackgroundColor = bcDefault); overload;
    procedure WriteTitle(const AText: string; ATextColor: TTextColor = tcWhite; ABackgroundColor: TBackgroundColor = bcDefault; AChar: Char = '-');
    procedure WriteSeparator(ATextColor: TTextColor = tcWhite; ABackgroundColor: TBackgroundColor = bcDefault; AChar: Char = '-');
    function WriteTaskStart(const AText :string; ATextColor: TTextColor = tcDefault; ABackgroundColor: TBackgroundColor = bcDefault): TTaskID;
    procedure WriteTaskStep(ATaskID: TTaskID; AStatus: TStatus; ABackgroundColor: TBackgroundColor = bcDefault); overload;
    procedure WriteTaskStep(ATaskID: TTaskID; APourcent: Integer; ABackgroundColor: TBackgroundColor = bcDefault); overload;
 
    class function IfThen(AValue: Boolean; ATrue: TColoredConsole.TTextColor; AFalse: TColoredConsole.TTextColor): TColoredConsole.TTextColor; inline;
 
    property Status[Index: TStatus]: string read GetStatus write SetStatus;
  end;
 
 
implementation
 
{ TConsole }
 
//------------------------------------------------------------------------------
constructor TConsole.Create();
begin
  inherited Create();
 
  FStdHandle.Input  := GetStdHandle(STD_INPUT_HANDLE);
  FStdHandle.Output := GetStdHandle(STD_OUTPUT_HANDLE);
 
  FLock := TCriticalSection.Create();
 
  with GetBufferInfo() do
  begin
    FScreenSize := dwSize.X * dwSize.Y;
    FLineLength := dwSize.X;
  end;
  FScreenTopLeft := Coord(0, 0);
end;
 
//------------------------------------------------------------------------------
destructor TConsole.Destroy();
begin
  FreeAndNil(FLock);
 
  inherited Destroy();
end;
 
//------------------------------------------------------------------------------
class function TConsole.Coord(const AX, AY: SHORT): TCoord;
begin
  Result.X := AX;
  Result.Y := AY;
end;
 
//------------------------------------------------------------------------------
procedure TConsole.Lock();
begin
  FLock.Acquire();
end;
 
//------------------------------------------------------------------------------
procedure TConsole.UnLock();
begin
  FLock.Release();
end;
 
//------------------------------------------------------------------------------
procedure TConsole.Clear();
var
  NumberOfCharsWritten: DWORD;
begin
  FillConsoleOutputCharacterA(FStdHandle.Output, ' ', FScreenSize, FScreenTopLeft, NumberOfCharsWritten);
  SetConsoleCursorPosition(FStdHandle.Output, FScreenTopLeft);
end;
 
//------------------------------------------------------------------------------
function TConsole.GetBufferInfo(): TConsoleScreenBufferInfo;
begin
  if not GetConsoleScreenBufferInfo(FStdHandle.Output, Result) then
    ZeroMemory(@Result, SizeOf(Result));
end;
 
//------------------------------------------------------------------------------
function TConsole.GetCursorPosition(): TCoord;
begin
  Lock();
  try
    Result := GetBufferInfo().dwCursorPosition;
  finally
    UnLock();
  end;
end;
 
//------------------------------------------------------------------------------
function TConsole.SetCursorPosition(ACursorPosition: TCoord): TCoord;
begin
  Lock();
  try
    Result := GetBufferInfo().dwCursorPosition;
    SetConsoleCursorPosition(FStdHandle.Output, ACursorPosition);
  finally
    UnLock();
  end;
end;
 
//------------------------------------------------------------------------------
function TConsole.ReadInput(AOptions: TSysCharSet; const AText: string = ''): AnsiChar;
var
  InputRecord: TInputRecord;
  lpNumberOfEventsRead: DWORD;
  C: AnsiChar;
  CaseFoldedOptions: TSysCharSet;
begin
  if AText <> '' then
    WriteLn(AText);
 
  CaseFoldedOptions := AOptions;
  for C in CaseFoldedOptions do
  begin
    if C in ['a'..'z'] then
      Include(CaseFoldedOptions, UpCase(C))
    else if C in ['A'..'Z'] then
      Include(CaseFoldedOptions, AnsiChar(Ord(C) - Ord('A') + Ord('a')));
  end;
 
  repeat
    ReadConsoleInput(FStdHandle.Input, InputRecord, 1, lpNumberOfEventsRead);
    C := InputRecord.Event.KeyEvent.AsciiChar;
  until (InputRecord.EventType = KEY_EVENT) and not InputRecord.Event.KeyEvent.bKeyDown and (C in CaseFoldedOptions);
 
  if InputRecord.EventType = KEY_EVENT then
    Result := UpCase(C)
  else
    Result := #0;
end;
 
//------------------------------------------------------------------------------
function TConsole.GetTitle(): string;
begin
  SetLength(Result, MAX_PATH);
  SetLength(Result, GetConsoleTitle(PChar(Result), MAX_PATH));
end;
 
procedure TConsole.SetTitle(const Value: string);
begin
  SetConsoleTitle(PChar(Value));
end;
 
{ TColoredConsole }
 
//------------------------------------------------------------------------------
constructor TColoredConsole.Create();
var
  S: TStatus;
begin
  inherited Create();
 
  FStepCoords := TCoordByID.Create();
 
  FStatusLengthMin := Length('100 %');
  for S := Low(DEFAULT_STATUS) to High(DEFAULT_STATUS) do
    SetStatus(S, DEFAULT_STATUS[S]);
 
  FStatusColors := DEFAULT_STATUS_COLORS;
end;
 
//------------------------------------------------------------------------------
destructor TColoredConsole.Destroy();
begin
  FStepCoords.Free();
 
  inherited Destroy();
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.Clear();
var
  Attributes: Word;
  NumberOfCharsWritten: DWORD;
begin
  inherited Clear();
 
  Attributes := Word(Ord(TTextColor.tcDefault)) or Word(Ord(TBackgroundColor.bcDefault));
  FillConsoleOutputAttribute(StdHandleOutput, Attributes, FScreenSize, FScreenTopLeft, NumberOfCharsWritten);
end;
 
//------------------------------------------------------------------------------
function TColoredConsole.ReadInput(AOptions: TSysCharSet; const AText: string = ''; ATextColor: TTextColor = tcDefault; ABackgroundColor: TBackgroundColor = bcDefault): AnsiChar;
begin
  if AText <> '' then
    WriteLn(AText, ATextColor, ABackgroundColor);
 
  Result := inherited ReadInput(AOptions, '');
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.Write(const AText: string = ''; ATextColor: TTextColor = tcDefault; ABackgroundColor: TBackgroundColor = bcDefault);
var
  Attributes: Word;
begin
  Attributes := Word(Ord(ATextColor)) or Word(Ord(ABackgroundColor));
 
  Lock();
  try
    SetConsoleTextAttribute(StdHandleOutput, Attributes);
    System.Write(AText);
  finally
    UnLock();
  end;
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.WriteLn(const AText: string = ''; ATextColor: TTextColor = tcDefault; ABackgroundColor: TBackgroundColor = bcDefault);
begin
  WriteLn(AText.Split([#13#10, #13]), ATextColor, ABackgroundColor);
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.WriteLn(const ATexts: TArray<string>; ATextColor: TTextColor = tcDefault; ABackgroundColor: TBackgroundColor = bcDefault);
var
  Attributes: Word;
  Line: string;
  CP, CPNew: TCoord;
  DeltaY: Integer;
begin
  Attributes := Word(Ord(ATextColor)) or Word(Ord(ABackgroundColor));
 
  DeltaY := 0;
 
  Lock();
  try
    SetConsoleTextAttribute(StdHandleOutput, Attributes);
 
    for Line in ATexts do
    begin
      CP := GetCursorPosition();
      System.WriteLn(Line);
      CPNew := GetCursorPosition();
      if CP.Y = CPNew.Y then
        Inc(DeltaY);
    end;
 
  finally
    UnLock();
  end;
 
  if DeltaY > 0 then
    FStepCoords.ApplyDelta(DeltaY);
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.WriteSeparator(ATextColor: TTextColor = tcWhite; ABackgroundColor: TBackgroundColor = bcDefault; AChar: Char = '-');
begin
  if GetCursorPosition().X > 0 then
    System.WriteLn;
 
  WriteLn(StringOfChar(AChar, FLineLength), ATextColor, ABackgroundColor);
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.WriteTitle(const AText: string; ATextColor: TTextColor = tcWhite; ABackgroundColor: TBackgroundColor = bcDefault; AChar: Char = '-');
begin
  WriteLn(['', AText, StringOfChar(aChar, aText.Length)], ATextColor, ABackgroundColor);
end;
 
//------------------------------------------------------------------------------
function TColoredConsole.WriteTaskStart(const AText: string; ATextColor: TTextColor = tcDefault; ABackgroundColor: TBackgroundColor = bcDefault): TTaskID;
var
  CP, CPBk: TCoord;
  Filler: string;
  Scrolling: Integer;
begin
  Result := TInterlocked.Increment(FCounter);
 
  Lock();
  try
    CP := GetCursorPosition();
    Filler := StringOfChar('.', LineLength - CP.X - FStatusLengthMax - AText.Length - 2);
    CP.X := LineLength - FStatusLengthMax - 1;
    FStepCoords.Add(Result, CP);
 
    WriteLn(Format('%s%s[%*.s]', [AText, Filler, FStatusLengthMax - FStatusLength[sPending], FStatus[sPending]]), ATextColor, ABackgroundColor);
 
    CPBk := SetCursorPosition(FStepCoords[Result]);
    Write(FStatus[sPending] + StringOfChar(' ', FStatusLengthMax - FStatusLength[sPending]), FStatusColors[sPending], ABackgroundColor);
    SetCursorPosition(CPBk);
 
  finally
    UnLock();
  end;
 
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.WriteTaskStep(ATaskID: TTaskID; AStatus: TStatus; ABackgroundColor: TBackgroundColor = bcDefault);
var
  CP: TCoord;
begin
  if not FStepCoords.ContainsTask(ATaskID) then
    Exit;
 
  CP := FStepCoords.ExtractTask(ATaskID);
  if CP.Y >= 0 then
  begin
    Lock();
    try
      CP := SetCursorPosition(CP);
      Write(FStatus[AStatus] + StringOfChar(' ', FStatusLengthMax - FStatusLength[AStatus]), FStatusColors[AStatus], ABackgroundColor);
      SetCursorPosition(CP);
    finally
      UnLock();
    end;
  end;
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.WriteTaskStep(ATaskID: TTaskID; APourcent: Integer; ABackgroundColor: TBackgroundColor = bcDefault);
var
  CP: TCoord;
begin
  if FStepCoords.TryGetCoord(ATaskID, CP) and (CP.Y >= 0) then
  begin
    Lock();
    try
      CP := SetCursorPosition(CP);
      Write(Format('%3.d %%', [APourcent]) + StringOfChar(' ', FStatusLengthMax - FStatusLengthMin - Trunc(Log10(APourcent))), FStatusColors[sPending], ABackgroundColor);
      SetCursorPosition(CP);
    finally
      UnLock();
    end;
  end;
end;
 
//------------------------------------------------------------------------------
function TColoredConsole.GetStatus(Index: TStatus): string;
begin
  Result := FStatus[Index];
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.SetStatus(Index: TStatus; const Value: string);
begin
  FStatus[Index] := Value;
  FStatusLength[Index] := Length(Value);
  FStatusLengthMax := Max(FStatusLengthMin, Max(FStatusLengthMax, FStatusLength[Index]));
end;
 
//------------------------------------------------------------------------------
class function TColoredConsole.IfThen(AValue: Boolean; ATrue: TColoredConsole.TTextColor; AFalse: TColoredConsole.TTextColor): TColoredConsole.TTextColor;
begin
  if AValue then
    Result := ATrue
  else
    Result := AFalse;
end;
 
 
 
 
{ TColoredConsole.TCoordByID }
 
//------------------------------------------------------------------------------
constructor TColoredConsole.TCoordByID.Create();
begin
  inherited Create();
 
  FLock := TCriticalSection.Create();
end;
 
//------------------------------------------------------------------------------
destructor TColoredConsole.TCoordByID.Destroy();
begin
  FreeAndNil(FLock);
 
  inherited Destroy();
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.TCoordByID.Add(ATaskID: TTaskID; const ACoord: TCoord);
begin
  FLock.Acquire();
  try
    inherited Add(ATaskID, ACoord);
  finally
    FLock.Release();
  end;
end;
 
 
//------------------------------------------------------------------------------
function TColoredConsole.TCoordByID.ContainsTask(ATaskID: TTaskID): Boolean;
begin
  FLock.Acquire();
  try
    Result := ContainsKey(ATaskID);
  finally
    FLock.Release();
  end;
end;
 
//------------------------------------------------------------------------------
function TColoredConsole.TCoordByID.ExtractTask(ATaskID: TTaskID): TCoord;
begin
  FLock.Acquire();
  try
    Result := ExtractPair(ATaskID).Value;
  finally
    FLock.Release();
  end;
end;
 
//------------------------------------------------------------------------------
function TColoredConsole.TCoordByID.TryGetCoord(ATaskID: TTaskID; out ACoord: TCoord): Boolean;
begin
  FLock.Acquire();
  try
    Result := TryGetValue(ATaskID, ACoord);
  finally
    FLock.Release();
  end;
end;
 
//------------------------------------------------------------------------------
procedure TColoredConsole.TCoordByID.ApplyDelta(ADelta: Integer);
var
  It: TPair<TTaskID, TCoord>;
  CP: TCoord;
begin
  FLock.Acquire();
  try
     for It in Self do
     begin
       CP := It.Value;
       Dec(CP.Y, ADelta);
       Self.AddOrSetValue(It.Key, CP);
     end;
  finally
    FLock.Release();
  end;
end;
 
end.

Sans Progression et Avec progression

[Galet]

Merci messieurs, de partager ces codes...
Le problème, c'est quelles donnent plein de nouvelles idées...et toujours pas de temps !
Belle journée à tous...

[Andnotor]

Pas tous mais plusieurs chemins mènent à Rome

Les procédures anonymes peuvent facilement être déroutantes en effet mais je ne voulais justement pas ce genre de chose :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
try
  if Error then
    EndTask(Error)
  else 
    EndTask(No error);
except
  EndTask(Error);
end;

Je ne voulais pas non plus créer d'objet, une classe abstraite suffit amplement à mon sens.

Sinon effectivement les variables en lignes poseront toujours problème. Voilà un version compatible depuis XE8 (j'ai pas plus vieux )

[ShaiLeTroll]

Oui, c'est "déroutant" exactement, niveau syntaxe, j'ai eu vraiment du mal à lire le code, rien que l'indentation est inhabituelle ... ça fait penser à du Async Await TypeScript (qu'est-ce que c'est moche ce langage)

Sync, meilleur nom, cela rappelle plus TThread.Synchronize (qui ne fonctionne que si TApplication dépile)

Je suis dans le cas de passer VCL à Console, en conservant les deux, donc pas de lien statique que le processus et l'affichage
C'est ce qui me gênait le plus : la question de responsabilité !
C'est Console qui lance la procédure anonyme
Cela revient à rendre la classe l'affichage responsable du lancement la tache
Je préfère plutôt un Launcher qui lance tache, celle-ci pourra informer son avancement via des TProgressEvent (si on les lui fourni)


J'ai poussé le vice à ajouter une Progression en plus du Status, j'ai aussi séparé le Lock Console du Lock TDictionary, toujours dans cette logique de responsabilité.

[Andnotor]

rien que l'indentation est inhabituelle ... ça fait penser à du Async Await TypeScript (qu'est-ce que c'est moche ce langage)

J'ai compris, tu n'aimes pas ma façon de coder, j'ai compris !

Mais tu n'as rien vu, j'ai créé un petit utilitaire pour lancer la compilation d'un composant sur huit versions de Delphi en parallèle... à coup de procédures anonymes imbriquées.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
function DoCompile(aDelphi :TDelphi; const aDestPath :string; aPlateform :byte; const aPackage, aDefine :string) :boolean;
begin
  Result := Console.WriteTask(Format('%s:Compilation de %s pour %s Win%d', [aDefine.ToUpper, aPackage, aDelphi.Name, aPlateform]),
                              function :boolean
                              begin
                                const Compiler = Format(dcc, [aDelphi.Version, aPlateform]);
                                const Dest     = Format('%s~%s\Lib\%s\Win%d\', [aDestPath, aDefine, aDelphi.Version, aPlateform]);
                                const Alias    = 'Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;';
                                const Params   = Format('-B -Q -LE%0:s -LN%0:s -NU%0:s -NS%1:s --description:"MonComponent %2:s" -D%2:s "%3:s.dpk"', [Dest, Alias, aDefine, aPackage]);
 
                                if not Exec(Compiler, Params,
                                            function(const aText :string; aExitCode :integer) :boolean
                                            begin
                                              Result := aExitCode <= ERROR_SUCCESS;
 
                                              if not Result then
                                                  Console.WriteLn(aText, Console.Red)
                                              else
                                              begin
                                                const Match = TRegEx.Match(aText, '\s([HWEF])\d+\s');
 
                                                if Match.Success then
                                                  case Match.Groups[1].Value.Chars[0] of
                                                    'H' : Console.WriteLn(aText, Console.DarkSkyBlue);  // [H]int
                                                    'W' : Console.WriteLn(aText, Console.DarkYellow);   // [W]arning
                                                    else  begin                                         // [E]rror or [F]atal
                                                            Console.WriteLn(aText, Console.Red);
                                                            Result := FALSE;
                                                          end;
                                                  end;
                                              end;
                                            end) then Exit(FALSE);
 
                                TFile.Move(Dest +aPackage +'.bpl', Dest +aPackage +aDelphi.PackageVersion +'.bpl');
                                TFile.Move(Dest +aPackage +'.dcp', Dest +aPackage +aDelphi.PackageVersion +'.dcp');
 
                                Result := TRUE;
                              end);
end;

Tu préfères une indentation "standard", c'est un choix ; j'aime quand les choses sont alignées

C'est ce qui me gênait le plus : la question de responsabilité !
C'est Console qui lance la procédure anonyme

C'est plus une question de terme non ? Si j'avais appelé cette méthode RunTask à la place de WriteTask ça ne t'aurait pas choqué.

j'ai aussi séparé le Lock Console du Lock TDictionary, toujours dans cette logique de responsabilité.

Ca posera problème en multithreads si tu n'es pas sur le même verrou. Dans ton approche rien ne garanti qu'il n'y a pas eu une nouvelle sortie écran entre WriteLn et ApplyDelta.
Le dictionnaire contient les positions d'affichage, il est étroitement lié aux write/writeln ; ils ne font qu'un.

WriteTaskStop par exemple : Lecture de la position sur un verrou, write sur un autre et sauvegarde de la nouvelle position sur un troisième ; oui en syncro (mais on aurait pas besoin de verrou, ni de dictionnaire d'ailleurs !) mais pas en multithreads. Ici les verrous ne servent juste... à rien !
Tu ne t'en rend pas compte parce que ton test tient sur un écran, tu le remarqueras dès qu'il y aura du défilement (affichage d'avertissements dans le cas de ma compilation par exemple)

Le verrou sert à protéger notre code, pas les accès à la console que Windows gère nativement (il n'y aura par exemple jamais de mélange de texte, les write successifs sont empilés/dépilés, c'est thread-safe).


Oui j'avais aussi pensé à une ProgressBar du style Job N°1......[=== ] qui tourne en boucle mais j'avais pas beaucoup de temps. Peut-être y reviendrais-je


ps: je suis assez surpris que tes tâches parallèles soient toujours exécutées dans l'ordre (Job°1 à 10), ton PC est réglé comme une horloge

[ShaiLeTroll]

ps: je suis assez surpris que tes tâches parallèles soient toujours exécutées dans l'ordre (Job°1 à 10), ton PC est réglé comme une horloge

Pas toujours ça fini parfois en 7 10 9 8.

Je teste à 40 ou à ScreenLineCount, j'ai observé le défilement justement, j'ai trouvé cela très intéressant, là on commence à voir l'effet de bord sur les rares négatifs non utilisables.


Sinon, je suis resté à l'approche évènementielle et couplage faible, clairement je ne pourrais jamais spontanément écrire des procédures anonymes imbriquées, j'ai déjà du mal à ne pas faire des TThread explicites via tu TTask ou autres.



PS : ah oui, la compil chez nous c'est un PowerShell qui génère des BAT

[Andnotor]

là on commence à voir l'effet de bord sur les rares négatifs non utilisables.

Rare dans ton test parce que réglé sur N*100ms et sans WriteLn intermédiaire (pas d'avertissement remonté).

Stresse un peu tout ça

A moins que tu parles juste du défilement hors écran...

je ne pourrais jamais spontanément écrire des procédures anonymes imbriquées

J'aime bien les procédures anonymes (et la capture de variables) mais ce paramètre est juste une référence, rien ne t'oblige à l'écrire inline, ceci va très bien :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
function MyFunc :boolean;
begin
end;
 
Result := Console.WriteTask('Job #1', MyFunc);

Après qu'on les imbrique, ça ne change pas grand chose.

Mais que tu préfères faire autrement ou que ta boîte t'impose une certaine structure de code ; je n'y trouve rien à redire

[Andnotor]

Voici la dernière évolution de cette petite unité.

J'ai un peu retravaillé tout cela et ajouté l'information d'avancement des tâches (sur une idée de ShaiLeTroll ) et une petite animation sur les tâches en cours, un clignotement à base de ThreadPoolTimer.

Compatible minimum XE8

[anapurna]

Salut

au lieu d'utiliser des class var ...
tu ne pourrais pas utiliser des class const

Par exemple

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
    class const FTaskTexts  : array[TTaskState] of string  = ('SUCCES','ERREUR','ANNULE');
    class const FTaskColors : array[TTaskState] of word   = (fgDarkGreen, fgDarkRed, fgDarkYellow);

[Andnotor]

C'est le cas pour les couleurs, à part que la constante est déclarée dans la méthode WriteTask. Je passe par une constante là parce qu'à mon sens il n'y a pas de meilleures couleurs

Par contre je voulais pouvoir personnaliser les textes (DONE/FAIL, OK/KO, O/X). Voire ne pas les gérer et laisser la main au callback pour, par exemple, afficher le numéro d'une erreur : E1234. Dans ce deuxième cas on ne fait que réserver une taille pour la zone de status (entre crochets) par une des trois chaînes constituée d'espace uniquement, d'où le test FTaskTexts[State].Trim.Length > 0.

Après, class const n'existe pas. Une constante est par définition accessible sans instanciation
On crée juste un bloc private const, public const.

[anapurna]

Salut

Autant pour moi , j'ai confondu avec l'autre EDI
PAr contre ton

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

FTaskTexts[State].Trim.Length > 0.

je trouve cela spécial . je serai à la limite parti avec un tableau de Boolean ou d'entier
pour savoir si je doit afficher ou non le libelle sans modification
Mais bon chacun sa façon de faire

[Andnotor]

Il aurait alors encore fallu une propriété pour la taille, mais pourquoi pas

Là on peut laisser SUCCES (qui fixe 6 caractères) et juste effacer ERROR, sans complication, pour les E1234.