『プログラミング作法』の中に出てくる、マルコフ連鎖 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 らしく書いてみたい。
