sakurasuite/SsPlayTime.pas

   1 {*************************************************************}
   2 { TSsPlayTime Component - Estimates SakuraScript playing time }
   3 {                                                             }
   4 {       Copyright (c) 2001-2003 naruto/CANO-Lab               }
   5 {*************************************************************}
   6
   7 unit SsPlayTime;
   8
   9 interface
  10
  11 uses
  12   Windows, SysUtils, Classes, SsParser;
  13
  14 type
  15   TSsPlayTimeException = class(Exception);
  16   TSsPlayTimeInitException = class(TSsPlayTimeException);
  17
  18   TSsPlayTimeParams = class(TComponent)
  19   private
  20     FCostWait: integer;
  21     FCostDBChar: integer;
  22     FCostChar: integer;
  23     FCostConst: integer;
  24     FCostHiResWait: integer;
  25     FCostSurface: integer;
  26     FCostQuickChar: integer;
  27     FCostWhiteSpace: integer;
  28     FCostDBWhiteSpace: integer;
  29     FProfileName: String;
  30     procedure SetCostChar(const Value: integer);
  31     procedure SetCostConst(const Value: integer);
  32     procedure SetCostDBChar(const Value: integer);
  33     procedure SetCostWait(const Value: integer);
  34     procedure SetCostHiResWait(const Value: integer);
  35     procedure SetCostSurface(const Value: integer);
  36     procedure SetCostQuickChar(const Value: integer);
  37     procedure SetProfileName(const Value: String);
  38   public
  39     constructor Create(AOwner: TComponent); override;
  40     procedure Assign(Source: TPersistent); override;
  41   published
  42     property ProfileName: String read FProfileName write SetProfileName;
  43     property CostConst: integer read FCostConst write SetCostConst default 0;
  44     property CostWait: integer read FCostWait write SetCostWait default 50;
  45     property CostHiResWait: integer read FCostHiResWait write SetCostHiResWait default 1;
  46     property CostSurface: integer read FCostSurface write SetCostSurface default 5;
  47     property CostChar: integer read FCostChar write SetCostChar default 50;
  48     property CostDBChar: integer read FCostDBChar write SetCostDBChar default 50;
  49     property CostWhiteSpace: integer read FCostWhiteSpace write FCostWhiteSpace default 10;
  50     property CostDBWhiteSpace: integer read FCostDBWhiteSpace write FCostDBWhiteSpace default 10;
  51     property CostQuickChar: integer read FCostQuickChar write SetCostQuickChar default 0;
  52   end;
  53
  54   TSsPlayTimeCount = record
  55     Wait: integer;
  56     HiResWait: integer;
  57     Surface: integer;
  58     Char: integer;
  59     DBChar: integer;
  60     WhiteSpace: integer;
  61     DBWhiteSpace : integer;
  62     QuickChar: integer;
  63   end;
  64
  65   TSsPlayTime = class(TComponent)
  66   private
  67     FPlayTimeParams: TSsPlayTimeParams;
  68     FSsParser: TSsParser;
  69     FCounts: TSsPlayTimeCount;
  70     procedure SetPlayTimeParams(const Value: TSsPlayTimeParams);
  71     procedure SetSsParser(const Value: TSsParser);
  72   protected
  73     procedure CountElements;
  74     procedure CountCharacterType(const Str: String; out SB, DB,
  75       SBS, DBS: integer);
  76   public
  77     function PlayTime(const Script: String): integer;
  78     property Counts: TSsPlayTimeCount read FCounts;
  79   published
  80     property PlayTimeParams: TSsPlayTimeParams read FPlayTimeParams write SetPlayTimeParams;
  81     property SsParser: TSsParser read FSsParser write SetSsParser;
  82   end;
  83
  84 procedure Register;
  85
  86 implementation
  87
  88 const
  89   CDBWhiteSpace = #129 + #64; // Shift_JIS DB White Space;
  90
  91 procedure Register;
  92 begin
  93   RegisterComponents('Samples', [TSsPlayTime, TSsPlayTimeParams]);
  94 end;
  95
  96 { TSsPlayTimeParams }
  97
  98 procedure TSsPlayTimeParams.Assign(Source: TPersistent);
  99 var
 100   Src: TSsPlayTimeParams;
 101 begin
 102   if not (Source is TSsPlayTimeParams) then
 103     inherited
 104   else
 105   begin
 106     Src := Source as TSsPlayTimeParams;
 107     FCostConst        := Src.FCostConst;
 108     FCostWait         := Src.FCostWait;
 109     FCostHiResWait    := Src.FCostHiResWait;
 110     FCostSurface      := Src.FCostSurface;
 111     FCostChar         := Src.FCostChar;
 112     FCostDBChar       := Src.FCostDBChar;
 113     FCostWhiteSpace   := Src.FCostWhiteSpace;
 114     FCostDBWhiteSpace := Src.FCostDBWhiteSpace;
 115     FCostQuickChar    := Src.FCostQuickChar;
 116     FProfileName      := Src.FProfileName;
 117   end;
 118 end;
 119
 120 constructor TSsPlayTimeParams.Create(AOwner: TComponent);
 121 begin
 122   inherited;
 123   FCostConst        := 0;
 124   FCostWait         := 50;
 125   FCostHiResWait    := 1;
 126   FCostSurface      := 5;
 127   FCostChar         := 50;
 128   FCostDBChar       := 50;
 129   FCostWhiteSpace   := 10;
 130   FCostDBWhiteSpace := 10;
 131   FCostQuickChar    := 0;
 132 end;
 133
 134 procedure TSsPlayTimeParams.SetCostChar(const Value: integer);
 135 begin
 136   FCostChar := Value;
 137 end;
 138
 139 procedure TSsPlayTimeParams.SetCostConst(const Value: integer);
 140 begin
 141   FCostConst := Value;
 142 end;
 143
 144 procedure TSsPlayTimeParams.SetCostDBChar(const Value: integer);
 145 begin
 146   FCostDBChar := Value;
 147 end;
 148
 149 procedure TSsPlayTimeParams.SetCostHiResWait(const Value: integer);
 150 begin
 151   FCostHiResWait := Value;
 152 end;
 153
 154 procedure TSsPlayTimeParams.SetCostQuickChar(const Value: integer);
 155 begin
 156   FCostQuickChar := Value;
 157 end;
 158
 159 procedure TSsPlayTimeParams.SetCostSurface(const Value: integer);
 160 begin
 161   FCostSurface := Value;
 162 end;
 163
 164 procedure TSsPlayTimeParams.SetCostWait(const Value: integer);
 165 begin
 166   FCostWait := Value;
 167 end;
 168
 169 procedure TSsPlayTimeParams.SetProfileName(const Value: String);
 170 begin
 171   FProfileName := Value;
 172 end;
 173
 174 { TSsPlayTime }
 175
 176 procedure TSsPlayTime.CountCharacterType(const Str: String; out SB,
 177   DB, SBS, DBS: integer);
 178 var
 179   i: integer;
 180   InLeadByte: boolean;
 181 begin
 182   SB := 0;
 183   DB := 0;
 184   SBS := 0;
 185   DBS := 0;
 186   InLeadByte := false;
 187   for i := 1 to Length(Str) do
 188   begin
 189     if InLeadByte then
 190     begin
 191       Inc(DB);
 192       InLeadByte := false;
 193     end
 194     else if Str[i] in LeadBytes then
 195     begin
 196       InLeadByte := true;
 197       if Str[i] + Str[i+1] = CDBWhiteSpace then
 198       begin
 199         Inc(DBS);
 200         Dec(DB);
 201       end;
 202     end
 203     else if Str[i] = ' ' then
 204       Inc(SBS)
 205     else
 206       Inc(SB);
 207   end;
 208 end;
 209
 210 procedure TSsPlayTime.CountElements;
 211 var
 212   i, SB, DB, SBS, DBS: integer;
 213   Mark: String;
 214   InQuick: boolean;
 215 begin
 216   ZeroMemory(@FCounts, sizeof(FCounts));
 217   InQuick := false;
 218   with SsParser do
 219   begin
 220     for i := 0 to SsParser.Count-1 do
 221     begin
 222       Mark := Str[i];
 223       case MarkUpType[i] of
 224         mtTag:
 225           begin
 226             if Mark = '\_q' then
 227               InQuick := not InQuick
 228             else if Match(Mark, '\w%d') = 3 then
 229               FCounts.Wait := FCounts.Wait + Ord(Mark[3]) - Ord('0')
 230             else if Match(Mark, '\_w[%D]') > 0 then
 231               Inc(FCounts.HiResWait, StrToInt(GetParam(Mark, 0)))
 232             else if Match(Mark, '\s%d') = 3 then
 233               Inc(FCounts.Surface)
 234             else if Match(Mark, '\s%b') > 0 then
 235               Inc(FCounts.Surface)
 236           end;
 237         mtMeta, mtStr:
 238           begin
 239             if InQuick then
 240             begin
 241               CountCharacterType(Mark, SB, DB, SBS, DBS);
 242               Inc(FCounts.QuickChar, SB + DB + SBS + DBS);
 243             end else
 244             begin
 245               CountCharacterType(Mark, SB, DB, SBS, DBS);
 246               Inc(FCounts.Char, SB);
 247               Inc(FCounts.DBChar, DB);
 248               Inc(FCounts.WhiteSpace, SBS);
 249               Inc(FCounts.DBWhiteSpace, DBS);
 250             end;
 251           end;
 252         // Ignore all tag errors
 253       end;
 254     end;
 255   end;
 256 end;
 257
 258 function TSsPlayTime.PlayTime(const Script: String): integer;
 259 begin
 260   Result := 0;
 261   if FSsParser = nil then
 262     raise TSsPlayTimeInitException.Create('SsParser is not set');
 263   if FPlayTimeParams = nil then
 264     raise TSsPlayTimeInitException.Create('PlayTimeParams is not set');
 265   try
 266     SsParser.InputString := Script;
 267     CountElements;
 268     with PlayTimeParams do
 269       Result := CostConst + CostWait * FCounts.Wait + CostSurface * FCounts.Surface +
 270         CostHiResWait * FCounts.HiResWait + CostChar * FCounts.Char +
 271         CostDBChar * FCounts.DBChar +
 272         CostWhiteSpace * FCounts.WhiteSpace + CostDBWhiteSpace * FCounts.DBWhiteSpace +
 273         CostQuickChar * FCounts.QuickChar;
 274   except
 275     Result := 0;
 276     raise;
 277   end;
 278 end;
 279
 280 procedure TSsPlayTime.SetPlayTimeParams(const Value: TSsPlayTimeParams);
 281 begin
 282   FPlayTimeParams := Value;
 283 end;
 284
 285 procedure TSsPlayTime.SetSsParser(const Value: TSsParser);
 286 begin
 287   FSsParser := Value;
 288 end;
 289
 290 end.
 291