Bitmap zu Ascii , schnelle Routiene gesucht.

[Namenloser]

Zitat von himitsu:

Selbst wenn TBitmap.Scanline nicht threadsave ist, könnte man sich die Scanline-Pointer vorher holen und an die Threads abgeben.

Jo, könnte man, muss man aber nicht

[turboPASCAL]

Ja, nun klappt es mit der Farbe. Leider noch nicht zu 100% da ich schwierigkeiten habe mit
dem erstellen der "Dos"- Farbpallette.

[Namenloser]

Nett Source Code?
Allerdings solltest du für die Textausgabe (Lauftext) Cleartype ausschalten.

[igel457]

Da es sich um das Konsolenfenster handelt, schätze ich kaum, dass man dort Kontrolle über ClearType hat

[Namenloser]

Zitat von igel457:

Da es sich um das Konsolenfenster handelt, schätze ich kaum, dass man dort Kontrolle über ClearType hat

Ich meine nicht die ausgegebenen ASCII-Zeichen. Ich meine den Lauftext. Der ist an manchen Stellen z.B. rot, wegen Cleartype, nehme ich an.

[turboPASCAL]

Zitat von NamenLozer:

Nett

THX.

Zitat von NamenLozer:

Source Code?

Klar, hier:

Delphi-Quellcode:

type
  TvColors = array [0..7, 0..1] of byte;

const
  RGBData: array[0..7] of TvColors = (
    (($B1, $4F), ($B1, $6F), ($B1, $7E), ($B1, $2F), ($B1, $3F), ($B1, $1F), ($B1, $5F), ($B1, $4F)),
    (($B2, $7C), ($B1, $76), ($B1, $7E), ($B2, $7A), ($B2, $7B), ($B1, $79), ($B2, $7D), ($B2, $7C)),
    (($B1, $4C), ($B2, $76), ($B2, $7E), ($B1, $2A), ($B1, $3B), ($B1, $09), ($B1, $5D), ($B1, $4C)),
    (($B0, $4C), ($B2, $76), ($B2, $7E), ($B0, $2A), ($B0, $3B), ($B0, $19), ($B0, $5D), ($B0, $4C)),
    (($B0, $44), ($B0, $66), ({DB}$B0, $0E), ($B2, $22), ($B2, $33), ($B2, $11), ($B2, $55), ($B2, $44)),
    (($B2, $04), ($B2, $06), ($B2, $0E), ($B2, $02), ($B2, $03), ($B2, $01), ($B2, $05), ($B2, $04)),
    (($B1, $04), ($B1, $06), ($B1, $0E), ($B1, $02), ($B1, $03), ($B1, $01), ($B1, $05), ($B1, $04)),
    (($B0, $04), ($B0, $06), ($B0, $0E), ($B0, $02), ($B0, $03), ($B0, $01), ($B0, $05), ($B0, $04)));

procedure TDosASCIIText.RGBtoHSL(Color: COLORREF; out H, S, L: Single);
var
  Delta: Single;
  CMax, CMin: Single;
  Red, Green, Blue : Single;
begin
  Red := GetRValue(Color) / 255;
  Green := GetGValue(Color) / 255;
  Blue := GetBValue(Color) / 255;

  CMax := Max(Red, Max(Green, Blue));
  CMin := Min(Red, Min(Green, Blue));
  L := (CMax + CMin) / 2;
  if CMax = CMin then
  begin
    S := 0;
    H := 0;
  end else
  begin
    if L < 0.5
      then S := (CMax - CMin) / (CMax + CMin)
      else S := (cmax - cmin) / (2 - cmax - cmin);

    delta := CMax - CMin;

    if Red = CMax then H := (Green - Blue) / Delta
    else
      if Green = CMax then H := 2 + (Blue - Red) / Delta
      else H := 4.0 + (Red - Green) / Delta;

    H := H / 6;

    if H < 0 then H := H + 1;
  end;

  H := (H * 360);  // 0.0 .. 360.0
  S := (S * 100);  // 0.0 .. 100.0
  L := (L * 100);  // 0.0 .. 100.0
end;

procedure TDosASCIIText.RGBToHSL_AsInteger(const Color: COLORREF; out Huge, Saturation, Luminance: integer);
var _Huge, _Saturation, _Luminance: single;
begin
  RGBToHSL(Color, _Huge, _Saturation, _Luminance);
  Huge := round(_Huge );
  Saturation := round(_Saturation);
  Luminance := round(_Luminance);
end;


procedure TDosASCIIText.BitmapToArray(var conBuffer: TConBuffer);
type
  TRGBA = packed record
    B, G, R, A: Byte;
  end;
  PRGBA = ^TRGBA;
var
  xx,yy: integer;
  rgba: prgba;

  C: Byte;
  Ch: Char;

  H, S, L, p, p2,p3: integer;

  function _SetTextColor(FColor, BColor: Byte): Byte;
  begin
    Result := FColor or (BColor shl 4);
  end;

begin
  for yy := 0 to BmpH - 1 do
  begin
    for xx := 0 to BmpW - 1 do
    begin
      rgba := pRGBA(DWORD(pBmpBits) + DWORD(xx + yy * BmpW) * 4);
      RGBToHSL_AsInteger(RGB(rgba.R, rgba.G, rgba.B), H, S, L);

      c := 0;
      ch := #0;
      
      if (H = 0) and (S = 0) then  // black & white gedöns
      begin
        case L of
           0.. 25: C := 0;
          26.. 50: C := 8;
          51.. 75: C := 7;
          76..100: C := 15;
        end;
        case L of
           0.. 19: Ch := ' ';
          20.. 39: Ch := '°';
          40.. 59: Ch := '±';
          60.. 79: Ch := '²';
          80..100: Ch := 'Û';
        end;
      end else
      begin                        // Farbe
        p := round( (H / 360) * 100     );
        p := round( (7 / 100) * p       );

        // sättigung & hälligkeit zusammen packen ???
        p2:= round( (7 / 100) * l       );
        p3:= round( (7 / 100) * s       );

        p2 := (p2 + p3) div 2;  

        C  := RGBData[7-p2,p,1];  //?farben im array vertauscht ?
        Ch := chr( RGBData[p2,p,0] );
      end;

      conBuffer[xx + yy * BmpW].AsciiChar := Ch;
      conBuffer[xx + yy * BmpW].Attributes := C;
    end;
  end;
end;

Zitat von NamenLozer:

Allerdings solltest du für die Textausgabe (Lauftext) Cleartype ausschalten.

Cleartype ham' 'wer ned.

//Edit:
kleines Update in Post #12 wegen einem Fehler