Merge branch 'develop'

Base/Colors.pas

@@ -9,7 +9,8 @@ interface
 
  function MyColor(r,g,b:cardinal):cardinal; overload;
  function MyColor(a,r,g,b:cardinal):cardinal; overload;
- function GrayColor(gray:integer):cardinal;
+ function GrayColor(gray:integer):cardinal; // FFxxxxxx
+ function GrayAlpha(alpha:single):cardinal; // aa808080
  function SwapColor(color:cardinal):cardinal; // swap red<->blue bytes
 
  function ColorAdd(c1,c2:cardinal):cardinal;
@@ -79,6 +80,11 @@ implementation
    result:=MyColor(255,gray,gray,gray);
   end;
 
+ function GrayAlpha(alpha:single):cardinal;
+  begin
+   result:=round(Clamp(alpha,0,1)*255) shl 24+$808080;
+  end;
+
  function Lightness(color:cardinal):byte; // яркость цвета (0..255)
   begin
    result:=round(

Base/EventMan.pas

@@ -276,7 +276,7 @@ function EventOfClass(event,eventClass:EventStr;out subEvent:EventStr):boolean;
     hnd:=handlers[h];
     while hnd<>nil do begin
      if hnd.event=event then
-      if (hnd.mode=emQueued) or ((hnd.mode=emMixed) and (threads[hnd.threadNum].Thread<>trID)) then
+      if (hnd.mode=emQueued) or ((hnd.mode=emMixed) and ((time>0) or (threads[hnd.threadNum].Thread<>trID))) then
           with threads[hnd.threadNum] do begin
         if time>0 then begin
          if delcnt>=31 then begin

Base/GlyphCaches.pas

@@ -540,7 +540,7 @@ function TDynamicGlyphCache.Find(chardata: cardinal): TGlyphInfoRec;
 
 procedure TDynamicGlyphCache.Keep;
 begin
- // Ensure that at least 20% of cache is free
+ // Ensure that at least 25% of cache is free
  while (freeMax-freeMin<aHeight div 4) do FreeOldBand;
 end;
 
@@ -551,7 +551,8 @@ procedure TDynamicGlyphCache.Release;
 
 procedure TDynamicGlyphCache.FreeOldBand;
 var
- y,i,key:integer;
+ y,i:integer;
+ key:cardinal;
 begin
  ASSERT(firstBand>=0);
  // Clear hash items

Base/MyServis.pas

@@ -123,6 +123,7 @@   EFatalError=class(TBaseException);
   TSplineFunc=function(x,x0,x1,y0,y1:single):single;
 
   TSortableObject=class
+   // Compare self to obj: return 1 if self>obj and -1 if self<obj
    function Compare(obj:TSortableObject):integer; virtual; // Stub
   end;
 
@@ -585,6 +586,8 @@   TSortableObject=class
 
  procedure CheckCritSections; // проверить критические секции на таймаут
 
+ procedure WaitFor(var p;maxTime:integer=1000000); // wait up to maxTime until p<>nil
+
  // Disable Data Execution Prevention (Windows)
  procedure DisableDEP;
 
@@ -4990,6 +4993,14 @@ function GetThreadName(threadID:cardinal=0):string; // вернуть имя (0=
   result:=GetNameOfThread(threadID);
  end;
 
+procedure WaitFor(var p;maxTime:integer);
+ var
+  t:int64;
+ begin
+  t:=MyTickCount+maxTime;
+  while (pointer(p)=nil) and (MyTickCount<t) do Sleep(1);
+ end;
+
 { TLogThread }
 
 procedure TLogThread.Execute;

BasicGame.pas

@@ -97,6 +97,7 @@  TBasicGame=class
   function MouseInRect(r:TRect):boolean; overload;
   function MouseInRect(r:TRect2s):boolean; overload;
   function MouseInRect(x,y,width,height:single):boolean; overload;
+  function MouseIsNear(x,y,radius:single):boolean; overload;
 
   function MouseWasInRect(r:TRect):boolean; overload;
   function MouseWasInRect(r:TRect2s):boolean; overload;
@@ -348,6 +349,12 @@ function TBasicGame.MouseInRect(x,y,width,height:single):boolean;
          (mouseX<x+width) and (mouseY<y+height);
 end;
 
+function TBasicGame.MouseIsNear(x,y,radius:single):boolean;
+begin
+ result:=Sqr(mouseX-x)+Sqr(mouseY-y)<=sqr(radius);
+end;
+
+
 function TBasicGame.MouseWasInRect(r:TRect):boolean;
 begin
  result:=(oldMouseX>=r.Left) and (oldmouseY>=r.Top) and
@@ -361,6 +368,10 @@ function TBasicGame.MouseWasInRect(r:TRect2s):boolean;
 end;
 
 constructor TBasicGame.Create;
+{$IFDEF MSWINDOWS}
+var
+ dc:HDC;
+{$ENDIF}
 begin
  ForceLogMessage('Creating '+self.ClassName);
  running:=false;
@@ -385,6 +396,10 @@ constructor TBasicGame.Create;
  {$IFDEF MSWINDOWS}
  screenWidth:=GetSystemMetrics(SM_CXSCREEN);
  screenHeight:=GetSystemMetrics(SM_CYSCREEN);
+ dc:=GetDC(0);
+ screenDPI:=GetDeviceCaps(dc,LOGPIXELSX);
+ ReleaseDC(window,dc);
+ LogMessage('Screen DPI=%d',[screenDPI]);
  {$ENDIF}
 
  PublishVar(@showDebugInfo,'ShowDebugInfo',TVarTypeInteger);
@@ -635,11 +650,12 @@ function SetProcessDPIAware:BOOL; external user32 name 'SetProcessDPIAware';
 procedure TBasicGame.Run;
 var
  i:integer;
+ res:boolean;
 begin
  if running then exit;
  game:=self;
  {$IFDEF MSWINDOWS}
- SetProcessDPIAware;
+ //res:=SetProcessDPIAware;
  {$ENDIF}
 
  if useMainThread then begin
@@ -1985,7 +2001,6 @@ procedure TBasicGame.FrameLoop;
    WindowClass:TWndClass;
    style:cardinal;
    i:integer;
-   dc:HDC;
   begin
    LogMessage('CreateMainWindow');
    with WindowClass do begin
@@ -2014,9 +2029,6 @@ procedure TBasicGame.FrameLoop;
    end;
    Layouts:=GetKeyboardLayoutList(10,LayoutList);
 
-   dc:=GetDC(window);
-   screenDPI:=GetDeviceCaps(dc,LOGPIXELSX);
-   ReleaseDC(window,dc);
   end;
   {$ELSE}
   begin

GameApp.pas

@@ -24,9 +24,10 @@ interface
    windowedMode:boolean=true;
    windowWidth:integer=1024;
    windowHeight:integer=768;
+   scaleWindowSize:boolean=false;
    gameMode:TGameAppMode=gamUseFullWindow;
 
-   deviceDPI:integer=96; // mobile only
+   deviceDPI:integer=96; //
    noVSync:boolean=false;
    directRenderOnly:boolean=false; // true -> for OpenGL: always render directly to the backbuffer, false -> allow frame render into texture
    checkForSteam:boolean=false;  // Check if STEAM client is running and get AppID
@@ -377,6 +378,7 @@ procedure TGameApplication.LoadOptions;
     windowWidth:=i;
     windowHeight:=CtlGetInt(configFileName+':\Options\WindowHeight',windowHeight);
    end;
+   scaleWindowSize:=ctlGetBool(configFileName+':\Options\scaleWindowSize',scaleWindowSize);
 
    Signal('GAMEAPP\OptionsLoaded');
   except
@@ -402,9 +404,12 @@ procedure TGameApplication.Prepare;
 
    if DirectoryExists('Logs') then begin
     configDir:='Logs\';
-    UseLogFile('Logs\game.log');
+    st:='Logs\game.log';
    end else
-    UseLogFile('game.log');
+    st:='game.log';
+   if fileExists(st) then
+     RenameFile(st,ChangeFileExt(st,'.old'));
+   UseLogFile(st);
    LogCacheMode(true,false,true);
    SetLogMode(lmVerbose);
 
@@ -572,11 +577,19 @@ procedure TGameApplication.SelectFonts;
  end;
 
 procedure TGameApplication.SetGameSettings(var settings: TGameSettings);
+var
+ scale:single;
 begin
   with settings do begin
    title:=GameTitle;
    width:=windowWidth;
    height:=windowHeight;
+   deviceDPI:=game.screenDPI;
+   if scaleWindowSize then begin
+    scale:=(deviceDPI/96);
+    width:=round(width*scale);
+    height:=round(height*scale);
+   end;
    colorDepth:=32;
    refresh:=0;
    case gameMode of

PainterGL2.pas

@@ -279,6 +279,8 @@ function TGLPainter2.SetStates(state: byte; primRect: TRect; tex: TTexture): boo
   actualTexMode:=curTexMode;
   if curTexMode=DEFAULT_TEX_MODE then begin
    glUseProgram(defaultShader);
+   m:=Matrix4s(MVP);
+   glUniformMatrix4fv(uMVP,1,GL_FALSE,@m);
    actualShader:=AS_DEFAULT;
   end else begin
    prog:=SetCustomProgram(curTexMode);

UDict.pas

@@ -468,19 +468,20 @@ function Translate(s:UTF8String):UTF8String;
 
 function Translate(s:widestring):widestring; overload;
 var ss:array[0..5] of widestring;
-    q,w:integer;
+    q,w,l:integer;
 begin
 // logmessage('translate: '+s);
  for q:=0 to 5 do ss[q]:='';
  w:=0;
  q:=length(s);
- if (q>0)and(s[q]='%') then
-  s:=s+' ';
+ if (q>0)and(s[q]='%') then s:=s+#0; // fake padding to split '%%%' - must be removed later
  s:=s+'%%';
  q:=pos(WideString('%%'),s);
  while q>0 do
  begin
   ss[w]:=Simplify(copy(s,1,q-1));
+  l:=length(ss[w]);
+  if (l>0) and (ss[w][l]=#0) then SetLength(ss[w],l-1);
   inc(w);
   s:=copy(s,q+2,16384);
   q:=pos(WideString('%%'),s);

UIScene.pas

@@ -431,7 +431,7 @@ function TUIScene.Process: boolean;
   end;
 begin
  result:=true;
- signal('Scenes\ProcessScene\'+name);
+ Signal('Scenes\ProcessScene\'+name);
  EnterCriticalSection(UICritSect);
  // отложенное удаление элементов
  toDelete.Clear;

customstyle.pas

@@ -199,7 +199,7 @@ {  TCustomStyleCls=class(TPublishedClass)
          end;
           // Вывод обычным текстом (тут всё устаревшее и требует переосмысления)
           for j:=0 to length(sa)-1 do begin
-           painter.TextOut(font,ix,iy,col,sa[j],mode,toAddBaseline);
+           painter.TextOutW(font,ix,iy,col,sa[j],mode,toAddBaseline);
            if bStyle.underline then begin
             col:=ColorMult2(col,$80FFFFFF);
             k:=round(painter.FontHeight(font)*0.96);

steamAPI.pas

@@ -36,6 +36,7 @@ interface
 
   function SteamAPI_Init():boolean; cdecl; external 'steam_api.dll';
   procedure SteamAPI_Shutdown(); cdecl; external 'steam_api.dll';
+  procedure SetSteamAchievement(name:string;enable:boolean=true);
 
   function SteamInternal_CreateInterface(ver:PAnsiChar):pointer; cdecl; external 'steam_api.dll';
   function SteamAPI_GetHSteamUser:HSteamUser;  cdecl; external 'steam_api.dll';
@@ -97,6 +98,24 @@   MicroTxnAuthorizationResponse_t=record
    Signal('STEAM\MicroTxnAuthorization\'+IntToStr(param.m_ulOrderID),param.m_bAuthorized);
   end;
 
+ procedure SetSteamAchievement(name:string;enable:boolean=true);
+  var
+   aName:PAnsiChar;
+   res:boolean;
+  begin
+   if not steamAvailable or (steamUserStats=nil) then begin
+    LogMessage('Steam not available');
+    exit;
+   end;
+   LogMessage('SSA: '+name);
+   aName:=PAnsiChar(AnsiString(name));
+   if enable then
+    res:=SteamAPI_ISteamUserStats_SetAchievement(steamUserStats,aName)
+   else
+    res:=SteamAPI_ISteamUserStats_ClearAchievement(steamUserStats,aName);
+   if not res then LogMessage('SSA failed');
+  end;
+
  function GetSteamAuthTicket:string;
   var
    ticket:array[0..1023] of byte;