sakurasuite/SsPlayTime.pas

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