TryStrToDateTimeEx 修正

ソースはこちら（GitHub）

昨日のエントリ「TryStrToDateTime を完璧にする」ですが、全然完璧じゃありませんでした！／(^o^)＼

２重ループを抜けていない、という問題がありました。
ということで、修正した物が↓こちらです。

function TryStrToDateTimeEx(
  const iStr: String;
  out oDateTime: TDateTime): Boolean;
label
  Last;
const
  DateSeps: array [0.. 1] of Char = ('/', '-');
  TimeSeps: array [0.. 1] of Char = (':', '.');
var
  FS: TFormatSettings;
  i, j: Integer;
begin
  FS := TFormatSettings.Create;

  for i := Low(DateSeps) to High(DateSeps) do begin
    FS.DateSeparator := DateSeps[i];

    for j := Low(TimeSeps) to High(TimeSeps) do begin
      FS.TimeSeparator := TimeSeps[j];

      Result := TryStrToDateTime(iStr, oDateTime, FS);
      if (Result) then
        goto Last;
    end;
  end;

Last:
end;

Delphi 言語には多重ループを一発で抜けるスマートな方法は用意されていません。
そのため、ここでは goto を使って抜けてみました。
本物のプログラマは goto を恐れずに使うからです！（まあ本物のプログラマは Pascal を使わずに  FORTRAN  を使うわけですがね……）

もしもここで、

for i = 0 to 99 do begin
  for j = 0 to 99 do begin
    Result := true;

    if (Result)
      Break;
  end;

  if (Result)
    Break;
end;

なんて書いた方が冗長だと判って貰えると思います。

Exit が引数を取れるようになったように、Break も一発で抜けれる機構を採り入れてくれたら、良いかも知れないですね。

TryStrToDateTime を完璧にする

※追記：2012/09/28 こちらの記事で下記の記事を修正しています

ソースはこちら（GitHub）

android Log Viewer というアンドロイド端末のログを見るツールを公開しています。

このロガーは、他のロガーから出力されるログを読み込むこともできるので、エラー発生先でログを取っておいて貰って、そのログを読み込む、といった用途にも使えます。
ですが、たまに読めないログが出てきて、その度に、ちょこちょこ直しています。

で、最近読めなかったのが adb 形式のログなのに各要素のセパレータが #$1d  じゃないもの。
で、なんで読めないのかなーと思っていたら TryStrToDateTime でこけていました。

こけた原因は DateSeparator が "-" になっていなかったから。
adb のデフォルトのセパレータは "/" ではなく "-" です。
そのため、そのまま TryStrToDateTime に流すと False を返します。

でもー。"-" も一般的だしー、そんなケチケチしないで全部見て欲しいよねーってことで、全部見るようにしました。

できたのが↓こちらになります。

function TryStrToDateTimeEx(
  const iStr: String;
  out oDateTime: TDateTime): Boolean;
const
  DateSeps: array [0.. 1] of Char = ('/', '-');
  TimeSeps: array [0.. 1] of Char = (':', '.');
var
  FS: TFormatSettings;
  i, j: Integer;
begin
  FS := TFormatSettings.Create;

  for i := Low(DateSeps) to High(DateSeps) do begin
    FS.DateSeparator := DateSeps[i];

    for j := Low(TimeSeps) to High(TimeSeps) do begin
      FS.TimeSeparator := TimeSeps[j];

      Result := TryStrToDateTime(iStr, oDateTime, FS);
      if (Result) then
        Break;
    end;
  end;
end;

ソースはこちらになります（GitHub）


コードを見ていただければ判りますが、まあ単に思いつく限りのセパレータで試してるだけ。
これで、めでたくログを読めるようになりました。

ちなみに、昔は、なんか読めたような気がするなあって思って調べてみたんですが、こんな普遍的に見えるルーチンでも、かなりコードが変更されていました。
特に Delphi 7 と XE2 では全然違いましたよ。ええ。
XE2 と XE3 でも、軽微な修正が入っていて、若干違うわけです！
こんなルーチンも、改良されて行っているわけですね。
ちなみに、昔は読めたような気がするのは気のせいでした。

FMX.Types.TCanvas.DrawLine のアンチエイリアスと DDA

サンプルソースはここから（GitHub）

twitter で LandscapeSketch （WorkToolSmith） さんから、アンチエイリアスの付いていない線を引きたい！というお話しがありました。

FireMonkey で普通に線を描こうと思ったら、↓こんなコードになります。

// FBmp は TBitmap のインスタンス
FBmp.Canvas.BeginScene;
try
  FBmp.Canvas.DrawLine(
    TPointF.Create(0, 0),
    TPointF.Create(FBmp.Width, FBmp.Height),
    1);
finally
  FBmp.Canvas.EndScene;
end;

そうすると描ける線は↓こんな風にアンチエイリアスがかかって非常にキレイな線になります。



↓線を拡大したところ


大体のケースでは線がキレイになるし問題ないんだろうと思いますが、アンチエイリアスが不必要な場合もあります。
たとえば、領域指定でアンチエイリアスの扱いをどうするのかとか……？

では、アンチエイリアスを外そう！と思っても、一筋縄ではいきません。
というのも、FireMonkey の TCanvas は複数の実装があり、TCanvas は、それらの Abstract クラスでしかないからです。

Direct2D が使える環境では TCanvasD2D が実装で、それ以外の GDI+ が使える環境では TCanvasGdiPlus が実装です。
もちろん Mac であれば、また違って TCanvasQuartz が実装になっています。

そうなると、アンチエイリアスを外そうにも実装によって異なっているため、非常に面倒な作業になります。
そもそも、アンチエイリアスを解除できない場合も想定されます。

TCanvasGdiPlus  だけアンチエイリアスを外そうと思えば外せそうです。
それは GDI＋に SetSmoothingMode という API があるからです。
ただし、TCanvasGdiPlus が持っている TGPGraphics のインスタンスは private 変数＆ pirvate メソッドでしか取得できないため、リフレクションを使うなど手荒な技が必要になります。

なお、実際にアンチエイリアスをかける実体は TStrokeBrush のインスタンスである TCanvas.Stroke です。

そういったわけで、FireMonkey でアンチエイリアスを外すくらいなら、自分で描いちゃおうぜっていうお話しです。

自分で線を描くためには DDA を使います。
DDA は Digital Differential Analyzer の略で日本語では「デジタル微分解析器」とかそんな意味です。

線を描くに当たって問題なのは「ディスプレイは画素の集まり」であって連続的な線を表せるわけでは無い事です。
そのため、始点から終点まで、どの画素を通るのかということを知る必要があります。
その計算をするのが（ここでの）DDA です。
その名の通り微分するので傾きが求まり、それをデジタル値として返します。

また、DDA が優れているのは、加算・減算・論理演算、のみで実装可能なことです。乗算や除算、小数演算などが必要無いため、非常に高速に実行できます。
ここでは Delphi 言語で実装していますが、機械語での実装も容易でしょう（有効かどうかはともあれ……）。

ということで、DDA で線の描画を実装したサンプルが↓です。


サンプルソースはここから（GitHub）


詳しい説明は、昔のデブキャンの資料（PDF）をどうぞ……と思ったら、そんなに詳しく書いていなかった件……。

大まかに説明すると、４つに場合分けします。

• 幅の方が大きい場合
• 始点の方が小さい
• 終点の方が小さい

• 高さの方が大きい場合
• 始点の方が小さい
• 終点の方が小さい

つまり、必ず小さい方から大きい方に動くように正規化してやります。
コードでは↓こんな感じです。

procedure DDA(
  iX1, iY1, iX2, iY2: Integer;
  const iOnDDAEvent: TDDAEvent;
  const iData: Pointer);
var
  （略）
begin
  XSize := abs(iX2 - iX1);
  YSize := abs(iY2 - iY1);

  if (XSize > YSize) then begin
    // 水平方向の方が広い場合
    Flag := XSize shr 1;

    if (iX1 < iX2) then begin
      // 左の方が小さい場合
      （略）
    end
    else begin
      // 右の方が小さい場合
      （略）
    end;
  end
  else begin
    // 垂直方向の方が広い場合
    Flag := YSize shr 1;

    if (iY1 < iY2) then begin
      // 上の方が小さい場合
       （略）
    end
    else begin
      // 下の方が小さい場合
      （略）
    end;
  end;
end;

それぞれの場合において、地道に X(n) に +1 をしていって、X(n+1) の値になったら Y(n)→Y(n+1) とするだけです。

全文ソースは GitHub に上がっているので、ご覧ください。

そんなこんなで DDA を使って書いた線がこちら。
赤がDDA で、青が通常の方法です。





赤の線はガックガクなのが判りますね

FMX.Types.TBitmap に ScanLine を付ける

Delphi-ML で「XE3 + FireMonkeyでScanlineプロパティが消えた？」というトピックが立ちました。

確かに、FMX.Types.TBitmap に ScanLine プロパティがありません。
Delphi-ML のログを読んでいただければ判るのですが FM2 では Map というメソッドで TBitmapData というレコードを受け取るように変わっていました。
こちらの方が洗練されていますが、今までのプログラムを移行するのは大変かもしれません。

そこで、クラスヘルパーを使って TBitmap に ScanLine を付けてみました。
ただ、終了処理が必要なので、どうしても同じにはなりませんし、初期化・終了処理がある分、速度的にも劣るかなと思います。

そんな訳で、できた Class Helper が↓こちら。
メソッド名は、BeginScanLine, EndScanLine としてみました（BeginUpdate, EndUpdate に準じた形）。

unit uBitmapScanLineHelper;

interface

uses
  FMX.Types;

type
  TBitmapScanLineHelper = class helper for TBitmap
  public
    function BeginScanLine(const Row: Integer): Pointer;
    procedure EndScanLine;
  end;

implementation

uses
  Generics.Collections, FMX.PixelFormats;

type
  TBmpDataDic = TDictionary<TBitmap, TBitmapData>;

var
  GBmpDataDic: TBmpDataDic = nil;

function TBitmapScanLineHelper.BeginScanLine(const Row: Integer): Pointer;
var
  BmpData: TBitmapData;
begin
  if (Map(TMapAccess.maReadWrite, BmpData)) then begin
    GBmpDataDic.Add(Self, BmpData);
    Result := BmpData.Data;
    Inc(PByte(Result), Row * Width * GetPixelFormatBytes(PixelFormat));
  end
  else
    Result := nil;
end;

procedure TBitmapScanLineHelper.EndScanLine;
var
  BmpData: TBitmapData;
begin
  if (GBmpDataDic.TryGetValue(Self, BmpData)) then begin
    Unmap(BmpData);
    GBmpDataDic.Remove(Self);
  end;
end;

initialization
begin
  GBmpDataDic := TBmpDataDic.Create;
end;

finalization
begin
  GBmpDataDic.Free;
end;

end.

ちなみに Class Helper はメンバー変数を持てない（追加できない）ので、ユニット変数(GBmpDataDic)を使って BitmapData を管理しています。

uBitmapScanLineHelper ソースはこちら（GitHub）


使い方は↓こんな感じです。

uses

  uBitmapScanLineHelper;

procedure TForm1.FormCreate(Sender: TObject);
const
  BMP_WIDTH = 320;
  BMP_HEIGHT = 240;
type
  PDWordArray = ^TDWordArray;
  TDWordArray = array [0.. 1] of DWORD;
var
  X, Y: Integer;
  Data: PDWordArray;
  Color: Cardinal;
begin
  Randomize;

  FBmp := TBitmap.Create(BMP_WIDTH, BMP_HEIGHT);

  // PixelFormat が A8R8G8B の 32bit を前提としています
  for Y := 0 to FBmp.Height - 1 do begin
    Color := $ff000000 or Cardinal(Random($1000000));

    Data := FBmp.BeginScanLine(Y);
    try
      for X := 0 to FBmp.Width - 1 do
        PDWordArray(Data)[X] := Color;
    finally
      FBmp.EndScanLine;
    end;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FBmp.Free;
end;

procedure TForm1.FormPaint(
  Sender: TObject;
  Canvas: TCanvas;
  const ARect: TRectF);
var
  W, H: Integer;
begin
  W := FBmp.Width;
  H := FBmp.Height;

  Canvas.DrawBitmap(
    FBmp,
    TRectF.Create(0, 0, W, H),
    TRectF.Create(0, 0, W, H),
    1);
end;

実行結果




あと、

BeginScanLine(0);

として呼び出せば、Map(); が返すポインタがそのまま返るので、普通に使う事もできます。

上のコードでは、for 文が回る度に BeginScanLine, EndScanLine としていますが、BeginScanLine(0); として後は自分でポインタ操作をすれば、速度は上がると思います（そうなった時点で最早 BegnScanLine を使う意味は無い本末転倒っぷりですが！）


書いているうちに、WorkToolSmith さんのところで、纏められていました！

Delphi XE3 FireMonkey変更点

HotKeyStyleHook

皆さんご存じの通り、Vcl.ComCtrls.THotKey を使うと簡単にホットキーを設定したりできます。
THotKey を実際に貼ってみると下図のように、簡単にホットキーが表示できます。

だが！しかし！
VCL スタイルを設定していると下図のように白く浮いてしまうわけです！

かっこわるい！

これは、THotKey に専用の StyleHook が用意されていないために起きています（THotKey の StyleHook は TEditStyleHook が指定されています）。

StyleHook については、こちら（ヘルプ）や、第２３回デベロッパーキャンプ 【B2】 Delphiテクニカルセッション 「見た目で楽しいDelphiプログラミング」のセッション資料を、ご覧ください。

Win32 の HotKey コントロールは自動的にホットキーを表示してくれますが、背景モードが OPAQUE になっています。
そのため、テキストの描画で、背景が塗りつぶされてしまうのです。

そこで、次の API を呼んでやります。

SetBkMode(Canvas.Handle, TRANSPARENT);

SetBkMode で TRANSPARENT に設定することで、テキストを描画したときに背景を塗りつぶさなくなります。

描画時に SetBkMode を呼ぶような Custom Style Hook の例が↓です。

unit uHotKeyStyleHook;

(略)

procedure THotKeyStyleHook.Paint(Canvas: TCanvas);
var
  Text: String;
  Shift: TShiftState;
  Key: Word;
begin
  // 表示する文字列を作成
  ShortCutToKey(THotKey(Control).HotKey, Key, Shift);

  if (ssAlt in Shift) then
    Text := Text + 'Alt + ';

  if (ssCtrl in Shift) then
    Text := Text + 'Ctrl + ';

  if (ssShift in Shift) then
    Text := Text + 'Shift + ';

  Text := Text + ShortCutToText(Key);
  
  // 背景モードを指定
  SetBkMode(Canvas.Handle, TRANSPARENT);

  // フォントカラーを StyleServices から取得
  Canvas.Font.Color := StyleServices.GetStyleFontColor(sfEditBoxTextNormal);

  // テキストを描画
  Canvas.TextOut(0, 0, Text);
end;

initialization
begin
  TCustomStyleEngine.RegisterStyleHook(THotKey, THotKeyStyleHook);
end;

end.

全ソースコードはこちら (GitHub)。

ここで、一点。
RegisterStyleHook を initialization 節に書いていますが、本来は StyleHook を適用したいコントロールの class constructor に書きます。
そうすると、そのコントロールを使わない限り、StyleHook が読み込まれることもありません。
しかし、THotKey は VCL で提供されているコントロールのため、THotKey のコードを書き換えるのは憚られます。

そのため、StyleHook 側の initialization 節に書いてみました。

この THotKeyStyleHook を使うために必要なコードは、たったこれだけです。

uses
  uHotKeyStyleHook;

uHotKeyStyleHook を組み込んだアプリは↓こちら。
ちゃんとスタイルが適用されました！！

ちなみに、このソースでは自分で文字列を組み立てて表示してますが、本当は

IAccessible::get_accKeyboardShortcut

というインターフェースから、ホットキーの組み合わせ文字列を取得できるみたいです。
僕は上手くできなかったので、どなたかお願いいたします！

CSS 修正

CSS を色々修正して、背景画像が透けるようにした！ あと、一覧で見たとき、記事の区切りが判りづらいから、タイトルに背景色つけてみた。 しばらく、これでいこうかな？

せっかく作った画像が！

背景画像頑張って作ったのに、ブログ背景で見えなくなるなんて＼(^o^)／ だから、貼っておく。

SysErrorMessage

初エントリなので軽めに。
CSS なんかの調節もしながら……。


Win32 API を呼んだとき、エラーが返ってきて、原因が知りたいなあ……

でも、メンドイなあっていうときには

System.SysUtils.SysErrorMessage()

を使うと便利です。

SysErrorMessage(GetLastError);

ってすると、簡単にエラーの原因を人間が読める文字列に！

僕は

function GetLastErrorMsg: String;
begin
  Result := SysErrorMessage(GetLastError);
end;

こんな関数を作って使っています。

test 投稿

テスト投稿ですよ。
ええ。

写真も貼ってみたりするよ。