hedgewars/uMisc.pas
author unc0rr
Sun, 02 Dec 2012 01:25:11 +0400
changeset 8178 8bd087478b48
parent 7848 775a72905708
child 8026 4a4f21070479
child 8865 dd4035ee0f12
permissions -rw-r--r--
Fix QSettings problems: - Reopen file in ReadOnly mode if it was open in ReadWrite mode and is being read. This is needed for stupid QSettings which opens file in ReadWrite mode just to call readAll() on it. - Implement setSize(0)

(*
 * Hedgewars, a free turn based strategy game
 * Copyright (c) 2004-2012 Andrey Korotaev <unC0Rr@gmail.com>
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; version 2 of the License
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
 *)

{$INCLUDE "options.inc"}

unit uMisc;
interface

uses SDLh, uConsts, GLunit, uTypes;

procedure initModule;
procedure freeModule;

procedure movecursor(dx, dy: LongInt);
function  doSurfaceConversion(tmpsurf: PSDL_Surface): PSDL_Surface;
function  MakeScreenshot(filename: shortstring; k: LongInt): boolean;
function  GetTeamStatString(p: PTeam): shortstring;
{$IFDEF SDL13}
function  SDL_RectMake(x, y, width, height: LongInt): TSDL_Rect; inline;
{$ELSE}
function  SDL_RectMake(x, y: SmallInt; width, height: Word): TSDL_Rect; inline;
{$ENDIF}

implementation
uses SysUtils, uVariables, uUtils
     {$IFDEF PNG_SCREENSHOTS}, PNGh, png {$ENDIF}
     {$IFNDEF USE_SDLTHREADS} {$IFDEF UNIX}, cthreads{$ENDIF} {$ENDIF};

type PScreenshot = ^TScreenshot;
     TScreenshot = record
         buffer: PByte;
         filename: shortstring;
         width, height: LongInt;
         size: QWord;
         end;

var conversionFormat: PSDL_PixelFormat;

procedure movecursor(dx, dy: LongInt);
var x, y: LongInt;
begin
if (dx = 0) and (dy = 0) then exit;

SDL_GetMouseState(@x, @y);
Inc(x, dx);
Inc(y, dy);
SDL_WarpMouse(x, y);
end;

{$IFDEF PNG_SCREENSHOTS}
// this funtion will be executed in separate thread
function SaveScreenshot(screenshot: pointer): PtrInt;
var i: LongInt;
    png_ptr: ^png_struct;
    info_ptr: ^png_info;
    f: file;
    image: PScreenshot;
begin
image:= PScreenshot(screenshot);

png_ptr := png_create_write_struct(png_get_libpng_ver(nil), nil, nil, nil);
if png_ptr = nil then
begin
    // AddFileLog('Error: Could not create png write struct.');
    SaveScreenshot:= 0;
    exit;
end;

info_ptr := png_create_info_struct(png_ptr);
if info_ptr = nil then
begin
    png_destroy_write_struct(@png_ptr, nil);
    // AddFileLog('Error: Could not create png info struct.');
    SaveScreenshot:= 0;
    exit;
end;

{$IOCHECKS OFF}
Assign(f, image^.filename);
Rewrite(f, 1);
if IOResult = 0 then
    begin
    png_init_pascal_io(png_ptr,@f);
    png_set_IHDR(png_ptr, info_ptr, image^.width, image^.height,
                 8, // bit depth
                 PNG_COLOR_TYPE_RGBA, PNG_INTERLACE_NONE,
                 PNG_COMPRESSION_TYPE_DEFAULT, PNG_FILTER_TYPE_DEFAULT);
    png_write_info(png_ptr, info_ptr);
    // glReadPixels and libpng number rows in different order
    for i:= image^.height-1 downto 0 do
        png_write_row(png_ptr, image^.buffer + i*4*image^.width);
    png_write_end(png_ptr, info_ptr);
    Close(f);
    end;
{$IOCHECKS ON}

// free everything
png_destroy_write_struct(@png_ptr, @info_ptr);
FreeMem(image^.buffer, image^.size);
Dispose(image);
SaveScreenshot:= 0;
end;

{$ELSE} // no PNG_SCREENSHOTS

// this funtion will be executed in separate thread
function SaveScreenshot(screenshot: pointer): PtrInt;
var f: file;
    // Windows Bitmap Header
    head: array[0..53] of Byte = (
    $42, $4D,       // identifier ("BM")
    0, 0, 0, 0,     // file size
    0, 0, 0, 0,     // reserved
    54, 0, 0, 0,    // starting offset
    40, 0, 0, 0,    // header size
    0, 0, 0, 0,     // width
    0, 0, 0, 0,     // height
    1, 0,           // color planes
    32, 0,          // bit depth
    0, 0, 0, 0,     // compression method (uncompressed)
    0, 0, 0, 0,     // image size
    96, 0, 0, 0,    // horizontal resolution
    96, 0, 0, 0,    // vertical resolution
    0, 0, 0, 0,     // number of colors (all)
    0, 0, 0, 0      // number of important colors
    );
    image: PScreenshot;
    size: QWord;
begin
image:= PScreenshot(screenshot);

size:= image^.Width*image^.Height*4;

head[$02]:= (size + 54) and $ff;
head[$03]:= ((size + 54) shr 8) and $ff;
head[$04]:= ((size + 54) shr 16) and $ff;
head[$05]:= ((size + 54) shr 24) and $ff;
head[$12]:= image^.Width and $ff;
head[$13]:= (image^.Width shr 8) and $ff;
head[$14]:= (image^.Width shr 16) and $ff;
head[$15]:= (image^.Width shr 24) and $ff;
head[$16]:= image^.Height and $ff;
head[$17]:= (image^.Height shr 8) and $ff;
head[$18]:= (image^.Height shr 16) and $ff;
head[$19]:= (image^.Height shr 24) and $ff;
head[$22]:= size and $ff;
head[$23]:= (size shr 8) and $ff;
head[$24]:= (size shr 16) and $ff;
head[$25]:= (size shr 24) and $ff;

{$IOCHECKS OFF}
Assign(f, image^.filename);
Rewrite(f, 1);
if IOResult = 0 then
    begin
    BlockWrite(f, head, sizeof(head));
    BlockWrite(f, image^.buffer^, size);
    Close(f);
    end
else
    begin
    //AddFileLog('Error: Could not write to ' + filename);
    end;
{$IOCHECKS ON}

// free everything
FreeMem(image^.buffer, image^.size);
Dispose(image);
SaveScreenshot:= 0;
end;

{$ENDIF} // no PNG_SCREENSHOTS

{$IFDEF USE_VIDEO_RECORDING}
// make image k times smaller (useful for saving thumbnails)
procedure ReduceImage(img: PByte; width, height, k: LongInt);
var i, j, i0, j0, w, h, r, g, b: LongInt;
begin
    w:= width  div k;
    h:= height div k;

    // rescale inplace
    if k <> 1 then
    begin
        for i:= 0 to h-1 do
            for j:= 0 to w-1 do
            begin
                r:= 0;
                g:= 0;
                b:= 0;
                for i0:= 0 to k-1 do
                    for j0:= 0 to k-1 do
                    begin
                        inc(r, img[4*(width*(i*k+i0) + j*k+j0)+0]);
                        inc(g, img[4*(width*(i*k+i0) + j*k+j0)+1]);
                        inc(b, img[4*(width*(i*k+i0) + j*k+j0)+2]);
                    end;
                img[4*(w*i + j)+0]:= r div (k*k);
                img[4*(w*i + j)+1]:= g div (k*k);
                img[4*(w*i + j)+2]:= b div (k*k);
                img[4*(w*i + j)+3]:= 255;
            end;
    end;
end;
{$ENDIF}

// captures and saves the screen. returns true on success.
// saved image will be k times smaller than original (useful for saving thumbnails).
function MakeScreenshot(filename: shortstring; k: LongInt): Boolean;
var p: Pointer;
    size: QWord;
    image: PScreenshot;
    format: GLenum;
    ext: string[4];
begin
{$IFDEF PNG_SCREENSHOTS}
format:= GL_RGBA;
ext:= '.png';
{$ELSE}
format:= GL_BGRA;
ext:= '.bmp';
{$ENDIF}

size:= toPowerOf2(cScreenWidth) * toPowerOf2(cScreenHeight) * 4;
p:= GetMem(size); // will be freed in SaveScreenshot()

// memory could not be allocated
if p = nil then
begin
    AddFileLog('Error: Could not allocate memory for screenshot.');
    MakeScreenshot:= false;
    exit;
end;

// read pixels from the front buffer
glReadPixels(0, 0, cScreenWidth, cScreenHeight, format, GL_UNSIGNED_BYTE, p);

{$IFDEF USE_VIDEO_RECORDING}
ReduceImage(p, cScreenWidth, cScreenHeight, k);
{$ENDIF}

// allocate and fill structure that will be passed to new thread
New(image); // will be disposed in SaveScreenshot()
image^.filename:= UserPathPrefix + filename + ext;
image^.width:= cScreenWidth div k;
image^.height:= cScreenHeight div k;
image^.size:= size;
image^.buffer:= p;

{$IFDEF USE_SDLTHREADS}
SDL_CreateThread(@SaveScreenshot{$IFDEF SDL13}, nil{$ENDIF}, image);
{$ELSE}
BeginThread(@SaveScreenshot, image);
{$ENDIF}
MakeScreenshot:= true; // possibly it is not true but we will not wait for thread to terminate
end;

// http://www.idevgames.com/forums/thread-5602-post-21860.html#pid21860
function doSurfaceConversion(tmpsurf: PSDL_Surface): PSDL_Surface;
var convertedSurf: PSDL_Surface;
begin
    doSurfaceConversion:= tmpsurf;
    if ((tmpsurf^.format^.bitsperpixel = 32) and (tmpsurf^.format^.rshift > tmpsurf^.format^.bshift)) or
       (tmpsurf^.format^.bitsperpixel = 24) then
    begin
        convertedSurf:= SDL_ConvertSurface(tmpsurf, conversionFormat, SDL_SWSURFACE);
        SDL_FreeSurface(tmpsurf);
        doSurfaceConversion:= convertedSurf;
    end;
end;

{$IFDEF SDL13}
function SDL_RectMake(x, y, width, height: LongInt): TSDL_Rect; inline;
{$ELSE}
function SDL_RectMake(x, y: SmallInt; width, height: Word): TSDL_Rect; inline;
{$ENDIF}
begin
    SDL_RectMake.x:= x;
    SDL_RectMake.y:= y;
    SDL_RectMake.w:= width;
    SDL_RectMake.h:= height;
end;

function GetTeamStatString(p: PTeam): shortstring;
var s: ansistring;
begin
    s:= p^.TeamName + ':' + IntToStr(p^.TeamHealth) + ':';
    GetTeamStatString:= s;
end;

procedure initModule;
const SDL_PIXELFORMAT_ABGR8888 = (1 shl 31) or (6 shl 24) or (7 shl 20) or (6 shl 16) or (32 shl 8) or 4;
begin
    conversionFormat:= SDL_AllocFormat(SDL_PIXELFORMAT_ABGR8888);
end;

procedure freeModule;
begin
    SDL_FreeFormat(conversionFormat);
end;

end.