カーニハンのプログラミング作法を Delphi で

『プログラミング作法』の中に出てくる、マルコフ連鎖 C バージョンを Delphi で書いてみた。ただし、標準入出力は使わずに、TStringList にテキストを読んでしまってから処理。結果も TStringList に返ってくるようにしてみた。

unit Markov_C;

interface

uses
  Classes, SysUtils, Windows;

const
  NPREF = 2;
  NHASH = 4093;
  MAXGEN = 10000;
  NONWORD = #$0A;

type
  PPrefix = ^TPrefix;
  TPrefix = array[0..NPREF-1] of PChar;
  PSuffix = ^TSuffix;
  PState = ^TState;
  TState = packed record
    Pref: TPrefix;
    Suf: PSuffix;
    Next: PState;
  end;
  TSuffix = packed record
    Word: PChar;
    Next: PSuffix;
  end;
  
var
  StateTab: array[0..NHASH-1] of PState;

function Hash(S: PPrefix): Cardinal;
function Lookup(Prefix: PPrefix; Create: Boolean): PState;
procedure Build(Prefix: PPrefix; FileName: string);
procedure Add(Prefix: PPrefix; Suffix: PChar);
procedure AddSuffix(SP: PState; Suffix: PChar);
procedure Generate(nWords: Integer; SL: TStringList);

implementation

function Hash(S: PPrefix): Cardinal;
var
  H: Cardinal;
  P: PChar;
  I: Integer;
const
  MULTIPLIER = 31; // set 31 or 37
begin
  H := 0;
  for I := 0 to NPREF - 1 do
  begin
    P := S[I];
    while Ord(P^) <> 0 do
    begin
      H := MULTIPLIER * H + Ord(P^);
      Inc(P);
    end;
  end;
  Result := H mod NHASH;
end;

function Lookup(Prefix: PPrefix; Create: Boolean): PState;
var
  I, H: Integer;
  SP: PState;
begin
  H := Hash(Prefix);
  SP := StateTab[H];
  while SP <> nil do
  begin
    for I := 0 to NPREF - 1 do
      if StrComp(Prefix[I], SP.Pref[I]) <> 0 then
        Break;
    if I = NPREF then
    begin
      Result := SP;
      Exit;
    end;
    SP := SP.Next;
  end;
  if Create then
  begin
    GetMem(SP, Sizeof(TState));
    for I := 0 to NPREF - 1 do
      SP.Pref[I] := Prefix[I];
    SP.Suf := nil;
    SP.Next := StateTab[H];
    StateTab[H] := SP;
  end;
  Result := SP;
end;

procedure Build(Prefix: PPrefix; FileName: string);
var
  SL: TStringList;
  I: Integer;
  Buf: PChar;
begin
  SL := TStringList.Create;
  try
    SL.LoadFromFile(FileName);
    SL.Text := StringReplace(SL.Text, ' ', #$0D#$0A, [rfReplaceAll]);
    for I := 0 to SL.Count - 1 do
      if SL[I] <> '' then
      begin
        GetMem(Buf, Length(SL[I]) + 1);
        StrCopy(Buf, PChar(SL[I]));
        Add(Prefix, Buf);
      end;
  finally
    SL.Free;
  end;
end;

procedure Add(Prefix: PPrefix; Suffix: PChar);
var
  SP: PState;
begin
  SP := Lookup(Prefix, True);
  AddSuffix(SP, Suffix);
  System.Move(Prefix[1], Prefix[0], (NPREF-1)*SizeOf(Prefix[0]));
  Prefix[NPREF-1] := Suffix;
end;

procedure AddSuffix(SP: PState; Suffix: PChar);
var
  Suf: PSuffix;
begin
  GetMem(Suf, SizeOf(TSuffix));
  Suf.Word := Suffix;
  Suf.Next := SP.Suf;
  SP.Suf := Suf;
end;

procedure Generate(nWords: Integer; SL: TStringList);
var
  SP: PState;
  Suf: PSuffix;
  Prefix: TPrefix;
  W: PChar;
  I, nMatch: Integer;
begin
  for I := 0 to NPREF - 1 do
    Prefix[I] := NONWORD;
  Randomize;
  W := nil; //コンパイラを黙らせる
  for I := 0 to nWords - 1 do
  begin
    SP := Lookup(@Prefix, False);
    nMatch := 0;
    Suf := SP.Suf;
    while Suf <> nil do
    begin
      Inc(nMatch);
      if (Random($7FFF) mod nMatch) = 0 then
        W := Suf.Word;
      Suf := Suf.Next;
    end;
    if StrComp(W, NONWORD) = 0 then
      Break;
    SL.Add(W);
    System.Move(Prefix[1], Prefix[0], (NPREF-1)*SizeOf(Prefix[0]));
    Prefix[NPREF-1] := W;
  end;
end;

end.

使うときはこんな感じ

procedure TForm1.btnBuildAndSaveClick(Sender: TObject);
var
  Prefix: TPrefix;
  I: Integer;
  SL: TStringList;
  FileName: string;
begin
  if not OpenDialog1.Execute then Exit;
  FileName := OpenDialog1.FileName;
  for I := 0 to NPREF - 1 do
    Prefix[I] := NONWORD;
  Build(@Prefix, FileName);
  Add(@Prefix, NONWORD);
  SL := TStringList.Create;
  try
    Generate(MAXGEN, SL);
    SL.Text := StringReplace(SL.Text, #$0D#$0A, ' ', [rfReplaceAll]);
    SL.SaveToFile(ChangeFileExt(FileName, '_out.txt'));
  finally
    SL.Free;
  end;
end;

なんか冗長な感じ・・・ツッコミ希望。次は Java, C++ バージョンを Delphi らしく書いてみたい。