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   TSsPlayTimeSpecialChar = class(TCollectionItem)
  19   private
  20     FWait: integer;
  21     FChar: String;
  22     procedure SetChar(const Value: String);
  23     procedure SetWait(const Value: integer);
  24   protected
  25     function GetDisplayName: String; override;
  26   public
  27     procedure Assign(Source: TPersistent); override;
  28     function DisplayChar: String;
  29   published
  30     property Char: String read FChar write SetChar;
  31     property Wait: integer read FWait write SetWait;
  32   end;
  33
  34   TSsPlayTimeSpecialChars = class(TCollection)
  35   end;
  36
  37   TSsPlayTimeParams = class(TComponent)
  38   private
  39     FCostWait: integer;
  40     FCostDBChar: integer;
  41     FCostChar: integer;
  42     FCostConst: integer;
  43     FCostHiResWait: integer;
  44     FCostSurface: integer;
  45     FCostQuickChar: integer;
  46     FProfileName: String;
  47     FSpecialChars: TSsPlayTimeSpecialChars;
  48     procedure SetCostChar(const Value: integer);
  49     procedure SetCostConst(const Value: integer);
  50     procedure SetCostDBChar(const Value: integer);
  51     procedure SetCostWait(const Value: integer);
  52     procedure SetCostHiResWait(const Value: integer);
  53     procedure SetCostSurface(const Value: integer);
  54     procedure SetCostQuickChar(const Value: integer);
  55     procedure SetProfileName(const Value: String);
  56     procedure SetSpecialChars(const Value: TSsPlayTimeSpecialChars);
  57   public
  58     constructor Create(AOwner: TComponent); override;
  59     destructor Destroy; override;
  60     procedure Assign(Source: TPersistent); override;
  61   published
  62     property ProfileName: String read FProfileName write SetProfileName;
  63     property CostConst: integer read FCostConst write SetCostConst default 0;
  64     property CostWait: integer read FCostWait write SetCostWait default 50;
  65     property CostHiResWait: integer read FCostHiResWait write SetCostHiResWait default 1;
  66     property CostSurface: integer read FCostSurface write SetCostSurface default 5;
  67     property CostChar: integer read FCostChar write SetCostChar default 50;
  68     property CostDBChar: integer read FCostDBChar write SetCostDBChar default 50;
  69     property CostQuickChar: integer read FCostQuickChar write SetCostQuickChar default 0;
  70     property SpecialChars: TSsPlayTimeSpecialChars read FSpecialChars write SetSpecialChars;
  71   end;
  72
  73   TSsPlayTimeCount = record
  74     Wait: integer;
  75     HiResWait: integer;
  76     Surface: integer;
  77     Char: integer;
  78     DBChar: integer;
  79     QuickChar: integer;
  80     Specials: integer;
  81   end;
  82
  83   TSsPlayTime = class(TComponent)
  84   private
  85     FPlayTimeParams: TSsPlayTimeParams;
  86     FSsParser: TSsParser;
  87     FCounts: TSsPlayTimeCount;
  88     procedure SetPlayTimeParams(const Value: TSsPlayTimeParams);
  89     procedure SetSsParser(const Value: TSsParser);
  90   protected
  91     procedure CountElements;
  92     procedure CountCharacterType(const Str: String; out SB, DB,
  93       SPNum, SPWait: integer);
  94   public
  95     function PlayTime(const Script: String): integer;
  96     property Counts: TSsPlayTimeCount read FCounts;
  97   published
  98     property PlayTimeParams: TSsPlayTimeParams read FPlayTimeParams write SetPlayTimeParams;
  99     property SsParser: TSsParser read FSsParser write SetSsParser;
 100   end;
 101
 102 procedure Register;
 103
 104 implementation
 105
 106 const
 107   CDBWhiteSpace = #129 + #64; // Shift_JIS DB White Space;
 108
 109 procedure Register;
 110 begin
 111   RegisterComponents('Samples', [TSsPlayTime, TSsPlayTimeParams]);
 112 end;
 113
 114 { TSsPlayTimeParams }
 115
 116 procedure TSsPlayTimeParams.Assign(Source: TPersistent);
 117 var
 118   Src: TSsPlayTimeParams;
 119 begin
 120   if not (Source is TSsPlayTimeParams) then
 121     inherited
 122   else
 123   begin
 124     Src := Source as TSsPlayTimeParams;
 125     FCostConst        := Src.FCostConst;
 126     FCostWait         := Src.FCostWait;
 127     FCostHiResWait    := Src.FCostHiResWait;
 128     FCostSurface      := Src.FCostSurface;
 129     FCostChar         := Src.FCostChar;
 130     FCostDBChar       := Src.FCostDBChar;
 131     FCostQuickChar    := Src.FCostQuickChar;
 132     FProfileName      := Src.FProfileName;
 133     FSpecialChars.Assign(Src.SpecialChars);
 134   end;
 135 end;
 136
 137 constructor TSsPlayTimeParams.Create(AOwner: TComponent);
 138 begin
 139   inherited;
 140   FCostConst        := 0;
 141   FCostWait         := 50;
 142   FCostHiResWait    := 1;
 143   FCostSurface      := 5;
 144   FCostChar         := 50;
 145   FCostDBChar       := 50;
 146   FCostQuickChar    := 0;
 147   FSpecialChars := TSsPlayTimeSpecialChars.Create(TSsPlayTimeSpecialChar);
 148 end;
 149
 150 destructor TSsPlayTimeParams.Destroy;
 151 begin
 152   FSpecialChars.Free;
 153   inherited;
 154 end;
 155
 156 procedure TSsPlayTimeParams.SetCostChar(const Value: integer);
 157 begin
 158   FCostChar := Value;
 159 end;
 160
 161 procedure TSsPlayTimeParams.SetCostConst(const Value: integer);
 162 begin
 163   FCostConst := Value;
 164 end;
 165
 166 procedure TSsPlayTimeParams.SetCostDBChar(const Value: integer);
 167 begin
 168   FCostDBChar := Value;
 169 end;
 170
 171 procedure TSsPlayTimeParams.SetCostHiResWait(const Value: integer);
 172 begin
 173   FCostHiResWait := Value;
 174 end;
 175
 176 procedure TSsPlayTimeParams.SetCostQuickChar(const Value: integer);
 177 begin
 178   FCostQuickChar := Value;
 179 end;
 180
 181 procedure TSsPlayTimeParams.SetCostSurface(const Value: integer);
 182 begin
 183   FCostSurface := Value;
 184 end;
 185
 186 procedure TSsPlayTimeParams.SetCostWait(const Value: integer);
 187 begin
 188   FCostWait := Value;
 189 end;
 190
 191 procedure TSsPlayTimeParams.SetProfileName(const Value: String);
 192 begin
 193   FProfileName := Value;
 194 end;
 195
 196 procedure TSsPlayTimeParams.SetSpecialChars(
 197   const Value: TSsPlayTimeSpecialChars);
 198 begin
 199   FSpecialChars.Assign(Value);
 200 end;
 201
 202 { TSsPlayTime }
 203
 204 procedure TSsPlayTime.CountCharacterType(const Str: String; out SB,
 205   DB, SPNum, SPWait: integer);
 206 var
 207   i, j: integer;
 208   InLeadByte, Flag: boolean;
 209   AChar: TSsPlayTimeSpecialChar;
 210 begin
 211   SB := 0;
 212   DB := 0;
 213   SPNum := 0;
 214   SPWait := 0;
 215   InLeadByte := false;
 216   for i := 1 to Length(Str) do
 217   begin
 218     if InLeadByte then
 219     begin
 220       Inc(DB);
 221       InLeadByte := false;
 222     end
 223     else
 224     begin
 225       Flag := false;
 226       for j := 0 to PlayTimeParams.SpecialChars.Count-1 do
 227       begin
 228         AChar := PlayTimeParams.SpecialChars.Items[j] as TSsPlayTimeSpecialChar;
 229         if Length(AChar.Char) = 2 then
 230         begin
 231           if Str[i] + Str[i+1] = AChar.Char then
 232           begin
 233             Inc(SPWait, AChar.Wait);
 234             Inc(SPNum);
 235             Dec(DB);
 236             Flag := true;
 237             InLeadByte := true;
 238             Break;
 239           end;
 240         end else
 241         begin
 242           if Str[i] = AChar.Char then
 243           begin
 244             Inc(SPWait, AChar.Wait);
 245             Inc(SPNum);
 246             Flag := true;
 247             Break;
 248           end;
 249         end;
 250       end;
 251       if not Flag then
 252       begin
 253         if Str[i] in LeadBytes then
 254           InLeadByte := true
 255         else
 256           Inc(SB);
 257       end;
 258     end;
 259   end;
 260 end;
 261
 262 procedure TSsPlayTime.CountElements;
 263 var
 264   i, SB, DB, SPNum, SPWait: integer;
 265   Mark: String;
 266   InQuick: boolean;
 267 begin
 268   ZeroMemory(@FCounts, sizeof(FCounts));
 269   InQuick := false;
 270   with SsParser do
 271   begin
 272     for i := 0 to SsParser.Count-1 do
 273     begin
 274       Mark := Str[i];
 275       case MarkUpType[i] of
 276         mtTag:
 277           begin
 278             if Mark = '\_q' then
 279               InQuick := not InQuick
 280             else if Match(Mark, '\w%d') = 3 then
 281               FCounts.Wait := FCounts.Wait + Ord(Mark[3]) - Ord('0')
 282             else if Match(Mark, '\_w[%D]') > 0 then
 283               Inc(FCounts.HiResWait, StrToInt(GetParam(Mark, 0)))
 284             else if Match(Mark, '\s%d') = 3 then
 285               Inc(FCounts.Surface)
 286             else if Match(Mark, '\s%b') > 0 then
 287               Inc(FCounts.Surface)
 288           end;
 289         mtMeta, mtStr:
 290           begin
 291             if InQuick then
 292             begin
 293               CountCharacterType(Mark, SB, DB, SPNum, SPWait);
 294               Inc(FCounts.QuickChar, SB + DB + SPNum);
 295             end else
 296             begin
 297               CountCharacterType(Mark, SB, DB, SPNum, SPWait);
 298               Inc(FCounts.Char, SB);
 299               Inc(FCounts.DBChar, DB);
 300               Inc(FCounts.Specials, SPWait);
 301             end;
 302           end;
 303         // Ignore all tag errors
 304       end;
 305     end;
 306   end;
 307 end;
 308
 309 function TSsPlayTime.PlayTime(const Script: String): integer;
 310 begin
 311   Result := 0;
 312   if FSsParser = nil then
 313     raise TSsPlayTimeInitException.Create('SsParser is not set');
 314   if FPlayTimeParams = nil then
 315     raise TSsPlayTimeInitException.Create('PlayTimeParams is not set');
 316   SsParser.InputString := Script;
 317   CountElements;
 318   with PlayTimeParams do
 319     Result := CostConst + CostWait * FCounts.Wait + CostSurface * FCounts.Surface +
 320       CostHiResWait * FCounts.HiResWait + CostChar * FCounts.Char +
 321       CostDBChar * FCounts.DBChar + FCounts.Specials +
 322       CostQuickChar * FCounts.QuickChar;
 323 end;
 324
 325 procedure TSsPlayTime.SetPlayTimeParams(const Value: TSsPlayTimeParams);
 326 begin
 327   FPlayTimeParams := Value;
 328 end;
 329
 330 procedure TSsPlayTime.SetSsParser(const Value: TSsParser);
 331 begin
 332   FSsParser := Value;
 333 end;
 334
 335 { TSsPlayTimeSpecialChar }
 336
 337 procedure TSsPlayTimeSpecialChar.Assign(Source: TPersistent);
 338 begin
 339   if not(Source is TSsPlayTimeSpecialChar) then
 340     inherited
 341   else
 342   begin
 343     Self.FChar := (Source as TSsPlayTimeSpecialChar).FChar;
 344     Self.FWait := (Source as TSsPlayTimeSpecialChar).FWait;
 345   end;
 346 end;
 347
 348 function TSsPlayTimeSpecialChar.DisplayChar: String;
 349 begin
 350   if FChar = ' ' then
 351     Result := '(SP)'
 352   else if FChar = CDBWhiteSpace then
 353     Result := '(DB SP)'
 354   else
 355     Result := FChar;
 356 end;
 357
 358 function TSsPlayTimeSpecialChar.GetDisplayName: String;
 359 begin
 360   Result := Format('"%s" = %d', [DisplayChar, FWait]);
 361 end;
 362
 363 procedure TSsPlayTimeSpecialChar.SetChar(const Value: String);
 364 begin
 365   if Value = '' then
 366     FChar := Value
 367   else
 368   begin
 369     if (Value[1] in LeadBytes) then
 370     begin
 371       if Length(Value) = 2 then
 372         FChar := Value;
 373     end else if Length(Value) = 1 then
 374       FChar := Value;
 375   end;
 376 end;
 377
 378 procedure TSsPlayTimeSpecialChar.SetWait(const Value: integer);
 379 begin
 380   FWait := Value;
 381 end;
 382
 383 end.
 384