partial merge of the webgl branch
This commit contains the new pas2c conversion tool, the pascal
to c build structure and the opengl2 rendering backend.
Patch reviewed by unC0Rr.
--- a/.hgignore Sun Jan 19 00:18:28 2014 +0400
+++ b/.hgignore Tue Jan 21 22:38:13 2014 +0100
@@ -40,6 +40,8 @@
glob:*.orig
glob:*.bak
glob:*.rej
+glob:project_files/hwc/*.c
+glob:project_files/hwc/*.h
glob:project_files/Android-build/SDL-android-project/jni/**
glob:project_files/Android-build/SDL-android-project/obj
glob:project_files/Android-build/SDL-android-project/libs/armeabi*
--- a/CMakeLists.txt Sun Jan 19 00:18:28 2014 +0400
+++ b/CMakeLists.txt Tue Jan 21 22:38:13 2014 +0100
@@ -33,6 +33,9 @@
option(MINIMAL_FLAGS "Respect system flags as much as possible (off)" OFF)
option(NOAUTOUPDATE "Disable OS X Sparkle update checking (off)" OFF)
+option(BUILD_ENGINE_C "Compile hwengine as native C [default: off]" OFF)
+option(GL2 "Enable OpenGL 2 rendering [default: off]" OFF)
+
set(GHFLAGS "" CACHE STRING "Additional Haskell flags")
if(UNIX AND NOT APPLE)
set(DATA_INSTALL_DIR "share/hedgewars" CACHE STRING "Resource folder path")
@@ -111,6 +114,7 @@
list(APPEND haskell_flags "-Wall" # all warnings
"-debug" # debug mode
"-dcore-lint" # internal sanity check
+ "-fno-warn-unused-do-bind"
)
else()
list(APPEND haskell_flags "-w" # no warnings
@@ -118,6 +122,25 @@
endif()
+#build engine without freepascal
+if(BUILD_ENGINE_C)
+ find_package(Clang REQUIRED)
+
+ if(${CLANG_VERSION} VERSION_LESS "3.0")
+ message(FATAL_ERROR "LLVM/Clang compiler required version is 3.0 but version ${CLANG_VERSION} was found!")
+ endif()
+
+ set(CMAKE_C_COMPILER ${CLANG_EXECUTABLE})
+ set(CMAKE_CXX_COMPILER ${CLANG_EXECUTABLE})
+endif()
+
+
+#server
+if(NOT NOSERVER)
+ add_subdirectory(gameServer)
+endif()
+
+
#lua discovery
if(LUA_SYSTEM)
if(NOT LUA_LIBRARY OR NOT LUA_INCLUDE_DIR)
@@ -182,28 +205,26 @@
#physfs helper library
add_subdirectory(misc/libphyslayer)
-#server
-if(NOT NOSERVER)
- add_subdirectory(gameServer)
+#maybe this could be merged inside hedgewars/CMakeLists.txt
+if(BUILD_ENGINE_C)
+ #pascal to c converter
+ add_subdirectory(tools/pas2c)
+ add_subdirectory(project_files/hwc)
+else()
+ #main pascal engine
+ add_subdirectory(hedgewars)
endif()
-#main engine
-add_subdirectory(hedgewars)
-
#Android related build scripts
+#TODO: when ANDROID, BUILD_ENGINE_LIBRARY should be set
if(ANDROID)
- #run cmake -DANDROID=1 to enable this
add_subdirectory(project_files/Android-build)
-endif()
-
-#TODO: when ANDROID, BUILD_ENGINE_LIBRARY should be set
-if(NOT ANDROID)
+else(ANDROID)
add_subdirectory(bin)
add_subdirectory(QTfrontend)
add_subdirectory(share)
add_subdirectory(tools)
-endif()
-
+endif(ANDROID)
include(${CMAKE_MODULE_PATH}/cpackvars.cmake)
--- a/QTfrontend/CMakeLists.txt Sun Jan 19 00:18:28 2014 +0400
+++ b/QTfrontend/CMakeLists.txt Tue Jan 21 22:38:13 2014 +0100
@@ -63,7 +63,7 @@
include_directories(${SDLMIXER_INCLUDE_DIR})
include_directories(BEFORE ${PHYSFS_INCLUDE_DIR})
include_directories(BEFORE ${PHYSLAYER_INCLUDE_DIR})
-
+include_directories(${LUA_INCLUDE_DIR}) #brought by physlayer hwpacksmounter.h
if(UNIX)
# HACK: in freebsd cannot find iconv.h included via SDL.h
@@ -215,6 +215,10 @@
)
endif()
+if(CMAKE_CXX_COMPILER MATCHES "clang*")
+ list(APPEND HW_LINK_LIBS stdc++ m)
+endif()
+
target_link_libraries(hedgewars ${HW_LINK_LIBS})
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cmake_modules/FindClang.cmake Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,36 @@
+# - Try to find the Clang/LLVM executable
+# Once done this will define
+#
+# CLANG_FOUND - system has Clang
+# CLANG_VERSION - Clang version
+# CLANG_EXECUTABLE - Clang executable
+#
+# Copyright (c) 2013, Vittorio Giovara <vittorio.giovara@gmail.com>
+#
+# Redistribution and use is allowed according to the terms of the BSD license.
+# For details see the accompanying COPYING-CMAKE-SCRIPTS file.
+
+find_program(CLANG_EXECUTABLE
+ NAMES clang-mp-3.3 clang-mp-3.2 clang-mp-3.1 clang-mp-3.0 clang
+ PATHS /opt/local/bin /usr/local/bin /usr/bin)
+
+if (CLANG_EXECUTABLE)
+ execute_process(COMMAND ${CLANG_EXECUTABLE} --version
+ OUTPUT_VARIABLE CLANG_VERSION_OUTPUT
+ ERROR_VARIABLE CLANG_VERSION_ERROR
+ RESULT_VARIABLE CLANG_VERSION_RESULT
+ OUTPUT_STRIP_TRAILING_WHITESPACE
+ )
+
+ if(${CLANG_VERSION_RESULT} EQUAL 0)
+ string(REGEX MATCH "[0-9]+\\.[0-9]+" CLANG_VERSION "${CLANG_VERSION_OUTPUT}")
+ string(REGEX REPLACE "([0-9]+\\.[0-9]+)" "\\1" CLANG_VERSION "${CLANG_VERSION}")
+ else()
+ message(SEND_ERROR "Command \"${CLANG_EXECUTABLE} --version\" failed with output: ${CLANG_VERSION_ERROR}")
+ endif()
+endif()
+
+include(FindPackageHandleStandardArgs)
+find_package_handle_standard_args(Clang DEFAULT_MSG CLANG_EXECUTABLE CLANG_VERSION)
+mark_as_advanced(CLANG_VERSION)
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cmake_modules/FindGLEW.cmake Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,39 @@
+# Find GLEW
+#
+# Once done this will define
+# GLEW_FOUND - system has GLEW
+# GLEW_INCLUDE_DIR - the GLEW include directory
+# GLEW_LIBRARY - The library needed to use GLEW
+# Copyright (c) 2013, Vittorio Giovara <vittorio.giovara@gmail.com>
+#
+# Distributed under the OSI-approved BSD License (the "License");
+# see accompanying file Copyright.txt for details.
+#
+# This software is distributed WITHOUT ANY WARRANTY; without even the
+# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+# See the License for more information.
+
+include(FindPackageHandleStandardArgs)
+
+find_path( GLEW_INCLUDE_DIR GL/glew.h
+ /usr/include
+ /usr/local/include
+ /sw/include
+ /opt/local/include
+ $ENV{PROGRAMFILES}/GLEW/include
+ DOC "The directory where GL/glew.h resides")
+find_library( GLEW_LIBRARY
+ NAMES GLEW glew glew32 glew32s
+ PATHS
+ /usr/lib64
+ /usr/lib
+ /usr/local/lib64
+ /usr/local/lib
+ /sw/lib
+ /opt/local/lib
+ $ENV{PROGRAMFILES}/GLEW/lib
+ DOC "The GLEW library")
+
+find_package_handle_standard_args(GLEW DEFAULT_MSG GLEW_LIBRARY GLEW_INCLUDE_DIR)
+mark_as_advanced(GLEW_LIBRARY GLEW_INCLUDE_DIR)
+
--- a/hedgewars/ArgParsers.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/ArgParsers.pas Tue Jan 21 22:38:13 2014 +0100
@@ -15,7 +15,7 @@
* 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 ArgParsers;
@@ -111,7 +111,7 @@
end
end;
-function parseNick(nick: String): String;
+function parseNick(nick: shortstring): shortstring;
begin
if isInternal then
parseNick:= DecodeBase64(nick)
@@ -158,35 +158,38 @@
{$ENDIF}
end;
-function getLongIntParameter(str:String; var paramIndex:LongInt; var wrongParameter:Boolean): LongInt;
+function getLongIntParameter(str:shortstring; var paramIndex:LongInt; var wrongParameter:Boolean): LongInt;
var tmpInt, c: LongInt;
begin
inc(paramIndex);
+{$IFDEF PAS2C}
+ val(str, tmpInt);
+{$ELSE}
val(str, tmpInt, c);
wrongParameter:= c <> 0;
if wrongParameter then
WriteLn(stderr, 'ERROR: '+ParamStr(paramIndex-1)+' expects a number, you passed "'+str+'"');
+{$ENDIF}
getLongIntParameter:= tmpInt;
end;
-function getStringParameter(str:String; var paramIndex:LongInt; var wrongParameter:Boolean): String;
+function getstringParameter(str:shortstring; var paramIndex:LongInt; var wrongParameter:Boolean): shortstring;
begin
inc(paramIndex);
wrongParameter:= (str='') or (Copy(str,1,2) = '--');
if wrongParameter then
WriteLn(stderr, 'ERROR: '+ParamStr(paramIndex-1)+' expects a string, you passed "'+str+'"');
- getStringParameter:= str;
+ getstringParameter:= str;
end;
-
-procedure parseClassicParameter(cmdArray: Array of String; size:LongInt; var paramIndex:LongInt); Forward;
+procedure parseClassicParameter(cmdArray: array of string; size:LongInt; var paramIndex:LongInt); forward;
-function parseParameter(cmd:String; arg:String; var paramIndex:LongInt): Boolean;
-const videoArray: Array [1..5] of String = ('--fullscreen-width','--fullscreen-height', '--width', '--height', '--depth');
- audioArray: Array [1..3] of String = ('--volume','--nomusic','--nosound');
- otherArray: Array [1..3] of String = ('--locale','--fullscreen','--showfps');
- mediaArray: Array [1..10] of String = ('--fullscreen-width', '--fullscreen-height', '--width', '--height', '--depth', '--volume','--nomusic','--nosound','--locale','--fullscreen');
- allArray: Array [1..18] of String = ('--fullscreen-width','--fullscreen-height', '--width', '--height', '--depth','--volume','--nomusic','--nosound','--locale','--fullscreen','--showfps','--altdmg','--frame-interval','--low-quality','--no-teamtag','--no-hogtag','--no-healthtag','--translucent-tags');
+function parseParameter(cmd:string; arg:string; var paramIndex:LongInt): Boolean;
+const videoArray: Array [1..5] of string = ('--fullscreen-width','--fullscreen-height', '--width', '--height', '--depth');
+ audioArray: Array [1..3] of string = ('--volume','--nomusic','--nosound');
+ otherArray: Array [1..3] of string = ('--locale','--fullscreen','--showfps');
+ mediaArray: Array [1..10] of string = ('--fullscreen-width', '--fullscreen-height', '--width', '--height', '--depth', '--volume','--nomusic','--nosound','--locale','--fullscreen');
+ allArray: Array [1..18] of string = ('--fullscreen-width','--fullscreen-height', '--width', '--height', '--depth','--volume','--nomusic','--nosound','--locale','--fullscreen','--showfps','--altdmg','--frame-interval','--low-quality','--no-teamtag','--no-hogtag','--no-healthtag','--translucent-tags');
reallyAll: array[0..35] of shortstring = (
'--prefix', '--user-prefix', '--locale', '--fullscreen-width', '--fullscreen-height', '--width',
'--height', '--frame-interval', '--volume','--nomusic', '--nosound',
@@ -204,9 +207,9 @@
while (cmdIndex <= High(reallyAll)) and (cmd <> reallyAll[cmdIndex]) do inc(cmdIndex);
case cmdIndex of
- {--prefix} 0 : PathPrefix := getStringParameter (arg, paramIndex, parseParameter);
- {--user-prefix} 1 : UserPathPrefix := getStringParameter (arg, paramIndex, parseParameter);
- {--locale} 2 : cLocaleFName := getStringParameter (arg, paramIndex, parseParameter);
+ {--prefix} 0 : PathPrefix := getstringParameter (arg, paramIndex, parseParameter);
+ {--user-prefix} 1 : UserPathPrefix := getstringParameter (arg, paramIndex, parseParameter);
+ {--locale} 2 : cLocaleFName := getstringParameter (arg, paramIndex, parseParameter);
{--fullscreen-width} 3 : cFullscreenWidth := max(getLongIntParameter(arg, paramIndex, parseParameter), cMinScreenWidth);
{--fullscreen-height} 4 : cFullscreenHeight := max(getLongIntParameter(arg, paramIndex, parseParameter), cMinScreenHeight);
{--width} 5 : cWindowedWidth := max(2 * (getLongIntParameter(arg, paramIndex, parseParameter) div 2), cMinScreenWidth);
@@ -221,7 +224,7 @@
{--low-quality} 14 : cReducedQuality := $FFFFFFFF xor rqLowRes;
{--raw-quality} 15 : cReducedQuality := getLongIntParameter(arg, paramIndex, parseParameter);
{--stereo} 16 : setStereoMode ( getLongIntParameter(arg, paramIndex, parseParameter) );
- {--nick} 17 : UserNick := parseNick( getStringParameter(arg, paramIndex, parseParameter) );
+ {--nick} 17 : UserNick := parseNick( getstringParameter(arg, paramIndex, parseParameter) );
{deprecated options}
{--depth} 18 : setDepth(paramIndex);
{--set-video} 19 : parseClassicParameter(videoArray,5,paramIndex);
@@ -242,7 +245,7 @@
{--no-hogtag} 32 : cTagsMask := cTagsMask and not htName;
{--no-healthtag} 33 : cTagsMask := cTagsMask and not htHealth;
{--translucent-tags} 34 : cTagsMask := cTagsMask or htTransparent;
- {--lua-test} 35 : begin cTestLua := true; cScriptName := getStringParameter(arg, paramIndex, parseParameter); WriteLn(stdout, 'Lua test file specified: ' + cScriptName);end;
+ {--lua-test} 35 : begin cTestLua := true; cScriptName := getstringParameter(arg, paramIndex, parseParameter); WriteLn(stdout, 'Lua test file specified: ' + cScriptName);end;
else
begin
//Assume the first "non parameter" is the replay file, anything else is invalid
@@ -257,10 +260,10 @@
end;
end;
-procedure parseClassicParameter(cmdArray: Array of String; size:LongInt; var paramIndex:LongInt);
+procedure parseClassicParameter(cmdArray: array of string; size:LongInt; var paramIndex:LongInt);
var index, tmpInt: LongInt;
isBool, isValid: Boolean;
- cmd, arg, newSyntax: String;
+ cmd, arg, newSyntax: string;
begin
WriteLn(stdout, 'WARNING: you are using a deprecated command, which could be removed in a future version!');
WriteLn(stdout, ' Consider updating to the latest syntax, which is much more flexible!');
@@ -287,9 +290,9 @@
if isValid then
begin
parseParameter(cmd, arg, tmpInt);
- newSyntax := newSyntax + cmd + ' ';
+ newSyntax:= newSyntax + cmd + ' ';
if not isBool then
- newSyntax := newSyntax + arg + ' ';
+ newSyntax:= newSyntax + arg + ' ';
end;
inc(index);
end;
@@ -340,7 +343,7 @@
begin
isInternal:= (ParamStr(1) = '--internal');
- UserPathPrefix := '.';
+ UserPathPrefix := _S'.';
PathPrefix := cDefaultPathPrefix;
recordFileName := '';
parseCommandLine();
--- a/hedgewars/CMakeLists.txt Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/CMakeLists.txt Tue Jan 21 22:38:13 2014 +0100
@@ -179,6 +179,11 @@
add_definitions(-dSDL2)
endif()
+#opengl 2
+IF(GL2)
+ add_definitions(-dGL2)
+ENDIF(GL2)
+
#needs to be last
add_definitions(-dDEBUGFILE)
--- a/hedgewars/LuaPas.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/LuaPas.pas Tue Jan 21 22:38:13 2014 +0100
@@ -21,7 +21,9 @@
{$ENDIF}
type
+{$IFNDEF PAS2C}
size_t = Cardinal;
+{$ENDIF}
Psize_t = ^size_t;
PPointer = ^Pointer;
@@ -55,12 +57,14 @@
@* of a function in debug information.
** CHANGE it if you want a different size.
*)
+
const
LUA_IDSIZE = 60;
(*
@@ LUAL_BUFFERSIZE is the buffer size used by the lauxlib buffer system.
*)
+
const
LUAL_BUFFERSIZE = 1024;
@@ -70,6 +74,7 @@
** CHANGE them if you want different prompts. (You can also change the
** prompts dynamically, assigning to globals _PROMPT/_PROMPT2.)
*)
+
const
LUA_PROMPT = '> ';
LUA_PROMPT2 = '>> ';
@@ -113,6 +118,7 @@
** See Copyright Notice at the end of this file
*)
+
const
LUA_VERSION = 'Lua 5.1';
LUA_VERSION_NUM = 501;
@@ -132,8 +138,10 @@
LUA_ENVIRONINDEX = -10001;
LUA_GLOBALSINDEX = -10002;
+
function lua_upvalueindex(idx : LongInt) : LongInt; // a marco
+
const
(* thread status; 0 is OK *)
LUA_YIELD_ = 1; // Note: the ending underscore is needed in Pascal
@@ -142,6 +150,7 @@
LUA_ERRMEM = 4;
LUA_ERRERR = 5;
+
type
lua_CFunction = function(L : Plua_State) : LongInt; cdecl;
@@ -156,6 +165,7 @@
*)
lua_Alloc = function (ud, ptr : Pointer; osize, nsize : size_t) : Pointer; cdecl;
+
const
(*
** basic types
@@ -181,12 +191,13 @@
(* type for integer functions *)
lua_Integer = LUA_INTEGER_;
+
(*
** state manipulation
*)
function lua_newstate(f : lua_Alloc; ud : Pointer) : Plua_State;
cdecl; external LuaLibName;
-
+
procedure lua_close(L: Plua_State);
cdecl; external LuaLibName;
function lua_newthread(L : Plua_State) : Plua_State;
@@ -201,22 +212,22 @@
*)
function lua_gettop(L : Plua_State) : LongInt;
cdecl; external LuaLibName;
-
+
procedure lua_settop(L : Plua_State; idx : LongInt);
cdecl; external LuaLibName;
-
+
procedure lua_pushvalue(L : Plua_State; idx : LongInt);
cdecl; external LuaLibName;
-
+
procedure lua_remove(L : Plua_State; idx : LongInt);
cdecl; external LuaLibName;
-
+
procedure lua_insert(L : Plua_State; idx : LongInt);
cdecl; external LuaLibName;
-
+
procedure lua_replace(L : Plua_State; idx : LongInt);
cdecl; external LuaLibName;
-
+
function lua_checkstack(L : Plua_State; sz : LongInt) : LongBool;
cdecl; external LuaLibName;
@@ -229,57 +240,55 @@
*)
function lua_isnumber(L : Plua_State; idx : LongInt) : LongBool;
cdecl; external LuaLibName;
-
+
function lua_isstring(L : Plua_State; idx : LongInt) : LongBool;
cdecl; external LuaLibName;
-
+
function lua_iscfunction(L : Plua_State; idx : LongInt) : LongBool;
cdecl; external LuaLibName;
-
+
function lua_isuserdata(L : Plua_State; idx : LongInt) : LongBool;
cdecl; external LuaLibName;
-
+
function lua_type(L : Plua_State; idx : LongInt) : LongInt;
cdecl; external LuaLibName;
-
+
function lua_typename(L : Plua_State; tp : LongInt) : PChar;
cdecl; external LuaLibName;
-
function lua_equal(L : Plua_State; idx1, idx2 : LongInt) : LongBool;
cdecl; external LuaLibName;
-
+
function lua_rawequal(L : Plua_State; idx1, idx2 : LongInt) : LongBool;
cdecl; external LuaLibName;
-
+
function lua_lessthan(L : Plua_State; idx1, idx2 : LongInt) : LongBool;
cdecl; external LuaLibName;
function lua_tonumber(L : Plua_State; idx : LongInt) : lua_Number;
cdecl; external LuaLibName;
-
+
function lua_tointeger(L : Plua_State; idx : LongInt) : lua_Integer;
cdecl; external LuaLibName;
-
+
function lua_toboolean(L : Plua_State; idx : LongInt) : LongBool;
cdecl; external LuaLibName;
-
-
+
function lua_tolstring(L : Plua_State; idx : LongInt; len : Psize_t) : PChar;
cdecl; external LuaLibName;
-
+
function lua_objlen(L : Plua_State; idx : LongInt) : size_t;
cdecl; external LuaLibName;
-
+
function lua_tocfunction(L : Plua_State; idx : LongInt) : lua_CFunction;
cdecl; external LuaLibName;
-
+
function lua_touserdata(L : Plua_State; idx : LongInt) : Pointer;
cdecl; external LuaLibName;
-
+
function lua_tothread(L : Plua_State; idx : LongInt) : Plua_State;
cdecl; external LuaLibName;
-
+
function lua_topointer(L : Plua_State; idx : LongInt) : Pointer;
cdecl; external LuaLibName;
@@ -289,36 +298,35 @@
*)
procedure lua_pushnil(L : Plua_State);
cdecl; external LuaLibName;
-
+
procedure lua_pushnumber(L : Plua_State; n : lua_Number);
cdecl; external LuaLibName;
-
+
procedure lua_pushinteger(L : Plua_State; n : lua_Integer);
cdecl; external LuaLibName;
-
+
procedure lua_pushlstring(L : Plua_State; const s : PChar; ls : size_t);
cdecl; external LuaLibName;
-
+
procedure lua_pushstring(L : Plua_State; const s : PChar);
cdecl; external LuaLibName;
-
-
+
function lua_pushvfstring(L : Plua_State;
const fmt : PChar; argp : Pointer) : PChar;
cdecl; external LuaLibName;
-
+
function lua_pushfstring(L : Plua_State; const fmt : PChar) : PChar; varargs;
cdecl; external LuaLibName;
-
+
procedure lua_pushcclosure(L : Plua_State; fn : lua_CFunction; n : LongInt);
cdecl; external LuaLibName;
-
+
procedure lua_pushboolean(L : Plua_State; b : LongBool);
cdecl; external LuaLibName;
-
+
procedure lua_pushlightuserdata(L : Plua_State; p : Pointer);
cdecl; external LuaLibName;
-
+
function lua_pushthread(L : Plua_state) : Cardinal;
cdecl; external LuaLibName;
@@ -328,25 +336,25 @@
*)
procedure lua_gettable(L : Plua_State ; idx : LongInt);
cdecl; external LuaLibName;
-
+
procedure lua_getfield(L : Plua_State; idx : LongInt; k : PChar);
cdecl; external LuaLibName;
-
+
procedure lua_rawget(L : Plua_State; idx : LongInt);
cdecl; external LuaLibName;
-
+
procedure lua_rawgeti(L : Plua_State; idx, n : LongInt);
cdecl; external LuaLibName;
-
+
procedure lua_createtable(L : Plua_State; narr, nrec : LongInt);
cdecl; external LuaLibName;
-
+
function lua_newuserdata(L : Plua_State; sz : size_t) : Pointer;
cdecl; external LuaLibName;
-
+
function lua_getmetatable(L : Plua_State; objindex : LongInt) : LongBool;
cdecl; external LuaLibName;
-
+
procedure lua_getfenv(L : Plua_State; idx : LongInt);
cdecl; external LuaLibName;
@@ -356,19 +364,19 @@
*)
procedure lua_settable(L : Plua_State; idx : LongInt);
cdecl; external LuaLibName;
-
+
procedure lua_setfield(L : Plua_State; idx : LongInt; const k : PChar);
cdecl; external LuaLibName;
-
+
procedure lua_rawset(L : Plua_State; idx : LongInt);
cdecl; external LuaLibName;
-
+
procedure lua_rawseti(L : Plua_State; idx , n: LongInt);
cdecl; external LuaLibName;
-
+
function lua_setmetatable(L : Plua_State; objindex : LongInt): LongBool;
cdecl; external LuaLibName;
-
+
function lua_setfenv(L : Plua_State; idx : LongInt): LongBool;
cdecl; external LuaLibName;
@@ -377,16 +385,16 @@
*)
procedure lua_call(L : Plua_State; nargs, nresults : LongInt);
cdecl; external LuaLibName;
-
+
function lua_pcall(L : Plua_State; nargs, nresults, errfunc : LongInt) : LongInt;
cdecl; external LuaLibName;
-
+
function lua_cpcall(L : Plua_State; func : lua_CFunction; ud : Pointer) : LongInt;
cdecl; external LuaLibName;
-
+
function lua_load(L : Plua_State; reader : lua_Reader; dt : Pointer; const chunkname : PChar) : LongInt;
cdecl; external LuaLibName;
-
+
function lua_dump(L : Plua_State; writer : lua_Writer; data: Pointer) : LongInt;
cdecl; external LuaLibName;
@@ -397,16 +405,17 @@
*)
function lua_yield(L : Plua_State; nresults : LongInt) : LongInt;
cdecl; external LuaLibName;
-
+
function lua_resume(L : Plua_State; narg : LongInt) : LongInt;
cdecl; external LuaLibName;
-
+
function lua_status(L : Plua_State) : LongInt;
cdecl; external LuaLibName;
(*
** garbage-collection functions and options
*)
+
const
LUA_GCSTOP = 0;
LUA_GCRESTART = 1;
@@ -434,7 +443,7 @@
function lua_getallocf(L : Plua_State; ud : PPointer) : lua_Alloc;
cdecl; external LuaLibName;
-
+
procedure lua_setallocf(L : Plua_State; f : lua_Alloc; ud : Pointer);
cdecl; external LuaLibName;
@@ -532,25 +541,25 @@
function lua_getstack(L : Plua_State; level : LongInt; ar : Plua_Debug) : LongInt;
cdecl; external LuaLibName;
-
+
function lua_getinfo(L : Plua_State; const what : PChar; ar: Plua_Debug): LongInt;
cdecl; external LuaLibName;
-
+
function lua_getlocal(L : Plua_State; ar : Plua_Debug; n : LongInt) : PChar;
cdecl; external LuaLibName;
-
+
function lua_setlocal(L : Plua_State; ar : Plua_Debug; n : LongInt) : PChar;
cdecl; external LuaLibName;
-
+
function lua_getupvalue(L : Plua_State; funcindex, n : LongInt) : PChar;
cdecl; external LuaLibName;
-
+
function lua_setupvalue(L : Plua_State; funcindex, n : LongInt) : PChar;
cdecl; external LuaLibName;
function lua_sethook(L : Plua_State; func : lua_Hook; mask, count: LongInt): LongInt;
cdecl; external LuaLibName;
-
+
{$IFDEF LUA_GETHOOK}
function lua_gethook(L : Plua_State) : lua_Hook;
cdecl; external LuaLibName;
@@ -558,7 +567,7 @@
function lua_gethookmask(L : Plua_State) : LongInt;
cdecl; external LuaLibName;
-
+
function lua_gethookcount(L : Plua_State) : LongInt;
cdecl; external LuaLibName;
--- a/hedgewars/SDLh.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/SDLh.pas Tue Jan 21 22:38:13 2014 +0100
@@ -404,15 +404,26 @@
w, h : LongInt;
pitch : {$IFDEF SDL2}LongInt{$ELSE}Word{$ENDIF};
pixels: Pointer;
-{$IFDEF SDL2}
- userdata: Pointer;
- locked: LongInt;
- lock_data: Pointer;
+{$IFDEF PAS2C}
+ hwdata : Pointer;
clip_rect: TSDL_Rect;
- map: Pointer;
- refcount: LongInt;
+ unsed1 : LongWord;
+ locked : LongWord;
+ map : Pointer;
+ format_version: Longword;
+ refcount : LongInt;
+ offset : LongInt;
{$ELSE}
- offset: LongInt;
+{$IFDEF SDL2}
+ userdata : Pointer;
+ locked : LongInt;
+ lock_data : Pointer;
+ clip_rect : TSDL_Rect;
+ map : Pointer;
+ refcount : LongInt;
+{$ELSE}
+ offset : LongInt;
+{$ENDIF}
{$ENDIF}
end;
@@ -825,6 +836,7 @@
TByteArray = array[0..65535] of Byte;
PByteArray = ^TByteArray;
+
TLongWordArray = array[0..16383] of LongWord;
PLongWordArray = ^TLongWordArray;
--- a/hedgewars/adler32.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/adler32.pas Tue Jan 21 22:38:13 2014 +0100
@@ -2,7 +2,6 @@
{ZLib - Adler32 checksum function}
-
interface
(*************************************************************************
@@ -66,7 +65,7 @@
Also, the structure was removed to simplify C conversion
*)
-function Adler32Update ( var adler :longint; Msg :pointer; Len :longint ) : longint;
+function Adler32Update (var adler : longint; Msg :Pointer; Len :longint ) : longint;
implementation
@@ -124,17 +123,19 @@
end;
*)
-function Adler32Update(var adler: longint; Msg: pointer; Len :longint) : longint;
+function Adler32Update(var adler:longint; Msg: Pointer; Len :longint) : longint;
{-update Adler32 with Msg data}
const
BASE = 65521; {max. prime < 65536 }
NMAX = 3854; {max. n with 255n(n+1)/2 + (n+1)(BASE-1) < 2^31}
var
- s1, s2: longint;
- i, n: integer;
+ s1, s2 : longint;
+ i, n : integer;
+ m : PByte;
begin
- s1 := adler and $FFFF;
- s2 := adler shr 16;
+ m := PByte(Msg);
+ s1 := Longword(adler) and $FFFF;
+ s2 := Longword(adler) shr 16;
while Len>0 do
begin
if Len<NMAX then
@@ -144,8 +145,8 @@
for i := 1 to n do
begin
- inc(s1, pByte(Msg)^);
- inc(Msg);
+ inc(s1, m^);
+ inc(m);
inc(s2, s1);
end;
s1 := s1 mod BASE;
--- a/hedgewars/config.inc.in Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/config.inc.in Tue Jan 21 22:38:13 2014 +0100
@@ -26,4 +26,8 @@
cRevisionString = '${HEDGEWARS_REVISION}';
cHashString = '${HEDGEWARS_HASH}';
cDefaultPathPrefix = '${HEDGEWARS_FULL_DATADIR}/Data';
+{$IFDEF PAS2C}
+ cFontsPaths = '';
+{$ELSE}
cFontsPaths: ${FONTS_DIRS_ARRAY}
+{$ENDIF}
Binary file hedgewars/hwengine.ico has changed
--- a/hedgewars/hwengine.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/hwengine.pas Tue Jan 21 22:38:13 2014 +0100
@@ -19,7 +19,7 @@
{$INCLUDE "options.inc"}
{$IFDEF WIN32}
-{$R hwengine.rc}
+{$R res/hwengine.rc}
{$ENDIF}
{$IFDEF HWLIBRARY}
@@ -92,7 +92,9 @@
end;
gsConfirm, gsGame, gsChat:
begin
- if not cOnlyStats then DrawWorld(Lag);
+ if not cOnlyStats then
+ // never place between ProcessKbd and DoGameTick - bugs due to /put cmd and isCursorVisible
+ DrawWorld(Lag);
DoGameTick(Lag);
if not cOnlyStats then ProcessVisualGears(Lag);
end;
@@ -114,7 +116,11 @@
if flagMakeCapture then
begin
flagMakeCapture:= false;
+ {$IFDEF PAS2C}
+ s:= '/Screenshots/hw';
+ {$ELSE}
s:= '/Screenshots/hw_' + FormatDateTime('YYYY-MM-DD_HH-mm-ss', Now()) + inttostr(GameTicks);
+ {$ENDIF}
// flash
playSound(sndShutter);
@@ -135,7 +141,7 @@
///////////////////////////////////////////////////////////////////////////////
procedure MainLoop;
var event: TSDL_Event;
- PrevTime, CurrTime: Longword;
+ PrevTime, CurrTime: LongWord;
isTerminated: boolean;
{$IFDEF SDL2}
previousGameState: TGameState;
@@ -275,11 +281,12 @@
CurrTime:= SDL_GetTicks();
if PrevTime + longword(cTimerInterval) <= CurrTime then
begin
- isTerminated := isTerminated or DoTimer(CurrTime - PrevTime);
- PrevTime:= CurrTime
+ isTerminated:= isTerminated or DoTimer(CurrTime - PrevTime);
+ PrevTime:= CurrTime;
end
else SDL_Delay(1);
IPCCheckSock();
+
end;
end;
@@ -414,11 +421,14 @@
{$IFDEF USE_VIDEO_RECORDING}
if GameType = gmtRecord then
- RecorderMainLoop()
- else
+ begin
+ RecorderMainLoop();
+ freeEverything(true);
+ exit;
+ end;
{$ENDIF}
- MainLoop();
+ MainLoop;
// clean up all the memory allocated
freeEverything(true);
end;
@@ -546,6 +556,10 @@
/////////////////////////////////// m a i n ///////////////////////////////////
///////////////////////////////////////////////////////////////////////////////
begin
+{$IFDEF PAS2C}
+ // workaround for pascal's ParamStr and ParamCount
+ init(argc, argv);
+{$ENDIF}
preInitEverything();
cTagsMask:= htTeamName or htName or htHealth; // this one doesn't fit nicely w/ reset of other variables. suggestions welcome
GetParams();
@@ -556,6 +570,11 @@
Game();
// return 1 when engine is not called correctly
+ {$IFDEF PAS2C}
+ exit(LongInt(GameType = gmtSyntax));
+ {$ELSE}
halt(LongInt(GameType = gmtSyntax));
+ {$ENDIF}
+
{$ENDIF}
end.
--- a/hedgewars/hwengine.rc Sun Jan 19 00:18:28 2014 +0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1 +0,0 @@
-MAINICON ICON "hwengine.ico"
\ No newline at end of file
--- a/hedgewars/options.inc Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/options.inc Tue Jan 21 22:38:13 2014 +0100
@@ -64,12 +64,9 @@
{$DEFINE SDL2}
{$ENDIF}
-
-//TODO: cruft to be removed
{$DEFINE _S:=}
{$DEFINE _P:=}
-
//{$DEFINE TRACEAIACTIONS}
//{$DEFINE COUNTTICKS}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/hedgewars/pas2cRedo.pas Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,113 @@
+redo;
+{This file contains functions that are re-implemented}
+{pas2c will add prefix fpcrtl_ to all these functions}
+type
+ uinteger = uinteger;
+ Integer = integer;
+ LongInt = integer;
+ LongWord = uinteger;
+ Cardinal = uinteger;
+ PtrInt = integer;
+ Word = uinteger;
+ Byte = integer;
+ SmallInt = integer;
+ ShortInt = integer;
+ Int64 = integer;
+ QWord = uinteger;
+ GLint = integer;
+ GLuint = integer;
+ int = integer;
+ size_t = integer;
+
+ pointer = pointer;
+
+ float = float;
+ single = float;
+ double = float;
+ real = float;
+ extended = float;
+ GLfloat = float;
+
+ boolean = boolean;
+ LongBool = boolean;
+
+ string = string;
+ shortstring = string;
+ ansistring = string;
+ widechar = string;
+
+ char = char;
+ PChar = ^char;
+ PPChar = ^Pchar;
+
+ PByte = ^Byte;
+ PLongInt = ^LongInt;
+ PLongWord = ^LongWord;
+ PInteger = ^Integer;
+
+ Handle = integer;
+
+var
+ write, writeLn, read, readLn, flush, CreateDir: procedure;
+
+ halt:procedure;
+
+ GetEnumName:function:shortstring;
+ TypeInfo:function:Integer;
+
+ lo:function:Integer;
+
+ init:procedure;
+
+ StrLen:function : integer;
+ odd, even : function : boolean;
+
+ Length : function : integer;
+
+ Now : function : integer;
+
+ new, dispose, FillChar, Move : procedure;
+
+ trunc, round : function : integer;
+ abs, sqr : function : integer;
+
+ StrPas, FormatDateTime, copy, delete, str, PosS, trim, LowerCase : function : shortstring;
+ pos : function : integer;
+ StrToInt : function : integer;
+ SetLength, val : procedure;
+ _pchar : function : PChar;
+ pchar2str : function : string;
+ memcpy : procedure;
+
+ min, max:function:integer;
+ assign, rewrite, rewrite_2, reset, reset_2, flush, BlockWrite, BlockRead, close : procedure;
+ FileExists, DirectoryExists, eof : function : boolean;
+ ExtractFileName : function : string;
+
+ ParamCount : function : integer;
+ ParamStr : function : string;
+
+ arctan2, power: function : float;
+
+ //TypeInfo, GetEnumName : function : shortstring;
+
+ UTF8ToUnicode, WrapText: function : shortstring;
+
+ GetMem : function : pointer;
+ FreeMem : procedure;
+
+ BeginThread, ThreadSwitch : procedure;
+ InterlockedIncrement, InterlockedDecrement : procedure;
+
+ random : function : integer;
+ randomize : procedure;
+
+ Assigned : function : boolean;
+
+ //EnumToStr : function : string;
+
+ initParams : procedure;
+
+ Load_GL_VERSION_2_0 : procedure;
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/hedgewars/pas2cSystem.pas Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,134 @@
+system;
+{This file contains functions that are external}
+type
+ uinteger = uinteger;
+ Integer = integer;
+ LongInt = integer;
+ LongWord = uinteger;
+ Cardinal = uinteger;
+ PtrInt = integer;
+ Word = uinteger;
+ Byte = integer;
+ SmallInt = integer;
+ ShortInt = integer;
+ Int64 = integer;
+ QWord = uinteger;
+ GLint = integer;
+ GLuint = integer;
+ GLenum = integer;
+
+ int = integer;
+ size_t = integer;
+
+ pointer = pointer;
+
+ float = float;
+ single = float;
+ double = float;
+ real = float;
+ extended = float;
+ GLfloat = float;
+
+ boolean = boolean;
+ LongBool = boolean;
+
+ string = string;
+ shortstring = string;
+ ansistring = string;
+ widechar = string;
+
+ char = char;
+ PChar = ^char;
+ PPChar = ^Pchar;
+
+ PByte = ^Byte;
+ PWord = ^Word;
+ PLongInt = ^LongInt;
+ PLongWord = ^LongWord;
+ PInteger = ^Integer;
+
+ Handle = integer;
+
+ png_structp = pointer;
+ png_size_t = integer;
+
+var
+ false, true: boolean;
+
+ ord, Succ, Pred : function : integer;
+ inc, dec, Low, High, Lo, Hi : function : integer;
+
+ IOResult : integer;
+ exit, break, halt, continue : procedure;
+
+ TextFile, File : Handle;
+ FileMode : integer;
+ exitcode : integer;
+ stdout, stderr : Handle;
+
+ sqrt, cos, sin: function : float;
+ pi : float;
+
+ sizeof : function : integer;
+
+ glGetString : function : pchar;
+
+ glBegin, glBindTexture, glBlendFunc, glClear, glClearColor,
+ glColor4ub, glColorMask, glColorPointer, glDeleteTextures,
+ glDisable, glDisableClientState, glDrawArrays, glEnable,
+ glEnableClientState, glEnd, glGenTextures, glGetIntegerv,
+ glHint, glLineWidth, glLoadIdentity, glMatrixMode, glPopMatrix,
+ glPushMatrix, glReadPixels, glRotatef, glScalef, glTexCoord2f,
+ glTexCoordPointer, glTexImage2D, glTexParameterf,
+ glTexParameteri, glTranslatef, glVertex2d, glVertexPointer,
+ glViewport, glext_LoadExtension, glDeleteRenderbuffersEXT,
+ glDeleteFramebuffersEXT, glGenFramebuffersEXT,
+ glGenRenderbuffersEXT, glBindFramebufferEXT,
+ glBindRenderbufferEXT, glRenderbufferStorageEXT,
+ glFramebufferRenderbufferEXT, glFramebufferTexture2DEXT,
+ glUniformMatrix4fv, glVertexAttribPointer, glCreateShader,
+ glShaderSource, glCompileShader, glGetShaderiv, glGetShaderInfoLog,
+ glCreateProgram, glAttachShader, glBindAttribLocation, glLinkProgram,
+ glDeleteShader, glGetProgramiv, glGetProgramInfoLog, glUseProgram,
+ glUniform1i, glGetUniformLocation, glEnableVertexAttribArray,
+ glGetError, glDeleteProgram, glDeleteBuffers,
+ glGenBuffers, glBufferData, glBindBuffer, glewInit,
+ glUniform4f, glDisableVertexAttribArray, glTexEnvi : procedure;
+
+ GL_BGRA, GL_BLEND, GL_CLAMP_TO_EDGE, GL_COLOR_ARRAY,
+ GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT, GL_DEPTH_COMPONENT,
+ GL_DITHER, GL_EXTENSIONS, GL_FALSE, GL_FASTEST, GL_LINEAR,
+ GL_LINE_LOOP, GL_LINES, GL_LINE_SMOOTH, GL_LINE_STRIP,
+ GL_MAX_TEXTURE_SIZE, GL_MODELVIEW, GL_ONE_MINUS_SRC_ALPHA,
+ GL_PERSPECTIVE_CORRECTION_HINT, GL_PROJECTION, GL_QUADS,
+ GL_RENDERER, GL_RGBA, GL_RGBA8, GL_SRC_ALPHA, GL_TEXTURE_2D,
+ GL_TEXTURE_COORD_ARRAY, GL_TEXTURE_MAG_FILTER,
+ GL_TEXTURE_MIN_FILTER, GL_TEXTURE_PRIORITY, GL_TEXTURE_WRAP_S,
+ GL_TEXTURE_WRAP_T, GL_TRIANGLE_FAN, GL_TRUE, GL_VENDOR,
+ GL_VERSION, GL_VERTEX_ARRAY, GLenum, GL_FRAMEBUFFER_EXT,
+ GL_RENDERBUFFER_EXT, GL_DEPTH_ATTACHMENT_EXT,
+ GL_COLOR_ATTACHMENT0_EXT, GL_FLOAT, GL_UNSIGNED_BYTE, GL_COMPILE_STATUS,
+ GL_INFO_LOG_LENGTH, GL_LINK_STATUS, GL_VERTEX_SHADER, GL_FRAGMENT_SHADER,
+ GL_NO_ERROR, GL_ARRAY_BUFFER, GL_STATIC_DRAW, GLEW_OK,
+ GL_AUX_BUFFERS, GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE, GL_ADD: integer;
+
+ TThreadId : function : integer;
+
+ _strconcat, _strappend, _strprepend, _chrconcat : function : string;
+ _strcompare, _strncompare, _strcomparec : function : boolean;
+
+ png_structp, png_set_write_fn, png_get_io_ptr,
+ png_get_libpng_ver, png_create_write_struct,
+ png_create_info_struct, png_destroy_write_struct,
+ png_write_row, png_set_ihdr, png_write_info,
+ png_write_end : procedure;
+
+ clear_filelist_hook, add_file_hook, idb_loader_hook, mainloop_hook, drawworld_hook : procedure;
+ SDL_InitPatch : procedure;
+
+ PHYSFS_init, PHYSFS_deinit, PHYSFS_mount, PHYSFS_readBytes : function : LongInt;
+ PHYSFSRWOPS_openRead, PHYSFSRWOPS_openWrite, PHYSFS_openRead : function : pointer;
+ PHYSFS_eof, PHYSFS_close, PHYSFS_exists : function : boolean;
+
+ hedgewarsMountPackages, physfsReaderSetBuffer, hedgewarsMountPackage : procedure;
+ physfsReader : function : pointer;
Binary file hedgewars/res/hwengine.ico has changed
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/hedgewars/res/hwengine.rc Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,2 @@
+MAINICON ICON "res/hwengine.ico"
+
--- a/hedgewars/uAI.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uAI.pas Tue Jan 21 22:38:13 2014 +0100
@@ -359,6 +359,10 @@
if GoInfo.FallPix >= FallPixForBranching then
Push(ticks, Actions, Me^, Me^.Message xor 3); // aia_Left xor 3 = aia_Right
+
+ if (StartTicks > GameTicks - 1500) and (not StopThinking) then
+ SDL_Delay(1000);
+
end {while};
if BestRate > BaseRate then
@@ -370,12 +374,13 @@
function Think(Me: PGear): LongInt; cdecl; export;
var BackMe, WalkMe: TGear;
switchCount: LongInt;
- StartTicks, currHedgehogIndex, itHedgehog, switchesNum, i: Longword;
+ currHedgehogIndex, itHedgehog, switchesNum, i: Longword;
switchImmediatelyAvailable: boolean;
Actions: TActions;
begin
dmgMod:= 0.01 * hwFloat2Float(cDamageModifier) * cDamagePercent;
StartTicks:= GameTicks;
+
currHedgehogIndex:= CurrentTeam^.CurrHedgehog;
itHedgehog:= currHedgehogIndex;
switchesNum:= 0;
@@ -397,7 +402,7 @@
Actions.Score:= 0;
if switchesNum > 0 then
begin
- if not switchImmediatelyAvailable then
+ if (not switchImmediatelyAvailable) then
begin
// when AI has to use switcher, make it cost smth unless they have a lot of switches
if (switchCount < 10) then Actions.Score:= (-27+switchCount*3)*4000;
@@ -421,8 +426,8 @@
or (itHedgehog = currHedgehogIndex)
or BestActions.isWalkingToABetterPlace;
- if (StartTicks > GameTicks - 1500) and (not StopThinking) then
- SDL_Delay(1000);
+ if (StartTicks > GameTicks - 1500) and (not StopThinking) then
+ SDL_Delay(1000);
if (BestActions.Score < -1023) and (not BestActions.isWalkingToABetterPlace) then
begin
@@ -437,11 +442,13 @@
i:= 12;
while (not StopThinking) and (BestActions.Count = 0) and (i > 0) do
begin
+
(*
// Maybe this would get a bit of movement out of them? Hopefully not *toward* water. Need to check how often he'd choose that strategy
if SuddenDeathDmg and ((hwRound(BackMe.Y)+cWaterRise*2) > cWaterLine) then
AddBonus(hwRound(BackMe.X), hwRound(BackMe.Y), 250, -40);
*)
+
FillBonuses(true);
WalkMe:= BackMe;
Actions.Count:= 0;
--- a/hedgewars/uAIAmmoTests.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uAIAmmoTests.pas Tue Jan 21 22:38:13 2014 +0100
@@ -247,7 +247,7 @@
or (y < 0)
or (trunc(x) > LAND_WIDTH)
or (trunc(y) > LAND_HEIGHT)
- or not TestCollExcludingObjects(trunc(x), trunc(y), 5)
+ or (not TestCollExcludingObjects(trunc(x), trunc(y), 5))
or (timer = 0)
end;
EX:= trunc(x);
@@ -779,7 +779,7 @@
Targ:= Targ; // avoid compiler hint
if Level < 3 then trackFall:= afTrackFall
- else trackFall:= 0;
+ else trackFall:= 0;
ap.ExplR:= 0;
ap.Time:= 0;
@@ -1241,7 +1241,7 @@
x:= x + dx;
dy:= dy + cGravityf;
y:= y + dy;
-
+
if TestColl(trunc(x), trunc(y), 3) then
t:= 0;
until t = 0;
@@ -1251,7 +1251,7 @@
if Level = 1 then
valueResult:= RateExplosion(Me, EX, EY, 76, afTrackFall or afErasesLand)
-else
+else
valueResult:= RateExplosion(Me, EX, EY, 76);
if (valueResult > 0) then
--- a/hedgewars/uAIMisc.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uAIMisc.pas Tue Jan 21 22:38:13 2014 +0100
@@ -53,7 +53,17 @@
X, Y: LongInt;
Radius: LongInt;
Score: LongInt;
- end;
+ end;
+
+Tbonuses = record
+ Count : Longword;
+ ar : array[0..Pred(MAXBONUS)] of TBonus;
+ end;
+
+Twalkbonuses = record
+ Count: Longword;
+ ar: array[0..Pred(MAXBONUS div 8)] of TBonus; // don't use too many
+ end;
procedure initModule;
procedure freeModule;
@@ -82,22 +92,16 @@
var ThinkingHH: PGear;
Targets: TTargets;
- bonuses: record
- Count: Longword;
- ar: array[0..Pred(MAXBONUS)] of TBonus;
- end;
+ bonuses: Tbonuses;
- walkbonuses: record
- Count: Longword;
- ar: array[0..Pred(MAXBONUS div 8)] of TBonus; // don't use too many
- end;
+ walkbonuses: Twalkbonuses;
const KillScore = 200;
var friendlyfactor: LongInt = 300;
var dmgMod: real = 1.0;
implementation
-uses uCollisions, uVariables, uUtils, uLandTexture, uGearsUtils;
+uses uCollisions, uVariables, uUtils, uGearsUtils;
var
KnownExplosion: record
@@ -127,13 +131,13 @@
if (((Gear^.Kind = gtHedgehog) and
(Gear <> ThinkingHH) and
(Gear^.Health > Gear^.Damage) and
- not(Gear^.Hedgehog^.Team^.hasgone)) or
+ (not Gear^.Hedgehog^.Team^.hasgone)) or
((Gear^.Kind = gtExplosives) and
(Gear^.Health > Gear^.Damage)) or
((Gear^.Kind = gtMine) and
(Gear^.Health = 0) and
(Gear^.Damage < 35))
- ) and
+ ) and
(Targets.Count < 256) then
begin
with Targets.ar[Targets.Count] do
@@ -155,7 +159,7 @@
Score:= Gear^.Damage - Gear^.Health;
inc(f)
end
- else
+ else
begin
Score:= Gear^.Health - Gear^.Damage;
inc(e)
@@ -163,7 +167,7 @@
end
else if Gear^.Kind = gtExplosives then
Score:= Gear^.Health - Gear^.Damage
- else if Gear^.Kind = gtMine then
+ else if Gear^.Kind = gtMine then
Score:= max(0,35-Gear^.Damage);
end;
inc(Targets.Count)
@@ -384,20 +388,20 @@
dmg := 1 + trunc((dY - 0.4) * 70);
exit(dmg)
end
- else
+ else
begin
dxdy:= abs(dX)+abs(dY);
- if ((Kind = gtMine) and (dxdy > 0.35)) or
- ((Kind = gtExplosives) and
+ if ((Kind = gtMine) and (dxdy > 0.35)) or
+ ((Kind = gtExplosives) and
(((State and gstTmpFlag <> 0) and (dxdy > 0.35)) or
- ((State and gstTmpFlag = 0) and
- ((abs(odX) > 0.15) or ((abs(odY) > 0.15) and
+ ((State and gstTmpFlag = 0) and
+ ((abs(odX) > 0.15) or ((abs(odY) > 0.15) and
(abs(odX) > 0.02))) and (dxdy > 0.35)))) then
begin
dmg := trunc(dxdy * 25);
exit(dmg)
end
- else if (Kind = gtExplosives) and not((abs(odX) > 0.15) or ((abs(odY) > 0.15) and (abs(odX) > 0.02))) and (dY > 0.2) then
+ else if (Kind = gtExplosives) and (not(abs(odX) > 0.15) or ((abs(odY) > 0.15) and (abs(odX) > 0.02))) and (dY > 0.2) then
begin
dmg := trunc(dy * 70);
exit(dmg)
@@ -436,20 +440,20 @@
dmg := trunc((dY - 0.4) * 70);
exit(dmg);
end
- else
+ else
begin
dxdy:= abs(dX)+abs(dY);
- if ((Kind = gtMine) and (dxdy > 0.4)) or
- ((Kind = gtExplosives) and
+ if ((Kind = gtMine) and (dxdy > 0.4)) or
+ ((Kind = gtExplosives) and
(((State and gstTmpFlag <> 0) and (dxdy > 0.4)) or
- ((State and gstTmpFlag = 0) and
- ((abs(odX) > 0.15) or ((abs(odY) > 0.15) and
+ ((State and gstTmpFlag = 0) and
+ ((abs(odX) > 0.15) or ((abs(odY) > 0.15) and
(abs(odX) > 0.02))) and (dxdy > 0.35)))) then
begin
dmg := trunc(dxdy * 50);
exit(dmg)
end
- else if (Kind = gtExplosives) and not((abs(odX) > 0.15) or ((abs(odY) > 0.15) and (abs(odX) > 0.02))) and (dY > 0.2) then
+ else if (Kind = gtExplosives) and (not(abs(odX) > 0.15) or ((abs(odY) > 0.15) and (abs(odX) > 0.02))) and (dY > 0.2) then
begin
dmg := trunc(dy * 70);
exit(dmg)
@@ -520,7 +524,7 @@
begin
dX:= (0.005 * dmg + 0.01) / Density;
dY:= dX;
- if (Kind = gtExplosives) and (State and gstTmpFlag = 0) and
+ if (Kind = gtExplosives) and (State and gstTmpFlag = 0) and
(((abs(dY) > 0.15) and (abs(dX) < 0.02)) or
((abs(dY) < 0.15) and (abs(dX) < 0.15))) then
dX:= 0;
@@ -606,8 +610,8 @@
pY:= Point.y-2;
fallDmg:= 0;
if (Flags and afSetSkip <> 0) then skip:= true;
- if not(dead) and (Flags and afTrackFall <> 0) and (Score > 0) and (power < Score) then
- if (Kind = gtExplosives) and (State and gstTmpFlag = 0) and
+ if (not dead) and (Flags and afTrackFall <> 0) and (Score > 0) and (power < Score) then
+ if (Kind = gtExplosives) and (State and gstTmpFlag = 0) and
(((abs(dY) > 0.15) and (abs(dX) < 0.02)) or
((abs(dY) < 0.15) and (abs(dX) < 0.15))) then
fallDmg:= trunc(TraceShoveFall(pX, pY, 0, dY, Targets.ar[i]) * dmgMod)
@@ -701,7 +705,7 @@
end;
if dmg > 0 then
begin
- if not(dead) and (Score > 0) and (dmg < Score) then
+ if (not dead) and (Score > 0) and (dmg < Score) then
begin
pX:= Point.x;
pY:= Point.y;
@@ -709,9 +713,9 @@
dY:= gdY * dmg / Density;
if dX < 0 then dX:= dX - 0.01
else dX:= dX + 0.01;
- if (Kind = gtExplosives) and (State and gstTmpFlag = 0) and
+ if (Kind = gtExplosives) and (State and gstTmpFlag = 0) and
(((abs(dY) > 0.15) and (abs(dX) < 0.02)) or
- ((abs(dY) < 0.15) and (abs(dX) < 0.15))) then
+ ((abs(dY) < 0.15) and (abs(dX) < 0.15))) then
dX:= 0;
if (x and LAND_WIDTH_MASK = 0) and ((y+cHHRadius+2) and LAND_HEIGHT_MASK = 0) and
(Land[y+cHHRadius+2, x] and lfIndestructible <> 0) then
--- a/hedgewars/uAmmos.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uAmmos.pas Tue Jan 21 22:38:13 2014 +0100
@@ -50,7 +50,7 @@
var StoreCnt: Longword;
implementation
-uses uLocale, uVariables, uCommands, uUtils, uCaptions, uDebug;
+uses uVariables, uCommands, uUtils, uCaptions, uDebug;
type TAmmoCounts = array[TAmmoType] of Longword;
TAmmoArray = array[TAmmoType] of TAmmo;
@@ -132,22 +132,22 @@
inc(Ammoz[a].SkipTurns,10000);
if ((GameFlags and gfPlaceHog) <> 0) and (a = amTeleport) then
ammos[a]:= AMMO_INFINITE
- end
-
+ end
+
else
ammos[a]:= AMMO_INFINITE;
- if ((GameFlags and gfPlaceHog) <> 0) and (a = amTeleport) then
+ if ((GameFlags and gfPlaceHog) <> 0) and (a = amTeleport) then
InitialCounts[Pred(StoreCnt)][a]:= cnt
else
InitialCounts[Pred(StoreCnt)][a]:= ammos[a];
end;
-
+
for a:= Low(TAmmoType) to High(TAmmoType) do
begin
newAmmos[a]:= Ammoz[a].Ammo;
newAmmos[a].Count:= ammos[a]
end;
-
+
FillAmmoStore(StoresList[Pred(StoreCnt)], newAmmos)
end;
@@ -272,7 +272,7 @@
Ammo^[Slot, ami]:= Ammo^[Slot, ami + 1];
Ammo^[Slot, ami + 1].Count:= 0
end;
- until not b;
+ until (not b);
AmmoMenuInvalidated:= true;
end;
@@ -311,7 +311,7 @@
if (AmmoType = Ammo) then
if Hedgehog.Team^.Clan^.TurnNumber > Ammoz[AmmoType].SkipTurns then
exit(Count)
- else
+ else
exit(0);
inc(ami)
end;
@@ -482,7 +482,7 @@
for a:= Low(TAmmoType) to High(TAmmoType) do
newAmmos[a]:= Ammoz[a].Ammo;
-
+
for i:= 0 to Pred(StoreCnt) do
begin
for a:= Low(TAmmoType) to High(TAmmoType) do
@@ -499,8 +499,8 @@
procedure chAddAmmoStore(var descr: shortstring);
begin
-descr:= ''; // avoid compiler hint
-AddAmmoStore
+ descr:= ''; // avoid compiler hint
+ AddAmmoStore
end;
procedure initModule;
--- a/hedgewars/uCaptions.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uCaptions.pas Tue Jan 21 22:38:13 2014 +0100
@@ -15,7 +15,7 @@
* 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 uCaptions;
@@ -45,12 +45,14 @@
procedure AddCaption(s: shortstring; Color: Longword; Group: TCapGroup);
begin
if cOnlyStats then exit;
+ if Length(s) = 0 then
+ exit;
if Captions[Group].Text <> s then
begin
FreeTexture(Captions[Group].Tex);
Captions[Group].Tex:= nil
end;
-
+
if Captions[Group].Tex = nil then
begin
Captions[Group].Color:= Color;
--- a/hedgewars/uChat.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uChat.pas Tue Jan 21 22:38:13 2014 +0100
@@ -42,7 +42,7 @@
Width: LongInt;
s: shortstring;
end;
- TChatCmd = (quit, pause, finish, showhistory, fullscreen);
+ TChatCmd = (ccQuit, ccPause, ccFinish, ccShowHistory, ccFullScreen);
var Strs: array[0 .. MaxStrIndex] of TChatLine;
MStrs: array[0 .. MaxStrIndex] of shortstring;
@@ -228,7 +228,7 @@
else if (s[1] = '-') and (s[Length(s)] = '-') then
x:= 3;
-if not CurrentTeam^.ExtDriven and (x <> 0) then
+if (not CurrentTeam^.ExtDriven) and (x <> 0) then
for c:= 0 to Pred(TeamsCount) do
if (TeamsArray[c] = CurrentTeam) then
t:= c;
--- a/hedgewars/uCollisions.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uCollisions.pas Tue Jan 21 22:38:13 2014 +0100
@@ -54,7 +54,7 @@
function TestRectancleForObstacle(x1, y1, x2, y2: LongInt; landOnly: boolean): boolean;
-// returns: negative sign if going downhill to left, value is steepness (noslope/error = _0, 45° = _0_5)
+// returns: negative sign if going downhill to left, value is steepness (noslope/error = _0, 45 = _0_5)
function CalcSlopeBelowGear(Gear: PGear): hwFloat;
function CalcSlopeNearGear(Gear: PGear; dirX, dirY: LongInt): hwFloat;
function CalcSlopeTangent(Gear: PGear; collisionX, collisionY: LongInt; var outDeltaX, outDeltaY: LongInt; TestWord: LongWord): boolean;
@@ -92,7 +92,7 @@
if (Count > (MAXRECTSINDEX-20)) then
begin
t:= GearsList;
- while (t <> nil) and (t^.Kind <> gtMine) do
+ while (t <> nil) and (t^.Kind <> gtMine) do
t:= t^.NextGear;
if (t <> nil) then
t^.State:= t^.State or gmDelete
@@ -234,7 +234,7 @@
for i:= 0 to Pred(Count) do
with cinfos[i] do
- if (Gear <> cGear) and
+ if (Gear <> cGear) and
((mx > x) xor (Dir > 0)) and
(
((cGear^.Kind in [gtHedgehog, gtMine, gtKnife]) and ((Gear^.State and gstNotKickable) = 0)) or
@@ -300,7 +300,7 @@
if (Gear <> cGear) and
((myr > y) xor (Dir > 0)) and
(Gear^.State and gstNotKickable = 0) and
- (cGear^.Kind in [gtHedgehog, gtMine, gtKnife, gtExplosives]) and
+ (cGear^.Kind in [gtHedgehog, gtMine, gtKnife, gtExplosives]) and
(sqr(mx - x) + sqr(my - y) <= sqr(Radius + Gear^.Radius + 2)) then
begin
with cGear^ do
@@ -327,7 +327,7 @@
begin
Gear^.X:= Gear^.X + ShiftX;
Gear^.Y:= Gear^.Y + int2hwFloat(ShiftY);
-if withGear then
+if withGear then
TestCollisionXwithXYShift:= TestCollisionXwithGear(Gear, Dir)
else TestCollisionXwithXYShift:= TestCollisionX(Gear, Dir);
Gear^.X:= Gear^.X - ShiftX;
@@ -394,7 +394,7 @@
TestCollisionYwithXYShift:= TestCollisionYwithGear(Gear, Dir)
else
TestCollisionYwithXYShift:= TestCollisionY(Gear, Dir);
-
+
Gear^.X:= Gear^.X - int2hwFloat(ShiftX);
Gear^.Y:= Gear^.Y - int2hwFloat(ShiftY)
end;
@@ -583,7 +583,7 @@
isColl, bSucc: Boolean;
begin
-if dirY <> 0 then
+if dirY <> 0 then
begin
y:= hwRound(Gear^.Y) + Gear^.Radius * dirY;
gx:= hwRound(Gear^.X);
--- a/hedgewars/uConsole.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uConsole.pas Tue Jan 21 22:38:13 2014 +0100
@@ -49,11 +49,11 @@
begin
{$IFNDEF NOCONSOLE}
WriteToConsole(s);
- lastConsoleline:= s;
{$IFNDEF ANDROID}
WriteLn(stderr, '');
{$ENDIF}
{$ENDIF}
+ lastConsoleline:= s;
end;
function ShortStringAsPChar(s: shortstring) : PChar;
--- a/hedgewars/uConsts.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uConsts.pas Tue Jan 21 22:38:13 2014 +0100
@@ -93,18 +93,18 @@
// lfObject and lfBasic are only to be different *graphically* in all other ways they should be treated the same
lfBasic = $8000; // white
lfIndestructible = $4000; // red
- lfObject = $2000;
+ lfObject = $2000;
lfDamaged = $1000; //
lfIce = $0800; // blue
lfBouncy = $0400; // green
lfLandMask = $FF00; // upper byte is used for terrain, not objects.
- lfCurrentHog = $0080; // CurrentHog. It is also used to flag crates, for convenience of AI. Since an active hog would instantly collect the crate, this doesn't impact play
+ lfCurrentHog = $0080; // CurrentHog. It is also used to flag crates, for convenience of AI. Since an active hog would instantly collect the crate, this does not impact play
lfNotCurrentMask = $FF7F; // inverse of above. frequently used
lfObjMask = $007F; // lower 7 bits used for hogs
lfNotObjMask = $FF80; // inverse of above.
- // lower byte is for objects.
- // consists of 0-127 counted for object checkins and $80 as a bit flag for current hog.
+ // lower byte is for objects.
+ // consists of 0-127 counted for object checkins and $80 as a bit flag for current hog.
lfAllObjMask = $00FF; // lfCurrentHog or lfObjMask
@@ -115,11 +115,13 @@
MAXNAMELEN = 192;
MAXROPEPOINTS = 3840;
+ {$IFNDEF PAS2C}
// some opengl headers do not have these macros
GL_BGR = $80E0;
GL_BGRA = $80E1;
GL_CLAMP_TO_EDGE = $812F;
GL_TEXTURE_PRIORITY = $8066;
+ {$ENDIF}
cVisibleWater : LongInt = 128;
cTeamHealthWidth : LongInt = 128;
@@ -150,7 +152,7 @@
cBlowTorchC = 6;
cakeDmg = 75;
- cKeyMaxIndex = 1023;
+ cKeyMaxIndex = 1600;
cKbdMaxIndex = 65536;//need more room for the modifier keys
cFontBorder = 2;
@@ -239,11 +241,11 @@
cMaxSlotIndex = 9;
cMaxSlotAmmoIndex = 5;
-
+
// ai hints
aihUsualProcessing = $00000000;
aihDoesntMatter = $00000001;
-
+
// ammo properties
ammoprop_Timerable = $00000001;
ammoprop_Power = $00000002;
@@ -261,7 +263,7 @@
ammoprop_Utility = $00001000;
ammoprop_Effect = $00002000;
ammoprop_SetBounce = $00004000;
- ammoprop_NeedUpDown = $00008000;//Used by TouchInterface to show or hide up/down widgets
+ ammoprop_NeedUpDown = $00008000;//Used by TouchInterface to show or hide up/down widgets
ammoprop_OscAim = $00010000;
ammoprop_NoMoveAfter = $00020000;
ammoprop_Track = $00040000;
@@ -296,7 +298,7 @@
htTransparent = $08;
NoPointX = Low(LongInt);
- cTargetPointRef : TPoint = (X: NoPointX; Y: 0);
+ cTargetPointRef : TPoint = (x: NoPointX; y: 0);
kSystemSoundID_Vibrate = $00000FFF;
--- a/hedgewars/uFloat.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uFloat.pas Tue Jan 21 22:38:13 2014 +0100
@@ -39,7 +39,6 @@
*)
interface
-{$IFDEF FPC}
{$IFDEF ENDIAN_LITTLE}
type hwFloat = record
isNegative: boolean;
@@ -63,7 +62,9 @@
// The implemented operators
operator = (const z1, z2: hwFloat) z : boolean; inline;
-
+{$IFDEF PAS2C}
+operator <> (const z1, z2: hwFloat) z : boolean; inline;
+{$ENDIF}
operator + (const z1, z2: hwFloat) z : hwFloat; inline;
operator - (const z1, z2: hwFloat) z : hwFloat; inline;
operator - (const z1: hwFloat) z : hwFloat; inline;
@@ -95,14 +96,9 @@
function hwSign(r: hwFloat): LongInt; inline; // Returns an integer with value 1 and sign of parameter r.
function hwSignf(r: real): LongInt; inline; // Returns an integer with value 1 and sign of parameter r.
function isZero(const z: hwFloat): boolean; inline;
-{$IFDEF FPC}
-{$J-}
-{$ENDIF}
+
{$WARNINGS OFF}
-
-
// some hwFloat constants
-
const _1div1024: hwFloat = (isNegative: false; QWordValue: 4194304);
_1div10000: hwFloat = (isNegative: false; QWordValue: 429496);
_1div50000: hwFloat = (isNegative: false; QWordValue: 85899);
@@ -150,20 +146,20 @@
_0_999: hwFloat = (isNegative: false; QWordValue: 4290672328);
_0: hwFloat = (isNegative: false; QWordValue: 0);
_1: hwFloat = (isNegative: false; QWordValue: 4294967296);
- _1_2: hwFloat = (isNegative: false; QWordValue: 1288490189*4);
+ _1_2: hwFloat = (isNegative: false; QWordValue: 4294967296 * 6 div 5 + 1);
_1_5: hwFloat = (isNegative: false; QWordValue: 4294967296 * 3 div 2);
_1_6: hwFloat = (isNegative: false; QWordValue: 4294967296 * 8 div 5);
_1_9: hwFloat = (isNegative: false; QWordValue: 8160437862);
_2: hwFloat = (isNegative: false; QWordValue: 4294967296 * 2);
_2_4: hwFloat = (isNegative: false; QWordValue: 4294967296 * 12 div 5);
_3: hwFloat = (isNegative: false; QWordValue: 4294967296 * 3);
- _3_2: hwFloat = (isNegative: false; QWordValue: 3435973837*4);
+ _3_2: hwFloat = (isNegative: false; QWordValue: 4294967296 * 16 div 5);
_PI: hwFloat = (isNegative: false; QWordValue: 13493037704);
_4: hwFloat = (isNegative: false; QWordValue: 4294967296 * 4);
_4_5: hwFloat = (isNegative: false; QWordValue: 4294967296 * 9 div 2);
_5: hwFloat = (isNegative: false; QWordValue: 4294967296 * 5);
_6: hwFloat = (isNegative: false; QWordValue: 4294967296 * 6);
- _6_4: hwFloat = (isNegative: false; QWordValue: 3435973837 * 8);
+ _6_4: hwFloat = (isNegative: false; QWordValue: 4294967296 * 32 div 5);
_7: hwFloat = (isNegative: false; QWordValue: 4294967296 * 7);
_10: hwFloat = (isNegative: false; QWordValue: 4294967296 * 10);
_12: hwFloat = (isNegative: false; QWordValue: 4294967296 * 12);
@@ -194,18 +190,11 @@
cLittle: hwFloat = (isNegative: false; QWordValue: 1);
cHHKick: hwFloat = (isNegative: false; QWordValue: 42949673); // _0_01
{$WARNINGS ON}
-{$ENDIF}
-
-{$IFNDEF FPC}
-type hwFloat = Extended;
-{$ENDIF}
implementation
uses uSinTable;
-{$IFDEF FPC}
-
function int2hwFloat (const i: LongInt) : hwFloat; inline;
begin
int2hwFloat.isNegative:= i < 0;
@@ -225,6 +214,13 @@
z:= (z1.isNegative = z2.isNegative) and (z1.QWordValue = z2.QWordValue);
end;
+{$IFDEF PAS2C}
+operator <> (const z1, z2: hwFloat) z : boolean; inline;
+begin
+ z:= (z1.isNegative <> z2.isNegative) or (z1.QWordValue <> z2.QWordValue);
+end;
+{$ENDIF}
+
operator + (const z1, z2: hwFloat) z : hwFloat; inline;
begin
if z1.isNegative = z2.isNegative then
@@ -294,95 +290,95 @@
operator - (const z1: hwFloat) z : hwFloat; inline;
begin
-z:= z1;
-z.isNegative:= not z.isNegative
+ z:= z1;
+ z.isNegative:= not z.isNegative
end;
operator * (const z1, z2: hwFloat) z : hwFloat; inline;
begin
-z.isNegative:= z1.isNegative xor z2.isNegative;
-z.QWordValue:= QWord(z1.Round) * z2.Frac + QWord(z1.Frac) * z2.Round + ((QWord(z1.Frac) * z2.Frac) shr 32);
-z.Round:= z.Round + QWord(z1.Round) * z2.Round;
+ z.isNegative:= z1.isNegative xor z2.isNegative;
+ z.QWordValue:= QWord(z1.Round) * z2.Frac + QWord(z1.Frac) * z2.Round + ((QWord(z1.Frac) * z2.Frac) shr 32);
+ z.Round:= z.Round + QWord(z1.Round) * z2.Round;
end;
operator * (const z1: hwFloat; const z2: LongInt) z : hwFloat; inline;
begin
-z.isNegative:= z1.isNegative xor (z2 < 0);
-z.QWordValue:= z1.QWordValue * abs(z2)
+ z.isNegative:= z1.isNegative xor (z2 < 0);
+ z.QWordValue:= z1.QWordValue * abs(z2)
end;
operator / (const z1: hwFloat; z2: hwFloat) z : hwFloat; inline;
var t: QWord;
begin
-z.isNegative:= z1.isNegative xor z2.isNegative;
-z.Round:= z1.QWordValue div z2.QWordValue;
-t:= z1.QWordValue - z2.QWordValue * z.Round;
-z.Frac:= 0;
+ z.isNegative:= z1.isNegative xor z2.isNegative;
+ z.Round:= z1.QWordValue div z2.QWordValue;
+ t:= z1.QWordValue - z2.QWordValue * z.Round;
+ z.Frac:= 0;
-if t <> 0 then
- begin
- while ((t and $FF00000000000000) = 0) and ((z2.QWordValue and $FF00000000000000) = 0) do
+ if t <> 0 then
begin
- t:= t shl 8;
- z2.QWordValue:= z2.QWordValue shl 8
- end;
+ while ((t and $FF00000000000000) = 0) and ((z2.QWordValue and $FF00000000000000) = 0) do
+ begin
+ t:= t shl 8;
+ z2.QWordValue:= z2.QWordValue shl 8
+ end;
- if z2.Round > 0 then
- inc(z.QWordValue, t div z2.Round);
- end
+ if z2.Round > 0 then
+ inc(z.QWordValue, t div z2.Round);
+ end
end;
operator / (const z1: hwFloat; const z2: LongInt) z : hwFloat; inline;
begin
-z.isNegative:= z1.isNegative xor (z2 < 0);
-z.QWordValue:= z1.QWordValue div abs(z2)
+ z.isNegative:= z1.isNegative xor (z2 < 0);
+ z.QWordValue:= z1.QWordValue div abs(z2)
end;
function cstr(const z: hwFloat): shortstring;
var tmpstr: shortstring;
begin
-str(z.Round, cstr);
-if z.Frac <> 0 then
- begin
- str(z.Frac / $100000000, tmpstr);
- delete(tmpstr, 1, 2);
- cstr:= cstr + '.' + copy(tmpstr, 1, 10)
- end;
-if z.isNegative then
- cstr:= '-' + cstr
+ str(z.Round, cstr);
+ if z.Frac <> 0 then
+ begin
+ str(z.Frac / $100000000, tmpstr);
+ delete(tmpstr, 1, 2);
+ cstr:= cstr + '.' + copy(tmpstr, 1, 10)
+ end;
+ if z.isNegative then
+ cstr:= '-' + cstr
end;
function hwRound(const t: hwFloat): LongInt;
begin
-if t.isNegative then
- hwRound:= -(t.Round and $7FFFFFFF)
-else
- hwRound:= t.Round and $7FFFFFFF
+ if t.isNegative then
+ hwRound:= -(t.Round and $7FFFFFFF)
+ else
+ hwRound:= t.Round and $7FFFFFFF
end;
function hwAbs(const t: hwFloat): hwFloat;
begin
-hwAbs:= t;
-hwAbs.isNegative:= false
+ hwAbs:= t;
+ hwAbs.isNegative:= false
end;
function hwSqr(const t: hwFloat): hwFloat; inline;
begin
-hwSqr.isNegative:= false;
-hwSqr.QWordValue:= ((QWord(t.Round) * t.Round) shl 32) + QWord(t.Round) * t.Frac * 2 + ((QWord(t.Frac) * t.Frac) shr 32);
+ hwSqr.isNegative:= false;
+ hwSqr.QWordValue:= ((QWord(t.Round) * t.Round) shl 32) + QWord(t.Round) * t.Frac * 2 + ((QWord(t.Frac) * t.Frac) shr 32);
end;
function hwPow(const t: hwFloat;p: LongWord): hwFloat;
begin
-hwPow:= t;
-if p mod 2 = 0 then hwPow.isNegative:= false;
+ hwPow:= t;
+ if p mod 2 = 0 then hwPow.isNegative:= false;
-while p > 0 do
- begin
- hwPow.QWordValue:= QWord(hwPow.Round) * t.Frac + QWord(hwPow.Frac) * t.Round + ((QWord(hwPow.Frac) * t.Frac) shr 32);
- dec(p)
- end
+ while p > 0 do
+ begin
+ hwPow.QWordValue:= QWord(hwPow.Round) * t.Frac + QWord(hwPow.Frac) * t.Round + ((QWord(hwPow.Frac) * t.Frac) shr 32);
+ dec(p)
+ end
end;
function hwSqrt1(const t: hwFloat): hwFloat;
@@ -392,65 +388,67 @@
var l, r: QWord;
c: hwFloat;
begin
-hwSqrt1.isNegative:= false;
+ hwSqrt1.isNegative:= false;
-if t.Round = 0 then
- begin
- l:= t.QWordValue;
- r:= $100000000
- end
-else
- begin
- if t.QWordValue > $FFFFFFFFFFFF then // t.Round > 65535.9999
+ if t.Round = 0 then
+ begin
+ l:= t.QWordValue;
+ r:= $100000000
+ end
+ else
begin
- l:= $10000000000; // 256
- r:= $FFFFFFFFFFFF; // 65535.9999
- end else
- if t.QWordValue >= rThreshold then
+ if t.QWordValue > $FFFFFFFFFFFF then // t.Round > 65535.9999
begin
- l:= lThreshold;
- r:= $10000000000; // 256
- end else
- begin
- l:= $100000000;
- r:= lThreshold;
- end;
+ l:= $10000000000; // 256
+ r:= $FFFFFFFFFFFF; // 65535.9999
+ end
+ else
+ if t.QWordValue >= rThreshold then
+ begin
+ l:= lThreshold;
+ r:= $10000000000; // 256
+ end
+ else
+ begin
+ l:= $100000000;
+ r:= lThreshold;
+ end;
end;
-repeat
- c.QWordValue:= (l + r) shr 1;
- if hwSqr(c).QWordValue > t.QWordValue then
- r:= c.QWordValue
- else
- l:= c.QWordValue
-until r - l <= 1;
+ repeat
+ c.QWordValue:= (l + r) shr 1;
+ if hwSqr(c).QWordValue > t.QWordValue then
+ r:= c.QWordValue
+ else
+ l:= c.QWordValue
+ until r - l <= 1;
-hwSqrt1.QWordValue:= l
+ hwSqrt1.QWordValue:= l
end;
function hwSqrt(const x: hwFloat): hwFloat;
var r, t, s, q: QWord;
i: integer;
begin
-hwSqrt.isNegative:= false;
+ hwSqrt.isNegative:= false;
-t:= $4000000000000000;
-r:= 0;
-q:= x.QWordValue;
+ t:= $4000000000000000;
+ r:= 0;
+ q:= x.QWordValue;
-for i:= 0 to 31 do
- begin
- s:= r + t;
- r:= r shr 1;
- if s <= q then
+ for i:= 0 to 31 do
begin
- dec(q, s);
- inc(r, t);
+ s:= r + t;
+ r:= r shr 1;
+ if s <= q then
+ begin
+ dec(q, s);
+ inc(r, t);
+ end;
+ t:= t shr 2;
end;
- t:= t shr 2;
- end;
-hwSqrt.QWordValue:= r shl 16
+ hwSqrt.QWordValue:= r shl 16
end;
@@ -458,25 +456,26 @@
function Distance(const dx, dy: hwFloat): hwFloat;
var r: QWord;
begin
-r:= dx.QWordValue or dy.QWordValue;
+ r:= dx.QWordValue or dy.QWordValue;
-if r < $10000 then
- begin
- Distance.QWordValue:= r;
- Distance.isNegative:= false
- end else
- Distance:= hwSqrt(hwSqr(dx) + hwSqr(dy))
+ if r < $10000 then
+ begin
+ Distance.QWordValue:= r;
+ Distance.isNegative:= false
+ end
+ else
+ Distance:= hwSqrt(hwSqr(dx) + hwSqr(dy))
end;
function DistanceI(const dx, dy: LongInt): hwFloat;
begin
-DistanceI:= hwSqrt(int2hwFloat(sqr(dx) + sqr(dy)))
+ DistanceI:= hwSqrt(int2hwFloat(sqr(dx) + sqr(dy)))
end;
function SignAs(const num, signum: hwFloat): hwFloat;
begin
-SignAs.QWordValue:= num.QWordValue;
-SignAs.isNegative:= signum.isNegative
+ SignAs.QWordValue:= num.QWordValue;
+ SignAs.isNegative:= signum.isNegative
end;
function hwSign(r: hwFloat): LongInt;
@@ -549,6 +548,4 @@
vector2Angle:= c
end;
-{$ENDIF}
-
end.
--- a/hedgewars/uGame.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uGame.pas Tue Jan 21 22:38:13 2014 +0100
@@ -116,9 +116,11 @@
AddVisualGear(0, 0, vgtTeamHealthSorter);
AddVisualGear(0, 0, vgtSmoothWindBar);
{$IFDEF IPHONEOS}InitIPC;{$ENDIF}
+ {$IFNDEF PAS2C}
with mobileRecord do
if SaveLoadingEnded <> nil then
SaveLoadingEnded();
+ {$ENDIF}
end;
end
else ProcessGears
--- a/hedgewars/uGears.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uGears.pas Tue Jan 21 22:38:13 2014 +0100
@@ -51,7 +51,7 @@
uses uStore, uSound, uTeams, uRandom, uIO, uLandGraphics,
{$IFDEF USE_TOUCH_INTERFACE}uTouch,{$ENDIF}
uLocale, uAmmos, uStats, uVisualGears, uScript, uVariables,
- uCommands, uUtils, uTextures, uRenderUtils, uGearsRender, uCaptions, uDebug, uLandTexture,
+ uCommands, uUtils, uTextures, uRenderUtils, uGearsRender, uCaptions, uDebug,
uGearsHedgehog, uGearsUtils, uGearsList, uGearsHandlersRope
, uVisualGearsList, uGearsHandlersMess, uAI;
--- a/hedgewars/uGearsHandlers.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uGearsHandlers.pas Tue Jan 21 22:38:13 2014 +0100
@@ -31,7 +31,10 @@
-const dirs: array[0..3] of TPoint = ((X: 0; Y: -1), (X: 1; Y: 0),(X: 0; Y: 1),(X: -1; Y: 0));
+const dirs: array[0..3] of TPoint = ((x: 0; y: -1),
+ (x: 1; y: 0),
+ (x: 0; y: 1),
+ (x: -1; y: 0));
procedure PrevAngle(Gear: PGear; dA: LongInt); inline;
begin
--- a/hedgewars/uGearsHandlersMess.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uGearsHandlersMess.pas Tue Jan 21 22:38:13 2014 +0100
@@ -24,7 +24,7 @@
* should NOT occur!
* Use safe functions and data types! (e.g. GetRandom() and hwFloat)
*)
-
+
{$INCLUDE "options.inc"}
unit uGearsHandlersMess;
@@ -394,7 +394,7 @@
if xland <> 0 then collH := -hwSign(Gear^.dX)
end;
//if Gear^.AdvBounce and (collV <>0) and (collH <> 0) and (hwSqr(tdX) + hwSqr(tdY) > _0_08) then
- if (collV <> 0) and (collH <> 0) and
+ if (collV <> 0) and (collH <> 0) and
(((Gear^.AdvBounce=1) and ((collV=-1) or ((tdX.QWordValue + tdY.QWordValue) > _0_2.QWordValue)))) then
//or ((xland or land) and lfBouncy <> 0)) then
begin
@@ -436,7 +436,7 @@
if ((xland or land) and lfBouncy <> 0) and (Gear^.dX.QWordValue < _0_15.QWordValue) and (Gear^.dY.QWordValue < _0_15.QWordValue) then
Gear^.State := Gear^.State or gstCollision;
-
+
if ((xland or land) and lfBouncy <> 0) and (Gear^.Radius >= 3) and
((Gear^.dX.QWordValue > _0_15.QWordValue) or (Gear^.dY.QWordValue > _0_15.QWordValue)) then
begin
@@ -760,7 +760,7 @@
yy:= hwRound(Gear^.Y);
if draw and (WorldEdge = weWrap) and ((xx < LongInt(leftX) + 3) or (xx > LongInt(rightX) - 3)) then
begin
- if xx < LongInt(leftX) + 3 then
+ if xx < LongInt(leftX) + 3 then
xx:= rightX-3
else xx:= leftX+3;
Gear^.X:= int2hwFloat(xx)
@@ -1054,7 +1054,7 @@
// no need to display remaining time anymore
Gear^.RenderTimer:= false;
// bee can drown when timer reached 0
- Gear^.State:= Gear^.State and not gstSubmersible;
+ Gear^.State:= Gear^.State and (not gstSubmersible);
end;
end;
end;
@@ -1235,7 +1235,7 @@
if ((y and LAND_HEIGHT_MASK) = 0) and ((x and LAND_WIDTH_MASK) = 0) and (Land[y, x] <> 0) then
inc(Gear^.Damage);
// let's interrupt before a collision to give portals a chance to catch the bullet
- if (Gear^.Damage = 1) and (Gear^.Tag = 0) and not(CheckLandValue(x, y, lfLandMask)) then
+ if (Gear^.Damage = 1) and (Gear^.Tag = 0) and (not CheckLandValue(x, y, lfLandMask)) then
begin
Gear^.Tag := 1;
Gear^.Damage := 0;
@@ -1772,7 +1772,7 @@
end
end
else // gsttmpFlag = 0
- if ((GameFlags and gfInfAttack = 0) and ((TurnTimeLeft = 0) or (Gear^.Hedgehog^.Gear = nil)))
+ if ((GameFlags and gfInfAttack = 0) and ((TurnTimeLeft = 0) or (Gear^.Hedgehog^.Gear = nil)))
or ((GameFlags and gfInfAttack <> 0) and (GameTicks > Gear^.FlightTime)) then
Gear^.State := Gear^.State or gsttmpFlag;
end;
@@ -1806,7 +1806,7 @@
if (Gear^.dY.QWordValue = 0) and (Gear^.dY.QWordValue = 0) and (TestCollisionYwithGear(Gear, 1) = 0) then
SetLittle(Gear^.dY);
Gear^.State := Gear^.State or gstAnimation;
- if Gear^.Health < cBarrelHealth then Gear^.State:= Gear^.State and not gstFrozen;
+ if Gear^.Health < cBarrelHealth then Gear^.State:= Gear^.State and (not gstFrozen);
if ((Gear^.dX.QWordValue <> 0)
or (Gear^.dY.QWordValue <> 0)) then
@@ -1892,7 +1892,7 @@
Gear^.Message := Gear^.Message and (not (gmLJump or gmHJump));
exit
end;
- if (k = gtExplosives) and (Gear^.Health < cBarrelHealth) then Gear^.State:= Gear^.State and not gstFrozen;
+ if (k = gtExplosives) and (Gear^.Health < cBarrelHealth) then Gear^.State:= Gear^.State and (not gstFrozen);
if ((k <> gtExplosives) and (Gear^.Damage > 0)) or ((k = gtExplosives) and (Gear^.Health<=0)) then
begin
@@ -2163,7 +2163,7 @@
exit
end
end
- else
+ else
begin
if (Gear^.Timer = 1) and (GameTicks and $3 = 0) then
begin
@@ -2471,9 +2471,11 @@
begin
doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, Gear^.Hedgehog, EXPLAutoSound);
DeleteGear(Gear);
+ {$IFNDEF PAS2C}
with mobileRecord do
if (performRumble <> nil) and (not fastUntilLag) then
performRumble(kSystemSoundID_Vibrate);
+ {$ENDIF}
exit
end;
if (GameTicks and $3F) = 0 then
@@ -2502,7 +2504,7 @@
if Gear^.AmmoType = amRubber then LandFlags:= lfBouncy
else if cIce then LandFlags:= lfIce;
- if ((Distance(tx - x, ty - y) > _256) and ((WorldEdge <> weWrap) or
+ if ((Distance(tx - x, ty - y) > _256) and ((WorldEdge <> weWrap) or
(
(Distance(tx - int2hwFloat(rightX+(rx-leftX)), ty - y) > _256) and
(Distance(tx - int2hwFloat(leftX-(rightX-rx)), ty - y) > _256)
@@ -4615,9 +4617,11 @@
Gear^.dY.isNegative := not Gear^.dY.isNegative;
Gear^.doStep := @doStepSineGunShotWork;
+ {$IFNDEF PAS2C}
with mobileRecord do
if (performRumble <> nil) and (not fastUntilLag) then
performRumble(kSystemSoundID_Vibrate);
+ {$ENDIF}
end;
////////////////////////////////////////////////////////////////////////////////
@@ -5380,7 +5384,7 @@
Gear^.SoundChannel:= -1;
if GameTicks mod 40 = 0 then dec(Gear^.Health)
end
- else
+ else
begin
if Gear^.SoundChannel = -1 then
Gear^.SoundChannel := LoopSound(sndIceBeam);
@@ -5487,14 +5491,15 @@
landRect.w := min(2*iceRadius, LAND_WIDTH - landRect.x - 1);
landRect.h := min(2*iceRadius, LAND_HEIGHT - landRect.y - 1);
UpdateLandTexture(landRect.x, landRect.w, landRect.y, landRect.h, true);
-
+
// Freeze nearby mines/explosives/cases too
iter := GearsList;
while iter <> nil do
begin
if (iter^.State and gstFrozen = 0) and
- ((iter^.Kind = gtExplosives) or (iter^.Kind = gtCase) or (iter^.Kind = gtMine)) and
- (abs(iter^.X.Round-target.x)+abs(iter^.Y.Round-target.y)+2<2*iceRadius) and (Distance(iter^.X-int2hwFloat(target.x),iter^.Y-int2hwFloat(target.y))<int2hwFloat(iceRadius*2)) then
+ ((iter^.Kind = gtExplosives) or (iter^.Kind = gtCase) or (iter^.Kind = gtMine)) and
+ (abs(LongInt(iter^.X.Round) - target.x) + abs(LongInt(iter^.Y.Round) - target.y) + 2 < 2 * iceRadius)
+ and (Distance(iter^.X - int2hwFloat(target.x), iter^.Y - int2hwFloat(target.y)) < int2hwFloat(iceRadius * 2)) then
begin
for t:= 0 to 5 do
begin
@@ -5621,7 +5626,7 @@
begin
with gi^ do CheckSum:= CheckSum xor X.round xor X.frac xor dX.round xor dX.frac xor Y.round xor Y.frac xor dY.round xor dY.frac;
AddRandomness(CheckSum);
- if gi^.Kind = gtGenericFaller then gi^.State:= gi^.State and not gstTmpFlag;
+ if gi^.Kind = gtGenericFaller then gi^.State:= gi^.State and (not gstTmpFlag);
gi := gi^.NextGear
end;
AddPickup(Gear^.Hedgehog^, a, Gear^.Power, hwRound(Gear^.X), hwRound(Gear^.Y));
--- a/hedgewars/uGearsHedgehog.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uGearsHedgehog.pas Tue Jan 21 22:38:13 2014 +0100
@@ -20,7 +20,7 @@
unit uGearsHedgehog;
interface
-uses uTypes, uGearsHandlersMess;
+uses uTypes, uGearsHandlersMess;
procedure doStepHedgehog(Gear: PGear);
procedure AfterAttack;
@@ -126,7 +126,7 @@
LoadHedgehogHat(HHGear^.Hedgehog^, Hat);
end;
// Try again in the next slot
- if (CurAmmoType = prevAmmo) and (slot < cMaxSlotIndex) then
+ if (CurAmmoType = prevAmmo) and (slot < cMaxSlotIndex) then
begin
inc(slot);
HHGear^.MsgParam:= slot;
@@ -416,7 +416,7 @@
amTardis: newGear:= AddGear(hwRound(X), hwRound(Y), gtTardis, 0, _0, _0, 0);
amIceGun: newGear:= AddGear(hwRound(X), hwRound(Y), gtIceGun, 0, _0, _0, 0);
end;
- if altUse and (newGear <> nil) and
+ if altUse and (newGear <> nil) and
((CurAmmoGear = nil) or (CurAmmoGear^.AmmoType <> amJetpack) or (Gear^.Message and gmPrecise = 0)) then
begin
newGear^.dX:= newDx / newGear^.Density;
@@ -470,15 +470,15 @@
begin
elastic:= int2hwfloat(CurWeapon^.Bounciness) / _1000;
- if elastic < _1 then
- newGear^.Elasticity:= newGear^.Elasticity * elastic
- else if elastic > _1 then
- newGear^.Elasticity:= _1 - ((_1-newGear^.Elasticity) / elastic);
- (* Experimented with friction modifier. Didn't seem helpful
- fric:= int2hwfloat(CurWeapon^.Bounciness) / _250;
- if fric < _1 then newGear^.Friction:= newGear^.Friction * fric
- else if fric > _1 then newGear^.Friction:= _1 - ((_1-newGear^.Friction) / fric)*)
- end;
+ if elastic < _1 then
+ newGear^.Elasticity:= newGear^.Elasticity * elastic
+ else if elastic > _1 then
+ newGear^.Elasticity:= _1 - ((_1-newGear^.Elasticity) / elastic);
+(* Experimented with friction modifier. Didn't seem helpful
+ fric:= int2hwfloat(CurWeapon^.Bounciness) / _250;
+ if fric < _1 then newGear^.Friction:= newGear^.Friction * fric
+ else if fric > _1 then newGear^.Friction:= _1 - ((_1-newGear^.Friction) / fric)*)
+ end;
uStats.AmmoUsed(CurAmmoType);
@@ -496,16 +496,15 @@
end;
Power:= 0;
- if (CurAmmoGear <> nil)
- and ((Ammoz[CurAmmoType].Ammo.Propz and ammoprop_AltUse) = 0){check for dropping ammo from rope} then
+ if (CurAmmoGear <> nil) and ((Ammoz[CurAmmoType].Ammo.Propz and ammoprop_AltUse) = 0){check for dropping ammo from rope} then
begin
- if CurAmmoType in [amRope,amResurrector] then Message:= Message or gmAttack;
+ if CurAmmoType in [amRope,amResurrector] then
+ Message:= Message or gmAttack;
CurAmmoGear^.Message:= Message
end
else
begin
- if not CurrentTeam^.ExtDriven
- and ((Ammoz[CurAmmoType].Ammo.Propz and ammoprop_Power) <> 0) then
+ if (not CurrentTeam^.ExtDriven) and ((Ammoz[CurAmmoType].Ammo.Propz and ammoprop_Power) <> 0) then
SendIPC(_S'a');
AfterAttack;
end
@@ -831,7 +830,7 @@
var da: LongWord;
begin
with HHGear^.Hedgehog^ do
- if (((CurAmmoType = amRope) or ((CurAmmoGear <> nil) and (CurAmmoGear^.AmmoType = amRope))) and
+ if (((CurAmmoType = amRope) or ((CurAmmoGear <> nil) and (CurAmmoGear^.AmmoType = amRope))) and
((HHGear^.State and (gstMoving or gstHHJumping)) = gstMoving))
or ((CurAmmoType = amPortalGun) and ((HHGear^.State and gstMoving) <> 0)) then
da:= 2
@@ -878,7 +877,7 @@
end;
if (land and lfBouncy = 0) or (Gear^.State and gstCollision <> 0) then
Gear^.dY:= _0;
- Gear^.State:= Gear^.State and not gstCollision
+ Gear^.State:= Gear^.State and (not gstCollision)
end;
Gear^.State:= Gear^.State or gstMoving;
if (Gear^.State and gstHHDriven <> 0) and
@@ -904,8 +903,8 @@
else
begin
land:= TestCollisionYwithGear(Gear, 1);
- if ((Gear^.dX.QWordValue + Gear^.dY.QWordValue) < _0_55.QWordValue) and ((land and lfIce) = 0)
- and ((land and lfBouncy = 0) or (Gear^.State and gstCollision <> 0))
+ if ((Gear^.dX.QWordValue + Gear^.dY.QWordValue) < _0_55.QWordValue) and ((land and lfIce) = 0)
+ and ((land and lfBouncy = 0) or (Gear^.State and gstCollision <> 0))
and ((Gear^.State and gstHHJumping) <> 0) then
SetLittle(Gear^.dX);
@@ -933,7 +932,7 @@
if (land and lfBouncy = 0) or (Gear^.dX.QWordValue < _0_02.QWordValue) then
Gear^.dY:= _0
end;
- Gear^.State:= Gear^.State and not gstCollision
+ Gear^.State:= Gear^.State and (not gstCollision)
end
else
Gear^.dY:= Gear^.dY + cGravity;
@@ -1058,7 +1057,7 @@
Gear^.dY:= _0;
Gear^.Y:= Gear^.Y + _1
end;
- Gear^.State:= Gear^.State and not gstCollision
+ Gear^.State:= Gear^.State and (not gstCollision)
end;
// could become nil if ai's hog fails to respawn in ai survival
@@ -1097,6 +1096,11 @@
else if Hedgehog^.CurAmmoType in [amShotgun, amDEagle, amSniperRifle] then
HHGear^.Message:= 0;
+if ((Ammoz[CurrentHedgehog^.CurAmmoType].Ammo.Propz and ammoprop_Utility) <> 0) and isInMultiShoot then
+ AllInactive:= true
+else if not isInMultiShoot then
+ AllInactive:= false;
+
if (TurnTimeLeft = 0) or (HHGear^.Damage > 0) then
begin
if (Hedgehog^.CurAmmoType = amKnife) then
@@ -1344,7 +1348,7 @@
tX:= Gear^.X;
if WorldWrap(Gear) then
begin
- if (WorldEdge <> weBounce) and (Gear = CurrentHedgehog^.Gear) and
+ if (WorldEdge <> weBounce) and (Gear = CurrentHedgehog^.Gear) and
(CurAmmoGear <> nil) and (CurAmmoGear^.Kind =gtRope) and (CurAmmoGear^.Elasticity <> _0) then
CurAmmoGear^.PortalCounter:= 1;
if (WorldEdge = weWrap) and ((TestCollisionXwithGear(Gear, 1) <> 0) or (TestCollisionXwithGear(Gear, -1) <> 0)) then
--- a/hedgewars/uGearsList.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uGearsList.pas Tue Jan 21 22:38:13 2014 +0100
@@ -158,8 +158,10 @@
var gear: PGear;
begin
inc(GCounter);
+
AddFileLog('AddGear: #' + inttostr(GCounter) + ' (' + inttostr(x) + ',' + inttostr(y) + '), d(' + floattostr(dX) + ',' + floattostr(dY) + ') type = ' + EnumToStr(Kind));
+
New(gear);
FillChar(gear^, sizeof(TGear), 0);
gear^.X:= int2hwFloat(X);
@@ -628,7 +630,7 @@
begin
t:= max(Gear^.Damage, Gear^.Health);
Gear^.Damage:= t;
- if ((not SuddenDeathDmg and (WaterOpacity < $FF)) or (SuddenDeathDmg and (WaterOpacity < $FF)))
+ if (((not SuddenDeathDmg) and (WaterOpacity < $FF)) or (SuddenDeathDmg and (WaterOpacity < $FF)))
and (hwRound(Gear^.Y) < cWaterLine + 256) then
spawnHealthTagForHH(Gear, t);
end;
--- a/hedgewars/uGearsRender.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uGearsRender.pas Tue Jan 21 22:38:13 2014 +0100
@@ -23,6 +23,18 @@
interface
uses uTypes, uConsts, GLunit, uFloat, SDLh;
+type
+ Tar = record
+ X, Y: hwFloat;
+ dLen: hwFloat;
+ b : boolean;
+ end;
+ TRopePoints = record
+ Count : Longword;
+ HookAngle : GLfloat;
+ ar : array[0..MAXROPEPOINTS] of Tar;
+ rounded : array[0..MAXROPEPOINTS + 2] of TVertex2f;
+ end;
procedure RenderGear(Gear: PGear; x, y: LongInt);
var RopePoints: record
@@ -83,6 +95,7 @@
if (X1 = X2) and (Y1 = Y2) then
begin
//OutError('WARNING: zero length rope line!', false);
+ DrawRopeLine:= 0;
exit
end;
eX:= 0;
@@ -143,7 +156,7 @@
DrawSprite(sprRopeNode, x - 2, y - 2, 0)
end
end;
-DrawRopeLine:= roplen;
+ DrawRopeLine:= roplen;
end;
procedure DrawRope(Gear: PGear);
@@ -1268,7 +1281,7 @@
begin
if isInLag and (Gear^.FlightTime < 256) then
inc(Gear^.FlightTime, 8)
- else if not isInLag and (Gear^.FlightTime > 0) then
+ else if (not isInLag) and (Gear^.FlightTime > 0) then
dec(Gear^.FlightTime, 8);
if Gear^.FlightTime > 0 then
Tint($FF, $FF, $FF, $FF-min(255,Gear^.FlightTime));
--- a/hedgewars/uGearsUtils.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uGearsUtils.pas Tue Jan 21 22:38:13 2014 +0100
@@ -23,7 +23,7 @@
uses uTypes, uFloat;
procedure doMakeExplosion(X, Y, Radius: LongInt; AttackingHog: PHedgehog; Mask: Longword); inline;
-procedure doMakeExplosion(X, Y, Radius: LongInt; AttackingHog: PHedgehog; Mask: Longword; const Tint: LongWord);
+procedure doMakeExplosion(X, Y, Radius: LongInt; AttackingHog: PHedgehog; Mask: Longword; const Tint: LongWord);
function ModifyDamage(dmg: Longword; Gear: PGear): Longword;
procedure ApplyDamage(Gear: PGear; AttackerHog: PHedgehog; Damage: Longword; Source: TDamageSource);
@@ -47,8 +47,8 @@
procedure ShotgunShot(Gear: PGear);
procedure SetAllToActive;
-procedure SetAllHHToActive; inline;
procedure SetAllHHToActive(Ice: boolean);
+procedure SetAllHHToActive(); inline;
function GetAmmo(Hedgehog: PHedgehog): TAmmoType;
function GetUtility(Hedgehog: PHedgehog): TAmmoType;
@@ -64,7 +64,7 @@
implementation
uses uSound, uCollisions, uUtils, uConsts, uVisualGears, uAIMisc,
uVariables, uLandGraphics, uScript, uStats, uCaptions, uTeams, uStore,
- uLocale, uTextures, uRenderUtils, uRandom, SDLh, uDebug,
+ uLocale, uTextures, uRenderUtils, uRandom, SDLh, uDebug,
uGearsList, Math, uVisualGearsList, uGearsHandlersMess,
uGearsHedgehog;
@@ -199,7 +199,7 @@
i:= _1;
if (CurrentHedgehog <> nil) and CurrentHedgehog^.King then
i:= _1_5;
-if (Gear^.Kind = gtHedgehog) and (Gear^.Hedgehog <> nil) and
+if (Gear^.Kind = gtHedgehog) and (Gear^.Hedgehog <> nil) and
(Gear^.Hedgehog^.King or (Gear^.Hedgehog^.Effects[heFrozen] > 0)) then
ModifyDamage:= hwRound(cDamageModifier * dmg * i * cDamagePercent * _0_5 * _0_01)
else
@@ -251,20 +251,20 @@
end;
end
end;
- if (GameFlags and gfKarma <> 0) and (GameFlags and gfInvulnerable = 0) and
+ if (GameFlags and gfKarma <> 0) and (GameFlags and gfInvulnerable = 0) and
(CurrentHedgehog^.Effects[heInvulnerable] = 0) then
begin // this cannot just use Damage or it interrupts shotgun and gets you called stupid
inc(CurrentHedgehog^.Gear^.Karma, tmpDmg);
CurrentHedgehog^.Gear^.LastDamage := CurrentHedgehog;
spawnHealthTagForHH(CurrentHedgehog^.Gear, tmpDmg);
end;
- uStats.HedgehogDamaged(Gear, AttackerHog, Damage, false);
+ uStats.HedgehogDamaged(Gear, AttackerHog, Damage, false);
end;
end else
//else if Gear^.Kind <> gtStructure then // not gtHedgehog nor gtStructure
Gear^.Hedgehog:= AttackerHog;
inc(Gear^.Damage, Damage);
-
+
ScriptCall('onGearDamage', Gear^.UID, Damage);
end;
@@ -277,7 +277,7 @@
AllInactive:= false;
HHGear^.Active:= true;
end;
-
+
procedure HHHurt(Hedgehog: PHedgehog; Source: TDamageSource);
begin
if Hedgehog^.Effects[heFrozen] <> 0 then exit;
@@ -302,7 +302,7 @@
end;
procedure CheckHHDamage(Gear: PGear);
-var
+var
dmg: LongInt;
i: LongWord;
particle: PVisualGear;
@@ -340,7 +340,7 @@
procedure CalcRotationDirAngle(Gear: PGear);
-var
+var
dAngle: real;
begin
// Frac/Round to be kind to JS as of 2012-08-27 where there is yet no int64/uint64
@@ -358,7 +358,7 @@
end;
function CheckGearDrowning(var Gear: PGear): boolean;
-var
+var
skipSpeed, skipAngle, skipDecay: hwFloat;
i, maxDrops, X, Y: LongInt;
vdX, vdY: real;
@@ -389,7 +389,7 @@
vdX:= hwFloat2Float(Gear^.dX);
vdY:= hwFloat2Float(Gear^.dY);
// this could perhaps be a tiny bit higher.
- if (cWaterLine + 64 + Gear^.Radius > Y) and (hwSqr(Gear^.dX) + hwSqr(Gear^.dY) > skipSpeed)
+ if (cWaterLine + 64 + Gear^.Radius > Y) and (hwSqr(Gear^.dX) + hwSqr(Gear^.dY) > skipSpeed)
and (hwAbs(Gear^.dX) > skipAngle * hwAbs(Gear^.dY)) then
begin
Gear^.dY.isNegative := true;
@@ -425,9 +425,9 @@
else
Gear^.doStep := @doStepDrowningGear;
if Gear^.Kind = gtFlake then
- exit // skip splashes
+ exit // skip splashes
end
- else if (Y > cWaterLine + cVisibleWater*4) and
+ else if (Y > cWaterLine + cVisibleWater*4) and
((Gear <> CurrentHedgehog^.Gear) or (CurAmmoGear = nil) or (CurAmmoGear^.State and gstSubmersible = 0)) then
Gear^.doStep:= @doStepDrowningGear;
if ((not isSubmersible) and (Y < cWaterLine + 64 + Gear^.Radius))
@@ -435,7 +435,7 @@
and (CurAmmoGear^.dY < _0_01))) then
if Gear^.Density * Gear^.dY > _1 then
PlaySound(sndSplash)
- else if Gear^.Density * Gear^.dY > _0_5 then
+ else if Gear^.Density * Gear^.dY > _0_5 then
PlaySound(sndSkip)
else
PlaySound(sndDroplet2);
@@ -447,7 +447,7 @@
and (CurAmmoGear^.dY < _0_01)))) then
begin
splash:= AddVisualGear(X, cWaterLine, vgtSplash);
- if splash <> nil then
+ if splash <> nil then
with splash^ do
begin
Scale:= hwFloat2Float(Gear^.Density / _3 * Gear^.dY);
@@ -470,12 +470,12 @@
dY := dY - vdY / 5;
if splash <> nil then
begin
- if splash^.Scale > 1 then
+ if splash^.Scale > 1 then
begin
dX:= dX * power(splash^.Scale,0.3333); // tone down the droplet height further
dY:= dY * power(splash^.Scale, 0.3333)
end
- else
+ else
begin
dX:= dX * splash^.Scale;
dY:= dY * splash^.Scale
@@ -489,7 +489,8 @@
end
else
begin
- if not (Gear^.Kind in [gtJetpack, gtBee]) then Gear^.State:= Gear^.State and not gstSubmersible; // making it temporary for most gears is more attractive I think
+ if (not ((Gear^.Kind = gtJetpack) or (Gear^.Kind = gtBee))) then
+ Gear^.State:= (Gear^.State and (not gstSubmersible)); // making it temporary for most gears is more attractive I think
CheckGearDrowning := false
end
end;
@@ -512,7 +513,7 @@
gear^.Hedgehog^.Effects[hePoisoned] := 0;
if (CurrentHedgehog^.Effects[heResurrectable] = 0) or ((CurrentHedgehog^.Effects[heResurrectable] <> 0)
and (Gear^.Hedgehog^.Team^.Clan <> CurrentHedgehog^.Team^.Clan)) then
- with CurrentHedgehog^ do
+ with CurrentHedgehog^ do
begin
inc(Team^.stats.AIKills);
FreeTexture(Team^.AIKillsTex);
@@ -529,7 +530,7 @@
sparkles^.Tint:= tempTeam^.Clan^.Color shl 8 or $FF;
//sparkles^.Angle:= random(360);
end;
- FindPlace(gear, false, 0, LAND_WIDTH, true);
+ FindPlace(gear, false, 0, LAND_WIDTH, true);
if gear <> nil then
begin
AddVisualGear(hwRound(gear^.X), hwRound(gear^.Y), vgtExplosion);
@@ -587,6 +588,7 @@
y, sy: LongInt;
ar: array[0..1023] of TPoint;
ar2: array[0..2047] of TPoint;
+ temp: TPoint;
cnt, cnt2: Longword;
delta: LongInt;
ignoreNearObjects, ignoreOverlap, tryAgain: boolean;
@@ -594,7 +596,7 @@
ignoreNearObjects:= false; // try not skipping proximity at first
ignoreOverlap:= false; // this not only skips proximity, but allows overlapping objects (barrels, mines, hogs, crates). Saving it for a 3rd pass. With this active, winning AI Survival goes back to virtual impossibility
tryAgain:= true;
-if WorldEdge <> weNone then
+if WorldEdge <> weNone then
begin
Left:= max(Left, LongInt(leftX) + Gear^.Radius);
Right:= min(Right,rightX-Gear^.Radius)
@@ -614,7 +616,7 @@
repeat
inc(y, 2);
until (y >= cWaterLine) or
- (not ignoreOverlap and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, $FFFF) = 0)) or
+ ((not ignoreOverlap) and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, $FFFF) = 0)) or
(ignoreOverlap and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, lfLandMask) = 0));
sy:= y;
@@ -622,8 +624,8 @@
repeat
inc(y);
until (y >= cWaterLine) or
- (not ignoreOverlap and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, $FFFF) <> 0)) or
- (ignoreOverlap and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, lfLandMask) <> 0));
+ ((not ignoreOverlap) and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, $FFFF) <> 0)) or
+ (ignoreOverlap and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, lfLandMask) <> 0));
if (y - sy > Gear^.Radius * 2)
and (((Gear^.Kind = gtExplosives)
@@ -648,12 +650,15 @@
end;
if cnt > 0 then
- with ar[GetRandom(cnt)] do
+ begin
+ temp := ar[GetRandom(cnt)];
+ with temp do
begin
ar2[cnt2].x:= x;
ar2[cnt2].y:= y;
inc(cnt2)
end
+ end
until (x + Delta > Right);
dec(Delta, 60)
@@ -667,12 +672,15 @@
end;
if cnt2 > 0 then
- with ar2[GetRandom(cnt2)] do
+ begin
+ temp := ar2[GetRandom(cnt2)];
+ with temp do
begin
Gear^.X:= int2hwFloat(x);
Gear^.Y:= int2hwFloat(y);
AddFileLog('Assigned Gear coordinates (' + inttostr(x) + ',' + inttostr(y) + ')');
end
+ end
else
begin
OutError('Can''t find place for Gear', false);
@@ -718,7 +726,7 @@
if (TestCollisionX(Gear, hwSign(Gear^.dX)) <> 0)
or (TestCollisionY(Gear, hwSign(Gear^.dY)) <> 0) then
Gear^.State := Gear^.State or gstCollision
- else
+ else
Gear^.State := Gear^.State and (not gstCollision)
end;
@@ -887,14 +895,14 @@
begin
dec(i);
Gear:= t^.ar[i];
- if ((Ammo^.Kind = gtFlame) or (Ammo^.Kind = gtBlowTorch)) and
+ if ((Ammo^.Kind = gtFlame) or (Ammo^.Kind = gtBlowTorch)) and
(Gear^.Kind = gtHedgehog) and (Gear^.Hedgehog^.Effects[heFrozen] > 255) then
Gear^.Hedgehog^.Effects[heFrozen]:= max(255,Gear^.Hedgehog^.Effects[heFrozen]-10000);
tmpDmg:= ModifyDamage(Damage, Gear);
if (Gear^.State and gstNoDamage) = 0 then
begin
- if (Ammo^.Kind = gtDEagleShot) or (Ammo^.Kind = gtSniperRifleShot) then
+ if (Ammo^.Kind = gtDEagleShot) or (Ammo^.Kind = gtSniperRifleShot) then
begin
VGear := AddVisualGear(hwround(Ammo^.X), hwround(Ammo^.Y), vgtBulletHit);
if VGear <> nil then
@@ -945,7 +953,7 @@
end
else
Gear^.State:= Gear^.State or gstWinner;
- if (Gear^.Kind = gtExplosives) and (Ammo^.Kind = gtBlowtorch) then
+ if (Gear^.Kind = gtExplosives) and (Ammo^.Kind = gtBlowtorch) then
begin
if (Ammo^.Hedgehog^.Gear <> nil) then
Ammo^.Hedgehog^.Gear^.State:= Ammo^.Hedgehog^.Gear^.State and (not gstNotKickable);
@@ -1056,9 +1064,9 @@
s:= 0;
SetLength(GearsNearArray, s);
t := GearsList;
- while t <> nil do
+ while t <> nil do
begin
- if (t^.Kind = Kind)
+ if (t^.Kind = Kind)
and ((X - t^.X)*(X - t^.X) + (Y - t^.Y)*(Y-t^.Y) < int2hwFloat(r)) then
begin
inc(s);
@@ -1241,7 +1249,7 @@
Gear^.dX.isNegative:= false;
Gear^.X:= int2hwfloat(LongInt(leftX) + Gear^.Radius)
end
- else
+ else
begin
RightImpactTimer:= 333;
Gear^.dX.isNegative:= true;
@@ -1253,7 +1261,7 @@
else if WorldEdge = weSea then
begin
if (hwRound(Gear^.Y) > cWaterLine) and (Gear^.State and gstSubmersible <> 0) then
- Gear^.State:= Gear^.State and not gstSubmersible
+ Gear^.State:= Gear^.State and (not gstSubmersible)
else
begin
Gear^.State:= Gear^.State or gstSubmersible;
@@ -1269,7 +1277,7 @@
* Window in the sky (Gear moved high into the sky, Y is used to determine X) [unfortunately, not a safe thing to do. shame, I thought aerial bombardment would be kinda neat
This one would be really easy to freeze game unless it was flagged unfortunately.
- else
+ else
begin
Gear^.X:= int2hwFloat(PlayWidth)*int2hwFloat(min(max(0,hwRound(Gear^.Y)),PlayHeight))/PlayHeight;
Gear^.Y:= -_2048-_256-_256;
--- a/hedgewars/uIO.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uIO.pas Tue Jan 21 22:38:13 2014 +0100
@@ -51,8 +51,7 @@
loTime: Word;
case byte of
1: (len: byte;
- cmd: Char;
- X, Y: LongInt);
+ cmd: Char);
2: (str: shortstring);
end;
@@ -122,6 +121,7 @@
procedure ParseIPCCommand(s: shortstring);
var loTicks: Word;
begin
+
case s[1] of
'!': begin AddFileLog('Ping? Pong!'); isPonged:= true; end;
'?': SendIPC(_S'!');
@@ -177,10 +177,10 @@
end;
procedure LoadRecordFromFile(fileName: shortstring);
-var f: file;
- ss: shortstring = '';
- i: LongInt;
- s: shortstring;
+var f : File;
+ ss : shortstring = '';
+ i : LongInt;
+ s : shortstring;
begin
// set RDNLY on file open
@@ -188,7 +188,6 @@
{$I-}
assign(f, fileName);
reset(f, 1);
-
tryDo(IOResult = 0, 'Error opening file ' + fileName, true);
i:= 0; // avoid compiler hints
@@ -196,13 +195,13 @@
repeat
BlockRead(f, s[1], 255 - Length(ss), i);
if i > 0 then
- begin
+ begin
s[0]:= char(i);
ss:= ss + s;
while (Length(ss) > 1)and(Length(ss) > byte(ss[1])) do
begin
ParseIPCCommand(copy(ss, 2, byte(ss[1])));
- Delete(ss, 1, Succ(byte(ss[1])))
+ Delete(ss, 1, Succ(byte(ss[1])));
end
end
until i = 0;
@@ -221,7 +220,11 @@
function isSyncedCommand(c: char): boolean;
begin
- isSyncedCommand:= (c in ['+', '#', 'L', 'l', 'R', 'r', 'U', 'u', 'D', 'd', 'Z', 'z', 'A', 'a', 'S', 'j', 'J', ',', 'c', 'N', 'p', 'P', 'w', 't', '1', '2', '3', '4', '5']) or ((c >= #128) and (c <= char(128 + cMaxSlotIndex)))
+ case c of
+ '+', '#', 'L', 'l', 'R', 'r', 'U', 'u', 'D', 'd', 'Z', 'z', 'A', 'a', 'S', 'j', 'J', ',', 'c', 'N', 'p', 'P', 'w', 't', '1', '2', '3', '4', '5': isSyncedCommand:= true;
+ else
+ isSyncedCommand:= ((c >= #128) and (c <= char(128 + cMaxSlotIndex)))
+ end
end;
procedure flushBuffer();
@@ -240,20 +243,20 @@
begin
if s[0] > #251 then
s[0]:= #251;
-
+
SDLNet_Write16(GameTicks, @s[Succ(byte(s[0]))]);
-
+
AddFileLog('[IPC out] '+ sanitizeCharForLog(s[1]));
inc(s[0], 2);
-
+
if isSyncedCommand(s[1]) then
begin
if sendBuffer.count + byte(s[0]) >= cSendBufferSize then
flushBuffer();
-
+
Move(s, sendBuffer.buf[sendBuffer.count], byte(s[0]) + 1);
inc(sendBuffer.count, byte(s[0]) + 1);
-
+
if (s[1] = 'N') or (s[1] = '#') then
flushBuffer();
end else
@@ -302,8 +305,8 @@
begin
if sendBuffer.count = 0 then
SendIPC(_S'+');
-
- flushBuffer()
+
+ flushBuffer()
end
end;
@@ -367,8 +370,8 @@
AddFileLog('got cmd "N": time '+IntToStr(hiTicks shl 16 + headcmd^.loTime))
end;
'p': begin
- x32:= SDLNet_Read32(@(headcmd^.X));
- y32:= SDLNet_Read32(@(headcmd^.Y));
+ x32:= SDLNet_Read32(@(headcmd^.str[2]));
+ y32:= SDLNet_Read32(@(headcmd^.str[6]));
doPut(x32, y32, false)
end;
'P': begin
@@ -377,8 +380,8 @@
// SDLNet_Read16(@(headcmd^.Y)) == cScreenHeight - CursorPoint.Y - WorldDy;
if CurrentTeam^.ExtDriven then
begin
- TargetCursorPoint.X:= LongInt(SDLNet_Read32(@(headcmd^.X))) + WorldDx;
- TargetCursorPoint.Y:= cScreenHeight - LongInt(SDLNet_Read32(@(headcmd^.Y))) - WorldDy;
+ TargetCursorPoint.X:= LongInt(SDLNet_Read32(@(headcmd^.str[2]))) + WorldDx;
+ TargetCursorPoint.Y:= cScreenHeight - LongInt(SDLNet_Read32(@(headcmd^.str[6]))) - WorldDy;
if not bShowAmmoMenu and autoCameraOn then
CursorPoint:= TargetCursorPoint
end
@@ -388,7 +391,7 @@
'h': ParseCommand('hogsay ' + copy(headcmd^.str, 2, Pred(headcmd^.len)), true);
'1'..'5': ParseCommand('timer ' + headcmd^.cmd, true);
else
- if (headcmd^.cmd >= #128) and (headcmd^.cmd <= char(128 + cMaxSlotIndex)) then
+ if (byte(headcmd^.cmd) >= 128) and (byte(headcmd^.cmd) <= 128 + cMaxSlotIndex) then
ParseCommand('slot ' + char(byte(headcmd^.cmd) - 79), true)
else
OutError('Unexpected protocol command: ' + headcmd^.cmd, True)
@@ -421,7 +424,7 @@
if CheckNoTeamOrHH or isPaused then
exit;
bShowFinger:= false;
-if not CurrentTeam^.ExtDriven and bShowAmmoMenu then
+if (not CurrentTeam^.ExtDriven) and bShowAmmoMenu then
begin
bSelected:= true;
exit
@@ -471,7 +474,7 @@
lastcmd:= nil;
isPonged:= false;
SocketString:= '';
-
+
hiTicks:= 0;
flushDelayTicks:= 0;
sendBuffer.count:= 0;
@@ -483,6 +486,7 @@
SDLNet_FreeSocketSet(fds);
SDLNet_TCP_Close(IPCSock);
SDLNet_Quit();
+
end;
end.
--- a/hedgewars/uInputHandler.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uInputHandler.pas Tue Jan 21 22:38:13 2014 +0100
@@ -49,7 +49,7 @@
procedure ControllerButtonEvent(joy, button: Byte; pressed: Boolean);
implementation
-uses uConsole, uCommands, uMisc, uVariables, uConsts, uUtils, uDebug, uPhysFSLayer;
+uses uConsole, uCommands, uVariables, uConsts, uUtils, uDebug, uPhysFSLayer;
const
LSHIFT = $0200;
@@ -57,7 +57,7 @@
LALT = $0800;
RALT = $1000;
LCTRL = $2000;
- RCTRL = $4000;
+ RCTRL = $4000;
var tkbd: array[0..cKbdMaxIndex] of boolean;
KeyNames: array [0..cKeyMaxIndex] of string[15];
@@ -91,16 +91,16 @@
(*
procedure MaskModifier(var code: LongInt; Modifier: LongWord);
begin
- if(Modifier and KMOD_LSHIFT) <> 0 then code:= code or LSHIFT;
- if(Modifier and KMOD_RSHIFT) <> 0 then code:= code or LSHIFT;
- if(Modifier and KMOD_LALT) <> 0 then code:= code or LALT;
- if(Modifier and KMOD_RALT) <> 0 then code:= code or LALT;
- if(Modifier and KMOD_LCTRL) <> 0 then code:= code or LCTRL;
- if(Modifier and KMOD_RCTRL) <> 0 then code:= code or LCTRL;
+ if(Modifier and KMOD_LSHIFT) <> 0 then code:= code or LSHIFT;
+ if(Modifier and KMOD_RSHIFT) <> 0 then code:= code or LSHIFT;
+ if(Modifier and KMOD_LALT) <> 0 then code:= code or LALT;
+ if(Modifier and KMOD_RALT) <> 0 then code:= code or LALT;
+ if(Modifier and KMOD_LCTRL) <> 0 then code:= code or LCTRL;
+ if(Modifier and KMOD_RCTRL) <> 0 then code:= code or LCTRL;
end;
*)
procedure MaskModifier(Modifier: shortstring; var code: LongInt);
-var mod_ : shortstring;
+var mod_ : shortstring = '';
ModifierCount, i: LongInt;
begin
if Modifier = '' then exit;
@@ -112,7 +112,7 @@
SplitByChar(Modifier, mod_, ':');//remove the first mod: part
Modifier:= mod_;
for i:= 0 to ModifierCount do
- begin
+ begin
mod_:= '';
SplitByChar(Modifier, mod_, ':');
if (Modifier = 'lshift') then code:= code or LSHIFT;
@@ -175,7 +175,7 @@
LocalMessage:= LocalMessage or gmSwitch
else if CurrentBinds[code] = '+precise' then
LocalMessage:= LocalMessage or gmPrecise;
-
+
ParseCommand(CurrentBinds[code], Trusted);
if (CurrentTeam <> nil) and (not CurrentTeam^.ExtDriven) and (ReadyTimeLeft > 1) then
ParseCommand('gencmd R', true)
@@ -183,7 +183,7 @@
else if (CurrentBinds[code][1] = '+') then
begin
if CurrentBinds[code] = '+precise' then
- LocalMessage:= LocalMessage and not(gmPrecise);
+ LocalMessage:= LocalMessage and (not gmPrecise);
s:= CurrentBinds[code];
s[1]:= '-';
ParseCommand(s, Trusted);
@@ -193,7 +193,7 @@
else
begin
if CurrentBinds[code] = 'switch' then
- LocalMessage:= LocalMessage and not(gmSwitch)
+ LocalMessage:= LocalMessage and (not gmSwitch)
end
end
end;
@@ -246,7 +246,7 @@
s:= shortstring(sdl_getkeyname(i));
//WriteLnToConsole('uInputHandler - ' + IntToStr(i) + ': ' + s + ' ' + IntToStr(cKeyMaxIndex));
if s = 'unknown key' then KeyNames[i]:= ''
- else
+ else
begin
for t:= 1 to Length(s) do
if s[t] = ' ' then
@@ -404,10 +404,10 @@
if ControllerNumAxes[j] > 20 then
ControllerNumAxes[j]:= 20;
//if ControllerNumBalls[j] > 20 then ControllerNumBalls[j]:= 20;
-
+
if ControllerNumHats[j] > 20 then
ControllerNumHats[j]:= 20;
-
+
if ControllerNumButtons[j] > 20 then
ControllerNumButtons[j]:= 20;
@@ -492,7 +492,7 @@
val(copy(l, i, 3), b);
p:= p + char(b);
inc(i, 3)
- end
+ end
else
begin
p:= p + l[i];
@@ -505,7 +505,7 @@
l:= copy(l, i + 1, length(l) - i);
if l <> 'default' then
begin
- if (length(l) = 2) and (l[1] = '\') then
+ if (length(l) = 2) and (l[1] = '\') then
l:= l[1]
else if (l[1] = '"') and (l[length(l)] = '"') then
l:= copy(l, 2, length(l) - 2);
@@ -517,7 +517,7 @@
end;
pfsClose(f)
- end
+ end
else
AddFileLog('[BINDS] file not found');
end;
@@ -547,7 +547,7 @@
if b = 0 then
OutError(errmsgUnknownVariable + ' "' + id + '"', false)
else
- begin
+ begin
// add bind: first check if this cmd is already bound, and remove old bind
i:= cKbdMaxIndex;
repeat
--- a/hedgewars/uLandGenMaze.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uLandGenMaze.pas Tue Jan 21 22:38:13 2014 +0100
@@ -16,7 +16,6 @@
DIR_S: direction = (x: 0; y: 1);
DIR_W: direction = (x: -1; y: 0);
-
operator = (const a, b: direction) c: Boolean;
begin
c := (a.x = b.x) and (a.y = b.y);
@@ -27,28 +26,43 @@
large_cell_size = 256;
braidness = 10;
-var x, y: LongInt;
- cellsize: LongInt; //selected by the user in the gui
- seen_cells_x, seen_cells_y: LongInt; //number of cells that can be visited by the generator, that is every second cell in x and y direction. the cells between there are walls that will be removed when we move from one cell to another
- num_edges_x, num_edges_y: LongInt; //number of resulting edges that need to be vertexificated
- num_cells_x, num_cells_y: LongInt; //actual number of cells, depending on cell size
- seen_list: array of array of LongInt;
- xwalls: array of array of Boolean;
- ywalls: array of array of Boolean;
- x_edge_list: array of array of Boolean;
- y_edge_list: array of array of Boolean;
- maze: array of array of Boolean;
- pa: TPixAr;
- num_vertices: LongInt;
- off_y: LongInt;
- num_steps: LongInt;
- current_step: LongInt;
- step_done: array of Boolean;
- done: Boolean;
- last_cell: array of record x, y: LongInt; end;
- came_from: array of array of record x, y: LongInt; end;
+type
+ cell_t = record x,y : LongInt
+ end;
+
+var x, y : LongInt;
+ cellsize : LongInt; //selected by the user in the gui
+ seen_cells_x, seen_cells_y : LongInt; //number of cells that can be visited by the generator, that is every second cell in x and y direction. the cells between there are walls that will be removed when we move from one cell to another
+ num_edges_x, num_edges_y : LongInt; //number of resulting edges that need to be vertexificated
+ num_cells_x, num_cells_y : LongInt; //actual number of cells, depending on cell size
+
+
+ seen_list : array of array of LongInt;
+ xwalls : array of array of Boolean;
+ ywalls : array of array of Boolean;
+ x_edge_list : array of array of Boolean;
+ y_edge_list : array of array of Boolean;
+ maze : array of array of Boolean;
+
+ pa : TPixAr;
+ num_vertices : LongInt;
+ off_y : LongInt;
+ num_steps : LongInt;
+ current_step : LongInt;
+
+ step_done : array of Boolean;
+
+ done : Boolean;
+
+{ last_cell : array 0..3 of record x, y :LongInt ; end;
+ came_from : array of array of record x, y: LongInt; end;
+ came_from_pos : array of LongInt;
+}
+ last_cell : array of cell_t;
+ came_from : array of array of cell_t;
came_from_pos: array of LongInt;
- maze_inverted: Boolean;
+
+ maze_inverted : Boolean;
function when_seen(x: LongInt; y: LongInt): LongInt;
begin
@@ -104,11 +118,11 @@
begin
//we have already seen the target cell, decide if we should remove the wall anyway
//(or put a wall there if maze_inverted, but we are not doing that right now)
- if not maze_inverted and (GetRandom(braidness) = 0) then
+ if (not maze_inverted) and (GetRandom(braidness) = 0) then
//or just warn that inverted+braid+indestructible terrain != good idea
begin
case dir.x of
-
+
-1:
if x > 0 then
ywalls[x-1, y] := false;
@@ -178,10 +192,10 @@
last_cell[current_step].x := came_from[current_step, came_from_pos[current_step]].x;
last_cell[current_step].y := came_from[current_step, came_from_pos[current_step]].y;
came_from_pos[current_step] := came_from_pos[current_step] - 1;
-
+
if came_from_pos[current_step] >= 0 then
- see_cell
-
+ see_cell()
+
else
step_done[current_step] := true;
end;
@@ -208,7 +222,7 @@
tmp_x := cellsize
else
tmp_x := cellsize * 2 div 3;
-
+
if maze_inverted or (y mod 2 = 0) then
tmp_y := cellsize
else
@@ -318,11 +332,11 @@
num_cells_x := LAND_WIDTH div cellsize;
if not odd(num_cells_x) then
num_cells_x := num_cells_x - 1; //needs to be odd
-
+
num_cells_y := LAND_HEIGHT div cellsize;
if not odd(num_cells_y) then
num_cells_y := num_cells_y - 1;
-
+
num_edges_x := num_cells_x - 1;
num_edges_y := num_cells_y - 1;
@@ -333,19 +347,23 @@
num_steps := 3 //TODO randomize, between 3 and 5?
else
num_steps := 1;
-
+
SetLength(step_done, num_steps);
SetLength(last_cell, num_steps);
SetLength(came_from_pos, num_steps);
SetLength(came_from, num_steps, num_cells_x*num_cells_y);
+
done := false;
for current_step := 0 to num_steps - 1 do
+begin
step_done[current_step] := false;
came_from_pos[current_step] := 0;
-
+end;
+
current_step := 0;
+
SetLength(seen_list, seen_cells_x, seen_cells_y);
SetLength(xwalls, seen_cells_x, seen_cells_y - 1);
SetLength(ywalls, seen_cells_x - 1, seen_cells_y);
@@ -353,6 +371,7 @@
SetLength(y_edge_list, num_cells_x, num_edges_y);
SetLength(maze, num_cells_x, num_cells_y);
+
num_vertices := 0;
playHeight := num_cells_y * cellsize;
--- a/hedgewars/uLandGraphics.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uLandGraphics.pas Tue Jan 21 22:38:13 2014 +0100
@@ -88,21 +88,21 @@
if ((Land[landY, landX] and lfBasic) <> 0) or ((Land[landY, landX] and lfObject) <> 0) then
begin
LandPixels[pixelY, pixelX]:= ExplosionBorderColor;
- Land[landY, landX]:= (Land[landY, landX] or lfDamaged) and not lfIce;
+ Land[landY, landX]:= (Land[landY, landX] or lfDamaged) and (not lfIce);
LandDirty[landY div 32, landX div 32]:= 1;
end;
end;
function isLandscapeEdge(weight:Longint):boolean; inline;
begin
-result := (weight < 8) and (weight >= 2);
+isLandscapeEdge := (weight < 8) and (weight >= 2);
end;
function getPixelWeight(x, y:Longint): Longint;
var
- i, j:Longint;
+ i, j, r: Longint;
begin
-result := 0;
+r := 0;
for i := x - 1 to x + 1 do
for j := y - 1 to y + 1 do
begin
@@ -110,13 +110,13 @@
(i > LAND_WIDTH - 1) or
(j < 0) or
(j > LAND_HEIGHT -1) then
- begin
- result := 9;
- exit;
- end;
- if Land[j, i] and lfLandMask and not lfIce = 0 then
- result := result + 1;
+ exit(9);
+
+ if Land[j, i] and lfLandMask and (not lfIce) = 0 then
+ inc(r)
end;
+
+ getPixelWeight:= r
end;
@@ -144,11 +144,11 @@
end
else
begin
- LandPixels[pixelY, pixelX]:= IceColor and not AMask or $E8 shl AShift;
+ LandPixels[pixelY, pixelX]:= IceColor and (not AMask) or $E8 shl AShift;
LandPixels[pixelY, pixelX]:= addBgColor(LandPixels[pixelY, pixelX], icePixels^[iceSurface^.w * (pixelY mod iceSurface^.h) + (pixelX mod iceSurface^.w)]);
// silly workaround to avoid having to make background erasure a tadb it smarter about sea ice
if LandPixels[pixelY, pixelX] and AMask shr AShift = 255 then
- LandPixels[pixelY, pixelX]:= LandPixels[pixelY, pixelX] and not AMask or 254 shl AShift;
+ LandPixels[pixelY, pixelX]:= LandPixels[pixelY, pixelX] and (not AMask) or 254 shl AShift;
end;
end;
@@ -159,7 +159,7 @@
if isLandscapeEdge(getPixelWeight(landX, landY)) then
begin
if (LandPixels[pixelY, pixelX] and AMask < 255) and (LandPixels[pixelY, pixelX] and AMask > 0) then
- LandPixels[pixelY, pixelX] := (IceEdgeColor and not AMask) or (LandPixels[pixelY, pixelX] and AMask)
+ LandPixels[pixelY, pixelX] := (IceEdgeColor and (not AMask)) or (LandPixels[pixelY, pixelX] and AMask)
else if (LandPixels[pixelY, pixelX] and AMask < 255) or (Land[landY, landX] > 255) then
LandPixels[pixelY, pixelX] := IceEdgeColor
end
@@ -167,7 +167,7 @@
begin
fillPixelFromIceSprite(pixelX, pixelY);
end;
-if Land[landY, landX] > 255 then Land[landY, landX] := Land[landY, landX] or lfIce and not lfDamaged;
+if Land[landY, landX] > 255 then Land[landY, landX] := Land[landY, landX] or lfIce and (not lfDamaged);
end;
@@ -344,11 +344,11 @@
begin
if not doSet and isCurrent then
FillRoundInLandFT(X, Y, Radius, setNotCurrentMask)
-else if not doSet and not IsCurrent then
+else if not doSet and (not IsCurrent) then
FillRoundInLandFT(X, Y, Radius, changePixelSetNotCurrent)
else if doSet and IsCurrent then
FillRoundInLandFT(X, Y, Radius, setCurrentHog)
-else if doSet and not IsCurrent then
+else if doSet and (not IsCurrent) then
FillRoundInLandFT(X, Y, Radius, changePixelNotSetNotCurrent);
end;
@@ -432,7 +432,7 @@
else
LandPixels[ty div 2, tx div 2]:= ExplosionBorderColor;
- Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and not lfIce;
+ Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and (not lfIce);
LandDirty[ty div 32, tx div 32]:= 1;
end;
inc(y, dY)
@@ -457,7 +457,7 @@
if ((ty and LAND_HEIGHT_MASK) = 0) and ((tx and LAND_WIDTH_MASK) = 0) and (((Land[ty, tx] and lfBasic) <> 0)
or ((Land[ty, tx] and lfObject) <> 0)) then
begin
- Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and not lfIce;
+ Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and (not lfIce);
if despeckle then
LandDirty[ty div 32, tx div 32]:= 1;
if (cReducedQuality and rqBlurryLand) = 0 then
@@ -501,7 +501,7 @@
and ((tx and LAND_WIDTH_MASK) = 0)
and (((Land[ty, tx] and lfBasic) <> 0) or ((Land[ty, tx] and lfObject) <> 0)) then
begin
- Land[ty, tx]:= Land[ty, tx] and not lfIce;
+ Land[ty, tx]:= Land[ty, tx] and (not lfIce);
if despeckle then
begin
Land[ty, tx]:= Land[ty, tx] or lfDamaged;
@@ -565,7 +565,7 @@
if ((ty and LAND_HEIGHT_MASK) = 0) and ((tx and LAND_WIDTH_MASK) = 0) and (((Land[ty, tx] and lfBasic) <> 0)
or ((Land[ty, tx] and lfObject) <> 0)) then
begin
- Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and not lfIce;
+ Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and (not lfIce);
if despeckle then
LandDirty[ty div 32, tx div 32]:= 1;
if (cReducedQuality and rqBlurryLand) = 0 then
--- a/hedgewars/uLandObjects.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uLandObjects.pas Tue Jan 21 22:38:13 2014 +0100
@@ -94,7 +94,7 @@
begin
BlitImageAndGenerateCollisionInfo(cpX, cpY, Width, Image, 0);
end;
-
+
procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface; LandFlags: Word);
var p: PLongwordArray;
x, y: Longword;
@@ -124,7 +124,7 @@
LandPixels[cpY + y, cpX + x]:= p^[x];
end
else
- if LandPixels[(cpY + y) div 2, (cpX + x) div 2] = 0 then
+ if LandPixels[(cpY + y) div 2, (cpX + x) div 2] = 0 then
LandPixels[(cpY + y) div 2, (cpX + x) div 2]:= p^[x];
if (Land[cpY + y, cpX + x] <= lfAllObjMask) and ((p^[x] and AMask) <> 0) then
@@ -164,7 +164,7 @@
LandPixels[cpY + y, cpX + x]:= p^[x];
end
else
- if LandPixels[(cpY + y) div 2, (cpX + x) div 2] = 0 then
+ if LandPixels[(cpY + y) div 2, (cpX + x) div 2] = 0 then
LandPixels[(cpY + y) div 2, (cpX + x) div 2]:= p^[x];
if (Land[cpY + y, cpX + x] <= lfAllObjMask) or (Land[cpY + y, cpX + x] and lfObject <> 0) then
@@ -261,7 +261,7 @@
inc(x2, 2);
k:= CountNonZeroz(x2, y)
until (x2 >= (rightX-150)) or (k = 0) or (k = 16) or (x2 > i) or (x2 - x1 >= 768);
-
+
if (x2 < (rightX - 150)) and (k = 16) and (x2 - x1 > 250) and (x2 - x1 < 768)
and (not CheckIntersect(x1 - 32, y - 64, x2 - x1 + 64, 144)) then
break;
@@ -277,7 +277,7 @@
rr.x:= x1;
while rr.x < x2 do
begin
- if cIce then
+ if cIce then
BlitImageAndGenerateCollisionInfo(rr.x, y, min(x2 - rr.x, tmpsurf^.w), tmpsurf, lfIce)
else
BlitImageAndGenerateCollisionInfo(rr.x, y, min(x2 - rr.x, tmpsurf^.w), tmpsurf);
@@ -454,9 +454,9 @@
procedure CheckRect(Width, Height, x, y, w, h: LongWord);
begin
- if (x + w > Width) then
+ if (x + w > Width) then
OutError('Object''s rectangle exceeds image: x + w (' + inttostr(x) + ' + ' + inttostr(w) + ') > Width (' + inttostr(Width) + ')', true);
- if (y + h > Height) then
+ if (y + h > Height) then
OutError('Object''s rectangle exceeds image: y + h (' + inttostr(y) + ' + ' + inttostr(h) + ') > Height (' + inttostr(Height) + ')', true);
end;
@@ -554,7 +554,7 @@
c2.g:= t;
c2.b:= t
end;
- ExplosionBorderColor:= (c2.r shl RShift) or (c2.g shl GShift) or (c2.b shl BShift) or AMask;
+ ExplosionBorderColor:= (c2.r shl RShift) or (c2.g shl GShift) or (c2.b shl BShift) or AMask;
end
else if key = 'water-top' then
begin
--- a/hedgewars/uLandOutline.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uLandOutline.pas Tue Jan 21 22:38:13 2014 +0100
@@ -27,8 +27,6 @@
end
end;
-const
- cMaxEdgePoints = 16384;
procedure Push(_xl, _xr, _y, _dir: LongInt);
begin
@@ -99,9 +97,9 @@
i:= 0;
with pa do
while i < LongInt(Count) - 1 do
- if (ar[i + 1].X = NTPX) then
+ if (ar[i + 1].X = NTPX) then
inc(i, 2)
- else
+ else
begin
DrawLine(ar[i].x, ar[i].y, ar[i + 1].x, ar[i + 1].y, Color);
inc(i)
@@ -130,7 +128,7 @@
begin
Vx:= _0;
Vy:= _0
- end
+ end
else
begin
d2:= _1 / d2;
@@ -237,7 +235,7 @@
CheckIntersect:= false
else if (c2 < 0) or (c2 > dm) then
CheckIntersect:= false;
- end
+ end
else
begin
if (c1 > 0) or (c1 < dm) then
--- a/hedgewars/uLandPainted.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uLandPainted.pas Tue Jan 21 22:38:13 2014 +0100
@@ -27,7 +27,7 @@
procedure freeModule;
implementation
-uses uLandGraphics, uConsts, uVariables, uUtils, SDLh, uCommands, uDebug, uScript;
+uses uLandGraphics, uConsts, uVariables, uUtils, SDLh, uCommands, uScript;
type PointRec = packed record
X, Y: SmallInt;
--- a/hedgewars/uLocale.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uLocale.pas Tue Jan 21 22:38:13 2014 +0100
@@ -36,13 +36,14 @@
{$ENDIF}
implementation
-uses uRandom, uUtils, uVariables, uDebug, uPhysFSLayer, sysutils;
+uses uRandom, uVariables, uDebug, uPhysFSLayer, sysutils;
var trevt: array[TEventId] of array [0..Pred(MAX_EVENT_STRINGS)] of PChar;
trevt_n: array[TEventId] of integer;
procedure LoadLocale(FileName: shortstring);
-var s, sc: PChar;
+var s: PChar = nil;
+ sc: PChar;
f: pfsFile;
a, b, c: LongInt;
first: array[TEventId] of boolean;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/hedgewars/uMatrix.pas Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,268 @@
+(*
+ * 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 uMatrix;
+
+interface
+
+uses uTypes {$IFNDEF PAS2C}, gl{$ENDIF};
+
+const
+ MATRIX_MODELVIEW:Integer = 0;
+ MATRIX_PROJECTION:Integer = 1;
+
+procedure MatrixLoadIdentity(out Result: TMatrix4x4f);
+procedure MatrixMultiply(out Result: TMatrix4x4f; const lhs, rhs: TMatrix4x4f);
+
+procedure hglMatrixMode(t: Integer);
+procedure hglLoadIdentity();
+procedure hglPushMatrix();
+procedure hglPopMatrix();
+procedure hglMVP(var res : TMatrix4x4f);
+procedure hglScalef(x: GLfloat; y: GLfloat; z: GLfloat);
+procedure hglTranslatef(x: GLfloat; y: GLfloat; z: GLfloat);
+procedure hglRotatef(a:GLfloat; x:GLfloat; y:GLfloat; z:GLfloat);
+procedure initModule();
+procedure freeModule();
+
+implementation
+
+const
+ MATRIX_STACK_SIZE = 10;
+
+type
+ TMatrixStack = record
+ top:Integer;
+ stack: array[0..9] of TMatrix4x4f;
+ end;
+var
+ MatrixStacks : array[0..1] of TMatrixStack;
+ CurMatrix: integer;
+
+procedure MatrixLoadIdentity(out Result: TMatrix4x4f);
+begin
+ Result[0,0]:= 1.0; Result[1,0]:=0.0; Result[2,0]:=0.0; Result[3,0]:=0.0;
+ Result[0,1]:= 0.0; Result[1,1]:=1.0; Result[2,1]:=0.0; Result[3,1]:=0.0;
+ Result[0,2]:= 0.0; Result[1,2]:=0.0; Result[2,2]:=1.0; Result[3,2]:=0.0;
+ Result[0,3]:= 0.0; Result[1,3]:=0.0; Result[2,3]:=0.0; Result[3,3]:=1.0;
+end;
+
+procedure hglMatrixMode(t: Integer);
+begin
+ CurMatrix := t;
+end;
+
+procedure hglLoadIdentity();
+begin
+ MatrixLoadIdentity(MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top]);
+end;
+
+procedure hglScalef(x: GLfloat; y: GLfloat; z: GLfloat);
+var
+ m:TMatrix4x4f;
+ t:TMatrix4x4f;
+begin
+ m[0,0]:=x;m[1,0]:=0;m[2,0]:=0;m[3,0]:=0;
+ m[0,1]:=0;m[1,1]:=y;m[2,1]:=0;m[3,1]:=0;
+ m[0,2]:=0;m[1,2]:=0;m[2,2]:=z;m[3,2]:=0;
+ m[0,3]:=0;m[1,3]:=0;m[2,3]:=0;m[3,3]:=1;
+
+ MatrixMultiply(t, MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top], m);
+ MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top] := t;
+end;
+
+procedure hglTranslatef(x: GLfloat; y: GLfloat; z: GLfloat);
+var
+ m:TMatrix4x4f;
+ t:TMatrix4x4f;
+begin
+ m[0,0]:=1;m[1,0]:=0;m[2,0]:=0;m[3,0]:=x;
+ m[0,1]:=0;m[1,1]:=1;m[2,1]:=0;m[3,1]:=y;
+ m[0,2]:=0;m[1,2]:=0;m[2,2]:=1;m[3,2]:=z;
+ m[0,3]:=0;m[1,3]:=0;m[2,3]:=0;m[3,3]:=1;
+
+ MatrixMultiply(t, MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top], m);
+ MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top] := t;
+end;
+
+procedure hglRotatef(a:GLfloat; x:GLfloat; y:GLfloat; z:GLfloat);
+var
+ m:TMatrix4x4f;
+ t:TMatrix4x4f;
+ c:GLfloat;
+ s:GLfloat;
+ xn, yn, zn:GLfloat;
+ l:GLfloat;
+begin
+ a:=a * 3.14159265368 / 180;
+ c:=cos(a);
+ s:=sin(a);
+
+ l := 1.0 / sqrt(x * x + y * y + z * z);
+ xn := x * l;
+ yn := y * l;
+ zn := z * l;
+
+ m[0,0]:=c + xn * xn * (1 - c);
+ m[1,0]:=xn * yn * (1 - c) - zn * s;
+ m[2,0]:=xn * zn * (1 - c) + yn * s;
+ m[3,0]:=0;
+
+
+ m[0,1]:=yn * xn * (1 - c) + zn * s;
+ m[1,1]:=c + yn * yn * (1 - c);
+ m[2,1]:=yn * zn * (1 - c) - xn * s;
+ m[3,1]:=0;
+
+ m[0,2]:=zn * xn * (1 - c) - yn * s;
+ m[1,2]:=zn * yn * (1 - c) + xn * s;
+ m[2,2]:=c + zn * zn * (1 - c);
+ m[3,2]:=0;
+
+ m[0,3]:=0;m[1,3]:=0;m[2,3]:=0;m[3,3]:=1;
+
+ MatrixMultiply(t, MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top], m);
+ MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top] := t;
+end;
+
+procedure hglMVP(var res: TMatrix4x4f);
+begin
+ MatrixMultiply(res,
+ MatrixStacks[MATRIX_PROJECTION].stack[MatrixStacks[MATRIX_PROJECTION].top],
+ MatrixStacks[MATRIX_MODELVIEW].stack[MatrixStacks[MATRIX_MODELVIEW].top]);
+end;
+
+procedure hglPushMatrix();
+var
+ t: Integer;
+begin
+ t := MatrixStacks[CurMatrix].top;
+ MatrixStacks[CurMatrix].stack[t + 1] := MatrixStacks[CurMatrix].stack[t];
+ inc(t);
+ MatrixStacks[CurMatrix].top := t;
+end;
+
+procedure hglPopMatrix();
+var
+ t: Integer;
+begin
+ t := MatrixStacks[CurMatrix].top;
+ dec(t);
+ MatrixStacks[CurMatrix].top := t;
+end;
+
+procedure initModule();
+begin
+ MatrixStacks[MATRIX_MODELVIEW].top := 0;
+ MatrixStacks[MATRIX_Projection].top := 0;
+ MatrixLoadIdentity(MatrixStacks[MATRIX_MODELVIEW].stack[0]);
+ MatrixLoadIdentity(MatrixStacks[MATRIX_PROJECTION].stack[0]);
+end;
+
+procedure freeModule();
+begin
+end;
+
+procedure MatrixMultiply(out Result: TMatrix4x4f; const lhs, rhs: TMatrix4x4f);
+var
+ test: TMatrix4x4f;
+ i, j: Integer;
+ error: boolean;
+begin
+ Result[0,0]:=lhs[0,0]*rhs[0,0] + lhs[1,0]*rhs[0,1] + lhs[2,0]*rhs[0,2] + lhs[3,0]*rhs[0,3];
+ Result[0,1]:=lhs[0,1]*rhs[0,0] + lhs[1,1]*rhs[0,1] + lhs[2,1]*rhs[0,2] + lhs[3,1]*rhs[0,3];
+ Result[0,2]:=lhs[0,2]*rhs[0,0] + lhs[1,2]*rhs[0,1] + lhs[2,2]*rhs[0,2] + lhs[3,2]*rhs[0,3];
+ Result[0,3]:=lhs[0,3]*rhs[0,0] + lhs[1,3]*rhs[0,1] + lhs[2,3]*rhs[0,2] + lhs[3,3]*rhs[0,3];
+
+ Result[1,0]:=lhs[0,0]*rhs[1,0] + lhs[1,0]*rhs[1,1] + lhs[2,0]*rhs[1,2] + lhs[3,0]*rhs[1,3];
+ Result[1,1]:=lhs[0,1]*rhs[1,0] + lhs[1,1]*rhs[1,1] + lhs[2,1]*rhs[1,2] + lhs[3,1]*rhs[1,3];
+ Result[1,2]:=lhs[0,2]*rhs[1,0] + lhs[1,2]*rhs[1,1] + lhs[2,2]*rhs[1,2] + lhs[3,2]*rhs[1,3];
+ Result[1,3]:=lhs[0,3]*rhs[1,0] + lhs[1,3]*rhs[1,1] + lhs[2,3]*rhs[1,2] + lhs[3,3]*rhs[1,3];
+
+ Result[2,0]:=lhs[0,0]*rhs[2,0] + lhs[1,0]*rhs[2,1] + lhs[2,0]*rhs[2,2] + lhs[3,0]*rhs[2,3];
+ Result[2,1]:=lhs[0,1]*rhs[2,0] + lhs[1,1]*rhs[2,1] + lhs[2,1]*rhs[2,2] + lhs[3,1]*rhs[2,3];
+ Result[2,2]:=lhs[0,2]*rhs[2,0] + lhs[1,2]*rhs[2,1] + lhs[2,2]*rhs[2,2] + lhs[3,2]*rhs[2,3];
+ Result[2,3]:=lhs[0,3]*rhs[2,0] + lhs[1,3]*rhs[2,1] + lhs[2,3]*rhs[2,2] + lhs[3,3]*rhs[2,3];
+
+ Result[3,0]:=lhs[0,0]*rhs[3,0] + lhs[1,0]*rhs[3,1] + lhs[2,0]*rhs[3,2] + lhs[3,0]*rhs[3,3];
+ Result[3,1]:=lhs[0,1]*rhs[3,0] + lhs[1,1]*rhs[3,1] + lhs[2,1]*rhs[3,2] + lhs[3,1]*rhs[3,3];
+ Result[3,2]:=lhs[0,2]*rhs[3,0] + lhs[1,2]*rhs[3,1] + lhs[2,2]*rhs[3,2] + lhs[3,2]*rhs[3,3];
+ Result[3,3]:=lhs[0,3]*rhs[3,0] + lhs[1,3]*rhs[3,1] + lhs[2,3]*rhs[3,2] + lhs[3,3]*rhs[3,3];
+
+{
+ Result[0,0]:=lhs[0,0]*rhs[0,0] + lhs[1,0]*rhs[0,1] + lhs[2,0]*rhs[0,2] + lhs[3,0]*rhs[0,3];
+ Result[0,1]:=lhs[0,0]*rhs[1,0] + lhs[1,0]*rhs[1,1] + lhs[2,0]*rhs[1,2] + lhs[3,0]*rhs[1,3];
+ Result[0,2]:=lhs[0,0]*rhs[2,0] + lhs[1,0]*rhs[2,1] + lhs[2,0]*rhs[2,2] + lhs[3,0]*rhs[2,3];
+ Result[0,3]:=lhs[0,0]*rhs[3,0] + lhs[1,0]*rhs[3,1] + lhs[2,0]*rhs[3,2] + lhs[3,0]*rhs[3,3];
+
+ Result[1,0]:=lhs[0,1]*rhs[0,0] + lhs[1,1]*rhs[0,1] + lhs[2,1]*rhs[0,2] + lhs[3,1]*rhs[0,3];
+ Result[1,1]:=lhs[0,1]*rhs[1,0] + lhs[1,1]*rhs[1,1] + lhs[2,1]*rhs[1,2] + lhs[3,1]*rhs[1,3];
+ Result[1,2]:=lhs[0,1]*rhs[2,0] + lhs[1,1]*rhs[2,1] + lhs[2,1]*rhs[2,2] + lhs[3,1]*rhs[2,3];
+ Result[1,3]:=lhs[0,1]*rhs[3,0] + lhs[1,1]*rhs[3,1] + lhs[2,1]*rhs[3,2] + lhs[3,1]*rhs[3,3];
+
+ Result[2,0]:=lhs[0,2]*rhs[0,0] + lhs[1,2]*rhs[0,1] + lhs[2,2]*rhs[0,2] + lhs[3,2]*rhs[0,3];
+ Result[2,1]:=lhs[0,2]*rhs[1,0] + lhs[1,2]*rhs[1,1] + lhs[2,2]*rhs[1,2] + lhs[3,2]*rhs[1,3];
+ Result[2,2]:=lhs[0,2]*rhs[2,0] + lhs[1,2]*rhs[2,1] + lhs[2,2]*rhs[2,2] + lhs[3,2]*rhs[2,3];
+ Result[2,3]:=lhs[0,2]*rhs[3,0] + lhs[1,2]*rhs[3,1] + lhs[2,2]*rhs[3,2] + lhs[3,2]*rhs[3,3];
+
+ Result[3,0]:=lhs[0,3]*rhs[0,0] + lhs[1,3]*rhs[0,1] + lhs[2,3]*rhs[0,2] + lhs[3,3]*rhs[0,3];
+ Result[3,1]:=lhs[0,3]*rhs[1,0] + lhs[1,3]*rhs[1,1] + lhs[2,3]*rhs[1,2] + lhs[3,3]*rhs[1,3];
+ Result[3,2]:=lhs[0,3]*rhs[2,0] + lhs[1,3]*rhs[2,1] + lhs[2,3]*rhs[2,2] + lhs[3,3]*rhs[2,3];
+ Result[3,3]:=lhs[0,3]*rhs[3,0] + lhs[1,3]*rhs[3,1] + lhs[2,3]*rhs[3,2] + lhs[3,3]*rhs[3,3];
+}
+
+ {$IFNDEF PAS2C}
+ glPushMatrix;
+ glLoadMatrixf(@lhs[0, 0]);
+ glMultMatrixf(@rhs[0, 0]);
+ glGetFloatv(GL_MODELVIEW_MATRIX, @test[0, 0]);
+ glPopMatrix;
+
+ error:=false;
+ for i:=0 to 3 do
+ for j:=0 to 3 do
+ if Abs(test[i, j] - Result[i, j]) > 0.000001 then
+ error:=true;
+
+ if error then
+ begin
+ writeln('shall:');
+ for i:=0 to 3 do
+ begin
+ for j:=0 to 3 do
+ write(test[i, j]);
+ writeln;
+ end;
+
+ writeln('is:');
+ for i:=0 to 3 do
+ begin
+ for j:=0 to 3 do
+ write(Result[i, j]);
+ writeln;
+ end;
+ halt(0);
+ end;
+ {$ENDIF}
+
+end;
+
+
+end.
--- a/hedgewars/uMisc.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uMisc.pas Tue Jan 21 22:38:13 2014 +0100
@@ -48,7 +48,7 @@
size: QWord;
end;
-var conversionFormat: PSDL_PixelFormat;
+var conversionFormat : PSDL_PixelFormat;
procedure movecursor(dx, dy: LongInt);
var x, y: LongInt;
@@ -67,7 +67,7 @@
var i: LongInt;
png_ptr: ^png_struct;
info_ptr: ^png_info;
- f: file;
+ f: File;
image: PScreenshot;
begin
image:= PScreenshot(screenshot);
@@ -140,6 +140,7 @@
);
image: PScreenshot;
size: QWord;
+ writeResult:LongInt;
begin
image:= PScreenshot(screenshot);
@@ -167,8 +168,8 @@
Rewrite(f, 1);
if IOResult = 0 then
begin
- BlockWrite(f, head, sizeof(head));
- BlockWrite(f, image^.buffer^, size);
+ BlockWrite(f, head, sizeof(head), writeResult);
+ BlockWrite(f, image^.buffer^, size, writeResult);
Close(f);
end
else
@@ -298,7 +299,6 @@
GetTeamStatString:= s;
end;
-procedure initModule;
{$IFDEF SDL2}
const SDL_PIXELFORMAT_ABGR8888 = (1 shl 28) or (6 shl 24) or (7 shl 20) or (6 shl 16) or (32 shl 8) or 4;
{$ELSE}
@@ -309,6 +309,8 @@
RMask: RMask; GMask: GMask; BMask: BMask; AMask: AMask;
colorkey: 0; alpha: 255);
{$ENDIF}
+
+procedure initModule;
begin
{$IFDEF SDL2}
conversionFormat:= SDL_AllocFormat(SDL_PIXELFORMAT_ABGR8888);
--- a/hedgewars/uPhysFSLayer.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uPhysFSLayer.pas Tue Jan 21 22:38:13 2014 +0100
@@ -40,7 +40,7 @@
function PHYSFS_init(argv0: PChar) : LongInt; cdecl; external PhysfsLibName;
function PHYSFS_deinit() : LongInt; cdecl; external PhysfsLibName;
-function PHYSFSRWOPS_openRead(fname: PChar): PSDL_RWops; cdecl ; external PhyslayerLibName;
+function PHYSFSRWOPS_openRead(fname: PChar): PSDL_RWops; cdecl; external PhyslayerLibName;
function PHYSFSRWOPS_openWrite(fname: PChar): PSDL_RWops; cdecl; external PhyslayerLibName;
function PHYSFS_mount(newDir, mountPoint: PChar; appendToPath: LongBool) : LongBool; cdecl; external PhysfsLibName;
--- a/hedgewars/uRandom.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uRandom.pas Tue Jan 21 22:38:13 2014 +0100
@@ -31,8 +31,8 @@
uses uFloat;
procedure SetRandomSeed(Seed: shortstring; dropAdditionalPart: boolean); // Sets the seed that should be used for generating pseudo-random values.
-function GetRandomf: hwFloat; overload; // Returns a pseudo-random hwFloat.
-function GetRandom(m: LongWord): LongWord; overload; inline; // Returns a positive pseudo-random integer smaller than m.
+function GetRandomf: hwFloat; // Returns a pseudo-random hwFloat.
+function GetRandom(m: LongWord): LongWord; inline; // Returns a positive pseudo-random integer smaller than m.
procedure AddRandomness(r: LongWord); inline;
function rndSign(num: hwFloat): hwFloat; // Returns num with a random chance of having a inverted sign.
@@ -45,10 +45,11 @@
procedure AddRandomness(r: LongWord); inline;
begin
n:= (n + 1) and $3F;
-cirbuf[n]:= cirbuf[n] xor r
+ cirbuf[n]:= cirbuf[n] xor r;
end;
function GetNext: Longword; inline;
+var s : string;
begin
n:= (n + 1) and $3F;
cirbuf[n]:=
@@ -56,7 +57,8 @@
cirbuf[(n + 9) and $3F]) {n - 55 mod 64}
and $7FFFFFFF; {mod 2^31}
-GetNext:= cirbuf[n]
+ GetNext:= cirbuf[n];
+ str(GetNext, s);
end;
procedure SetRandomSeed(Seed: shortstring; dropAdditionalPart: boolean);
@@ -80,7 +82,7 @@
cirbuf[i]:= $A98765 + 68; // odd number
for i:= 0 to 1023 do
- GetNext
+ GetNext;
end;
function GetRandomf: hwFloat;
--- a/hedgewars/uRender.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uRender.pas Tue Jan 21 22:38:13 2014 +0100
@@ -17,12 +17,13 @@
*)
{$INCLUDE "options.inc"}
+{$IF GLunit = GL}{$DEFINE GLunit:=GL,GLext}{$ENDIF}
unit uRender;
interface
-uses SDLh, uTypes, GLunit, uConsts;
+uses SDLh, uTypes, GLunit, uConsts, uStore{$IFDEF GL2}, uMatrix{$ENDIF};
procedure DrawSprite (Sprite: TSprite; X, Y, Frame: LongInt);
procedure DrawSprite (Sprite: TSprite; X, Y, FrameX, FrameY: LongInt);
@@ -55,7 +56,6 @@
procedure untint(); inline;
procedure setTintAdd (f: boolean); inline;
-
implementation
uses uVariables;
@@ -78,6 +78,7 @@
begin
DrawTextureFromRectDir(X, Y, r^.w, r^.h, r, SourceTexture, 1)
end;
+
procedure DrawTextureFromRect(X, Y, W, H: LongInt; r: PSDL_Rect; SourceTexture: PTexture); inline;
begin
DrawTextureFromRectDir(X, Y, W, H, r, SourceTexture, 1)
@@ -143,7 +144,7 @@
glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]);
glTexCoordPointer(2, GL_FLOAT, 0, @TextureBuffer[0]);
-glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer));
+glDrawArrays(GL_TRIANGLE_FAN, 0, High(VertexBuffer) - Low(VertexBuffer) + 1);
end;
procedure DrawTexture(X, Y: LongInt; Texture: PTexture); inline;
@@ -154,17 +155,30 @@
procedure DrawTexture(X, Y: LongInt; Texture: PTexture; Scale: GLfloat);
begin
+{$IFDEF GL2}
+hglPushMatrix;
+hglTranslatef(X, Y, 0);
+hglScalef(Scale, Scale, 1);
+{$ELSE}
glPushMatrix;
glTranslatef(X, Y, 0);
glScalef(Scale, Scale, 1);
+{$ENDIF}
glBindTexture(GL_TEXTURE_2D, Texture^.id);
-glVertexPointer(2, GL_FLOAT, 0, @Texture^.vb);
-glTexCoordPointer(2, GL_FLOAT, 0, @Texture^.tb);
+SetVertexPointer(@Texture^.vb, Length(Texture^.vb));
+SetTexCoordPointer(@Texture^.tb, Length(Texture^.vb));
+
+{$IFDEF GL2}
+UpdateModelviewProjection;
glDrawArrays(GL_TRIANGLE_FAN, 0, Length(Texture^.vb));
+hglPopMatrix;
+{$ELSE}
+glDrawArrays(GL_TRIANGLE_FAN, 0, Length(Texture^.vb));
+glPopMatrix;
+{$ENDIF}
-glPopMatrix
end;
procedure DrawTextureF(Texture: PTexture; Scale: GLfloat; X, Y, Frame, Dir, w, h: LongInt);
@@ -183,14 +197,25 @@
if (abs(Y) > H) and ((abs(Y + OffsetY - (0.5 * cScreenHeight)) - W / 2) * cScaleFactor > cScreenHeight) then
exit;
+{$IFDEF GL2}
+hglPushMatrix;
+hglTranslatef(X, Y, 0);
+{$ELSE}
glPushMatrix;
glTranslatef(X, Y, 0);
+{$ENDIF}
+
if Dir = 0 then Dir:= 1;
+{$IFDEF GL2}
+hglRotatef(Angle, 0, 0, Dir);
+hglTranslatef(Dir*OffsetX, OffsetY, 0);
+hglScalef(Scale, Scale, 1);
+{$ELSE}
glRotatef(Angle, 0, 0, Dir);
-
glTranslatef(Dir*OffsetX, OffsetY, 0);
glScalef(Scale, Scale, 1);
+{$ENDIF}
// Any reason for this call? And why only in t direction, not s?
//glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE);
@@ -225,11 +250,21 @@
TextureBuffer[3].X:= fl;
TextureBuffer[3].Y:= fb;
-glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]);
-glTexCoordPointer(2, GL_FLOAT, 0, @TextureBuffer[0]);
+SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer));
+SetTexCoordPointer(@TextureBuffer[0], Length(VertexBuffer));
+
+{$IFDEF GL2}
+UpdateModelviewProjection;
+{$ENDIF}
+
glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer));
-glPopMatrix
+{$IFDEF GL2}
+hglPopMatrix;
+{$ELSE}
+glPopMatrix;
+{$ENDIF}
+
end;
procedure DrawSpriteRotated(Sprite: TSprite; X, Y, Dir: LongInt; Angle: real);
@@ -242,19 +277,42 @@
procedure DrawSpriteRotatedF(Sprite: TSprite; X, Y, Frame, Dir: LongInt; Angle: real);
begin
+
+{$IFDEF GL2}
+hglPushMatrix;
+hglTranslatef(X, Y, 0);
+{$ELSE}
glPushMatrix;
glTranslatef(X, Y, 0);
+{$ENDIF}
if Dir < 0 then
+{$IFDEF GL2}
+ hglRotatef(Angle, 0, 0, -1)
+{$ELSE}
glRotatef(Angle, 0, 0, -1)
+{$ENDIF}
else
+{$IFDEF GL2}
+ hglRotatef(Angle, 0, 0, 1);
+{$ELSE}
glRotatef(Angle, 0, 0, 1);
+{$ENDIF}
if Dir < 0 then
+{$IFDEF GL2}
+ hglScalef(-1.0, 1.0, 1.0);
+{$ELSE}
glScalef(-1.0, 1.0, 1.0);
+{$ENDIF}
DrawSprite(Sprite, -SpritesData[Sprite].Width div 2, -SpritesData[Sprite].Height div 2, Frame);
-glPopMatrix
+{$IFDEF GL2}
+hglPopMatrix;
+{$ELSE}
+glPopMatrix;
+{$ENDIF}
+
end;
procedure DrawTextureRotated(Texture: PTexture; hw, hh, X, Y, Dir: LongInt; Angle: real);
@@ -266,17 +324,29 @@
if (abs(Y) > 2 * hh) and ((abs(Y - 0.5 * cScreenHeight) - hh) > cScreenHeight / cScaleFactor) then
exit;
+{$IFDEF GL2}
+hglPushMatrix;
+hglTranslatef(X, Y, 0);
+{$ELSE}
glPushMatrix;
glTranslatef(X, Y, 0);
+{$ENDIF}
if Dir < 0 then
begin
hw:= - hw;
+{$IFDEF GL2}
+ hglRotatef(Angle, 0, 0, -1);
+{$ELSE}
glRotatef(Angle, 0, 0, -1);
+{$ENDIF}
end
else
- glRotatef(Angle, 0, 0, 1);
-
+{$IFDEF GL2}
+ hglRotatef(Angle, 0, 0, 1);
+{$ELSE}
+ glRotatef(Angle, 0, 0, 1);
+{$ENDIF}
glBindTexture(GL_TEXTURE_2D, Texture^.id);
@@ -289,11 +359,21 @@
VertexBuffer[3].X:= -hw;
VertexBuffer[3].Y:= hh;
-glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]);
-glTexCoordPointer(2, GL_FLOAT, 0, @Texture^.tb);
+SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer));
+SetTexCoordPointer(@Texture^.tb, Length(VertexBuffer));
+
+{$IFDEF GL2}
+UpdateModelviewProjection;
+{$ENDIF}
+
glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer));
-glPopMatrix
+{$IFDEF GL2}
+hglPopMatrix;
+{$ELSE}
+glPopMatrix;
+{$ENDIF}
+
end;
procedure DrawSprite(Sprite: TSprite; X, Y, Frame: LongInt);
@@ -335,7 +415,7 @@
if (X + SpritesData[Sprite].Width > RightX) then
r.w:= RightX - X + 1;
-if (r.h < r.y) or (r.w < r.x) then
+if (r.h < r.y) or (r.w < r.x) then
exit;
dec(r.h, r.y);
@@ -362,8 +442,9 @@
procedure DrawLine(X0, Y0, X1, Y1, Width: Single; r, g, b, a: Byte);
var VertexBuffer: array [0..1] of TVertex2f;
begin
+ glEnable(GL_LINE_SMOOTH);
+{$IFNDEF GL2}
glDisable(GL_TEXTURE_2D);
- glEnable(GL_LINE_SMOOTH);
glPushMatrix;
glTranslatef(WorldDx, WorldDy, 0);
@@ -375,13 +456,37 @@
VertexBuffer[1].X:= X1;
VertexBuffer[1].Y:= Y1;
- glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]);
+ SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer));
glDrawArrays(GL_LINES, 0, Length(VertexBuffer));
untint;
-
+
glPopMatrix;
-
+
glEnable(GL_TEXTURE_2D);
+
+{$ELSE}
+ EnableTexture(False);
+
+ hglPushMatrix;
+ hglTranslatef(WorldDx, WorldDy, 0);
+ glLineWidth(Width);
+
+ UpdateModelviewProjection;
+
+ Tint(r, g, b, a);
+ VertexBuffer[0].X:= X0;
+ VertexBuffer[0].Y:= Y0;
+ VertexBuffer[1].X:= X1;
+ VertexBuffer[1].Y:= Y1;
+
+ SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer));
+ glDrawArrays(GL_LINES, 0, Length(VertexBuffer));
+ Tint($FF, $FF, $FF, $FF);
+
+ hglPopMatrix;
+ EnableTexture(True);
+
+{$ENDIF}
glDisable(GL_LINE_SMOOTH);
end;
@@ -389,12 +494,17 @@
var VertexBuffer: array [0..3] of TVertex2f;
begin
// do not draw anything outside the visible screen space (first check fixes some sprite drawing, e.g. hedgehogs)
+
if (abs(r.x) > r.w) and ((abs(r.x + r.w / 2) - r.w / 2) * cScaleFactor > cScreenWidth) then
exit;
if (abs(r.y) > r.h) and ((abs(r.y + r.h / 2 - (0.5 * cScreenHeight)) - r.h / 2) * cScaleFactor > cScreenHeight) then
exit;
+{$IFDEF GL2}
+EnableTexture(False);
+{$ELSE}
glDisable(GL_TEXTURE_2D);
+{$ENDIF}
Tint($00, $00, $00, $80);
@@ -407,21 +517,26 @@
VertexBuffer[3].X:= r.x;
VertexBuffer[3].Y:= r.y + r.h;
-glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]);
+SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer));
glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer));
untint;
+{$IFDEF GL2}
+EnableTexture(True);
+{$ELSE}
glEnable(GL_TEXTURE_2D)
+{$ENDIF}
+
end;
-procedure DrawCircle(X, Y, Radius, Width: LongInt; r, g, b, a: Byte);
+procedure DrawCircle(X, Y, Radius, Width: LongInt; r, g, b, a: Byte);
begin
Tint(r, g, b, a);
- DrawCircle(X, Y, Radius, Width);
+ DrawCircle(X, Y, Radius, Width);
untint;
end;
-procedure DrawCircle(X, Y, Radius, Width: LongInt);
+procedure DrawCircle(X, Y, Radius, Width: LongInt);
var
i: LongInt;
CircleVertex: array [0..59] of TVertex2f;
@@ -430,6 +545,9 @@
CircleVertex[i].X := X + Radius*cos(i*pi/30);
CircleVertex[i].Y := Y + Radius*sin(i*pi/30);
end;
+
+{$IFNDEF GL2}
+
glDisable(GL_TEXTURE_2D);
glEnable(GL_LINE_SMOOTH);
glPushMatrix;
@@ -439,6 +557,18 @@
glPopMatrix;
glEnable(GL_TEXTURE_2D);
glDisable(GL_LINE_SMOOTH);
+
+{$ELSE}
+ EnableTexture(False);
+ glEnable(GL_LINE_SMOOTH);
+ hglPushMatrix;
+ glLineWidth(Width);
+ SetVertexPointer(@CircleVertex[0], 60);
+ glDrawArrays(GL_LINE_LOOP, 0, 60);
+ hglPopMatrix;
+ EnableTexture(True);
+ glDisable(GL_LINE_SMOOTH);
+{$ENDIF}
end;
@@ -471,10 +601,15 @@
r:= (Step + 1) * 32 / HHTexture^.w
end;
-
+{$IFDEF GL2}
+ hglPushMatrix();
+ hglTranslatef(X, Y, 0);
+ hglRotatef(Angle, 0, 0, 1);
+{$ELSE}
glPushMatrix();
glTranslatef(X, Y, 0);
glRotatef(Angle, 0, 0, 1);
+{$ENDIF}
glBindTexture(GL_TEXTURE_2D, HHTexture^.id);
@@ -487,11 +622,20 @@
TextureBuffer[3].X:= l;
TextureBuffer[3].Y:= b;
- glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]);
- glTexCoordPointer(2, GL_FLOAT, 0, @TextureBuffer[0]);
+ SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer));
+ SetTexCoordPointer(@TextureBuffer[0], Length(VertexBuffer));
+
+{$IFDEF GL2}
+ UpdateModelviewProjection;
+{$ENDIF}
+
glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer));
- glPopMatrix
+{$IFDEF GL2}
+ hglPopMatrix;
+{$ELSE}
+ glPopMatrix;
+{$ENDIF}
end;
procedure DrawScreenWidget(widget: POnScreenWidget);
@@ -505,9 +649,9 @@
if RealTicks > (fadeAnimStart + FADE_ANIM_TIME) then
fadeAnimStart:= 0
else
- if show then
+ if show then
alpha:= Byte(trunc((RealTicks - fadeAnimStart)/FADE_ANIM_TIME * $FF))
- else
+ else
alpha:= Byte($FF - trunc((RealTicks - fadeAnimStart)/FADE_ANIM_TIME * $FF));
end;
@@ -542,7 +686,11 @@
end;
procedure Tint(r, g, b, a: Byte); inline;
-var nc, tw: Longword;
+var
+ nc, tw: Longword;
+ {$IFDEF GL2}
+ scale:Real = 1.0/255.0;
+ {$ENDIF}
begin
nc:= (r shl 24) or (g shl 16) or (b shl 8) or a;
@@ -559,7 +707,12 @@
b:= tw
end;
+ {$IFDEF GL2}
+ glUniform4f(uMainTintLocation, r*scale, g*scale, b*scale, a*scale);
+ //glColor4ub(r, g, b, a);
+ {$ELSE}
glColor4ub(r, g, b, a);
+ {$ENDIF}
lastTint:= nc;
end;
--- a/hedgewars/uRenderUtils.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uRenderUtils.pas Tue Jan 21 22:38:13 2014 +0100
@@ -68,7 +68,7 @@
r.y:= rect^.y + 2;
r.w:= rect^.w - 2;
r.h:= rect^.h - 4;
- SDL_FillRect(Surface, @r, FillColor)
+ SDL_FillRect(Surface, @r, FillColor);
end;
(*
function WriteInRoundRect(Surface: PSDL_Surface; X, Y: LongInt; Color: LongWord; Font: THWFont; s: ansistring): TSDL_Rect;
@@ -115,6 +115,7 @@
pixels: PLongWordArray;
begin
TryDo(Surface^.format^.BytesPerPixel = 4, 'flipSurface failed, expecting 32 bit surface', true);
+ SDL_LockSurface(Surface);
pixels:= Surface^.pixels;
if Vertical then
for y := 0 to (Surface^.h div 2) - 1 do
@@ -136,6 +137,7 @@
pixels^[i]:= pixels^[j];
pixels^[j]:= tmpPixel;
end;
+ SDL_UnlockSurface(Surface);
end;
procedure copyToXY(src, dest: PSDL_Surface; destX, destY: LongInt); inline;
@@ -150,6 +152,10 @@
begin
maxDest:= (dest^.pitch div 4) * dest^.h;
maxSrc:= (src^.pitch div 4) * src^.h;
+
+ SDL_LockSurface(src);
+ SDL_LockSurface(dest);
+
srcPixels:= src^.pixels;
destPixels:= dest^.pixels;
@@ -169,6 +175,9 @@
destPixels^[i]:= SDL_MapRGBA(dest^.format, r0, g0, b0, a0);
end;
end;
+
+ SDL_UnlockSurface(src);
+ SDL_UnlockSurface(dest);
end;
procedure DrawSprite2Surf(sprite: TSprite; dest: PSDL_Surface; x,y: LongInt); inline;
@@ -182,12 +191,12 @@
numFramesFirstCol:= SpritesData[sprite].imageHeight div SpritesData[sprite].Height;
row:= Frame mod numFramesFirstCol;
col:= Frame div numFramesFirstCol;
-
- copyToXYFromRect(SpritesData[sprite].Surface, dest,
- col*SpritesData[sprite].Width,
- row*SpritesData[sprite].Height,
- SpritesData[sprite].Width,
- spritesData[sprite].Height,
+
+ copyToXYFromRect(SpritesData[sprite].Surface, dest,
+ col*SpritesData[sprite].Width,
+ row*SpritesData[sprite].Height,
+ SpritesData[sprite].Width,
+ spritesData[sprite].Height,
x,y);
end;
@@ -199,13 +208,16 @@
begin
//max:= (dest^.pitch div 4) * dest^.h;
yMax:= dest^.pitch div 4;
+
+ SDL_LockSurface(dest);
+
destPixels:= dest^.pixels;
dx:= abs(x1-x0);
dy:= abs(y1-y0);
if x0 < x1 then sx:= 1 else sx:= -1;
if y0 < y1 then sy:= 1 else sy:= -1;
- err:= dx-dy;
+ err:= dx-dy;
while(true) do
begin
@@ -225,7 +237,8 @@
err:= err + dx;
y0:=y0+sy
end;
- end;
+ end;
+ SDL_UnlockSurface(dest);
end;
procedure copyRotatedSurface(src, dest: PSDL_Surface); // this is necessary since width/height are read only in SDL, apparently
@@ -235,6 +248,9 @@
TryDo(src^.format^.BytesPerPixel = 4, 'rotateSurface failed, expecting 32 bit surface', true);
TryDo(dest^.format^.BytesPerPixel = 4, 'rotateSurface failed, expecting 32 bit surface', true);
+ SDL_LockSurface(src);
+ SDL_LockSurface(dest);
+
srcPixels:= src^.pixels;
destPixels:= dest^.pixels;
@@ -246,6 +262,10 @@
destPixels^[j]:= srcPixels^[i];
inc(j)
end;
+
+ SDL_UnlockSurface(src);
+ SDL_UnlockSurface(dest);
+
end;
function RenderStringTex(s: ansistring; Color: Longword; font: THWFont): PTexture;
@@ -282,11 +302,11 @@
var textWidth, textHeight, x, y, w, h, i, j, pos, prevpos, line, numLines, edgeWidth, edgeHeight, cornerWidth, cornerHeight: LongInt;
finalSurface, tmpsurf, rotatedEdge: PSDL_Surface;
rect: TSDL_Rect;
- chars: set of char = [#9,' ',';',':','?','!',','];
+ //chars: set of char = [#9,' ',';',':','?','!',','];
substr: shortstring;
edge, corner, tail: TSPrite;
begin
- case SpeechType of
+ case SpeechType of
1: begin;
edge:= sprSpeechEdge;
corner:= sprSpeechCorner;
@@ -463,6 +483,7 @@
SDL_FreeSurface(rotatedEdge);
SDL_FreeSurface(finalSurface);
+
end;
end.
--- a/hedgewars/uScript.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uScript.pas Tue Jan 21 22:38:13 2014 +0100
@@ -85,8 +85,12 @@
uIO,
uVisualGearsList,
uGearsHandlersMess,
- uPhysFSLayer,
- typinfo
+ uPhysFSLayer
+{$IFDEF PAS2C}
+ , hwpacksmounter
+{$ELSE}
+ , typinfo
+{$ENDIF}
;
var luaState : Plua_State;
@@ -155,7 +159,7 @@
lua_pushnil(L);
end
else
- lua_pushinteger(L, not lua_tointeger(L, 1));
+ lua_pushinteger(L, (not lua_tointeger(L, 1)));
lc_bnot := 1;
end;
@@ -251,7 +255,7 @@
var i : integer;
begin
for i:= 1 to lua_gettop(L) do
- GameFlags := GameFlags and not(LongWord(lua_tointeger(L, i)));
+ GameFlags := (GameFlags and (not (LongWord(lua_tointeger(L, i)))));
ScriptSetInteger('GameFlags', GameFlags);
lc_disablegameflags:= 0;
end;
@@ -1172,7 +1176,7 @@
RecountTeamHealth(gear^.Hedgehog^.Team)
end;
// Why did this do a "setalltoactive" ?
- //SetAllToActive;
+ //SetAllToActive;
Gear^.Active:= true;
AllInactive:= false
end
@@ -2241,7 +2245,7 @@
procedure ScriptCall(fname : shortstring);
begin
-if not ScriptLoaded or (not ScriptExists(fname)) then
+if (not ScriptLoaded) or (not ScriptExists(fname)) then
exit;
SetGlobals;
lua_getglobal(luaState, Str2PChar(fname));
@@ -2292,7 +2296,7 @@
function ScriptCall(fname : shortstring; par1, par2, par3, par4 : LongInt) : LongInt;
begin
-if not ScriptLoaded or (not ScriptExists(fname)) then
+if (not ScriptLoaded) or (not ScriptExists(fname)) then
exit;
SetGlobals;
lua_getglobal(luaState, Str2PChar(fname));
--- a/hedgewars/uSound.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uSound.pas Tue Jan 21 22:38:13 2014 +0100
@@ -315,7 +315,7 @@
WriteLnToConsole(msgOK);
Mix_AllocateChannels(Succ(chanTPU));
- ChangeVolume(cInitVolume);
+ ChangeVolume(cInitVolume);
end;
procedure ResetSound;
@@ -452,7 +452,7 @@
i:= 0;
while (i<High(VoiceList)) and (VoiceList[i].snd = sndNone) do
inc(i);
-
+
if (VoiceList[i].snd <> sndNone) then
begin
LastVoice.snd:= VoiceList[i].snd;
--- a/hedgewars/uStats.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uStats.pas Tue Jan 21 22:38:13 2014 +0100
@@ -25,7 +25,7 @@
var TotalRounds: LongInt;
FinishedTurnsTotal: LongInt;
SendHealthStatsOn : boolean = true;
-
+
procedure initModule;
procedure freeModule;
@@ -111,7 +111,7 @@
else if CurrentHedgehog^.stats.StepDamageRecv > 0 then
begin
AddVoice(sndStupid, PreviousTeam^.voicepack);
- if CurrentHedgehog^.stats.DamageGiven = CurrentHedgehog^.stats.StepDamageRecv then
+ if CurrentHedgehog^.stats.DamageGiven = CurrentHedgehog^.stats.StepDamageRecv then
AddCaption(Format(GetEventString(eidHurtSelf), CurrentHedgehog^.Name), cWhiteColor, capgrpMessage);
end
@@ -164,7 +164,7 @@
StepDamageRecv:= 0;
StepDamageGiven:= 0
end;
-
+
if SendHealthStatsOn then
for t:= 0 to Pred(ClansCount) do
with ClansArray[t]^ do
@@ -298,7 +298,7 @@
SendStat(siKilledHHs, IntToStr(KilledHHs));
// now to console
- if winnersClan <> nil then
+ if winnersClan <> nil then
begin
WriteLnToConsole('WINNERS');
WriteLnToConsole(inttostr(winnersClan^.TeamsNumber));
@@ -307,12 +307,12 @@
end
else
WriteLnToConsole('DRAW');
-
+
ScriptCall('onAchievementsDeclaration');
end;
procedure declareAchievement(id, teamname, location: shortstring; value: LongInt);
-begin
+begin
if (length(id) = 0) or (length(teamname) = 0) or (length(location) = 0) then exit;
WriteLnToConsole('ACHIEVEMENT');
WriteLnToConsole(id);
--- a/hedgewars/uStore.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uStore.pas Tue Jan 21 22:38:13 2014 +0100
@@ -21,7 +21,7 @@
unit uStore;
interface
-uses StrUtils, SysUtils, uConsts, SDLh, GLunit, uTypes, uLandTexture, uCaptions, uChat;
+uses {$IFNDEF PAS2C} StrUtils, {$ENDIF}SysUtils, uConsts, SDLh, GLunit, uTypes, uLandTexture, uCaptions, uChat;
procedure initModule;
procedure freeModule;
@@ -59,15 +59,24 @@
procedure SwapBuffers; {$IFDEF USE_VIDEO_RECORDING}cdecl{$ELSE}inline{$ENDIF};
procedure SetSkyColor(r, g, b: real);
+{$IFDEF GL2}
+procedure UpdateModelviewProjection;
+procedure EnableTexture(enable:Boolean);
+{$ENDIF}
+
+procedure SetTexCoordPointer(p: Pointer;n: Integer);
+procedure SetVertexPointer(p: Pointer;n: Integer);
+procedure SetColorPointer(p: Pointer;n: Integer);
+procedure BeginWater;
+procedure EndWater;
+
implementation
-uses uMisc, uConsole, uVariables, uUtils, uTextures, uRender, uRenderUtils, uCommands
- , uPhysFSLayer
- , uDebug
+uses uMisc, uConsole, uVariables, uUtils, uTextures, uRender, uRenderUtils,
+ uCommands, uPhysFSLayer, uDebug
+ {$IFDEF GL2}, uMatrix{$ENDIF}
{$IFDEF USE_CONTEXT_RESTORE}, uWorld{$ENDIF}
{$IF NOT DEFINED(SDL2) AND DEFINED(USE_VIDEO_RECORDING)}, glut {$ENDIF};
-//type TGPUVendor = (gvUnknown, gvNVIDIA, gvATI, gvIntel, gvApple);
-
var MaxTextureSize: LongInt;
{$IFDEF SDL2}
SDLwindow: PSDL_Window;
@@ -79,6 +88,13 @@
numsquares : LongInt;
ProgrTex: PTexture;
+{$IFDEF GL2}
+ shaderMain: GLuint;
+ shaderWater: GLuint;
+
+ // attributes
+{$ENDIF}
+
const
cHHFileName = 'Hedgehog';
cCHFileName = 'Crosshair';
@@ -159,7 +175,13 @@
r.x:= 0;
r.y:= 0;
drY:= - 4;
+{$IFNDEF PAS2C}
DecodeDate(Date, year, month, md);
+{$ELSE}
+year:= 0;
+month:= 0;
+md:= 0;
+{$ENDIF}
for t:= 0 to Pred(TeamsCount) do
with TeamsArray[t]^ do
begin
@@ -249,7 +271,7 @@
else if (month = 10) and (md = 31) then
Hat := 'fr_pumpkin'; // Halloween/Hedgewars' birthday
end;
-
+
if Hat <> 'NoHat' then
begin
if (Length(Hat) > 39) and (Copy(Hat,1,8) = 'Reserved') and (Copy(Hat,9,32) = PlayerHash) then
@@ -450,8 +472,10 @@
if not reload then
AddProgress;
IMG_Quit();
+
end;
+{$IFNDEF PAS2C}
{$IF DEFINED(USE_S3D_RENDERING) OR DEFINED(USE_VIDEO_RECORDING)}
procedure CreateFramebuffer(var frame, depth, tex: GLuint);
begin
@@ -476,6 +500,7 @@
glDeleteFramebuffersEXT(1, @frame);
end;
{$ENDIF}
+{$ENDIF}
procedure StoreRelease(reload: boolean);
var ii: TSprite;
@@ -539,6 +564,7 @@
end;
end;
end;
+{$IFNDEF PAS2C}
{$IFDEF USE_VIDEO_RECORDING}
if defaultFrame <> 0 then
DeleteFramebuffer(defaultFrame, depthv, texv);
@@ -550,6 +576,7 @@
DeleteFramebuffer(framer, depthr, texr);
end
{$ENDIF}
+{$ENDIF}
end;
@@ -667,6 +694,8 @@
function glLoadExtension(extension : shortstring) : boolean;
begin
+//TODO: pas2c does not handle {$IF (GLunit = gles11) OR DEFINED(PAS2C)}
+{$IFNDEF PAS2C}
{$IF GLunit = gles11}
// FreePascal doesnt come with OpenGL ES 1.1 Extension headers
extension:= extension; // avoid hint
@@ -679,6 +708,7 @@
else
AddFileLog('OpenGL - "' + extension + '" failed to load');
{$ENDIF}
+{$ENDIF}
end;
procedure SetupOpenGLAttributes;
@@ -701,6 +731,112 @@
SDL_GL_SetAttribute(SDL_GL_ACCELERATED_VISUAL, 1); // prefer hw rendering
end;
+{$IFDEF GL2}
+function CompileShader(shaderFile: string; shaderType: GLenum): GLuint;
+var
+ shader: GLuint;
+ f: Textfile;
+ source, line: AnsiString;
+ sourceA: Pchar;
+ lengthA: GLint;
+ compileResult: GLint;
+ logLength: GLint;
+ log: PChar;
+begin
+ Assign(f, PathPrefix + cPathz[ptShaders] + '/' + shaderFile);
+ filemode:= 0; // readonly
+ Reset(f);
+ if IOResult <> 0 then
+ begin
+ AddFileLog('Unable to load ' + shaderFile);
+ halt(-1);
+ end;
+
+ source:='';
+ while not eof(f) do
+ begin
+ ReadLn(f, line);
+ source:= source + line + #10;
+ end;
+
+ Close(f);
+
+ WriteLnToConsole('Compiling shader: ' + PathPrefix + cPathz[ptShaders] + '/' + shaderFile);
+
+ sourceA:=PChar(source);
+ lengthA:=Length(source);
+
+ shader:=glCreateShader(shaderType);
+ glShaderSource(shader, 1, @sourceA, @lengthA);
+ glCompileShader(shader);
+ glGetShaderiv(shader, GL_COMPILE_STATUS, @compileResult);
+ glGetShaderiv(shader, GL_INFO_LOG_LENGTH, @logLength);
+
+ if logLength > 1 then
+ begin
+ log := GetMem(logLength);
+ glGetShaderInfoLog(shader, logLength, nil, log);
+ WriteLnToConsole('========== Compiler log ==========');
+ WriteLnToConsole(shortstring(log));
+ WriteLnToConsole('===================================');
+ FreeMem(log, logLength);
+ end;
+
+ if compileResult <> GL_TRUE then
+ begin
+ WriteLnToConsole('Shader compilation failed, halting');
+ halt(-1);
+ end;
+
+ CompileShader:= shader;
+end;
+
+function CompileProgram(shaderName: string): GLuint;
+var
+ program_: GLuint;
+ vs, fs: GLuint;
+ linkResult: GLint;
+ logLength: GLint;
+ log: PChar;
+begin
+ program_:= glCreateProgram();
+ vs:= CompileShader(shaderName + '.vs', GL_VERTEX_SHADER);
+ fs:= CompileShader(shaderName + '.fs', GL_FRAGMENT_SHADER);
+ glAttachShader(program_, vs);
+ glAttachShader(program_, fs);
+
+ glBindAttribLocation(program_, aVertex, PChar('vertex'));
+ glBindAttribLocation(program_, aTexCoord, PChar('texcoord'));
+ glBindAttribLocation(program_, aColor, PChar('color'));
+
+ glLinkProgram(program_);
+ glDeleteShader(vs);
+ glDeleteShader(fs);
+
+ glGetProgramiv(program_, GL_LINK_STATUS, @linkResult);
+ glGetProgramiv(program_, GL_INFO_LOG_LENGTH, @logLength);
+
+ if logLength > 1 then
+ begin
+ log := GetMem(logLength);
+ glGetProgramInfoLog(program_, logLength, nil, log);
+ WriteLnToConsole('========== Compiler log ==========');
+ WriteLnToConsole(shortstring(log));
+ WriteLnToConsole('===================================');
+ FreeMem(log, logLength);
+ end;
+
+ if linkResult <> GL_TRUE then
+ begin
+ WriteLnToConsole('Linking program failed, halting');
+ halt(-1);
+ end;
+
+ CompileProgram:= program_;
+end;
+
+{$ENDIF}
+
procedure SetupOpenGL;
var buf: array[byte] of char;
AuxBufNum: LongInt = 0;
@@ -708,6 +844,7 @@
tmpint: LongInt;
tmpn: LongInt;
begin
+
{$IFDEF SDL2}
AddFileLog('Setting up OpenGL (using driver: ' + shortstring(SDL_GetCurrentVideoDriver()) + ')');
{$ELSE}
@@ -740,8 +877,8 @@
cReducedQuality := cReducedQuality or rqNoBackground;
AddFileLog('Texture size too small for backgrounds, disabling.');
end;
-
// everyone loves debugging
+ // find out which gpu we are using (for extension compatibility maybe?)
AddFileLog('OpenGL-- Renderer: ' + shortstring(pchar(glGetString(GL_RENDERER))));
AddFileLog(' |----- Vendor: ' + shortstring(pchar(glGetString(GL_VENDOR))));
AddFileLog(' |----- Version: ' + shortstring(pchar(glGetString(GL_VERSION))));
@@ -750,6 +887,7 @@
glGetIntegerv(GL_AUX_BUFFERS, @AuxBufNum);
AddFileLog(' |----- Number of auxiliary buffers: ' + inttostr(AuxBufNum));
{$ENDIF}
+{$IFNDEF PAS2C}
AddFileLog(' \----- Extensions: ');
// fetch extentions and store them in string
@@ -769,6 +907,7 @@
tmpint := tmpint + 3;
end;
until (tmpint > tmpn);
+{$ENDIF}
AddFileLog('');
defaultFrame:= 0;
@@ -796,8 +935,42 @@
end;
{$ENDIF}
-{$IFDEF USE_S3D_RENDERING}
- if (cStereoMode = smHorizontal) or (cStereoMode = smVertical) then
+{$IFDEF GL2}
+
+{$IFDEF PAS2C}
+ err := glewInit();
+ if err <> GLEW_OK then
+ begin
+ WriteLnToConsole('Failed to initialize GLEW.');
+ halt;
+ end;
+{$ENDIF}
+
+{$IFNDEF PAS2C}
+ if not Load_GL_VERSION_2_0 then
+ halt;
+{$ENDIF}
+
+ shaderWater:= CompileProgram('water');
+ glUseProgram(shaderWater);
+ glUniform1i(glGetUniformLocation(shaderWater, pchar('tex0')), 0);
+ uWaterMVPLocation:= glGetUniformLocation(shaderWater, pchar('mvp'));
+
+ shaderMain:= CompileProgram('default');
+ glUseProgram(shaderMain);
+ glUniform1i(glGetUniformLocation(shaderMain, pchar('tex0')), 0);
+ uMainMVPLocation:= glGetUniformLocation(shaderMain, pchar('mvp'));
+ uMainTintLocation:= glGetUniformLocation(shaderMain, pchar('tint'));
+
+ uCurrentMVPLocation:= uMainMVPLocation;
+
+ Tint(255, 255, 255, 255);
+ UpdateModelviewProjection;
+{$ENDIF}
+
+{$IFNDEF PAS2C}
+{$IFNDEF USE_S3D_RENDERING}
+ if (cStereoMode = smHorizontal) or (cStereoMode = smVertical) or (cStereoMode = smAFR) then
begin
// prepare left and right frame buffers and associated textures
if glLoadExtension('GL_EXT_framebuffer_object') then
@@ -812,19 +985,33 @@
cStereoMode:= smNone;
end;
{$ENDIF}
+{$ENDIF}
- // set view port to whole window
- glViewport(0, 0, cScreenWidth, cScreenHeight);
+// set view port to whole window
+glViewport(0, 0, cScreenWidth, cScreenHeight);
+{$IFDEF GL2}
+ uMatrix.initModule;
+ hglMatrixMode(MATRIX_MODELVIEW);
+ // prepare default translation/scaling
+ hglLoadIdentity();
+ hglScalef(2.0 / cScreenWidth, -2.0 / cScreenHeight, 1.0);
+ hglTranslatef(0, -cScreenHeight / 2, 0);
+
+ EnableTexture(True);
+
+ glEnableVertexAttribArray(aVertex);
+ glEnableVertexAttribArray(aTexCoord);
+ glGenBuffers(1, @vBuffer);
+ glGenBuffers(1, @tBuffer);
+ glGenBuffers(1, @cBuffer);
+{$ELSE}
glMatrixMode(GL_MODELVIEW);
// prepare default translation/scaling
glLoadIdentity();
glScalef(2.0 / cScreenWidth, -2.0 / cScreenHeight, 1.0);
glTranslatef(0, -cScreenHeight / 2, 0);
- // enable alpha blending
- glEnable(GL_BLEND);
- glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
// disable/lower perspective correction (will not need it anyway)
glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_FASTEST);
// disable dithering
@@ -833,8 +1020,97 @@
glEnable(GL_TEXTURE_2D);
glEnableClientState(GL_VERTEX_ARRAY);
glEnableClientState(GL_TEXTURE_COORD_ARRAY);
+{$ENDIF}
+
+ // enable alpha blending
+ glEnable(GL_BLEND);
+ glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
+ // disable/lower perspective correction (will not need it anyway)
end;
+{$IFDEF GL2}
+procedure EnableTexture(enable:Boolean);
+begin
+ if enable then
+ glUniform1i(glGetUniformLocation(shaderMain, pchar('enableTexture')), 1)
+ else
+ glUniform1i(glGetUniformLocation(shaderMain, pchar('enableTexture')), 0);
+end;
+{$ENDIF}
+
+procedure SetTexCoordPointer(p: Pointer; n: Integer);
+begin
+{$IFDEF GL2}
+ glBindBuffer(GL_ARRAY_BUFFER, tBuffer);
+ glBufferData(GL_ARRAY_BUFFER, sizeof(GLfloat) * n * 2, p, GL_STATIC_DRAW);
+ glEnableVertexAttribArray(aTexCoord);
+ glVertexAttribPointer(aTexCoord, 2, GL_FLOAT, GL_FALSE, 0, pointer(0));
+{$ELSE}
+ n:= n;
+ glTexCoordPointer(2, GL_FLOAT, 0, p);
+{$ENDIF}
+end;
+
+procedure SetVertexPointer(p: Pointer; n: Integer);
+begin
+{$IFDEF GL2}
+ glBindBuffer(GL_ARRAY_BUFFER, vBuffer);
+ glBufferData(GL_ARRAY_BUFFER, sizeof(GLfloat) * n * 2, p, GL_STATIC_DRAW);
+ glEnableVertexAttribArray(aVertex);
+ glVertexAttribPointer(aVertex, 2, GL_FLOAT, GL_FALSE, 0, pointer(0));
+{$ELSE}
+ n:= n;
+ glVertexPointer(2, GL_FLOAT, 0, p);
+{$ENDIF}
+end;
+
+procedure SetColorPointer(p: Pointer; n: Integer);
+begin
+{$IFDEF GL2}
+ glBindBuffer(GL_ARRAY_BUFFER, cBuffer);
+ glBufferData(GL_ARRAY_BUFFER, n * 4, p, GL_STATIC_DRAW);
+ glEnableVertexAttribArray(aColor);
+ glVertexAttribPointer(aColor, 4, GL_UNSIGNED_BYTE, GL_TRUE, 0, pointer(0));
+{$ELSE}
+ n:= n;
+ glColorPointer(4, GL_UNSIGNED_BYTE, 0, p);
+{$ENDIF}
+end;
+
+{$IFDEF GL2}
+procedure UpdateModelviewProjection;
+var
+ mvp: TMatrix4x4f;
+begin
+ //MatrixMultiply(mvp, mProjection, mModelview);
+{$HINTS OFF}
+ hglMVP(mvp);
+{$HINTS ON}
+ glUniformMatrix4fv(uCurrentMVPLocation, 1, GL_FALSE, @mvp[0, 0]);
+end;
+{$ENDIF}
+
+(*
+procedure UpdateProjection;
+var
+ s: GLfloat;
+begin
+ s:=cScaleFactor;
+ mProjection[0,0]:= s/cScreenWidth; mProjection[0,1]:= 0.0; mProjection[0,2]:=0.0; mProjection[0,3]:= 0.0;
+ mProjection[1,0]:= 0.0; mProjection[1,1]:= -s/cScreenHeight; mProjection[1,2]:=0.0; mProjection[1,3]:= 0.0;
+ mProjection[2,0]:= 0.0; mProjection[2,1]:= 0.0; mProjection[2,2]:=1.0; mProjection[2,3]:= 0.0;
+ mProjection[3,0]:= cStereoDepth; mProjection[3,1]:= s/2; mProjection[3,2]:=0.0; mProjection[3,3]:= 1.0;
+
+{$IFDEF GL2}
+ UpdateModelviewProjection;
+{$ELSE}
+ glMatrixMode(GL_PROJECTION);
+ glLoadMatrixf(@mProjection[0, 0]);
+ glMatrixMode(GL_MODELVIEW);
+{$ENDIF}
+end;
+*)
+
procedure SetScale(f: GLfloat);
begin
// leave immediately if scale factor did not change
@@ -842,18 +1118,62 @@
exit;
if f = cDefaultZoomLevel then
- glPopMatrix // return to default scaling
+{$IFDEF GL2}
+ hglPopMatrix // "return" to default scaling
+{$ELSE}
+ glPopMatrix
+{$ENDIF}
else // other scaling
begin
+{$IFDEF GL2}
+ hglPushMatrix; // save default scaling
+ hglLoadIdentity;
+ hglScalef(f / cScreenWidth, -f / cScreenHeight, 1.0);
+ hglTranslatef(0, -cScreenHeight / 2, 0);
+{$ELSE}
glPushMatrix; // save default scaling
glLoadIdentity;
glScalef(f / cScreenWidth, -f / cScreenHeight, 1.0);
glTranslatef(0, -cScreenHeight / 2, 0);
+{$ENDIF}
end;
cScaleFactor:= f;
+
+{$IFDEF GL2}
+ UpdateModelviewProjection;
+{$ENDIF}
end;
+procedure BeginWater;
+begin
+{$IFDEF GL2}
+ glUseProgram(shaderWater);
+ uCurrentMVPLocation:=uWaterMVPLocation;
+ UpdateModelviewProjection;
+ glDisableVertexAttribArray(aTexCoord);
+ glEnableVertexAttribArray(aColor);
+{$ELSE}
+ glDisableClientState(GL_TEXTURE_COORD_ARRAY);
+ glEnableClientState(GL_COLOR_ARRAY);
+{$ENDIF}
+end;
+
+procedure EndWater;
+begin
+{$IFDEF GL2}
+ glUseProgram(shaderMain);
+ uCurrentMVPLocation:=uMainMVPLocation;
+ UpdateModelviewProjection;
+ glDisableVertexAttribArray(aColor);
+ glEnableVertexAttribArray(aTexCoord);
+{$ELSE}
+ glDisableClientState(GL_COLOR_ARRAY);
+ glEnableClientState(GL_TEXTURE_COORD_ARRAY);
+{$ENDIF}
+end;
+
+
////////////////////////////////////////////////////////////////////////////////
procedure AddProgress;
var r: TSDL_Rect;
@@ -870,10 +1190,11 @@
squaresize:= texsurf^.w shr 1;
numsquares:= texsurf^.h div squaresize;
SDL_FreeSurface(texsurf);
+ {$IFNDEF PAS2C}
with mobileRecord do
if GameLoading <> nil then
GameLoading();
-
+ {$ENDIF}
end;
TryDo(ProgrTex <> nil, 'Error - Progress Texure is nil!', true);
@@ -891,14 +1212,17 @@
DrawTextureFromRect( -squaresize div 2, (cScreenHeight - squaresize) shr 1, @r, ProgrTex);
SwapBuffers;
+
inc(Step);
end;
procedure FinishProgress;
begin
+ {$IFNDEF PAS2C}
with mobileRecord do
if GameLoaded <> nil then
GameLoaded();
+ {$ENDIF}
WriteLnToConsole('Freeing progress surface... ');
FreeTexture(ProgrTex);
ProgrTex:= nil;
@@ -1244,6 +1568,7 @@
{$ENDIF}
SetupOpenGL();
+
if reinit then
begin
// clean the window from any previous content
@@ -1320,6 +1645,13 @@
procedure freeModule;
begin
+{$IFDEF GL2}
+ glDeleteProgram(shaderMain);
+ glDeleteProgram(shaderWater);
+ glDeleteBuffers(1, @vBuffer);
+ glDeleteBuffers(1, @tBuffer);
+ glDeleteBuffers(1, @cBuffer);
+{$ENDIF}
StoreRelease(false);
TTF_Quit();
{$IFDEF SDL2}
--- a/hedgewars/uTeams.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uTeams.pas Tue Jan 21 22:38:13 2014 +0100
@@ -20,7 +20,7 @@
unit uTeams;
interface
-uses uConsts, uInputHandler, uRandom, uFloat, uStats,
+uses uConsts, uInputHandler, uRandom, uFloat, uStats,
uCollisions, uSound, uStore, uTypes, uScript
{$IFDEF USE_TOUCH_INTERFACE}, uWorld{$ENDIF};
@@ -567,7 +567,10 @@
var i: LongInt;
begin
for i:= 1 to length(s) do
- if s[i] in ['\', '/', ':'] then s[i]:= '_';
+ if ((s[i] = '\') or
+ (s[i] = '/') or
+ (s[i] = ':')) then
+ s[i]:= '_';
s:= cPathz[ptTeams] + '/' + s + '.hwt';
@@ -593,7 +596,7 @@
CurrentTeam^.TeamName:= ts;
CurrentTeam^.PlayerHash:= s;
loadTeamBinds(ts);
-
+
if GameType in [gmtDemo, gmtSave, gmtRecord] then
CurrentTeam^.ExtDriven:= true;
--- a/hedgewars/uTouch.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uTouch.pas Tue Jan 21 22:38:13 2014 +0100
@@ -360,8 +360,9 @@
//Check array sizes
if length(fingers) < pointerCount then
begin
- setLength(fingers, pointerCount * 2);
- WriteLnToConsole('allocated ' + inttostr(length(fingers)) + ' finger elements');
+ setLength(fingers, length(fingers)*2);
+ for index := length(fingers) div 2 to length(fingers) do
+ fingers[index].id := nilFingerId;
end;
xCursor := convertToCursorX(x);
--- a/hedgewars/uTypes.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uTypes.pas Tue Jan 21 22:38:13 2014 +0100
@@ -43,8 +43,9 @@
// Different files are stored in different folders, this enumeration is used to tell which folder to use
TPathType = (ptNone, ptData, ptGraphics, ptThemes, ptCurrTheme, ptTeams, ptMaps,
- ptMapCurrent, ptDemos, ptSounds, ptGraves, ptFonts, ptForts,
- ptLocale, ptAmmoMenu, ptHedgehog, ptVoices, ptHats, ptFlags, ptMissionMaps, ptSuddenDeath, ptButtons);
+ ptMapCurrent, ptDemos, ptSounds, ptGraves, ptFonts, ptForts, ptLocale,
+ ptAmmoMenu, ptHedgehog, ptVoices, ptHats, ptFlags, ptMissionMaps,
+ ptSuddenDeath, ptButtons, ptShaders);
// Available sprites for displaying stuff
TSprite = (sprWater, sprCloud, sprBomb, sprBigDigit, sprFrame,
@@ -90,7 +91,7 @@
);
// Gears that interact with other Gears and/or Land
- TGearType = ({-->}gtFlame, gtHedgehog, gtMine, gtCase, gtExplosives, // <-- these are gears which should be avoided when searching a spawn place
+ TGearType = (gtFlame, gtHedgehog, gtMine, gtCase, gtExplosives, // these gears should be avoided when searching a spawn place
gtGrenade, gtShell, gtGrave, gtBee, // 8
gtShotgunShot, gtPickHammer, gtRope, // 11
gtDEagleShot, gtDynamite, gtClusterBomb, gtCluster, gtShover, // 16
@@ -138,9 +139,10 @@
sndHellishImpact1, sndHellishImpact2, sndHellishImpact3, sndHellishImpact4,
sndMelonImpact, sndDroplet1, sndDroplet2, sndDroplet3, sndEggBreak, sndDrillRocket,
sndPoisonCough, sndPoisonMoan, sndBirdyLay, sndWhistle, sndBeeWater,
- sndPiano0, sndPiano1, sndPiano2, sndPiano3, sndPiano4, sndPiano5, sndPiano6, sndPiano7, sndPiano8,
- sndSkip, sndSineGun, sndOoff1, sndOoff2, sndOoff3, sndWhack,
- sndComeonthen, sndParachute, sndBump, sndResurrector, sndPlane, sndTardis, sndFrozenHogImpact, sndIceBeam, sndHogFreeze
+ sndPiano0, sndPiano1, sndPiano2, sndPiano3, sndPiano4, sndPiano5, sndPiano6, sndPiano7,
+ sndPiano8, sndSkip, sndSineGun, sndOoff1, sndOoff2, sndOoff3, sndWhack,
+ sndComeonthen, sndParachute, sndBump, sndResurrector, sndPlane, sndTardis, sndFrozenHogImpact,
+ sndIceBeam, sndHogFreeze
);
// Available ammo types to be used by hedgehogs
@@ -167,7 +169,7 @@
siMaxTeamKills, siMaxTurnSkips, siCustomAchievement, siGraphTitle,
siPointType);
- // Various "emote" animations a hedgehog can do
+ // Various 'emote' animations a hedgehog can do
TWave = (waveRollup, waveSad, waveWave, waveHurrah, waveLemonade, waveShrug, waveJuggle);
TRenderMode = (rmDefault, rmLeftEye, rmRightEye);
@@ -186,8 +188,8 @@
TAmmo = record
Propz: LongWord;
Count: LongWord;
-(* Using for place hedgehogs mode, but for any other situation where the initial count would be needed I guess.
-For example, say, a mode where the weaponset is reset each turn, or on sudden death *)
+// Using for place hedgehogs mode, but for any other situation where the initial count would be needed I guess.
+// For example, say, a mode where the weaponset is reset each turn, or on sudden death
NumPerTurn: LongWord;
Timer: LongWord;
Pos: LongWord;
@@ -204,6 +206,8 @@
X, Y: GLint;
end;
+ TMatrix4x4f = array[0..3, 0..3] of GLfloat;
+
PTexture = ^TTexture;
TTexture = record
id: GLuint;
@@ -224,10 +228,10 @@
PClan = ^TClan;
TGearStepProcedure = procedure (Gear: PGear);
-// So, you're here looking for variables you can (ab)use to store some gear state?
+// So, you are here looking for variables you can (ab)use to store some gear state?
// Not all members of this structure are created equal. Comments below are my take on what can be used for what in the gear structure.
TGear = record
-// Don't ever override these.
+// Do *not* ever override these.
NextGear, PrevGear: PGear; // Linked list
Z: Longword; // Z index. For rendering. Sets order in list
Active: Boolean; // Is gear Active (running step code)
@@ -251,7 +255,7 @@
// Don't use these if you're using generic movement like doStepFallingGear and explosion shoves. Generally recommended not to use.
Radius: LongInt; // Radius. If not using uCollisions, is usually used to indicate area of effect
CollisionMask: Word; // Masking off Land impact FF7F for example ignores current hog and crates
- AdvBounce: Longword; // Triggers 45° bounces. Is a counter to avoid edge cases
+ AdvBounce: Longword; // Triggers 45 bounces. Is a counter to avoid edge cases
Elasticity: hwFloat;
Friction : hwFloat;
Density : hwFloat; // Density is kind of a mix of size and density. Impacts distance thrown, wind.
@@ -259,7 +263,7 @@
nImpactSounds: Word; // count of ImpactSounds.
// Don't use these if you want to take damage normally, otherwise health/damage are commonly used for other purposes
Health, Damage, Karma: LongInt;
-// DirAngle is a "real" - if you don't need it for rotation of sprite in uGearsRender, you can use it for any visual-only value
+// DirAngle is a 'real' - if you do not need it for rotation of sprite in uGearsRender, you can use it for any visual-only value
DirAngle: real;
// These are frequently overridden to serve some other purpose
Pos: Longword; // Commonly overridden. Example use is posCase values in uConsts.
@@ -268,8 +272,8 @@
Tag: LongInt; // Quite generic. Variety of uses.
FlightTime: Longword; // Initially added for batting of hogs to determine homerun. Used for some firing delays
MsgParam: LongWord; // Initially stored a set of messages. So usually gm values like Message. Frequently overriden
-// These are not used generically, but should probably be used for purpose intended. Definitely shouldn't override pointer type
- Tex: PTexture; // A texture created by the gear. Shouldn't use for anything but textures
+// These are not used generically, but should probably be used for purpose intended. Definitely should not override pointer type
+ Tex: PTexture; // A texture created by the gear. Should not use for anything but textures
LinkedGear: PGear; // Used to track a related gear. Portal pairs for example.
Hedgehog: PHedgehog; // set to CurrentHedgehog on gear creation
SoundChannel: LongInt; // Used to track a sound the gear started
@@ -415,6 +419,7 @@
cdeclPtr = procedure; cdecl;
cdeclIntPtr = procedure(num: LongInt); cdecl;
+ funcDoublePtr = function: Double;
TMobileRecord = record
PerformRumble: cdeclIntPtr;
@@ -454,10 +459,12 @@
gidRandomMineTimer, gidDamageModifier, gidResetHealth, gidAISurvival,
gidInfAttack, gidResetWeps, gidPerHogAmmo, gidTagTeam);
+
TLandArray = packed array of array of LongWord;
TCollisionArray = packed array of array of Word;
+ TDirtyTag = packed array of array of byte;
+
TPreview = packed array[0..127, 0..31] of byte;
- TDirtyTag = packed array of array of byte;
PWidgetMovement = ^TWidgetMovement;
TWidgetMovement = record
--- a/hedgewars/uUtils.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uUtils.pas Tue Jan 21 22:38:13 2014 +0100
@@ -25,7 +25,10 @@
procedure SplitBySpace(var a, b: shortstring);
procedure SplitByChar(var a, b: shortstring; c: char);
+
+{$IFNDEF PAS2C}
procedure SplitByChar(var a, b: ansistring; c: char);
+{$ENDIF}
function EnumToStr(const en : TGearType) : shortstring; overload;
function EnumToStr(const en : TVisualGearType) : shortstring; overload;
@@ -67,8 +70,10 @@
function GetLaunchX(at: TAmmoType; dir: LongInt; angle: LongInt): LongInt;
function GetLaunchY(at: TAmmoType; angle: LongInt): LongInt;
+{$IFNDEF PAS2C}
procedure Write(var f: textfile; s: shortstring);
procedure WriteLn(var f: textfile; s: shortstring);
+{$ENDIF}
function isPhone: Boolean; inline;
@@ -88,7 +93,7 @@
implementation
-uses typinfo, Math, uConsts, uVariables, SysUtils;
+uses {$IFNDEF PAS2C}typinfo, {$ENDIF}Math, uConsts, uVariables, SysUtils;
{$IFDEF DEBUGFILE}
var f: textfile;
@@ -96,7 +101,7 @@
logMutex: TRTLCriticalSection; // mutex for debug file
{$ENDIF}
{$ENDIF}
-var CharArray: array[byte] of Char;
+var CharArray: array[0..255] of Char;
procedure SplitBySpace(var a,b: shortstring);
begin
@@ -115,11 +120,15 @@
Inc(a[t], 32);
b:= copy(a, i + 1, Length(a) - i);
a[0]:= char(Pred(i))
+ {$IFDEF PAS2C}
+ a[i] := 0;
+ {$ENDIF}
end
else
b:= '';
end;
+{$IFNDEF PAS2C}
procedure SplitByChar(var a, b: ansistring; c: char);
var i: LongInt;
begin
@@ -129,7 +138,8 @@
b:= copy(a, i + 1, Length(a) - i);
setlength(a, Pred(i));
end else b:= '';
-end;
+end; { SplitByChar }
+{$ENDIF}
function EnumToStr(const en : TGearType) : shortstring; overload;
begin
@@ -189,14 +199,18 @@
str(n, IntToStr)
end;
-function StrToInt(s: shortstring): LongInt;
+function StrToInt(s: shortstring): LongInt;
var c: LongInt;
begin
+{$IFDEF PAS2C}
+val(s, StrToInt);
+{$ELSE}
val(s, StrToInt, c);
{$IFDEF DEBUGFILE}
if c <> 0 then
writeln(f, 'Error at position ' + IntToStr(c) + ' : ' + s[c])
{$ENDIF}
+{$ENDIF}
end;
function FloatToStr(n: hwFloat): shortstring;
@@ -290,10 +304,14 @@
function Str2PChar(const s: shortstring): PChar;
+var i :Integer ;
begin
-CharArray:= s;
+ for i:= 1 to Length(s) do
+ begin
+ CharArray[i - 1] := s[i];
+ end;
CharArray[Length(s)]:= #0;
-Str2PChar:= @CharArray
+ Str2PChar:= @(CharArray[0]);
end;
@@ -312,22 +330,26 @@
procedure AddFileLog(s: shortstring);
begin
-s:= s;
+// s:= s;
{$IFDEF DEBUGFILE}
+
{$IFDEF USE_VIDEO_RECORDING}
EnterCriticalSection(logMutex);
{$ENDIF}
writeln(f, inttostr(GameTicks) + ': ' + s);
flush(f);
+
{$IFDEF USE_VIDEO_RECORDING}
LeaveCriticalSection(logMutex);
{$ENDIF}
+
{$ENDIF}
end;
procedure AddFileLogRaw(s: pchar); cdecl;
begin
s:= s;
+{$IFNDEF PAS2C}
{$IFDEF DEBUGFILE}
{$IFDEF USE_VIDEO_RECORDING}
EnterCriticalSection(logMutex);
@@ -338,6 +360,7 @@
LeaveCriticalSection(logMutex);
{$ENDIF}
{$ENDIF}
+{$ENDIF}
end;
function CheckCJKFont(s: ansistring; font: THWFont): THWFont;
@@ -370,7 +393,7 @@
((#$F900 <= u) and (u <= #$FAFF)) or // CJK Compatibility Ideographs
((#$FE30 <= u) and (u <= #$FE4F)) or // CJK Compatibility Forms
((#$FF66 <= u) and (u <= #$FF9D))) // halfwidth katakana
- then
+ then
begin
CheckCJKFont:= THWFont( ord(font) + ((ord(High(THWFont))+1) div 2) );
exit;
@@ -408,6 +431,7 @@
CheckNoTeamOrHH:= (CurrentTeam = nil) or (CurrentHedgehog^.Gear = nil);
end;
+{$IFNDEF PAS2C}
procedure Write(var f: textfile; s: shortstring);
begin
system.write(f, s)
@@ -417,7 +441,7 @@
begin
system.writeln(f, s)
end;
-
+{$ENDIF}
// this function is just to determine whether we are running on a limited screen device
function isPhone: Boolean; inline;
@@ -444,7 +468,7 @@
r[i]:= '?'
else
r[i]:= s[i];
-
+
sanitizeForLog:= r
end;
@@ -454,8 +478,12 @@
if (c < #32) or (c > #127) then
r:= '#' + inttostr(byte(c))
else
- r:= c;
-
+ begin
+ // some magic for pas2c
+ r[0]:= #1;
+ r[1]:= c;
+ end;
+
sanitizeCharForLog:= r
end;
@@ -479,13 +507,16 @@
InitCriticalSection(logMutex);
{$ENDIF}
{$I-}
+{$IFNDEF PAS2C}
f:= stderr; // if everything fails, write to stderr
+{$ENDIF}
if (UserPathPrefix <> '') then
begin
+ {$IFNDEF PAS2C}
// create directory if it doesn't exist
if not FileExists(UserPathPrefix + '/Logs/') then
CreateDir(UserPathPrefix + '/Logs/');
-
+ {$ENDIF}
// if log is locked, write to the next one
i:= 0;
while(i < 7) do
--- a/hedgewars/uVariables.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uVariables.pas Tue Jan 21 22:38:13 2014 +0100
@@ -21,7 +21,7 @@
unit uVariables;
interface
-uses SDLh, uTypes, uFloat, GLunit, uConsts, Math;
+uses SDLh, uTypes, uFloat, GLunit, uConsts, Math, uUtils, uMatrix;
var
/////// init flags ///////
@@ -174,7 +174,7 @@
cArtillery : boolean;
WeaponTooltipTex: PTexture;
AmmoMenuInvalidated: boolean;
- AmmoRect : TSDL_Rect;
+ AmmoRect : TSDL_Rect;
HHTexture : PTexture;
cMaxZoomLevel : real;
cMinZoomLevel : real;
@@ -234,7 +234,7 @@
// these consts are here because they would cause circular dependencies in uConsts/uTypes
cPathz: array[TPathType] of shortstring = (
'', // ptNone
- '/', // ptData
+ '//', // ptData
'/Graphics', // ptGraphics
'/Themes', // ptThemes
'/Themes/Bamboo', // ptCurrTheme
@@ -254,9 +254,11 @@
'/Graphics/Flags', // ptFlags
'/Missions/Maps', // ptMissionMaps
'/Graphics/SuddenDeath', // ptSuddenDeath
- '/Graphics/Buttons' // ptButton
+ '/Graphics/Buttons', // ptButton
+ '/Shaders' // ptShaders
);
+var
Fontz: array[THWFont] of THHFont = (
(Handle: nil;
Height: 12;
@@ -718,7 +720,7 @@
TimeAfterTurn: Longword;
minAngle, maxAngle: Longword;
isDamaging: boolean;
- SkipTurns: Longword;
+ SkipTurns: LongWord;
PosCount: Longword;
PosSprite: TSprite;
ejectX, ejectY: Longint;
@@ -751,9 +753,9 @@
NameTex: nil;
Probability: 0;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_Timerable or
- ammoprop_Power or
- ammoprop_AltUse or
+ Ammo: (Propz: ammoprop_Timerable or
+ ammoprop_Power or
+ ammoprop_AltUse or
ammoprop_SetBounce or
ammoprop_NeedUpDown;
Count: AMMO_INFINITE;
@@ -779,9 +781,9 @@
NameTex: nil;
Probability: 100;
NumberInCase: 3;
- Ammo: (Propz: ammoprop_Timerable or
- ammoprop_Power or
- ammoprop_AltUse or
+ Ammo: (Propz: ammoprop_Timerable or
+ ammoprop_Power or
+ ammoprop_AltUse or
ammoprop_SetBounce or
ammoprop_NeedUpDown;
Count: 5;
@@ -807,7 +809,7 @@
NameTex: nil;
Probability: 0;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_Power or
+ Ammo: (Propz: ammoprop_Power or
ammoprop_AltUse or
ammoprop_NeedUpDown;
Count: AMMO_INFINITE;
@@ -833,8 +835,8 @@
NameTex: nil;
Probability: 100;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_Power or
- ammoprop_NeedTarget or
+ Ammo: (Propz: ammoprop_Power or
+ ammoprop_NeedTarget or
ammoprop_DontHold or
ammoprop_NeedUpDown;
Count: 2;
@@ -886,9 +888,9 @@
NameTex: nil;
Probability: 0;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_ForwMsgs or
- ammoprop_AttackInMove or
- ammoprop_NoCrosshair or
+ Ammo: (Propz: ammoprop_ForwMsgs or
+ ammoprop_AttackInMove or
+ ammoprop_NoCrosshair or
ammoprop_DontHold;
Count: 2;
NumPerTurn: 0;
@@ -969,10 +971,10 @@
NameTex: nil;
Probability: 100;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_NoCrosshair or
- ammoprop_AttackInMove or
- ammoprop_DontHold or
- ammoprop_AltUse or
+ Ammo: (Propz: ammoprop_NoCrosshair or
+ ammoprop_AttackInMove or
+ ammoprop_DontHold or
+ ammoprop_AltUse or
ammoprop_SetBounce;
Count: 2;
NumPerTurn: 0;
@@ -1021,9 +1023,9 @@
NameTex: nil;
Probability: 100;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_NoCrosshair or
- ammoprop_AttackInMove or
- ammoprop_DontHold or
+ Ammo: (Propz: ammoprop_NoCrosshair or
+ ammoprop_AttackInMove or
+ ammoprop_DontHold or
ammoprop_AltUse;
Count: 1;
NumPerTurn: 0;
@@ -1048,8 +1050,8 @@
NameTex: nil;
Probability: 0;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_NoCrosshair or
- ammoprop_ForwMsgs or
+ Ammo: (Propz: ammoprop_NoCrosshair or
+ ammoprop_ForwMsgs or
ammoprop_AttackInMove;
Count: AMMO_INFINITE;
NumPerTurn: 0;
@@ -1344,8 +1346,8 @@
NameTex: nil;
Probability: 100;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_ForwMsgs or
- ammoprop_DontHold or
+ Ammo: (Propz: ammoprop_ForwMsgs or
+ ammoprop_DontHold or
ammoprop_NeedUpDown or
ammoprop_AttackInMove;
Count: 1;
@@ -1371,8 +1373,8 @@
NameTex: nil;
Probability: 100;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_ForwMsgs or
- ammoprop_NoCrosshair or
+ Ammo: (Propz: ammoprop_ForwMsgs or
+ ammoprop_NoCrosshair or
ammoprop_DontHold or
ammoprop_Track;
Count: 1;
@@ -1398,7 +1400,7 @@
NameTex: nil;
Probability: 100;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_ForwMsgs or
+ Ammo: (Propz: ammoprop_ForwMsgs or
ammoprop_DontHold or
ammoprop_NoCrosshair;
Count: 1;
@@ -1424,8 +1426,8 @@
NameTex: nil;
Probability: 400;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_Timerable or
- ammoprop_Power or
+ Ammo: (Propz: ammoprop_Timerable or
+ ammoprop_Power or
ammoprop_NeedUpDown or
ammoprop_AltUse;
Count: 0;
@@ -1451,7 +1453,7 @@
NameTex: nil;
Probability: 400;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_Power or
+ Ammo: (Propz: ammoprop_Power or
ammoprop_NeedUpDown or
ammoprop_AltUse;
Count: 0;
@@ -1505,7 +1507,7 @@
NameTex: nil;
Probability: 300;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_Power or
+ Ammo: (Propz: ammoprop_Power or
ammoprop_NeedUpDown or
ammoprop_AltUse;
Count: AMMO_INFINITE;
@@ -1531,7 +1533,7 @@
NameTex: nil;
Probability: 400;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_ForwMsgs or
+ Ammo: (Propz: ammoprop_ForwMsgs or
ammoprop_NeedUpDown or
ammoprop_DontHold;
Count: AMMO_INFINITE;
@@ -1816,7 +1818,7 @@
NameTex: nil;
Probability: 0;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_Power or
+ Ammo: (Propz: ammoprop_Power or
ammoprop_NeedUpDown or
ammoprop_AltUse;
Count: AMMO_INFINITE;
@@ -1925,9 +1927,9 @@
NameTex: nil;
Probability: 0;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_Timerable or
- ammoprop_Power or
- ammoprop_AltUse or
+ Ammo: (Propz: ammoprop_Timerable or
+ ammoprop_Power or
+ ammoprop_AltUse or
ammoprop_NeedUpDown or
ammoprop_SetBounce;
Count: AMMO_INFINITE;
@@ -1978,7 +1980,7 @@
NameTex: nil;
Probability: 20;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_ForwMsgs or
+ Ammo: (Propz: ammoprop_ForwMsgs or
ammoprop_NeedUpDown or
ammoprop_DontHold;
Count: 1;
@@ -2109,7 +2111,7 @@
NameTex: nil;
Probability: 0;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_Power or
+ Ammo: (Propz: ammoprop_Power or
ammoprop_AltUse or
ammoprop_NoRoundEnd;
Count: 2;
@@ -2127,7 +2129,7 @@
SkipTurns: 0;
PosCount: 1;
PosSprite: sprWater;
- ejectX: 0;
+ ejectX: 0;
ejectY: 0),
// Tardis
@@ -2157,7 +2159,7 @@
ejectX: 0;
ejectY: 0),
-// Structure
+// Structure
{
(NameId: sidStructure;
NameTex: nil;
@@ -2185,7 +2187,7 @@
ejectX: 0;
ejectY: 0),
}
-
+
// Land Gun
(NameId: sidLandGun;
NameTex: nil;
@@ -2215,7 +2217,7 @@
NameTex: nil;
Probability: 20;
NumberInCase: 1;
- Ammo: (Propz: ammoprop_ForwMsgs or
+ Ammo: (Propz: ammoprop_ForwMsgs or
ammoprop_NeedUpDown or
ammoprop_DontHold;
Count: 1;
@@ -2342,6 +2344,7 @@
SyncTexture,
ConfirmTexture: PTexture;
cScaleFactor: GLfloat;
+ cStereoDepth: GLfloat;
SupportNPOTT: Boolean;
Step: LongInt;
MissionIcons: PSDL_Surface;
@@ -2365,13 +2368,29 @@
lastTurnChecksum : Longword;
- cTestLua : Boolean;
+ mModelview: TMatrix4x4f;
+ mProjection: TMatrix4x4f;
+ vBuffer: GLuint; // vertex buffer
+ tBuffer: GLuint; // texture coords buffer
+ cBuffer: GLuint; // color buffer
+
+ uCurrentMVPLocation: GLint;
+
+ uMainMVPLocation: GLint;
+ uMainTintLocation: GLint;
+
+ uWaterMVPLocation: GLint;
+
+ aVertex: GLint;
+ aTexCoord: GLint;
+ aColor: GLint;
var trammo: array[TAmmoStrId] of PChar; // name of the weapon
trammoc: array[TAmmoStrId] of PChar; // caption of the weapon
trammod: array[TAmmoStrId] of PChar; // description of the weapon
trmsg: array[TMsgStrId] of PChar; // message of the event
trgoal: array[TGoalStrId] of PChar; // message of the goal
+ cTestLua : Boolean;
procedure preInitModule;
procedure initModule;
@@ -2437,9 +2456,14 @@
trmsg[msid]:= nil;
for gsid:= Low(TGoalStrId) to High(TGoalStrId) do
trgoal[gsid]:= nil;
-
+
+// TODO: fixme
+{$IFDEF PAS2C}
+ cLocale:= 'en';
+{$ELSE}
// TODO: we could just have one cLocale variables and drop strutils
cLocale:= ExtractDelimited(1, cLocaleFName, StdWordDelims);
+{$ENDIF}
cFlattenFlakes := false;
cFlattenClouds := false;
@@ -2575,7 +2599,7 @@
cHasFocus := true;
cInactDelay := 100;
ReadyTimeLeft := 0;
-
+
disableLandBack := false;
ScreenFade := sfNone;
--- a/hedgewars/uVisualGears.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uVisualGears.pas Tue Jan 21 22:38:13 2014 +0100
@@ -219,7 +219,7 @@
else
DrawSprite(sprDroplet, round(Gear^.X) + WorldDx - 8, round(Gear^.Y) + WorldDy - 8, Gear^.Frame);
vgtBubble: DrawSprite(sprBubbles, round(Gear^.X) + WorldDx - 8, round(Gear^.Y) + WorldDy - 8, Gear^.Frame);//(RealTicks div 64 + Gear^.Frame) mod 8);
- vgtStraightShot: begin
+ vgtStraightShot: begin
if Gear^.dX < 0 then
i:= -1
else
@@ -264,9 +264,9 @@
DrawTextureCentered(round(Gear^.X) + WorldDx, round(Gear^.Y) + WorldDy, Gear^.Tex);
end;
vgtSmallDamageTag: DrawTextureCentered(round(Gear^.X) + WorldDx, round(Gear^.Y) + WorldDy, Gear^.Tex);
- vgtHealthTag: if Gear^.Tex <> nil then
+ vgtHealthTag: if Gear^.Tex <> nil then
begin
- if Gear^.Frame = 0 then
+ if Gear^.Frame = 0 then
DrawTextureCentered(round(Gear^.X) + WorldDx, round(Gear^.Y) + WorldDy, Gear^.Tex)
else
begin
@@ -274,11 +274,11 @@
if Gear^.Angle = 0 then
DrawTexture(round(Gear^.X), round(Gear^.Y), Gear^.Tex)
else
- DrawTexture(round(Gear^.X), round(Gear^.Y), Gear^.Tex, Gear^.Angle);
+ DrawTexture(round(Gear^.X), round(Gear^.Y), Gear^.Tex, Gear^.Angle);
SetScale(zoom)
end
end;
- vgtStraightShot: begin
+ vgtStraightShot: begin
if Gear^.dX < 0 then
i:= -1
else
--- a/hedgewars/uVisualGearsHandlers.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uVisualGearsHandlers.pas Tue Jan 21 22:38:13 2014 +0100
@@ -24,15 +24,15 @@
* => The usage of safe functions or data types (e.g. GetRandom() or hwFloat)
* is usually not necessary and therefore undesirable.
*)
-
-{$INCLUDE "options.inc"}
-
+
+{$INCLUDE "options.inc"}
+
unit uVisualGearsHandlers;
interface
uses uTypes;
-var doStepHandlers: array[TVisualGearType] of TVGearStepProcedure;
+var doStepVGHandlers: array[TVisualGearType] of TVGearStepProcedure;
procedure doStepFlake(Gear: PVisualGear; Steps: Longword);
procedure doStepBeeTrace(Gear: PVisualGear; Steps: Longword);
@@ -112,8 +112,8 @@
else
if Angle < - 360 then
Angle:= Angle + 360;
-
-
+
+
if (round(X) >= cLeftScreenBorder)
and (round(X) <= cRightScreenBorder)
and (round(Y) - 75 <= LAND_HEIGHT)
@@ -249,7 +249,9 @@
////////////////////////////////////////////////////////////////////////////////
procedure doStepLineTrail(Gear: PVisualGear; Steps: Longword);
begin
+{$IFNDEF PAS2C}
Steps := Steps;
+{$ENDIF}
if Gear^.Timer <= Steps then
DeleteVisualGear(Gear)
else
@@ -528,7 +530,9 @@
b: boolean;
t, h: LongInt;
begin
+{$IFNDEF PAS2C}
Steps:= Steps; // avoid compiler hint
+{$ENDIF}
for t:= 0 to Pred(TeamsCount) do
with thexchar[t] do
@@ -602,7 +606,10 @@
procedure doStepSpeechBubble(Gear: PVisualGear; Steps: Longword);
begin
+
+{$IFNDEF PAS2C}
Steps:= Steps; // avoid compiler hint
+{$ENDIF}
with Gear^.Hedgehog^ do
if SpeechGear <> nil then
@@ -708,10 +715,10 @@
begin
gX:= round(Gear^.X);
gY:= round(Gear^.Y);
-for i:= 0 to 31 do
+for i:= 0 to 31 do
begin
vg:= AddVisualGear(gX, gY, vgtFire);
- if vg <> nil then
+ if vg <> nil then
begin
vg^.State:= gstTmpFlag;
inc(vg^.FrameTicks, vg^.FrameTicks)
@@ -752,10 +759,10 @@
gX:= round(Gear^.X);
gY:= round(Gear^.Y);
AddVisualGear(gX, gY, vgtSmokeRing);
-for i:= 0 to 46 do
+for i:= 0 to 46 do
begin
vg:= AddVisualGear(gX, gY, vgtFire);
- if vg <> nil then
+ if vg <> nil then
begin
vg^.State:= gstTmpFlag;
inc(vg^.FrameTicks, vg^.FrameTicks)
@@ -768,9 +775,12 @@
Gear^.doStep:= @doStepBigExplosionWork;
if Steps > 1 then
Gear^.doStep(Gear, Steps-1);
+
+{$IFNDEF PAS2C}
with mobileRecord do
if (performRumble <> nil) and (not fastUntilLag) then
performRumble(kSystemSoundID_Vibrate);
+{$ENDIF}
end;
procedure doStepChunk(Gear: PVisualGear; Steps: Longword);
@@ -832,7 +842,7 @@
procedure doStepSmoothWindBar(Gear: PVisualGear; Steps: Longword);
begin
inc(Gear^.Timer, Steps);
-
+
while Gear^.Timer >= 10 do
begin
dec(Gear^.Timer, 10);
@@ -851,8 +861,8 @@
cWindspeedf := cWindspeedf + Gear^.Angle*Steps;
if cWindspeedf > Gear^.dAngle then cWindspeedf:= Gear^.dAngle;
end;
-
-if (WindBarWidth = Gear^.Tag) and (cWindspeedf = Gear^.dAngle) then
+
+if (WindBarWidth = Gear^.Tag) and (cWindspeedf = Gear^.dAngle) then
DeleteVisualGear(Gear)
end;
////////////////////////////////////////////////////////////////////////////////
@@ -866,7 +876,7 @@
else
begin
dec(Gear^.FrameTicks, Steps);
- if (Gear^.FrameTicks < 501) and (Gear^.FrameTicks mod 5 = 0) then
+ if (Gear^.FrameTicks < 501) and (Gear^.FrameTicks mod 5 = 0) then
Gear^.Tint:= (Gear^.Tint and $FFFFFF00) or (((Gear^.Tint and $000000FF) * Gear^.FrameTicks) div 500)
end
end;
@@ -911,7 +921,7 @@
procedure initModule;
begin
- doStepHandlers:= handlers
+ doStepVGHandlers:= handlers
end;
end.
--- a/hedgewars/uVisualGearsList.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uVisualGearsList.pas Tue Jan 21 22:38:13 2014 +0100
@@ -29,7 +29,7 @@
procedure DeleteVisualGear(Gear: PVisualGear);
function VisualGearByUID(uid : Longword) : PVisualGear;
-const
+const
cExplFrameTicks = 110;
var VGCounter: LongWord;
@@ -75,7 +75,7 @@
vgtEvilTrace,
vgtNote,
vgtSmoothWindBar])) then
-
+
exit;
inc(VGCounter);
@@ -84,7 +84,7 @@
gear^.X:= real(X);
gear^.Y:= real(Y);
gear^.Kind := Kind;
-gear^.doStep:= doStepHandlers[Kind];
+gear^.doStep:= doStepVGHandlers[Kind];
gear^.State:= 0;
gear^.Tint:= $FFFFFFFF;
gear^.uid:= VGCounter;
@@ -289,7 +289,7 @@
if random(2) = 0 then
dx := -dx;
end;
- vgtNote:
+ vgtNote:
begin
dx:= 0.005 * (random(15) + 10);
dy:= -0.001 * (random(40) + 20);
@@ -306,7 +306,7 @@
Frame:= 7;
Angle:= 0;
end;
-vgtSmoothWindBar:
+vgtSmoothWindBar:
begin
Angle:= hwFloat2Float(cMaxWindSpeed)*2 / 1440; // seems rate below is supposed to change wind bar at 1px per 10ms. Max time, 1440ms. This tries to match the rate of change
Tag:= hwRound(cWindSpeed * 72 / cMaxWindSpeed);
@@ -332,7 +332,7 @@
case Gear^.Kind of
vgtFlake: if cFlattenFlakes then
gear^.Layer:= 0
- else if random(3) = 0 then
+ else if random(3) = 0 then
begin
gear^.Scale:= 0.5;
gear^.Layer:= 0 // 33% - far back
--- a/hedgewars/uWorld.pas Sun Jan 19 00:18:28 2014 +0400
+++ b/hedgewars/uWorld.pas Tue Jan 21 22:38:13 2014 +0100
@@ -64,6 +64,9 @@
{$IFDEF USE_VIDEO_RECORDING}
, uVideoRec
{$ENDIF}
+{$IFDEF GL2}
+ , uMatrix
+{$ENDIF}
;
var cWaveWidth, cWaveHeight: LongInt;
@@ -444,14 +447,14 @@
AmmoRect.w:= (BORDERSIZE*2) + (SlotsNumX * AMSlotSize) + (SlotsNumX-1);
AmmoRect.h:= (BORDERSIZE*2) + (SlotsNumY * AMSlotSize) + (SlotsNumY-1);
amSurface := SDL_CreateRGBSurface(SDL_SWSURFACE, AmmoRect.w, AmmoRect.h, 32, RMask, GMask, BMask, AMask);
-
+
AMRect.x:= BORDERSIZE;
AMRect.y:= BORDERSIZE;
AMRect.w:= AmmoRect.w - (BORDERSIZE*2);
AMRect.h:= AmmoRect.h - (BORDERSIZE*2);
SDL_FillRect(amSurface, @AMRect, SDL_MapRGB(amSurface^.format, 0,0,0));
-
+
x:= AMRect.x;
y:= AMRect.y;
for i:= 0 to cMaxSlotIndex do
@@ -485,25 +488,25 @@
AMFrame:= LongInt(Ammo^[i,t].AmmoType) - 1;
if STurns >= 0 then //weapon not usable yet, draw grayed out with turns remaining
begin
- DrawSpriteFrame2Surf(sprAMAmmosBW, amSurface, x + AMSlotPadding,
+ DrawSpriteFrame2Surf(sprAMAmmosBW, amSurface, x + AMSlotPadding,
y + AMSlotPadding, AMFrame);
if STurns < 100 then
- DrawSpriteFrame2Surf(sprTurnsLeft, amSurface,
- x + AMSlotSize-16,
+ DrawSpriteFrame2Surf(sprTurnsLeft, amSurface,
+ x + AMSlotSize-16,
y + AMSlotSize + 1 - 16, STurns);
end
else //draw colored version
begin
- DrawSpriteFrame2Surf(sprAMAmmos, amSurface, x + AMSlotPadding,
+ DrawSpriteFrame2Surf(sprAMAmmos, amSurface, x + AMSlotPadding,
y + AMSlotPadding, AMFrame);
end;
{$IFDEF USE_LANDSCAPE_AMMOMENU}
- inc(y, AMSlotSize + 1); //the plus one is for the border
+ inc(y, AMSlotSize + 1); //the plus one is for the border
{$ELSE}
- inc(x, AMSlotSize + 1);
+ inc(x, AMSlotSize + 1);
{$ENDIF}
- end;
- end;
+ end;
+ end;
{$IFDEF USE_LANDSCAPE_AMMOMENU}
inc(x, AMSlotSize + 1);
{$ELSE}
@@ -512,7 +515,7 @@
end;
for i:= 1 to SlotsNumX -1 do
-DrawLine2Surf(amSurface, i * (AMSlotSize+1)+1, BORDERSIZE, i * (AMSlotSize+1)+1, AMRect.h + BORDERSIZE - AMSlotSize - 2,160,160,160);
+DrawLine2Surf(amSurface, i * (AMSlotSize+1)+1, BORDERSIZE, i * (AMSlotSize+1)+1, AMRect.h + BORDERSIZE - AMSlotSize - 2,160,160,160);
for i:= 1 to SlotsNumY -1 do
DrawLine2Surf(amSurface, BORDERSIZE, i * (AMSlotSize+1)+1, AMRect.w + BORDERSIZE, i * (AMSlotSize+1)+1,160,160,160);
@@ -557,8 +560,8 @@
exit
end;
-//Init the menu
-if(AmmoMenuInvalidated) then
+//Init the menu
+if(AmmoMenuInvalidated) then
begin
AmmoMenuInvalidated:= false;
FreeTexture(AmmoMenuTex);
@@ -614,7 +617,7 @@
begin
AMShiftX:= Round(AMShiftTargetX * (1 - AMAnimState));
AMShiftY:= Round(AMShiftTargetY * (1 - AMAnimState));
- if (AMAnimType and AMTypeMaskAlpha) <> 0 then
+ if (AMAnimType and AMTypeMaskAlpha) <> 0 then
Tint($FF, $ff, $ff, Round($ff * AMAnimState));
end
else
@@ -639,10 +642,10 @@
begin
AMShiftX:= Round(AMShiftTargetX * AMAnimState);
AMShiftY:= Round(AMShiftTargetY * AMAnimState);
- if (AMAnimType and AMTypeMaskAlpha) <> 0 then
+ if (AMAnimType and AMTypeMaskAlpha) <> 0 then
Tint($FF, $ff, $ff, Round($ff * (1-AMAnimState)));
end
- else
+ else
begin
AMShiftX:= AMShiftTargetX;
AMShiftY:= AMShiftTargetY;
@@ -651,10 +654,10 @@
AMState:= AMHidden;
end;
end;
-
+
DrawTexture(AmmoRect.x + AMShiftX, AmmoRect.y + AMShiftY, AmmoMenuTex);
-if ((AMState = AMHiding) or (AMState = AMShowingUp)) and ((AMAnimType and AMTypeMaskAlpha) <> 0 )then
+if ((AMState = AMHiding) or (AMState = AMShowingUp)) and ((AMAnimType and AMTypeMaskAlpha) <> 0 )then
Tint($FF, $ff, $ff, $ff);
Pos:= -1;
@@ -675,15 +678,15 @@
begin
if (CursorPoint.Y <= (cScreenHeight - AmmoRect.y) - ( g * (AMSlotSize+1))) and
(CursorPoint.Y > (cScreenHeight - AmmoRect.y) - ((g+1) * (AMSlotSize+1))) and
- (CursorPoint.X > AmmoRect.x + ( c * (AMSlotSize+1))) and
+ (CursorPoint.X > AmmoRect.x + ( c * (AMSlotSize+1))) and
(CursorPoint.X <= AmmoRect.x + ((c+1) * (AMSlotSize+1))) then
begin
Slot:= i;
Pos:= t;
STurns:= Ammoz[Ammo^[i, t].AmmoType].SkipTurns - CurrentTeam^.Clan^.TurnNumber;
if (STurns < 0) and (AMShiftX = 0) and (AMShiftY = 0) then
- DrawSprite(sprAMSlot,
- AmmoRect.x + BORDERSIZE + (c * (AMSlotSize+1)) + AMSlotPadding,
+ DrawSprite(sprAMSlot,
+ AmmoRect.x + BORDERSIZE + (c * (AMSlotSize+1)) + AMSlotPadding,
AmmoRect.y + BORDERSIZE + (g * (AMSlotSize+1)) + AMSlotPadding -1, 0);
end;
inc(g);
@@ -705,15 +708,15 @@
begin
if (CursorPoint.Y <= (cScreenHeight - AmmoRect.y) - ( c * (AMSlotSize+1))) and
(CursorPoint.Y > (cScreenHeight - AmmoRect.y) - ((c+1) * (AMSlotSize+1))) and
- (CursorPoint.X > AmmoRect.x + ( g * (AMSlotSize+1))) and
+ (CursorPoint.X > AmmoRect.x + ( g * (AMSlotSize+1))) and
(CursorPoint.X <= AmmoRect.x + ((g+1) * (AMSlotSize+1))) then
begin
Slot:= i;
Pos:= t;
STurns:= Ammoz[Ammo^[i, t].AmmoType].SkipTurns - CurrentTeam^.Clan^.TurnNumber;
if (STurns < 0) and (AMShiftX = 0) and (AMShiftY = 0) then
- DrawSprite(sprAMSlot,
- AmmoRect.x + BORDERSIZE + (g * (AMSlotSize+1)) + AMSlotPadding,
+ DrawSprite(sprAMSlot,
+ AmmoRect.x + BORDERSIZE + (g * (AMSlotSize+1)) + AMSlotPadding,
AmmoRect.y + BORDERSIZE + (c * (AMSlotSize+1)) + AMSlotPadding -1, 0);
end;
inc(g);
@@ -748,7 +751,7 @@
{$IFDEF USE_TOUCH_INTERFACE}//show the aiming buttons + animation
if (Ammo^[Slot, Pos].Propz and ammoprop_NeedUpDown) <> 0 then
begin
- if not(arrowUp.show) then
+ if (not arrowUp.show) then
begin
animateWidget(@arrowUp, true, true);
animateWidget(@arrowDown, true, true);
@@ -771,7 +774,7 @@
if (WeaponTooltipTex <> nil) and (AMShiftX = 0) and (AMShiftY = 0) then
{$IFDEF USE_LANDSCAPE_AMMOMENU}
- if not isPhone() then
+ if (not isPhone()) then
ShowWeaponTooltip(-WeaponTooltipTex^.w div 2, AmmoRect.y - WeaponTooltipTex^.h - AMSlotSize);
{$ELSE}
ShowWeaponTooltip(AmmoRect.x - WeaponTooltipTex^.w - 3, Min(AmmoRect.y + 1, cScreenHeight - WeaponTooltipTex^.h - 40));
@@ -785,9 +788,9 @@
end;
procedure DrawWater(Alpha: byte; OffsetY: LongInt);
-var VertexBuffer: array [0..3] of TVertex2f;
- r: TSDL_Rect;
- lw, lh: GLfloat;
+var VertexBuffer : array [0..3] of TVertex2f;
+ r : TSDL_Rect;
+ lw, lh : GLfloat;
begin
if SuddenDeathDmg then
begin
@@ -824,6 +827,7 @@
VertexBuffer[3].X:= -lw;
VertexBuffer[3].Y:= lh;
+{$IFNDEF GL2}
glDisableClientState(GL_TEXTURE_COORD_ARRAY);
glEnableClientState(GL_COLOR_ARRAY);
if SuddenDeathDmg then
@@ -837,7 +841,27 @@
glDisableClientState(GL_COLOR_ARRAY);
glEnableClientState(GL_TEXTURE_COORD_ARRAY);
- glColor4ub($FF, $FF, $FF, $FF); // must not be Tint() as color array seems to stay active and color reset is required
+
+{$ELSE}
+ UpdateModelviewProjection;
+
+ BeginWater;
+ if SuddenDeathDmg then
+ SetColorPointer(@SDWaterColorArray[0], 4)
+ else
+ SetColorPointer(@WaterColorArray[0], 4);
+
+ SetVertexPointer(@VertexBuffer[0], 4);
+
+ glDrawArrays(GL_TRIANGLE_FAN, 0, 4);
+
+ EndWater;
+{$ENDIF}
+
+{$IFNDEF GL2}
+ // must not be Tint() as color array seems to stay active and color reset is required
+ glColor4ub($FF, $FF, $FF, $FF);
+{$ENDIF}
glEnable(GL_TEXTURE_2D);
end;
end;
@@ -892,8 +916,13 @@
TextureBuffer[3].Y:= TextureBuffer[2].Y;
-glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]);
-glTexCoordPointer(2, GL_FLOAT, 0, @TextureBuffer[0]);
+SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer));
+SetTexCoordPointer(@TextureBuffer[0], Length(VertexBuffer));
+
+{$IFDEF GL2}
+UpdateModelviewProjection;
+{$ENDIF}
+
glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer));
untint;
@@ -1105,12 +1134,19 @@
else if rm = rmLeftEye then
d:= -d;
stereoDepth:= stereoDepth + d;
+
+{$IFDEF GL2}
+ hglMatrixMode(MATRIX_PROJECTION);
+ hglTranslatef(d, 0, 0);
+ hglMatrixMode(MATRIX_MODELVIEW);
+{$ELSE}
glMatrixMode(GL_PROJECTION);
glTranslatef(d, 0, 0);
glMatrixMode(GL_MODELVIEW);
{$ENDIF}
+{$ENDIF}
end;
-
+
procedure ResetDepth(rm: TRenderMode);
begin
{$IFNDEF USE_S3D_RENDERING}
@@ -1119,14 +1155,19 @@
{$ELSE}
if rm = rmDefault then
exit;
+{$IFDEF GL2}
+ hglMatrixMode(MATRIX_PROJECTION);
+ hglTranslatef(-stereoDepth, 0, 0);
+ hglMatrixMode(MATRIX_MODELVIEW);
+{$ELSE}
glMatrixMode(GL_PROJECTION);
glTranslatef(-stereoDepth, 0, 0);
glMatrixMode(GL_MODELVIEW);
- stereoDepth:= 0;
+{$ENDIF}
+ cStereoDepth:= 0;
{$ENDIF}
end;
-
procedure RenderWorldEdge(Lag: Longword);
var
VertexBuffer: array [0..3] of TVertex2f;
@@ -1189,7 +1230,7 @@
glColor4ub($FF, $FF, $FF, $FF); // must not be Tint() as color array seems to stay active and color reset is required
glEnable(GL_TEXTURE_2D);
- // I'd still like to have things happen to the border when a wrap or bounce just occurred, based on a timer
+ // I'd still like to have things happen to the border when a wrap or bounce just occurred, based on a timer
if WorldEdge = weBounce then
begin
// could maybe alternate order of these on a bounce, or maybe drop the outer ones.
@@ -1291,7 +1332,7 @@
for i:= 0 to cMaxHHIndex do
begin
inc(h, Hedgehogs[i].HealthBarHealth);
- if (h < TeamHealthBarHealth) and (Hedgehogs[i].HealthBarHealth > 0) then
+ if (h < TeamHealthBarHealth) and (Hedgehogs[i].HealthBarHealth > 0) then
DrawTexture(15 + h * TeamHealthBarWidth div TeamHealthBarHealth, cScreenHeight + DrawHealthY + smallScreenOffset + 1, SpritesData[sprSlider].Texture);
end;
@@ -1374,7 +1415,7 @@
if (cReducedQuality and rq2DWater) = 0 then
begin
// Waves
- DrawWater(255, SkyOffset);
+ DrawWater(255, SkyOffset);
ChangeDepth(RM, -cStereo_Water_distant);
DrawWaves( 1, 0 - WorldDx div 32, - cWaveHeight + offsetY div 35, 64);
ChangeDepth(RM, -cStereo_Water_distant);
@@ -1393,6 +1434,30 @@
DrawWater(255, 0);
+(*
+// Attack bar
+ if CurrentTeam <> nil then
+ case AttackBar of
+ //1: begin
+ //r:= StuffPoz[sPowerBar];
+ //{$WARNINGS OFF}
+ //r.w:= (CurrentHedgehog^.Gear^.Power * 256) div cPowerDivisor;
+ //{$WARNINGS ON}
+ //DrawSpriteFromRect(r, cScreenWidth - 272, cScreenHeight - 48, 16, 0, Surface);
+ //end;
+ 2: with CurrentHedgehog^ do
+ begin
+ tdx:= hwSign(Gear^.dX) * Sin(Gear^.Angle * Pi / cMaxAngle);
+ tdy:= - Cos(Gear^.Angle * Pi / cMaxAngle);
+ for i:= (Gear^.Power * 24) div cPowerDivisor downto 0 do
+ DrawSprite(sprPower,
+ hwRound(Gear^.X) + GetLaunchX(CurAmmoType, hwSign(Gear^.dX), Gear^.Angle) + LongInt(round(WorldDx + tdx * (24 + i * 2))) - 16,
+ hwRound(Gear^.Y) + GetLaunchY(CurAmmoType, Gear^.Angle) + LongInt(round(WorldDy + tdy * (24 + i * 2))) - 16,
+ i)
+ end
+ end;
+*)
+
DrawVisualGears(1);
DrawGears;
DrawVisualGears(6);
@@ -1471,7 +1536,7 @@
i:= Succ(Pred(ReadyTimeLeft) div 1000)
else
i:= Succ(Pred(TurnTimeLeft) div 1000);
-
+
if i>99 then
t:= 112
else if i>9 then
@@ -1556,14 +1621,14 @@
AMAnimStartTime:= RealTicks - (AMAnimDuration - (RealTicks - AMAnimStartTime));
AMState:= AMShowingUp;
end;
-if not(bShowAmmoMenu) and ((AMstate = AMShowing) or (AMState = AMShowingUp)) then
+if (not bShowAmmoMenu) and ((AMstate = AMShowing) or (AMState = AMShowingUp)) then
begin
if (AMState = AMShowing) then
AMAnimStartTime:= RealTicks
else
AMAnimStartTime:= RealTicks - (AMAnimDuration - (RealTicks - AMAnimStartTime));
AMState:= AMHiding;
- end;
+ end;
if bShowAmmoMenu or (AMState = AMHiding) then
ShowAmmoMenu;
@@ -1575,6 +1640,7 @@
// Chat
DrawChat;
+
// various captions
if fastUntilLag then
DrawTextureCentered(0, (cScreenHeight shr 1), SyncTexture);
@@ -1618,8 +1684,8 @@
if t < 10 then
s:= '0' + s;
s:= inttostr(i div 60) + ':' + s;
-
-
+
+
tmpSurface:= TTF_RenderUTF8_Blended(Fontz[fnt16].Handle, Str2PChar(s), cWhiteColorChannels);
tmpSurface:= doSurfaceConversion(tmpSurface);
FreeTexture(timeTexture);
@@ -1655,7 +1721,7 @@
if ScreenFade <> sfNone then
begin
- if not isFirstFrame then
+ if (not isFirstFrame) then
case ScreenFade of
sfToBlack, sfToWhite: if ScreenFadeValue + Lag * ScreenFadeSpeed < sfMax then
inc(ScreenFadeValue, Lag * ScreenFadeSpeed)
@@ -1685,7 +1751,7 @@
glDisable(GL_TEXTURE_2D);
glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]);
- glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer));
+ glDrawArrays(GL_TRIANGLE_FAN, 0, High(VertexBuffer) - Low(VertexBuffer) + 1);
glEnable(GL_TEXTURE_2D);
untint;
@@ -1710,7 +1776,7 @@
DrawTexture( -(cScreenWidth shr 1) + 50, 20, recTexture);
// draw red circle
- glDisable(GL_TEXTURE_2D);
+ glDisable(GL_TEXTURE_2D);
Tint($FF, $00, $00, Byte(Round(127*(1 + sin(SDL_GetTicks()*0.007)))));
glBegin(GL_POLYGON);
for i:= 0 to 20 do
@@ -1749,7 +1815,7 @@
// Cursor
if isCursorVisible then
begin
- if not bShowAmmoMenu then
+ if (not bShowAmmoMenu) then
begin
if not CurrentTeam^.ExtDriven then TargetCursorPoint:= CursorPoint;
with CurrentHedgehog^ do
@@ -1765,7 +1831,8 @@
DrawSprite(sprArrow, TargetCursorPoint.X, cScreenHeight - TargetCursorPoint.Y, (RealTicks shr 6) mod 8)
end
end;
-isFirstFrame:= false;
+
+isFirstFrame:= false
end;
var PrevSentPointTime: LongWord = 0;
@@ -1780,7 +1847,7 @@
{$ENDIF}
z:= round(200/zoom);
inbtwnTrgtAttks := (CurrentHedgehog <> nil) and ((Ammoz[CurrentHedgehog^.CurAmmoType].Ammo.Propz and ammoprop_NeedTarget) <> 0) and ((GameFlags and gfInfAttack) <> 0);
-if autoCameraOn and not PlacingHogs and (FollowGear <> nil) and (not isCursorVisible) and (not bShowAmmoMenu) and (not fastUntilLag) and not inbtwnTrgtAttks then
+if autoCameraOn and (not PlacingHogs) and (FollowGear <> nil) and (not isCursorVisible) and (not bShowAmmoMenu) and (not fastUntilLag) and (not inbtwnTrgtAttks) then
if ((abs(CursorPoint.X - prevPoint.X) + abs(CursorPoint.Y - prevpoint.Y)) > 4) then
begin
FollowGear:= nil;
@@ -1821,7 +1888,7 @@
{$ENDIF}
{$ENDIF}
- if CursorPoint.X < AmmoRect.x + amNumOffsetX + 3 then//check left
+ if CursorPoint.X < AmmoRect.x + amNumOffsetX + 3 then//check left
CursorPoint.X:= AmmoRect.x + amNumOffsetX + 3;
if CursorPoint.X > AmmoRect.x + AmmoRect.w - 3 then//check right
CursorPoint.X:= AmmoRect.x + AmmoRect.w - 3;
@@ -1950,10 +2017,10 @@
{$IFDEF USE_VIDEO_RECORDING}
// do not change volume during prerecording as it will affect sound in video file
-if not flagPrerecording then
+if (not flagPrerecording) then
{$ENDIF}
begin
- if not cHasFocus then DampenAudio()
+ if (not cHasFocus) then DampenAudio()
else UndampenAudio();
end;
end;
@@ -1969,7 +2036,7 @@
begin
utilityWidget.sprite:= sprTimerButton;
animateWidget(@utilityWidget, true, true);
- end
+ end
else if (Ammoz[ammoType].Ammo.Propz and ammoprop_NeedTarget) <> 0 then
begin
utilityWidget.sprite:= sprTargetButton;
@@ -1993,7 +2060,7 @@
begin
show:= showWidget;
if fade then fadeAnimStart:= RealTicks;
-
+
with moveAnim do
begin
animate:= true;
--- a/misc/liblua/lauxlib.c Sun Jan 19 00:18:28 2014 +0400
+++ b/misc/liblua/lauxlib.c Tue Jan 21 22:38:13 2014 +0100
@@ -25,12 +25,12 @@
#include "lauxlib.h"
-#define FREELIST_REF 0 /* free list of references */
+#define FREELIST_REF 0 /* free list of references */
/* convert a stack index to positive */
-#define abs_index(L, i) ((i) > 0 || (i) <= LUA_REGISTRYINDEX ? (i) : \
- lua_gettop(L) + (i) + 1)
+#define abs_index(L, i) ((i) > 0 || (i) <= LUA_REGISTRYINDEX ? (i) : \
+ lua_gettop(L) + (i) + 1)
/*
@@ -389,10 +389,10 @@
*/
-#define bufflen(B) ((B)->p - (B)->buffer)
-#define bufffree(B) ((size_t)(LUAL_BUFFERSIZE - bufflen(B)))
+#define bufflen(B) ((B)->p - (B)->buffer)
+#define bufffree(B) ((size_t)(LUAL_BUFFERSIZE - bufflen(B)))
-#define LIMIT (LUA_MINSTACK/2)
+#define LIMIT (LUA_MINSTACK/2)
static int emptybuffer (luaL_Buffer *B) {
@@ -574,7 +574,8 @@
lf.f = freopen(filename, "rb", lf.f); /* reopen in binary mode */
if (lf.f == NULL) return errfile(L, "reopen", fnameindex);
/* skip eventual `#!...' */
- while ((c = getc(lf.f)) != EOF && c != LUA_SIGNATURE[0]) ;
+ while ((c = getc(lf.f)) != EOF && c != LUA_SIGNATURE[0])
+ /* do nothing */ ;
lf.extraline = 0;
}
ungetc(c, lf.f);
--- a/misc/libphyslayer/CMakeLists.txt Sun Jan 19 00:18:28 2014 +0400
+++ b/misc/libphyslayer/CMakeLists.txt Tue Jan 21 22:38:13 2014 +0100
@@ -4,8 +4,7 @@
include_directories(${SDL_INCLUDE_DIR})
include_directories(${LUA_INCLUDE_DIR})
-## extra functions needed by Hedgewars
-## TODO: maybe it's better to have them in a separate library?
+
set(PHYSLAYER_SRCS
physfscompat.c
physfsrwops.c
--- a/misc/libphyslayer/hwpacksmounter.h Sun Jan 19 00:18:28 2014 +0400
+++ b/misc/libphyslayer/hwpacksmounter.h Tue Jan 21 22:38:13 2014 +0100
@@ -2,8 +2,8 @@
#define HEDGEWARS_PACKAGES_MOUNTER_H
#include "physfs.h"
-
#include "physfscompat.h"
+#include "lua.h"
#ifdef __cplusplus
extern "C" {
@@ -12,6 +12,9 @@
PHYSFS_DECL void hedgewarsMountPackages();
PHYSFS_DECL void hedgewarsMountPackage(char * fileName);
+PHYSFS_DECL const char * physfsReader(lua_State *L, PHYSFS_File *f, size_t *size);
+PHYSFS_DECL void physfsReaderSetBuffer(void *buffer);
+
#ifdef __cplusplus
}
#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/CMakeLists.txt Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,84 @@
+#the usual set of dependencies
+find_package(OpenGL REQUIRED)
+find_package(GLEW REQUIRED)
+find_package(SDL REQUIRED)
+find_package(SDL_mixer REQUIRED)
+find_package(SDL_net REQUIRED)
+find_package(SDL_image REQUIRED)
+find_package(SDL_ttf REQUIRED)
+
+#compile our rtl implementation
+include_directories(${GLEW_INCLUDE_DIR})
+include_directories(${CMAKE_CURRENT_SOURCE_DIR}/rtl)
+include_directories(${PHYSFS_INCLUDE_DIR})
+include_directories(${PHYSLAYER_INCLUDE_DIR})
+add_subdirectory(rtl)
+
+configure_file(${CMAKE_SOURCE_DIR}/hedgewars/config.inc.in ${CMAKE_CURRENT_BINARY_DIR}/config.inc)
+
+#get the list of pas files that are going to be converted and compiled
+file(GLOB engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/*.pas")
+#TODO: temporary until cmake can configure itself accordingly
+list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/uWeb.pas")
+list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/uVideoRec.pas")
+list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/uTouch.pas")
+list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/PNGh.pas")
+list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/pas2cSystem.pas")
+list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/pas2cRedo.pas")
+list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/hwLibrary.pas")
+
+#remove and readd hwengine so that it is compiled first, compiling every other file in the process
+list(REMOVE_ITEM engine_sources_pas ${CMAKE_SOURCE_DIR}/hedgewars/hwengine.pas)
+list(APPEND engine_sources_pas ${CMAKE_SOURCE_DIR}/hedgewars/hwengine.pas)
+
+#process files .pas -> .c
+foreach(sourcefile ${engine_sources_pas})
+ get_filename_component(sourcename ${sourcefile} NAME_WE) #drops .pas
+ list(APPEND engine_sources "${CMAKE_CURRENT_BINARY_DIR}/${sourcename}.c")
+endforeach()
+
+#add again files for external functions and for fpcrtl_ functions
+list(APPEND engine_sources_pas ${CMAKE_SOURCE_DIR}/hedgewars/pas2cSystem.pas)
+list(APPEND engine_sources_pas ${CMAKE_SOURCE_DIR}/hedgewars/pas2cRedo.pas)
+
+
+#invoke pas2c on main module, it will call all the others
+add_custom_command(OUTPUT ${engine_sources}
+ COMMAND "${EXECUTABLE_OUTPUT_PATH}/pas2c${CMAKE_EXECUTABLE_SUFFIX}"
+ ARGS -n "hwengine"
+ -i "${CMAKE_SOURCE_DIR}/hedgewars"
+ -o "${CMAKE_CURRENT_BINARY_DIR}"
+ -a "${CMAKE_CURRENT_BINARY_DIR}"
+ -d "ENDIAN_LITTLE"
+ -d "DEBUGFILE"
+ DEPENDS pas2c #converter tool
+ ${engine_sources_pas} #original pascal file
+ )
+
+#wrap conversion for all source in this command
+add_custom_target(engine_c DEPENDS ${engine_sources})
+
+
+#compile the c files
+add_executable(hwengine WIN32 ${engine_sources})
+
+target_link_libraries(hwengine fpcrtl
+ ${LUA_LIBRARY}
+ ${OPENGL_LIBRARY}
+ ${SDL_LIBRARY}
+ ${SDLMIXER_LIBRARY}
+ ${SDLNET_LIBRARY}
+ ${SDLIMAGE_LIBRARY}
+ ${SDLTTF_LIBRARY}
+ ${GLEW_LIBRARY}
+ physfs
+ physlayer
+ m
+ #TODO: add other libraries
+ )
+if(APPLE)
+ target_link_libraries(hwengine IOKit SDLmain)
+endif()
+
+install(PROGRAMS "${EXECUTABLE_OUTPUT_PATH}/hwengine${CMAKE_EXECUTABLE_SUFFIX}" DESTINATION ${target_binary_install_dir})
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/CMakeLists.txt Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,16 @@
+
+include_directories(${GLEW_INCLUDE_DIR})
+
+file(GLOB fpcrtl_src *.c)
+
+add_library(fpcrtl STATIC ${fpcrtl_src})
+
+#if(WEBGL)
+# set_target_properties(fpcrtl PROPERTIES PREFIX "em")
+# set_target_properties(fpcrtl PROPERTIES SUFFIX ".bc")
+#endif(WEBGL)
+
+
+
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/GL.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,8 @@
+#pragma once
+
+#ifdef __APPLE__
+#include <OpenGL/gl.h>
+#else
+#include "GL/gl.h"
+#endif
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/Math.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,4 @@
+#pragma once
+
+#include <math.h>
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/SysUtils.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,41 @@
+#ifndef _FPCRTL_SYSUTILS_H_
+#define _FPCRTL_SYSUTILS_H_
+
+#include "Types.h"
+
+// EFFECTS: return the current date time in pascal notation
+// http://www.merlyn.demon.co.uk/del-prgg.htm#TDT
+TDateTime fpcrtl_now();
+#define now fpcrtl_now
+#define Now fpcrtl_now
+
+// EFFECTS: return the current time
+// http://www.merlyn.demon.co.uk/del-prgg.htm#TDT
+TDateTime fpcrtl_time();
+
+
+// EFFECTS: return the current date
+// http://www.merlyn.demon.co.uk/del-prgg.htm#TDT
+TDateTime fpcrtl_date();
+#define date fpcrtl_date
+#define Date fpcrtl_date
+
+// EFFECTS: Trim strips blank characters (spaces) at the beginning and end of S
+// and returns the resulting string. Only #32 characters are stripped.
+// If the string contains only spaces, an empty string is returned.
+string255 fpcrtl_trim(string255 s);
+#define trim fpcrtl_trim
+#define Trim fpcrtl_trim
+
+Integer fpcrtl_strToInt(string255 s);
+#define StrToInt fpcrtl_strToInt
+#define strToInt fpcrtl_strToInt
+
+string255 fpcrtl_extractFileName(string255 f);
+#define fpcrtl_ExtractFileName fpcrtl_extractFileName
+
+string255 fpcrtl_strPas(PChar);
+#define fpcrtl_StrPas fpcrtl_strPas
+
+
+#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/Types.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,39 @@
+#ifndef _TYPES_H_
+#define _TYPES_H_
+
+#include "pas2c.h"
+
+/*
+ * Not very useful currently
+ */
+
+typedef double TDate;
+typedef double TTime;
+typedef double TDateTime;
+typedef string255 TMonthNameArray[13];
+typedef string255 TWeekNameArray[8];
+
+typedef struct {
+ Byte CurrencyFormat;
+ Byte NegCurrFormat;
+ Char ThousandSeparator;
+ Char DecimalSeparator;
+ Byte CurrencyDecimals;
+ Char DateSeparator;
+ Char TimeSeparator;
+ Char ListSeparator;
+ string255 CurrencyString;
+ string255 ShortDateFormat;
+ string255 LongDateFormat;
+ string255 TimeAMString;
+ string255 TimePMString;
+ string255 ShortTimeFormat;
+ string255 LongTimeFormat;
+ TMonthNameArray ShortMonthNames;
+ TMonthNameArray LongMonthNames;
+ TWeekNameArray ShortDayNames;
+ TWeekNameArray LongDayNames;
+ Word TwoDigitYearCenturyWindow;
+}TFormatSettings;
+
+#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/fileio.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,225 @@
+/*
+ * XXX: assume all files are text files
+ */
+
+#include "misc.h"
+#include "fileio.h"
+#include <string.h>
+#include <stdlib.h>
+#include <assert.h>
+#include <sys/stat.h>
+
+io_result_t IOResult;
+int FileMode;
+
+static void init(File f) {
+ f->fp = NULL;
+ f->eof = 0;
+ f->mode = NULL;
+ f->record_len = 0;
+}
+
+void fpcrtl_assign__vars(File *f, string255 name) {
+ FIX_STRING(name);
+ *f = (File) malloc(sizeof(file_wrapper_t));
+ strcpy((*f)->file_name, name.str);
+ init(*f);
+}
+
+void fpcrtl_reset1(File f) {
+ f->fp = fopen(f->file_name, "r");
+ if (!f->fp) {
+ IOResult = IO_ERROR_DUMMY;
+ printf("Failed to open %s\n", f->file_name);
+ return;
+ } else {
+#ifdef FPCRTL_DEBUG
+ printf("Opened %s\n", f->file_name);
+#endif
+ }
+ IOResult = IO_NO_ERROR;
+ f->mode = "r";
+}
+
+void fpcrtl_reset2(File f, int l) {
+ f->eof = 0;
+ f->fp = fopen(f->file_name, "rb");
+ if (!f->fp) {
+ IOResult = IO_ERROR_DUMMY;
+ printf("Failed to open %s\n", f->file_name);
+ return;
+ }
+ IOResult = IO_NO_ERROR;
+ f->mode = "rb";
+ f->record_len = l;
+}
+
+void __attribute__((overloadable)) fpcrtl_rewrite(File f) {
+ f->fp = fopen(f->file_name, "w+");
+ if (!f->fp) {
+ IOResult = IO_ERROR_DUMMY;
+ return;
+ }
+ IOResult = IO_NO_ERROR;
+ f->mode = "w+";
+}
+
+void __attribute__((overloadable)) fpcrtl_rewrite(File f, Integer l) {
+ IOResult = IO_NO_ERROR;
+ fpcrtl_rewrite(f);
+ if (f->fp) {
+ f->record_len = l;
+ }
+}
+
+void fpcrtl_close(File f) {
+ IOResult = IO_NO_ERROR;
+ fclose(f->fp);
+ free(f);
+}
+
+boolean fpcrtl_eof(File f) {
+ IOResult = IO_NO_ERROR;
+ if (f->eof || f->fp == NULL || feof(f->fp)) {
+ return true;
+ } else {
+ return false;
+ }
+}
+
+void __attribute__((overloadable)) fpcrtl_readLn(File f) {
+ IOResult = IO_NO_ERROR;
+ char line[256];
+ if (fgets(line, sizeof(line), f->fp) == NULL) {
+ f->eof = 1;
+ }
+ if (feof(f->fp)) {
+ f->eof = 1;
+ }
+}
+
+void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, Integer *i) {
+ string255 s;
+
+ if (feof(f->fp)) {
+ f->eof = 1;
+ return;
+ }
+
+ fpcrtl_readLn__vars(f, &s);
+
+ *i = atoi(s.str);
+}
+
+void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, LongWord *i) {
+ string255 s;
+
+ if (feof(f->fp)) {
+ f->eof = 1;
+ return;
+ }
+
+ fpcrtl_readLn__vars(f, &s);
+
+ *i = atoi(s.str);
+}
+
+void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, string255 *s) {
+
+ if (fgets(s->str, 255, f->fp) == NULL) {
+
+ s->len = 0;
+ s->str[0] = 0;
+
+ f->eof = 1;
+ return;
+ }
+
+ if (feof(f->fp)) {
+ s->len = 0;
+ f->eof = 1;
+ return;
+ }
+
+ IOResult = IO_NO_ERROR;
+
+ s->len = strlen(s->str);
+ if ((s->len > 0) && (s->str[s->len - 1] == '\n')) {
+ s->str[s->len - 1] = 0;
+ s->len--;
+ }
+}
+
+void __attribute__((overloadable)) fpcrtl_write(File f, string255 s) {
+ FIX_STRING(s);
+ fprintf(f->fp, "%s", s.str);
+}
+
+void __attribute__((overloadable)) fpcrtl_write(FILE *f, string255 s) {
+ FIX_STRING(s);
+ fprintf(f, "%s", s.str);
+}
+
+void __attribute__((overloadable)) fpcrtl_writeLn(File f, string255 s) {
+ FIX_STRING(s);
+ fprintf(f->fp, "%s\n", s.str);
+}
+
+void __attribute__((overloadable)) fpcrtl_writeLn(FILE *f, string255 s) {
+ FIX_STRING(s);
+ fprintf(f, "%s\n", s.str);
+}
+
+void fpcrtl_blockRead__vars(File f, void *buf, Integer count, Integer *result) {
+ assert(f->record_len > 0);
+ *result = fread(buf, f->record_len, count, f->fp);
+}
+
+/*
+ * XXX: dummy blockWrite
+ */
+void fpcrtl_blockWrite__vars(File f, const void *buf, Integer count,
+ Integer *result) {
+ assert(0);
+}
+
+bool fpcrtl_directoryExists(string255 dir) {
+
+ struct stat st;
+ FIX_STRING(dir);
+
+ IOResult = IO_NO_ERROR;
+
+#ifdef FPCRTL_DEBUG
+ printf("Warning: directoryExists is called. This may not work when compiled to js.\n");
+#endif
+
+ if (stat(dir.str, &st) == 0) {
+ return true;
+ }
+
+ return false;
+}
+
+bool fpcrtl_fileExists(string255 filename) {
+
+ FIX_STRING(filename);
+
+ IOResult = IO_NO_ERROR;
+
+ FILE *fp = fopen(filename.str, "r");
+ if (fp) {
+ fclose(fp);
+ return true;
+ }
+ return false;
+}
+
+void __attribute__((overloadable)) fpcrtl_flush(Text f) {
+ fflush(f->fp);
+}
+
+void __attribute__((overloadable)) fpcrtl_flush(FILE *f) {
+ fflush(f);
+}
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/fileio.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,78 @@
+#ifndef FILEIO_H_
+#define FILEIO_H_
+
+#include <stdio.h>
+#include "Types.h"
+#include "misc.h"
+
+extern int FileMode;
+
+typedef enum{
+ IO_NO_ERROR = 0,
+ IO_ERROR_DUMMY = 1
+}io_result_t;
+
+extern io_result_t IOResult;
+
+typedef struct{
+ FILE *fp;
+ const char* mode;
+ char file_name[256];
+ int eof;
+ int record_len;
+}file_wrapper_t;
+
+typedef file_wrapper_t* File;
+typedef File Text;
+typedef Text TextFile;
+
+void __attribute__((overloadable)) fpcrtl_readLn(File f);
+#define fpcrtl_readLn1(f) fpcrtl_readLn(f)
+
+void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, Integer *i);
+void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, LongWord *i);
+void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, string255 *s);
+#define fpcrtl_readLn2(f, t) fpcrtl_readLn__vars(f, &(t))
+
+#define fpcrtl_readLn(...) macro_dispatcher(fpcrtl_readLn, __VA_ARGS__)(__VA_ARGS__)
+
+
+void fpcrtl_blockRead__vars(File f, void *buf, Integer count, Integer *result);
+#define fpcrtl_blockRead(f, buf, count, result) fpcrtl_blockRead__vars(f, &(buf), count, &(result))
+#define fpcrtl_BlockRead fpcrtl_blockRead
+
+#define fpcrtl_assign(f, name) fpcrtl_assign__vars(&f, name)
+void fpcrtl_assign__vars(File *f, string255 name);
+
+boolean fpcrtl_eof(File f);
+
+void fpcrtl_reset1(File f);
+void fpcrtl_reset2(File f, Integer l);
+#define fpcrtl_reset1(f) fpcrtl_reset1(f)
+#define fpcrtl_reset2(f, l) fpcrtl_reset2(f, l)
+#define fpcrtl_reset(...) macro_dispatcher(fpcrtl_reset, __VA_ARGS__)(__VA_ARGS__)
+
+void fpcrtl_close(File f);
+
+void __attribute__((overloadable)) fpcrtl_rewrite(File f);
+void __attribute__((overloadable)) fpcrtl_rewrite(File f, Integer l);
+
+void __attribute__((overloadable)) fpcrtl_flush(Text f);
+void __attribute__((overloadable)) fpcrtl_flush(FILE *f);
+
+void __attribute__((overloadable)) fpcrtl_write(File f, string255 s);
+void __attribute__((overloadable)) fpcrtl_write(FILE *f, string255 s);
+void __attribute__((overloadable)) fpcrtl_writeLn(File f, string255 s);
+void __attribute__((overloadable)) fpcrtl_writeLn(FILE *f, string255 s);
+
+void fpcrtl_blockWrite__vars(File f, const void *buf, Integer count, Integer *result);
+#define fpcrtl_blockWrite(f, buf, count, result) fpcrtl_blockWrite__vars(f, &(buf), count, &(result))
+#define fpcrtl_BlockWrite fpcrtl_blockWrite
+
+bool fpcrtl_directoryExists(string255 dir);
+#define fpcrtl_DirectoryExists fpcrtl_directoryExists
+
+bool fpcrtl_fileExists(string255 filename);
+#define fpcrtl_FileExists fpcrtl_fileExists
+
+#endif /* FILEIO_H_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/fpcrtl.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,202 @@
+#ifndef _FPCRTL_H_
+#define _FPCRTL_H_
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <unistd.h>
+#include <math.h>
+
+#include "SysUtils.h"
+#include "system.h"
+#include "misc.h"
+#include "fileio.h"
+#include "pmath.h"
+
+#ifndef EMSCRIPTEN
+#if __APPLE__
+#define main SDL_main
+#endif
+#include "GL/glew.h"
+#endif
+
+#define fpcrtl_memcpy memcpy
+
+#define luapas_lua_gettop lua_gettop
+#define luapas_lua_close lua_close
+#define luapas_lua_createtable lua_createtable
+#define luapas_lua_error lua_error
+#define luapas_lua_gc lua_gc
+#define luapas_lua_getfield lua_getfield
+#define luapas_lua_objlen lua_objlen
+#define luapas_lua_call lua_call
+#define luapas_lua_pcall lua_pcall
+#define luapas_lua_pushboolean lua_pushboolean
+#define luapas_lua_pushcclosure lua_pushcclosure
+#define luapas_lua_pushinteger lua_pushinteger
+#define luapas_lua_pushnil lua_pushnil
+#define luapas_lua_pushnumber lua_pushnumber
+#define luapas_lua_pushlstring lua_pushlstring
+#define luapas_lua_pushstring lua_pushstring
+#define luapas_lua_pushvalue lua_pushvalue
+#define luapas_lua_rawgeti lua_rawgeti
+#define luapas_lua_setfield lua_setfield
+#define luapas_lua_settop lua_settop
+#define luapas_lua_toboolean lua_toboolean
+#define luapas_lua_tointeger lua_tointeger
+#define luapas_lua_tolstring lua_tolstring
+#define luapas_lua_tonumber lua_tonumber
+#define luapas_lua_type lua_type
+#define luapas_lua_typename lua_typename
+#define luapas_luaL_argerror luaL_argerror
+#define luapas_luaL_checkinteger luaL_checkinteger
+#define luapas_luaL_checklstring luaL_checklstring
+#define luapas_luaL_loadfile luaL_loadfile
+#define luapas_luaL_loadstring luaL_loadstring
+#define luapas_luaL_newstate luaL_newstate
+#define luapas_luaL_optinteger luaL_optinteger
+#define luapas_luaL_optlstring luaL_optlstring
+#define luapas_luaL_prepbuffer luaL_prepbuffer
+#define luapas_luaL_ref luaL_ref
+#define luapas_luaL_unref luaL_unref
+#define luapas_luaopen_base luaopen_base
+#define luapas_luaopen_math luaopen_math
+#define luapas_luaopen_string luaopen_string
+#define luapas_luaopen_table luaopen_table
+#define luapas_lua_load lua_load
+
+#define sdlh_IMG_Load IMG_Load
+#define sdlh_IMG_Load_RW IMG_Load_RW
+
+#ifndef EMSCRIPTEN
+#define sdlh_Mix_AllocateChannels Mix_AllocateChannels
+#define sdlh_Mix_CloseAudio Mix_CloseAudio
+#define sdlh_Mix_FadeInChannelTimed Mix_FadeInChannelTimed
+#define sdlh_Mix_FadeInMusic Mix_FadeInMusic
+#define sdlh_Mix_FadeOutChannel Mix_FadeOutChannel
+#define sdlh_Mix_FreeChunk Mix_FreeChunk
+#define sdlh_Mix_FreeMusic Mix_FreeMusic
+#define sdlh_Mix_HaltChannel Mix_HaltChannel
+#define sdlh_Mix_HaltMusic Mix_HaltMusic
+#define sdlh_Mix_LoadMUS Mix_LoadMUS
+#define sdlh_Mix_LoadMUS_RW Mix_LoadMUS_RW
+#define sdlh_Mix_LoadWAV_RW Mix_LoadWAV_RW
+#define sdlh_Mix_OpenAudio Mix_OpenAudio
+#define sdlh_Mix_PauseMusic Mix_PauseMusic
+#define sdlh_Mix_PlayChannelTimed Mix_PlayChannelTimed
+#define sdlh_Mix_Playing Mix_Playing
+#define sdlh_Mix_ResumeMusic Mix_ResumeMusic
+#define sdlh_Mix_Volume Mix_Volume
+#define sdlh_Mix_VolumeMusic Mix_VolumeMusic
+#else
+#define sdlh_Mix_AllocateChannels stub_Mix_AllocateChannels
+#define sdlh_Mix_CloseAudio stub_Mix_CloseAudio
+#define sdlh_Mix_FadeInChannelTimed stub_Mix_FadeInChannelTimed
+#define sdlh_Mix_FadeInMusic stub_Mix_FadeInMusic
+#define sdlh_Mix_FadeOutChannel stub_Mix_FadeOutChannel
+#define sdlh_Mix_FreeChunk stub_Mix_FreeChunk
+#define sdlh_Mix_FreeMusic stub_Mix_FreeMusic
+#define sdlh_Mix_HaltChannel stub_Mix_HaltChannel
+#define sdlh_Mix_HaltMusic stub_Mix_HaltMusic
+#define sdlh_Mix_LoadMUS stub_Mix_LoadMUS
+#define sdlh_Mix_LoadMUS_RW stub_Mix_LoadMUS_RW
+#define sdlh_Mix_LoadWAV_RW stub_Mix_LoadWAV_RW
+#define sdlh_Mix_OpenAudio stub_Mix_OpenAudio
+#define sdlh_Mix_PauseMusic stub_Mix_PauseMusic
+#define sdlh_Mix_PlayChannelTimed stub_Mix_PlayChannelTimed
+#define sdlh_Mix_Playing stub_Mix_Playing
+#define sdlh_Mix_ResumeMusic stub_Mix_ResumeMusic
+#define sdlh_Mix_Volume stub_Mix_Volume
+#define sdlh_Mix_VolumeMusic stub_Mix_VolumeMusic
+#endif
+
+#define sdlh_SDL_ConvertSurface SDL_ConvertSurface
+#define sdlh_SDL_CreateRGBSurface SDL_CreateRGBSurface
+#define sdlh_SDL_CreateThread SDL_CreateThread
+#define sdlh_SDL_Delay SDL_Delay
+#define sdlh_SDL_EnableKeyRepeat SDL_EnableKeyRepeat
+#define sdlh_SDL_EnableUNICODE SDL_EnableUNICODE
+#define sdlh_SDL_FillRect SDL_FillRect
+#define sdlh_SDL_FreeSurface SDL_FreeSurface
+#define sdlh_SDL_GetError SDL_GetError
+#define sdlh_SDL_GetKeyName SDL_GetKeyName
+#define sdlh_SDL_GetKeyState SDL_GetKeyState
+#define sdlh_SDL_GetMouseState SDL_GetMouseState
+#define sdlh_SDL_GetRGBA SDL_GetRGBA
+#define sdlh_SDL_GetTicks SDL_GetTicks
+#define sdlh_SDL_GL_SetAttribute SDL_GL_SetAttribute
+#define sdlh_SDL_GL_SwapBuffers SDL_GL_SwapBuffers
+#define sdlh_SDL_Init SDL_Init
+#define sdlh_SDL_InitSubSystem SDL_InitSubSystem
+#define sdlh_SDL_JoystickClose SDL_JoystickClose
+#define sdlh_SDL_JoystickEventState SDL_JoystickEventState
+#define sdlh_SDL_JoystickName SDL_JoystickName
+#define sdlh_SDL_JoystickNumAxes SDL_JoystickNumAxes
+#define sdlh_SDL_JoystickNumButtons SDL_JoystickNumButtons
+#define sdlh_SDL_JoystickNumHats SDL_JoystickNumHats
+#define sdlh_SDL_JoystickOpen SDL_JoystickOpen
+#define sdlh_SDL_LockSurface SDL_LockSurface
+#define sdlh_SDL_MapRGB SDL_MapRGB
+#define sdlh_SDL_MapRGBA SDL_MapRGBA
+#define sdlh_SDL_NumJoysticks SDL_NumJoysticks
+#define sdlh_SDL_PeepEvents SDL_PeepEvents
+#define sdlh_SDL_PumpEvents SDL_PumpEvents
+#define sdlh_SDL_Quit SDL_Quit
+#define sdlh_SDL_RWFromFile SDL_RWFromFile
+#define sdlh_SDL_SetColorKey SDL_SetColorKey
+#define sdlh_SDL_SetVideoMode SDL_SetVideoMode
+#define sdlh_SDL_WaitThread SDL_WaitThread
+#define sdlh_SDL_CreateMutex SDL_CreateMutex
+#define sdlh_SDL_DestroyMutex SDL_DestroyMutex
+#define sdlh_SDL_LockMutex SDL_mutexP
+#define sdlh_SDL_UnlockMutex SDL_mutexV
+#ifndef EMSCRIPTEN
+#define sdlh_SDL_ShowCursor SDL_ShowCursor
+#else
+#define sdlh_SDL_ShowCursor SDL_ShowCursor_patch
+#endif
+#define sdlh_SDL_UnlockSurface SDL_UnlockSurface
+#define sdlh_SDL_UpperBlit SDL_UpperBlit
+#define sdlh_SDL_VideoDriverName SDL_VideoDriverName
+#define sdlh_SDL_WarpMouse SDL_WarpMouse
+#define sdlh_SDL_WM_SetCaption SDL_WM_SetCaption
+#define sdlh_SDL_WM_SetIcon SDL_WM_SetIcon
+#define sdlh_SDLNet_AddSocket SDLNet_AddSocket
+#define sdlh_SDLNet_AllocSocketSet SDLNet_AllocSocketSet
+#define sdlh_SDLNet_CheckSockets SDLNet_CheckSockets
+#define sdlh_SDLNet_FreeSocketSet SDLNet_FreeSocketSet
+#define sdlh_SDLNet_Init SDLNet_Init
+#define sdlh_SDLNet_Quit SDLNet_Quit
+#define sdlh_SDLNet_ResolveHost SDLNet_ResolveHost
+#define sdlh_SDLNet_TCP_Close SDLNet_TCP_Close
+#define sdlh_SDLNet_TCP_Open SDLNet_TCP_Open
+#define sdlh_SDLNet_TCP_Recv SDLNet_TCP_Recv
+#define sdlh_SDLNet_TCP_Send SDLNet_TCP_Send
+#define sdlh_TTF_Init TTF_Init
+#define sdlh_TTF_OpenFont TTF_OpenFont
+#define sdlh_TTF_OpenFontRW TTF_OpenFontRW
+#define sdlh_TTF_Quit TTF_Quit
+#define sdlh_TTF_RenderUTF8_Blended TTF_RenderUTF8_Blended
+#define sdlh_TTF_RenderUTF8_Solid TTF_RenderUTF8_Solid
+#define sdlh_TTF_SetFontStyle TTF_SetFontStyle
+#define sdlh_TTF_SizeUTF8 TTF_SizeUTF8
+
+#define _strconcat fpcrtl_strconcat
+#define _strappend fpcrtl_strappend
+#define _strprepend fpcrtl_strprepend
+#define _strcompare fpcrtl_strcompare
+#define _strncompare fpcrtl_strncompare
+#define _strcomparec fpcrtl_strcomparec
+#define _chrconcat fpcrtl_chrconcat
+#define _pchar fpcrtl_pchar
+
+// hooks are implemented in javascript
+void start_hook(void);
+void mainloop_hook(void);
+void clear_filelist_hook(void);
+void add_file_hook(const char* ptr);
+void idb_loader_hook();
+void showcursor_hook();
+void hidecursor_hook();
+void drawworld_init_hook();
+#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/misc.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,168 @@
+#include "misc.h"
+#include <stdio.h>
+#include <stdarg.h>
+#include <string.h>
+#include <assert.h>
+
+char strbuf[512];
+
+void fpcrtl_assert(int i)
+{
+ if(!i){
+ assert(0);
+ }
+}
+
+// EFFECTS: return the nearest integer of the given number
+int fpcrtl_round(double number)
+{
+ return (number >= 0) ? (int)(number + 0.5) : (int)(number - 0.5);
+}
+
+void fpcrtl_printf(const char* format, ...)
+{
+#ifdef FPCRTL_DEBUG
+ va_list args;
+ va_start (args, format);
+ vprintf (format, args);
+ va_end (args);
+#endif
+}
+
+//
+//void fpcrtl_check_string(string255 str)
+//{
+//#ifdef FPCRTL_DEBUG
+// int len = strlen(str.str);
+// if(len != str.len){
+// printf("String %s internal inconsistency error. Length should be %d but actually is %d.\n", str.str, len, str.len);
+// }
+// //assert(len == str.len);
+//#endif
+//}
+
+string255 fpcrtl_strconcat(string255 str1, string255 str2)
+{
+ //printf("str1 = %d, %d\n", str1.len, strlen(str1.str));
+ //printf("str2 = %d, %d\n", str2.len, strlen(str2.str));
+
+#ifdef FPCRTL_DEBUG
+ if(str1.len + (int)(str2.len) > 255){
+ printf("String overflow\n");
+ printf("str1(%d): %s\nstr2(%d): %s\n", str1.len, str1.str, str2.len, str2.str);
+ printf("String will be truncated.\n");
+
+ strbuf[0] = 0;
+ strcpy(strbuf, str1.str);
+ strcat(strbuf, str2.str);
+ memcpy(str1.str, strbuf, 255);
+ str1.str[254] = 0;
+
+ return str1;
+ }
+#endif
+
+ memcpy(&(str1.str[str1.len]), str2.str, str2.len);
+ str1.str[str1.len + str2.len] = 0;
+ str1.len += str2.len;
+
+ return str1;
+}
+
+string255 fpcrtl_strappend(string255 s, char c)
+{
+ s.str[s.len] = c;
+ s.str[s.len + 1] = 0;
+ s.len ++;
+
+ return s;
+}
+
+string255 fpcrtl_strprepend(char c, string255 s)
+{
+ FIX_STRING(s);
+
+ memmove(s.str + 1, s.str, s.len + 1); // also move '/0'
+ s.str[0] = c;
+ s.len++;
+
+ return s;
+}
+
+string255 fpcrtl_chrconcat(char a, char b)
+{
+ string255 result;
+
+ result.len = 2;
+ result.str[0] = a;
+ result.str[1] = b;
+ result.str[2] = 0;
+
+ return result;
+}
+
+bool fpcrtl_strcompare(string255 str1, string255 str2)
+{
+ //printf("str1 = %d, %d\n", str1.len, strlen(str1.str));
+ //printf("str2 = %d, %d\n", str2.len, strlen(str2.str));
+ FIX_STRING(str1);
+ FIX_STRING(str2);
+
+ if(strcmp(str1.str, str2.str) == 0){
+ return true;
+ }
+
+ return false;
+}
+
+bool fpcrtl_strcomparec(string255 a, char b)
+{
+ FIX_STRING(a);
+
+ if(a.len == 1 && a.str[0] == b){
+ return true;
+ }
+
+ return false;
+}
+
+bool fpcrtl_strncompare(string255 a, string255 b)
+{
+ return !fpcrtl_strcompare(a, b);
+}
+
+//char* fpcrtl_pchar(string255 s)
+//{
+// return s.str;
+//}
+
+string255 fpcrtl_pchar2str(char *s)
+{
+ string255 result;
+ int t = strlen(s);
+
+ if(t > 255){
+ printf("pchar2str, length > 255\n");
+ assert(0);
+ }
+
+ result.len = t;
+ memcpy(result.str, s, t);
+ result.str[t] = 0;
+
+ return result;
+}
+
+string255 fpcrtl_make_string(const char* s) {
+ string255 result;
+ strcpy(result.str, s);
+ result.len = strlen(s);
+ return result;
+}
+
+#ifdef EMSCRIPTEN
+GLenum glewInit()
+{
+ return GLEW_OK;
+}
+#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/misc.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,58 @@
+#ifndef _FPCRTL_MISC_H_
+#define _FPCRTL_MISC_H_
+
+#include "pas2c.h"
+#include <assert.h>
+#include <stdbool.h>
+
+#ifdef EMSCRIPTEN
+#include <GL/gl.h>
+#else
+#include <GL/glew.h>
+#endif
+
+#define VA_NUM_ARGS(...) VA_NUM_ARGS_IMPL(__VA_ARGS__, 5,4,3,2,1)
+#define VA_NUM_ARGS_IMPL(_1,_2,_3,_4,_5,N,...) N
+
+#define macro_dispatcher(func, ...) macro_dispatcher_(func, VA_NUM_ARGS(__VA_ARGS__))
+#define macro_dispatcher_(func, nargs) macro_dispatcher__(func, nargs)
+#define macro_dispatcher__(func, nargs) func ## nargs
+
+#define FPCRTL_DEBUG
+
+#define FIX_STRING(s) (s.str[s.len] = 0)
+
+//#define fpcrtl_check_string(s) do{ if(strlen((s).str) != (s).len){ \
+// printf("String %s internal inconsistency error. Length should be %d but actually is %d.\n", (s).str, strlen((s).str), (s).len); \
+// assert(0);\
+// }}while(0)
+
+void fpcrtl_assert(int);
+void fpcrtl_print_trace (void);
+
+int fpcrtl_round(double number);
+void fpcrtl_printf(const char* format, ...);
+
+string255 fpcrtl_make_string(const char* s);
+
+string255 fpcrtl_strconcat(string255 str1, string255 str2);
+string255 fpcrtl_strappend(string255 s, char c);
+string255 fpcrtl_strprepend(char c, string255 s);
+string255 fpcrtl_chrconcat(char a, char b);
+
+// return true if str1 == str2
+bool fpcrtl_strcompare(string255 str1, string255 str2);
+bool fpcrtl_strcomparec(string255 a, char b);
+bool fpcrtl_strncompare(string255 a, string255 b);
+
+#define fpcrtl__pchar(s) ((s).str)
+string255 fpcrtl_pchar2str(char *s);
+
+#define fpcrtl_TypeInfo sizeof // dummy
+
+#ifdef EMSCRIPTEN
+#define GLEW_OK 1
+GLenum glewInit();
+#endif
+
+#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/pas2c.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,80 @@
+#pragma once
+
+#include <stddef.h>
+#include <stdint.h>
+#include <stdbool.h>
+#include <wchar.h>
+#include <math.h>
+
+#define MAX_PARAMS 64
+
+typedef union string255_
+ {
+ struct {
+ unsigned char s[257];
+ };
+ struct {
+ unsigned char len;
+ unsigned char str[256];
+ };
+ } string255;
+typedef struct string192_
+ {
+ unsigned char s[193];
+ } string192;
+typedef struct string31_
+ {
+ unsigned char s[32];
+ } string31;
+typedef struct string15_
+ {
+ unsigned char s[16];
+ } string15;
+
+typedef string255 shortstring;
+typedef string255 ansistring;
+
+typedef uint8_t Byte;
+typedef int8_t ShortInt;
+typedef uint16_t Word;
+typedef int16_t SmallInt;
+typedef uint32_t LongWord;
+typedef int32_t LongInt;
+typedef uint64_t QWord;
+typedef int64_t Int64;
+typedef LongWord Cardinal;
+
+typedef LongInt Integer;
+typedef float extended;
+typedef float real;
+typedef float single;
+
+typedef bool boolean;
+typedef int LongBool;
+
+typedef void * pointer;
+typedef Byte * PByte;
+typedef char * PChar;
+typedef LongInt * PLongInt;
+typedef LongWord * PLongWord;
+typedef Integer * PInteger;
+typedef int PtrInt;
+typedef wchar_t widechar;
+typedef wchar_t* PWideChar;
+typedef char Char;
+typedef LongInt SizeInt;
+typedef char ** PPChar;
+typedef Word* PWord;
+
+string255 _strconcat(string255 a, string255 b);
+string255 _strappend(string255 s, unsigned char c);
+string255 _strprepend(unsigned char c, string255 s);
+string255 _chrconcat(unsigned char a, unsigned char b);
+bool _strcompare(string255 a, string255 b);
+bool _strcomparec(string255 a, unsigned char b);
+bool _strncompare(string255 a, string255 b);
+
+
+#define STRINIT(a) {.len = sizeof(a) - 1, .str = a}
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/pmath.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,49 @@
+#include "pmath.h"
+#include <stdlib.h>
+#include <math.h>
+
+/*
+ * power raises base to the power power.
+ * This is equivalent to exp(power*ln(base)). Therefore base should be non-negative.
+ */
+float fpcrtl_power(float base, float exponent)
+{
+ return exp(exponent * log(base));
+}
+
+/* Currently the games only uses sign of an integer */
+int fpcrtl_signi(int x)
+{
+ if(x > 0){
+ return 1;
+ }
+ else if(x < 0){
+ return -1;
+ }
+ else{
+ return 0;
+ }
+}
+
+float fpcrtl_csc(float x)
+{
+ return 1 / sin(x);
+}
+
+float __attribute__((overloadable)) fpcrtl_abs(float x)
+{
+ return fabs(x);
+}
+double __attribute__((overloadable)) fpcrtl_abs(double x)
+{
+ return fabs(x);
+}
+int __attribute__((overloadable)) fpcrtl_abs(int x)
+{
+ return abs(x);
+}
+
+int64_t __attribute__((overloadable)) fpcrtl_abs(int64_t x)
+{
+ return x < 0 ? -x : x;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/pmath.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,24 @@
+#ifndef PMATH_H_
+#define PMATH_H_
+
+#include <stdint.h>
+#include <math.h>
+
+#define fpcrtl_min(a, b) ((a) < (b) ? (a) : (b))
+#define fpcrtl_max(a, b) ((a) > (b) ? (a) : (b))
+
+float fpcrtl_power(float base, float exponent);
+
+/* Currently the games only uses sign of an integer */
+int fpcrtl_signi(int x);
+
+float fpcrtl_csc(float x);
+
+#define fpcrtl_arctan2(y, x) atan2(y, x)
+
+float __attribute__((overloadable)) fpcrtl_abs(float x);
+double __attribute__((overloadable)) fpcrtl_abs(double x);
+int __attribute__((overloadable)) fpcrtl_abs(int x);
+int64_t __attribute__((overloadable)) fpcrtl_abs(int64_t x);
+
+#endif /* PMATH_H_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/system.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,282 @@
+#include "system.h"
+#include <string.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <wchar.h>
+
+#ifndef M_PI
+// some math.h do not have M_PI macros
+# define M_PI 3.14159265358979323846 /* pi */
+# define M_PI_2 1.57079632679489661923 /* pi/2 */
+# define M_PI_4 0.78539816339744830962 /* pi/4 */
+# define M_PIl 3.1415926535897932384626433832795029L /* pi */
+# define M_PI_2l 1.5707963267948966192313216916397514L /* pi/2 */
+# define M_PI_4l 0.7853981633974483096156608458198757L /* pi/4 */
+#endif
+
+double pi = M_PI;
+
+int paramCount;
+string255 params[MAX_PARAMS];
+
+string255 fpcrtl_copy(string255 s, Integer index, Integer count) {
+ string255 result = STRINIT("");
+
+ if (count < 1) {
+ return result;
+ }
+
+ if (index < 1) {
+ index = 1;
+ }
+
+ if (index > s.len) {
+ return result;
+ }
+
+ if (index + count > s.len + 1) {
+ count = s.len + 1 - index;
+ }
+
+ memcpy(result.str, s.str + index - 1, count);
+
+ result.str[count] = 0;
+ result.len = count;
+
+ return result;
+}
+
+void fpcrtl_delete__vars(string255 *s, SizeInt index, SizeInt count) {
+ // number of chars to be move
+ int num_move;
+ int new_length;
+
+ string255 temp = *s;
+
+ if (index < 1) {
+ // in fpc, if index < 1, the string won't be modified
+ return;
+ }
+
+ if(index > s->len){
+ return;
+ }
+
+ if (count > s->len - index + 1) {
+ s->str[index - 1] = 0;
+ s->len = index - 1;
+ return;
+ }
+
+ num_move = s->len - index + 1 - count;
+ new_length = s->len - count;
+
+ memmove(s->str + index - 1, temp.str + index - 1 + count, num_move);
+ s->str[new_length] = 0;
+
+ s->len = new_length;
+
+}
+
+string255 fpcrtl_floatToStr(double n) {
+ string255 t;
+ sprintf(t.str, "%f", n);
+ t.len = strlen(t.str);
+
+ return t;
+}
+
+void fpcrtl_move__vars(void *src, void *dst, SizeInt count) {
+ memmove(dst, src, count);
+}
+
+Integer __attribute__((overloadable)) fpcrtl_pos(Char c, string255 str) {
+ string255 t;
+ t.len = 1;
+ t.str[0] = c;
+ t.str[1] = 0;
+ return fpcrtl_pos(t, str);
+}
+
+Integer __attribute__((overloadable)) fpcrtl_pos(string255 substr, string255 str) {
+
+ char* p;
+
+ FIX_STRING(substr);
+ FIX_STRING(str);
+
+ if (str.len == 0) {
+ return 0;
+ }
+
+ if (substr.len == 0) {
+ return 0;
+ }
+
+ str.str[str.len] = 0;
+ substr.str[substr.len] = 0;
+
+ p = strstr(str.str, substr.str);
+
+ if (p == NULL) {
+ return 0;
+ }
+
+ return strlen(str.str) - strlen(p) + 1;
+}
+
+Integer fpcrtl_length(string255 s) {
+ return s.len;
+}
+
+string255 fpcrtl_lowerCase(string255 s) {
+ int i;
+
+ for (i = 0; i < s.len; i++) {
+ if (s.str[i] >= 'A' && s.str[i] <= 'Z') {
+ s.str[i] += 'a' - 'A';
+ }
+ }
+
+ return s;
+}
+
+void fpcrtl_fillChar__vars(void *x, SizeInt count, Byte value) {
+ memset(x, value, count);
+}
+
+void fpcrtl_new__vars(void **p, int size) {
+ *p = malloc(size);
+}
+
+Integer fpcrtl_trunc(extended n) {
+ return (int) n;
+}
+
+LongInt str_to_int(char *src)
+{
+ int i;
+ int len = strlen(src);
+ char *end;
+ for(i = 0; i < len; i++)
+ {
+ if(src[i] == '$'){
+ // hex
+ return strtol(src + i + 1, &end, 16);
+ }
+ }
+
+ // decimal
+ return atoi(src);
+}
+
+void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, LongInt *a)
+{
+ FIX_STRING(s);
+ *a = str_to_int(s.str);
+}
+
+void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, Byte *a)
+{
+ FIX_STRING(s);
+ *a = str_to_int(s.str);
+}
+
+void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, LongWord *a)
+{
+ FIX_STRING(s);
+ *a = str_to_int(s.str);
+}
+
+LongInt fpcrtl_random(LongInt l) {
+ return (LongInt) (rand() / (double) RAND_MAX * l);
+}
+
+void __attribute__((overloadable)) fpcrtl_str__vars(float x, string255 *s) {
+ sprintf(s->str, "%f", x);
+ s->len = strlen(s->str);
+}
+void __attribute__((overloadable)) fpcrtl_str__vars(double x, string255 *s) {
+ sprintf(s->str, "%f", x);
+ s->len = strlen(s->str);
+}
+void __attribute__((overloadable)) fpcrtl_str__vars(uint8_t x, string255 *s) {
+ sprintf(s->str, "%u", x);
+ s->len = strlen(s->str);
+}
+void __attribute__((overloadable)) fpcrtl_str__vars(int8_t x, string255 *s) {
+ sprintf(s->str, "%d", x);
+ s->len = strlen(s->str);
+}
+void __attribute__((overloadable)) fpcrtl_str__vars(uint16_t x, string255 *s) {
+ sprintf(s->str, "%u", x);
+ s->len = strlen(s->str);
+}
+void __attribute__((overloadable)) fpcrtl_str__vars(int16_t x, string255 *s) {
+ sprintf(s->str, "%d", x);
+ s->len = strlen(s->str);
+}
+void __attribute__((overloadable)) fpcrtl_str__vars(uint32_t x, string255 *s) {
+ sprintf(s->str, "%u", x);
+ s->len = strlen(s->str);
+}
+void __attribute__((overloadable)) fpcrtl_str__vars(int32_t x, string255 *s) {
+ sprintf(s->str, "%d", x);
+ s->len = strlen(s->str);
+}
+void __attribute__((overloadable)) fpcrtl_str__vars(uint64_t x, string255 *s) {
+ sprintf(s->str, "%llu", x);
+ s->len = strlen(s->str);
+}
+void __attribute__((overloadable)) fpcrtl_str__vars(int64_t x, string255 *s) {
+ sprintf(s->str, "%lld", x);
+ s->len = strlen(s->str);
+}
+
+/*
+ * XXX No protection currently!
+ */
+void fpcrtl_interlockedIncrement__vars(int *i) {
+ (*i)++;
+}
+
+void fpcrtl_interlockedDecrement__vars(int *i) {
+ (*i)--;
+}
+
+/*
+ * This function should be called when entering main
+ */
+void fpcrtl_init(int argc, char** argv) {
+ int i;
+ paramCount = argc;
+
+ printf("ARGC = %d\n", paramCount);
+
+ for (i = 0; i < argc; i++) {
+ if (strlen(argv[i]) > 255) {
+ assert(0);
+ }
+ strcpy(params[i].str, argv[i]);
+ params[i].len = strlen(params[i].str);
+ }
+
+}
+
+int fpcrtl_paramCount() {
+ return paramCount - 1; // ignore the first one
+}
+
+string255 fpcrtl_paramStr(int i) {
+ return params[i];
+}
+
+int fpcrtl_UTF8ToUnicode(PWideChar dest, PChar src, SizeInt maxLen) {
+ //return swprintf(dest, maxLen, L"%hs", "src"); //doesn't work in emscripten
+ return 0;
+}
+
+uint32_t __attribute__((overloadable)) fpcrtl_lo(uint64_t i) {
+ return (i & 0xFFFFFFFF);
+}
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/system.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,169 @@
+#ifndef SYSTEM_H_
+#define SYSTEM_H_
+
+#include <time.h>
+#include "Types.h"
+#include "misc.h"
+
+extern double pi;
+
+typedef TDate* PDate;
+
+// dimension info for dynamic arrays
+typedef struct {
+ int dim;
+ int a[4]; // at most 4
+} fpcrtl_dimension_t;
+
+/*
+ * Copy returns a string which is a copy if the Count characters in S, starting at position Index.
+ * If Count is larger than the length of the string S, the result is truncated.
+ * If Index is larger than the length of the string S, then an empty string is returned.
+ * Index is 1-based.
+ */
+string255 fpcrtl_copy(string255 s, Integer Index, Integer Count);
+
+/*
+ * Delete removes Count characters from string S, starting at position Index.
+ * All characters after the deleted characters are shifted Count positions to the left,
+ * and the length of the string is adjusted.
+ */
+#define fpcrtl_delete(s, index, count) fpcrtl_delete__vars(&(s), index, count)
+void fpcrtl_delete__vars(string255 *s, SizeInt index, SizeInt count);
+
+string255 fpcrtl_floatToStr(double n);
+
+/*
+ * Move data from one location in memory to another
+ */
+void fpcrtl_move__vars(void *src, void *dst, SizeInt count);
+#define fpcrtl_move(src, dst, count) fpcrtl_move__vars(&(src), &(dst), count);
+#define fpcrtl_Move fpcrtl_move
+
+Integer __attribute__((overloadable)) fpcrtl_pos(Char c, string255 str);
+Integer __attribute__((overloadable)) fpcrtl_pos(string255 substr, string255 str);
+
+Integer fpcrtl_length(string255 s);
+#define fpcrtl_Length fpcrtl_length
+
+#define fpcrtl_sqr(x) ((x) * (x))
+
+#define fpcrtl_odd(x) ((x) % 2 != 0 ? true : false)
+
+#define fpcrtl_StrLen strlen
+
+#define SizeOf sizeof
+
+string255 fpcrtl_lowerCase(string255 s);
+#define fpcrtl_LowerCase fpcrtl_lowerCase
+
+void fpcrtl_fillChar__vars(void *x, SizeInt count, Byte value);
+#define fpcrtl_fillChar(x, count, value) fpcrtl_fillChar__vars(&(x), count, value)
+#define fpcrtl_FillChar fpcrtl_fillChar
+
+void fpcrtl_new__vars(void **p, int size);
+#define fpcrtl_new(a) fpcrtl_new__vars((void **)&(a), sizeof(*(a)))
+
+#define fpcrtl_dispose free
+
+#define fpcrtl_freeMem(p, size) free(p)
+#define fpcrtl_FreeMem(p, size) free(p)
+
+#define fpcrtl_getMem(size) malloc(size)
+#define fpcrtl_GetMem fpcrtl_getMem
+
+#define fpcrtl_assigned(p) ((p) != NULL)
+#define fpcrtl_Assigned fpcrtl_assigned
+
+Integer fpcrtl_trunc(extended n);
+
+#define fpcrtl_val(s, a) fpcrtl_val__vars(s, &(a))
+void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, LongInt *a);
+void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, Byte *a);
+void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, LongWord *a);
+
+#define fpcrtl_randomize() srand(time(NULL))
+
+/*
+ * Random returns a random number larger or equal to 0 and strictly less than L
+ */
+LongInt fpcrtl_random(LongInt l);
+
+string255 fpcrtl_paramStr(LongInt);
+#define fpcrtl_ParamStr fpcrtl_paramStr
+
+/*
+ * Str returns a string which represents the value of X. X can be any numerical type.
+ */
+#define fpcrtl_str(x, s) fpcrtl_str__vars(x, &(s))
+void __attribute__((overloadable)) fpcrtl_str__vars(float x, string255 *s);
+void __attribute__((overloadable)) fpcrtl_str__vars(double x, string255 *s);
+void __attribute__((overloadable)) fpcrtl_str__vars(uint8_t x, string255 *s);
+void __attribute__((overloadable)) fpcrtl_str__vars(int8_t x, string255 *s);
+void __attribute__((overloadable)) fpcrtl_str__vars(uint16_t x, string255 *s);
+void __attribute__((overloadable)) fpcrtl_str__vars(int16_t x, string255 *s);
+void __attribute__((overloadable)) fpcrtl_str__vars(uint32_t x, string255 *s);
+void __attribute__((overloadable)) fpcrtl_str__vars(int32_t x, string255 *s);
+void __attribute__((overloadable)) fpcrtl_str__vars(uint64_t x, string255 *s);
+void __attribute__((overloadable)) fpcrtl_str__vars(int64_t x, string255 *s);
+
+void fpcrtl_interlockedIncrement__vars(int *i);
+void fpcrtl_interlockedDecrement__vars(int *i);
+
+#define fpcrtl_interlockedIncrement(i) fpcrtl_interlockedIncrement__vars(&(i))
+#define fpcrtl_interlockedDecrement(i) fpcrtl_interlockedDecrement__vars(&(i))
+
+#define fpcrtl_InterlockedIncrement fpcrtl_interlockedIncrement
+#define fpcrtl_InterlockedDecrement fpcrtl_interlockedDecrement
+
+void fpcrtl_init(int argc, char** argv);
+
+int fpcrtl_paramCount();
+#define fpcrtl_ParamCount fpcrtl_paramCount
+
+string255 fpcrtl_paramStr(int i);
+#define fpcrtl_ParamStr fpcrtl_paramStr
+
+int fpcrtl_UTF8ToUnicode(PWideChar dest, PChar src, SizeInt maxLen);
+
+#define fpcrtl_halt(t) assert(0)
+
+#define fpcrtl_Load_GL_VERSION_2_0() 1
+
+uint32_t __attribute__((overloadable)) fpcrtl_lo(uint64_t);
+#define fpcrtl_Lo fpcrtl_lo
+
+#define __SET_LENGTH2(arr, d, b) do{\
+ d.dim = 1;\
+ arr = realloc(arr, b * sizeof(typeof(*arr)));\
+ d.a[0] = b;\
+ }while(0)
+
+#define SET_LENGTH2(arr, b) __SET_LENGTH2(arr, arr##_dimension_info, (b))
+
+#define __SET_LENGTH3(arr, d, b, c) do{\
+ d.dim = 2;\
+ for (int i = 0; i < d.a[0]; i++) {\
+ arr[i] = realloc(arr[i], c * sizeof(typeof(**arr)));\
+ }\
+ if (d.a[0] > b) {\
+ for (int i = b; i < d.a[0]; i++) {\
+ free(arr[i]);\
+ }\
+ arr = realloc(arr, b * sizeof(typeof(*arr)));\
+ } else if (d.a[0] < b) {\
+ arr = realloc(arr, b * sizeof(typeof(*arr)));\
+ for (int i = d.a[0]; i < b; i++) {\
+ arr[i] = malloc(c * sizeof(typeof(**arr)));\
+ memset(arr[i], 0, c * sizeof(typeof(**arr)));\
+ }\
+ }\
+ d.a[0] = b;\
+ d.a[1] = c;\
+ }while(0)
+
+#define SET_LENGTH3(arr, b, c) __SET_LENGTH3(arr, arr##_dimension_info, (b), (c))
+
+#define fpcrtl_SetLength(...) macro_dispatcher(SET_LENGTH, __VA_ARGS__)(__VA_ARGS__)
+
+#endif /* SYSTEM_H_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/sysutils.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,178 @@
+#include "SysUtils.h"
+
+#include <time.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "system.h"
+#include "misc.h"
+
+TDateTime fpcrtl_date()
+{
+ const int num_days_between_1900_1980 = 29220;
+
+ struct tm ref_date;
+ struct tm cur_date;
+ time_t local_time;
+ time_t ref_time, cur_time;
+
+ double timeDiff;
+ double day_time_frac; //fraction that represents the time in one day
+ int num_seconds;
+ int numDays;
+
+ // unix epoch doesn't work, choose Jan 1st 1980 instead
+ ref_date.tm_year = 80;
+ ref_date.tm_mon = 0;
+ ref_date.tm_mday = 1;
+ ref_date.tm_hour = 0;
+ ref_date.tm_min = 0;
+ ref_date.tm_sec = 0;
+ ref_date.tm_isdst = 0;
+ ref_date.tm_wday = 0; // ignored
+ ref_date.tm_yday = 0; // ignored
+
+ local_time = time(NULL);
+ cur_date = *localtime(&local_time);
+
+ cur_date.tm_hour = 0;
+ cur_date.tm_min = 0;
+ cur_date.tm_sec = 0;
+
+ ref_time = mktime(&ref_date);
+ cur_time = mktime(&cur_date);
+
+ timeDiff = difftime(cur_time, ref_time);
+ numDays = fpcrtl_round(timeDiff / 3600 / 24) + num_days_between_1900_1980 + 1;
+
+ fpcrtl_printf("[date] tim diff: %f\n", timeDiff);
+ fpcrtl_printf("[date] num days between 1980 and today: %d\n", fpcrtl_round(timeDiff/3600/24));
+ fpcrtl_printf("[date] current date: %s\n", asctime(&cur_date));
+ fpcrtl_printf("[date] reference date: %s\n", asctime(&ref_date));
+ fpcrtl_printf("[date] num days: %d\n", numDays);
+
+ return numDays;
+}
+
+TDateTime fpcrtl_time()
+{
+ struct tm cur_date;
+ time_t local_time;
+ time_t cur_time;
+
+ double day_time_frac; //fraction that represents the time in one day
+ int num_seconds;
+
+ local_time = time(NULL);
+ cur_date = *localtime(&local_time);
+
+ num_seconds = cur_date.tm_hour * 3600 + cur_date.tm_min * 60 + cur_date.tm_sec;
+ day_time_frac = num_seconds / 3600.0 / 24.0;
+
+ fpcrtl_printf("%f\n", day_time_frac);
+
+ return day_time_frac;
+}
+
+TDateTime fpcrtl_now()
+{
+ return fpcrtl_date() + fpcrtl_time();
+}
+
+/*
+ * XXX: dummy
+ */
+string255 fpcrtl_formatDateTime(string255 FormatStr, TDateTime DateTime)
+{
+ string255 result = STRINIT("2012 01-01");
+ return result;
+}
+
+string255 fpcrtl_trim(string255 s)
+{
+ int left, right;
+
+ if(s.len == 0){
+ return s;
+ }
+
+ for(left = 0; left < s.len; left++)
+ {
+ if(s.str[left] != ' '){
+ break;
+ }
+ }
+
+ for(right = s.len - 1; right >= 0; right--)
+ {
+ if(s.str[right] != ' '){
+ break;
+ }
+ }
+
+ if(left > right){
+ s.len = 0;
+ s.str[0] = 0;
+ return s;
+ }
+
+ s.len = right - left + 1;
+ memmove(s.str, s.str + left, s.len);
+
+ s.str[s.len] = 0;
+
+ return s;
+}
+
+Integer fpcrtl_strToInt(string255 s)
+{
+ s.str[s.len] = 0;
+ return atoi(s.str);
+}
+
+//function ExtractFileName(const FileName: string): string;
+//var
+// i : longint;
+// EndSep : Set of Char;
+//begin
+// I := Length(FileName);
+// EndSep:=AllowDirectorySeparators+AllowDriveSeparators;
+// while (I > 0) and not (FileName[I] in EndSep) do
+// Dec(I);
+// Result := Copy(FileName, I + 1, MaxInt);
+//end;
+
+string255 fpcrtl_extractFileName(string255 f)
+{
+ const char sep[] = {'\\', '/', ':'};
+ LongInt i,j;
+
+ i = f.len - 1;
+ while(i >= 0){
+ for(j = 0; j < sizeof(sep); j++){
+ if(f.str[i] == sep[j]){
+ goto FPCRTL_EXTRACTFILENAME_END;
+ }
+ }
+ i--;
+ }
+FPCRTL_EXTRACTFILENAME_END:
+ return fpcrtl_copy(f, i + 2, 256);
+}
+
+string255 fpcrtl_strPas(PChar p)
+{
+ string255 s;
+ int l = strlen(p);
+
+ if(l > 255){
+ printf("strPas: source string length > 255\n");
+ assert(0);
+ }
+
+ s.len = l;
+ strcpy(s.str, p);
+
+ return s;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_check.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,23 @@
+#include <check.h>
+#include <stdlib.h>
+#include "check_check.h"
+
+int main(void)
+{
+ int number_failed;
+
+ Suite *s1 = system_suite();
+ Suite *s2 = misc_suite();
+ Suite *s3 = sysutils_suite();
+ Suite *s4 = fileio_suite();
+
+ SRunner *sr = srunner_create(s1);
+ srunner_add_suite(sr, s2);
+ srunner_add_suite(sr, s3);
+ srunner_add_suite(sr, s4);
+
+ srunner_run_all(sr, CK_NORMAL);
+ number_failed = srunner_ntests_failed(sr);
+ srunner_free(sr);
+ return (number_failed == 0) ? EXIT_SUCCESS : EXIT_FAILURE;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_check.h Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,9 @@
+#ifndef _CHECK_CHECK_H_
+#define _CHECK_CHECK_H_
+
+Suite *system_suite();
+Suite *misc_suite();
+Suite *sysutils_suite();
+Suite *fileio_suite();
+
+#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_fileio.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,103 @@
+#include <check.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include "check_check.h"
+#include "../src/fpcrtl.h"
+
+typedef struct __TResourceList
+{
+ Integer count;
+ string255 files[500 + 1];
+} TResourceList;
+
+string255 t = STRINIT("test");
+string255 Pathz[1] =
+{ STRINIT("../../") };
+int ptCurrTheme = 0;
+string255 cThemeCFGFilename = STRINIT("theme.cfg");
+const string255 __str79 = STRINIT("object");
+string255 c1 = STRINIT("=");
+string255 c2 = STRINIT("\x2c");
+string255 c3 = STRINIT("\x2f");
+
+static string255 make_string(const char* str)
+{
+ string255 s;
+ s.len = strlen(str);
+ memcpy(s.str, str, s.len + 1);
+ return s;
+}
+
+TResourceList readThemeCfg_0()
+{
+ TResourceList readthemecfg_result;
+ string255 s;
+ string255 key;
+ TextFile f;
+ Integer i;
+ TResourceList res;
+
+ s = _strconcat(_strappend(Pathz[ptCurrTheme], '\x2f'), cThemeCFGFilename);
+ //umisc_log(s);
+
+ fpcrtl_assign(f, s);
+
+ FileMode = 0;
+ fpcrtl_reset(f);
+
+ res.count = 0;
+ while (!(fpcrtl_eof(f)))
+ {
+ fpcrtl_readLnS(f, s);
+ if ((fpcrtl_Length(s)) == (0))
+ {
+ continue;
+ }
+ if ((s.s[1]) == ('\x3b'))
+ {
+ continue;
+ }
+ i = fpcrtl_pos('\x3d', s);
+ key = fpcrtl_trim(fpcrtl_copy(s, 1, i - 1));
+ fpcrtl_delete(s, 1, i);
+ if (_strcompare(key, __str79))
+ {
+ i = fpcrtl_pos('\x2c', s);
+ res.files[res.count] = _strconcat(
+ _strappend(Pathz[ptCurrTheme], '\x2f'),
+ fpcrtl_trim(fpcrtl_copy(s, 1, i - 1)));
+ ++res.count;
+ //umisc_log(fpcrtl_trim(fpcrtl_copy(s, 1, i - 1)));
+ }
+ }
+ fpcrtl_close(f);
+ readthemecfg_result = res;
+ return readthemecfg_result;
+}
+
+START_TEST(test_readthemecfg)
+ {
+ int i;
+ TResourceList result;
+
+ printf("-----Entering test readthemecfg-----\n");
+ result = readThemeCfg_0();
+ for (i = 0; i < result.count; i++)
+ {
+ printf("%s\n", result.files[i].str);
+ }
+ printf("-----Leaving test readthemecfg-----\n");
+ }END_TEST
+
+Suite* fileio_suite(void)
+{
+ Suite *s = suite_create("fileio");
+
+ TCase *tc_core = tcase_create("Core");
+
+ tcase_add_test(tc_core, test_readthemecfg);
+
+ suite_add_tcase(s, tc_core);
+
+ return s;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_misc.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,88 @@
+#include <check.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include "check_check.h"
+#include "../src/misc.h"
+
+static string255 make_string(const char* str)
+{
+ string255 s;
+ s.len = strlen(str);
+ memcpy(s.str, str, s.len + 1);
+ return s;
+}
+
+START_TEST(test_strconcat)
+{
+ string255 t;
+ t = fpcrtl_strconcat(make_string(""), make_string(""));
+ fail_if(strcmp(t.str, ""), "strconcat(\"\", \"\")");
+
+ t = fpcrtl_strconcat(make_string(""), make_string("a"));
+ fail_if(strcmp(t.str, "a"), "strconcat(\"\", \"a\")");
+
+ t = fpcrtl_strconcat(make_string("a"), make_string(""));
+ fail_if(strcmp(t.str, "a"), "strconcat(\"a\", \"\")");
+
+ t = fpcrtl_strconcat(make_string("ab"), make_string(""));
+ fail_if(strcmp(t.str, "ab"), "strconcat(\"ab\", \"\")");
+
+ t = fpcrtl_strconcat(make_string("ab"), make_string("cd"));
+ fail_if(strcmp(t.str, "abcd"), "strconcat(\"ab\", \"cd\")");
+}
+END_TEST
+
+START_TEST (test_strappend)
+{
+ string255 t;
+
+ t = fpcrtl_strappend(make_string(""), 'c');
+ fail_if(strcmp(t.str, "c"), "strappend(\"\", 'c')");
+
+ t = fpcrtl_strappend(make_string("ab"), 'c');
+ fail_if(strcmp(t.str, "abc"), "strappend(\"ab\", 'c')");
+}
+END_TEST
+
+START_TEST (test_strprepend)
+{
+ string255 t;
+
+ t = fpcrtl_strprepend('c', make_string(""));
+ fail_if(strcmp(t.str, "c"), "strprepend('c', \"\")");
+
+ t = fpcrtl_strprepend('c', make_string("ab"));
+ fail_if(strcmp(t.str, "cab"), "strprepend('c', \"ab\")");
+}
+END_TEST
+
+START_TEST (test_strcompare)
+{
+ fail_unless(fpcrtl_strcompare(make_string(""), make_string("")), "strcompare(\"\", \"\")");
+ fail_unless(fpcrtl_strcompare(make_string("a"), make_string("a")), "strcompare(\"a\", \"a\"");
+ fail_unless(!fpcrtl_strcompare(make_string("a"), make_string("b")), "strcompare(\"a\", \"b\")");
+ fail_unless(!fpcrtl_strcompare(make_string("a"), make_string("ab")), "strcompare(\"a\", \"ab\")");
+
+ fail_unless(fpcrtl_strcomparec(make_string(" "), ' '), "strcomparec(\" \", ' ')");
+ fail_unless(fpcrtl_strcomparec(make_string("a"), 'a'), "strcomparec(\"a\", 'a')");
+ fail_unless(!fpcrtl_strcomparec(make_string(" "), ' '), "strcomparec(\" \", ' '");
+ fail_unless(!fpcrtl_strcomparec(make_string(""), ' '), "strcomparec(\"\", ' ')");
+
+}
+END_TEST
+
+Suite* misc_suite(void)
+{
+ Suite *s = suite_create("misc");
+
+ TCase *tc_core = tcase_create("Core");
+
+ tcase_add_test(tc_core, test_strconcat);
+ tcase_add_test(tc_core, test_strappend);
+ tcase_add_test(tc_core, test_strprepend);
+ tcase_add_test(tc_core, test_strcompare);
+
+ suite_add_tcase(s, tc_core);
+
+ return s;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_system.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,251 @@
+#include <check.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include "check_check.h"
+#include "../src/system.h"
+
+void check_string(string255 str)
+{
+ fail_unless(strlen(str.str) == str.len, "String internal inconsistency error");
+}
+
+static string255 make_string(const char* str)
+{
+ string255 s;
+ s.len = strlen(str);
+ memcpy(s.str, str, s.len + 1);
+ return s;
+}
+
+START_TEST (test_copy)
+ {
+ string255 s = STRINIT("1234567");
+ string255 t;
+
+ t = fpcrtl_copy(s, 1, 1);
+ fail_if(strcmp(t.str, "1"), "Test copy fail 1");
+
+ t = fpcrtl_copy(s, 7, 1);
+ fail_if(strcmp(t.str, "7"), "Test copy fail 2");
+
+ t = fpcrtl_copy(s, 8, 1);
+ fail_if(t.len != 0, "Test copy fail 3");
+
+ t = fpcrtl_copy(s, 8, 100);
+ fail_if(t.len != 0, "Test copy fail 4");
+ check_string(t);
+
+ t = fpcrtl_copy(s, 0, 100);
+ fail_if(strcmp(t.str, "1234567"), "Test copy fail 5");
+
+ t = fpcrtl_copy(s, 0, 5);
+ fail_if(strcmp(t.str, "12345"), "Test copy fail 6");
+
+ t = fpcrtl_copy(s, 4, 100);
+ fail_if(strcmp(t.str, "4567"), "Test copy fail 7");
+
+ t = fpcrtl_copy(s, 4, 2);
+ fail_if(strcmp(t.str, "45"), "Test copy fail 8");
+ }END_TEST
+
+START_TEST (test_delete)
+ {
+ string255 s = STRINIT("1234567");
+ string255 s2 = STRINIT("1234567");
+ string255 s3 = STRINIT("1234567");
+
+ fpcrtl_delete(s, 0, 10);
+ fail_if(strcmp(s.str, "1234567"), "delete(\"1234567\", 0, 10)");
+ check_string(s);
+
+ fpcrtl_delete(s, 1, 1);
+ fail_if(strcmp(s.str, "234567"), "delete(\"1234567\", 1, 1)");
+ check_string(s);
+
+ fpcrtl_delete(s, 1, 100);
+ fail_if(strcmp(s.str, ""), "delete(\"234567\", 1, 100)");
+ check_string(s);
+
+ fpcrtl_delete(s2, 3, 2);
+ fail_if(strcmp(s2.str, "12567"), "delete(\"1234567\", 3, 2)");
+ check_string(s2);
+
+ fpcrtl_delete(s3, 3, 100);
+ fail_if(strcmp(s3.str, "12"), "delete(\"1234567\", 3, 100)");
+ check_string(s3);
+
+ }
+END_TEST
+
+START_TEST (test_FloatToStr)
+ {
+ double s = 1.2345;
+ string255 t = fpcrtl_floatToStr(s);
+ printf("-----Entering test floatToStr-----\n");
+ printf("FloatToStr(%f) = %s\n", s, t.str);
+ printf("-----Leaving test floatToStr-----\n");
+ }
+END_TEST
+
+START_TEST (test_random)
+ {
+ fpcrtl_randomize();
+ printf("-----Entering test random-----\n");
+ printf("random(5000) = %d\n", fpcrtl_random(5000));
+ printf("random(1) = %d\n", fpcrtl_random(1));
+ printf("random(2) = %d\n", fpcrtl_random(2));
+ printf("-----Leaving test random-----\n");
+
+ }
+END_TEST
+
+START_TEST (test_posS)
+ {
+ string255 substr1 = STRINIT("123");
+ string255 str1 = STRINIT("12345");
+
+ string255 substr2 = STRINIT("45");
+ string255 str2 = STRINIT("12345");
+
+ string255 substr3 = STRINIT("");
+ string255 str3 = STRINIT("12345");
+
+ string255 substr4 = STRINIT("123");
+ string255 str4 = STRINIT("");
+
+ string255 substr5 = STRINIT("123");
+ string255 str5 = STRINIT("456");
+
+ fail_unless(fpcrtl_posS(substr1, str1) == 1, "pos(123, 12345)");
+ fail_unless(fpcrtl_posS(substr2, str2) == 4, "pos(45, 12345)");
+ fail_unless(fpcrtl_posS(substr3, str3) == 0, "pos(, 12345)");
+ fail_unless(fpcrtl_posS(substr4, str4) == 0, "pos(123, )");
+ fail_unless(fpcrtl_posS(substr5, str5) == 0, "pos(123, 456)");
+ }
+END_TEST
+
+START_TEST (test_trunc)
+ {
+ fail_unless(fpcrtl_trunc(123.456) == 123, "trunc(123.456)");
+ fail_unless(fpcrtl_trunc(-123.456) == -123, "trunc(-123.456)");
+ fail_unless(fpcrtl_trunc(12.3456) == 12, "trunc(12.3456)");
+ fail_unless(fpcrtl_trunc(-12.3456) == -12, "trunc(-12.3456)");
+ }
+END_TEST
+
+START_TEST (test_odd)
+{
+ fail_unless(fpcrtl_odd(123) != 0, "odd(123)");
+ fail_unless(fpcrtl_odd(124) == 0, "odd(124)");
+ fail_unless(fpcrtl_odd(0) == 0, "odd(0)");
+ fail_unless(fpcrtl_odd(-1) != 0, "odd(-1)");
+ fail_unless(fpcrtl_odd(-2) == 0, "odd(-2)");
+}
+END_TEST
+
+START_TEST (test_sqr)
+{
+ fail_unless(fpcrtl_sqr(0) == 0, "sqr(0)");
+ fail_unless(fpcrtl_sqr(5) == 25, "sqr(5)");
+ fail_unless(fpcrtl_sqr(-5) == 25, "sqr(-5)");
+}
+END_TEST
+
+START_TEST (test_lowercase)
+{
+ string255 s1 = STRINIT("");
+ string255 s2 = STRINIT("a");
+ string255 s3 = STRINIT("abc");
+ string255 t;
+
+ t = fpcrtl_lowerCase(make_string(""));
+ fail_if(strcmp(t.str, s1.str), "lowerCase(\"\")");
+
+ t = fpcrtl_lowerCase(make_string("a"));
+ fail_if(strcmp(t.str, s2.str), "lowerCase(\"a\")");
+
+ t = fpcrtl_lowerCase(make_string("A"));
+ fail_if(strcmp(t.str, s2.str), "lowerCase(\"A\")");
+
+ t = fpcrtl_lowerCase(make_string("AbC"));
+ fail_if(strcmp(t.str, s3.str), "lowerCase(\"AbC\")");
+
+ t = fpcrtl_lowerCase(make_string("abc"));
+ fail_if(strcmp(t.str, s3.str), "lowerCase(\"abc\")");
+}
+END_TEST
+
+START_TEST (test_str)
+{
+ int8_t a1 = -8;
+ uint8_t a2 = 8;
+ int16_t a3 = -13;
+ uint16_t a4 = 13;
+ int32_t a5 = -19;
+ uint32_t a6 = 22;
+ int64_t a7 = -199999999999999;
+ uint64_t a8 = 200000000000000;
+
+ float a9 = 12345.6789;
+ double a10 = -9876.54321;
+
+ string255 s;
+
+ printf("-----Entering test str-----\n");
+
+ fpcrtl_str(a1, s);
+ printf("%d == %s\n", a1, s.str);
+
+ fpcrtl_str(a2, s);
+ printf("%u == %s\n", a2, s.str);
+
+ fpcrtl_str(a3, s);
+ printf("%d == %s\n", a3, s.str);
+
+ fpcrtl_str(a4, s);
+ printf("%u == %s\n", a4, s.str);
+
+ fpcrtl_str(a5, s);
+ printf("%d == %s\n", a5, s.str);
+
+ fpcrtl_str(a6, s);
+ printf("%u == %s\n", a6, s.str);
+
+ fpcrtl_str(a7, s);
+ printf("%lld == %s\n", a7, s.str);
+
+ fpcrtl_str(a8, s);
+ printf("%llu == %s\n", a8, s.str);
+
+ fpcrtl_str(a9, s);
+ printf("%f == %s\n", a9, s.str);
+
+ fpcrtl_str(a10, s);
+ printf("%f == %s\n", a10, s.str);
+
+ printf("-----Leaving test str------\n");
+}
+END_TEST
+
+Suite* system_suite(void)
+{
+ Suite *s = suite_create("system");
+
+ TCase *tc_core = tcase_create("Core");
+
+ tcase_add_test(tc_core, test_copy);
+ tcase_add_test(tc_core, test_FloatToStr);
+ tcase_add_test(tc_core, test_random);
+ tcase_add_test(tc_core, test_posS);
+ tcase_add_test(tc_core, test_trunc);
+ tcase_add_test(tc_core, test_delete);
+ tcase_add_test(tc_core, test_odd);
+ tcase_add_test(tc_core, test_sqr);
+ tcase_add_test(tc_core, test_lowercase);
+ tcase_add_test(tc_core, test_str);
+
+ suite_add_tcase(s, tc_core);
+
+ return s;
+}
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_sysutils.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,80 @@
+#include <check.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include "check_check.h"
+#include "../src/sysutils.h"
+
+static string255 make_string(const char* str)
+{
+ string255 s;
+ s.len = strlen(str);
+ memcpy(s.str, str, s.len + 1);
+ return s;
+}
+
+static int is_string_equal(string255 s1, string255 s2)
+{
+ return (s1.len == s2.len) && (strcmp(s1.str, s2.str) == 0);
+}
+
+START_TEST (test_trim)
+{
+ string255 t;
+
+ t = fpcrtl_trim(make_string(""));
+ fail_if(strcmp(t.str, ""), "trim(\"\")");
+
+ t = fpcrtl_trim(make_string("ab"));
+ fail_if(strcmp(t.str, "ab"), "trim(\"ab\")");
+
+ t = fpcrtl_trim(make_string(" "));
+ fail_if(strcmp(t.str, ""), "trim(\" \")");
+
+ t = fpcrtl_trim(make_string(" "));
+ fail_if(strcmp(t.str, ""), "trim(\" \")");
+
+ t = fpcrtl_trim(make_string(" ab"));
+ fail_if(strcmp(t.str, "ab"), "trim(\" ab\")");
+
+ t = fpcrtl_trim(make_string("ab "));
+ fail_if(strcmp(t.str, "ab"), "trim(\"ab \")");
+
+ t = fpcrtl_trim(make_string(" ab "));
+ fail_if(strcmp(t.str, "ab"), "trim(\" ab \")");
+
+}
+END_TEST
+
+START_TEST (test_strToInt)
+{
+ fail_unless(fpcrtl_strToInt(make_string("123")) == 123, "strToInt(\"123\")");
+ fail_unless(fpcrtl_strToInt(make_string("0")) == 0, "strToInt(\"0\")");
+ fail_unless(fpcrtl_strToInt(make_string("-123")) == -123, "strToInt(\"-123\")");
+}
+END_TEST
+
+START_TEST (test_extractFileName)
+{
+ fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("abc")), make_string("abc")), "extractFileName(\"abc\")");
+ fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("a:abc")), make_string("abc")), "extractFileName(\"a:abc\")");
+ fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("/abc")), make_string("abc")), "extractFileName(\"/abc\")");
+ fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("\\abc")), make_string("abc")), "extractFileName(\"\\abc\")");
+ fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("/usr/bin/abc")), make_string("abc")), "extractFileName(\"/usr/bin/abc\")");
+ fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("c:\\def\\abc")), make_string("abc")), "extractFileName(\"c:\\def\\abc\")");
+}
+END_TEST
+
+Suite* sysutils_suite(void)
+{
+ Suite *s = suite_create("sysutils");
+
+ TCase *tc_core = tcase_create("Core");
+
+ tcase_add_test(tc_core, test_trim);
+ tcase_add_test(tc_core, test_strToInt);
+ tcase_add_test(tc_core, test_extractFileName);
+
+ suite_add_tcase(s, tc_core);
+
+ return s;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/fileio_test.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,59 @@
+
+#include "pas2c.h"
+
+#include "fpcrtl.h"
+
+char Pathz[1][128] = {"./"};
+int ptCurrTheme = 0;
+cThemeCFGFilename = "theme.cfg";
+const string255 __str79 = STRINIT("object");
+
+typedef struct __TResourceList {
+ Integer count;
+ string255 files[500 + 1];
+} TResourceList;
+
+TResourceList readThemeCfg_0()
+{
+ TResourceList readthemecfg_result;
+ string255 s;
+ string255 key;
+ TextFile f;
+ Integer i;
+ TResourceList result;
+ s = _strconcat(_strappend(Pathz[ptCurrTheme], '\x2f'), cThemeCFGFilename);
+
+ assign(f, s);
+ FileMode = 0;
+ reset(f);
+ result.count = 0;
+ while(!eof(f))
+ {
+ readLnS(f, s);
+ if((Length(s)) == (0))
+ {
+ continue;
+ }
+ if((s.s[1]) == ('\x3b'))
+ {
+ continue;
+ }
+ i = pos('\x3d', s);
+ key = trim(copy(s, 1, i - 1));
+ delete(s, 1, i);
+ if(_strcompare(key, __str79))
+ {
+ i = pos('\x2c', s);
+ result.files[result.count] = _strconcat(_strappend(Pathz[ptCurrTheme], '\x2f'), trim(copy(s, 1, i - 1)));
+ ++result.count;
+ }
+ }
+ close(f);
+ readthemecfg_result = result;
+ return readthemecfg_result;
+};
+
+int main(int argc, char** argv)
+{
+ readThemeCfg_0();
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/main.c Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,80 @@
+#if 0
+#include <stdio.h>
+#include "fpcrtl.h"
+#include "fileio.h"
+
+string255 t = STRINIT("test");
+string255 Pathz[1] = {STRINIT(".")};
+//int ptCurrTheme = 0;
+string255 cThemeCFGFilename = STRINIT("theme.cfg");
+const string255 __str79 = STRINIT("object");
+string255 c1 = STRINIT("=");
+string255 c2 = STRINIT("\x2c");
+string255 c3 = STRINIT("\x2f");
+
+typedef struct __TResourceList {
+ Integer count;
+ string255 files[500 + 1];
+} TResourceList;
+
+TResourceList readThemeCfg_0()
+{
+ TResourceList readthemecfg_result;
+ string255 s;
+ string255 key;
+ TextFile f;
+ Integer i;
+ TResourceList result;
+
+ int t = 0;
+
+ s = _strconcat(_strappend(Pathz[ptCurrTheme], '\x2f'), cThemeCFGFilename);
+
+ assign(&f, s);
+
+ reset(&f);
+
+ if (f.fp == NULL) {
+ readthemecfg_result.count = 0;
+ return readthemecfg_result;
+ }
+
+ result.count = 0;
+ while (!eof(&f)) {
+ readLnS(&f, &s);
+
+ if ((Length(s)) == (0)) {
+ continue;
+ }
+ if ((s.s[1]) == ('\x3b')) {
+ continue;
+ }
+
+ i = pos(c1, s);
+
+ key = fpcrtl_trim(fpcrtl_copy(s, 1, i - 1));
+
+ fpcrtl_delete(&s, 1, i);
+
+ if (_strcompare(key, __str79)) {
+ i = pos(c2, s);
+ result.files[result.count] = _strconcat(_strappend(Pathz[ptCurrTheme], '\x2f'), trim(copy(s, 1, i - 1)));
+ ++result.count;
+ }
+ }
+
+ close(&f);
+ readthemecfg_result = result;
+ return readthemecfg_result;
+}
+
+int main(int argc, char** argv)
+{
+ int i;
+
+ TResourceList result = readThemeCfg_0();
+ for(i = 0; i < result.count; i++) {
+ printf("%s\n", result.files[i].str);
+ }
+}
+#endif
--- a/share/hedgewars/Data/CMakeLists.txt Sun Jan 19 00:18:28 2014 +0400
+++ b/share/hedgewars/Data/CMakeLists.txt Tue Jan 21 22:38:13 2014 +0100
@@ -1,3 +1,7 @@
foreach(dir "Fonts" "Forts" "Graphics" "Locale" "Maps" "Music" "Sounds" "Themes" "Missions" "Names" "misc" "Scripts")
- add_subdirectory(${dir})
+ add_subdirectory(${dir})
endforeach(dir)
+
+if(${GL2})
+ add_subdirectory(Shaders)
+endif(${GL2})
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/share/hedgewars/Data/Shaders/CMakeLists.txt Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,7 @@
+file(GLOB vertshaders *.vs)
+file(GLOB fragshaders *.fs)
+
+install(FILES
+ ${vertshaders}
+ ${fragshaders}
+ DESTINATION ${SHAREPATH}Data/Shaders)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/share/hedgewars/Data/Shaders/default.fs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,15 @@
+uniform sampler2D tex0;
+uniform vec4 tint;
+uniform bool enableTexture;
+
+varying vec2 tex;
+
+
+void main()
+{
+ if(enableTexture){
+ gl_FragColor = texture2D(tex0, tex) * tint;
+ }else{
+ gl_FragColor = tint;
+ }
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/share/hedgewars/Data/Shaders/default.vs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,16 @@
+
+
+attribute vec2 vertex;
+attribute vec2 texcoord;
+attribute vec4 colors;
+
+varying vec2 tex;
+
+uniform mat4 mvp;
+
+void main()
+{
+ vec4 p = mvp * vec4(vertex, 0.0, 1.0);
+ gl_Position = p;
+ tex = texcoord;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/share/hedgewars/Data/Shaders/water.fs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,8 @@
+
+varying vec4 vcolor;
+
+
+void main()
+{
+ gl_FragColor = vcolor;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/share/hedgewars/Data/Shaders/water.vs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,15 @@
+
+
+attribute vec2 vertex;
+attribute vec4 color;
+
+varying vec4 vcolor;
+
+uniform mat4 mvp;
+
+void main()
+{
+ vec4 p = mvp * vec4(vertex, 0.0, 1.0);
+ gl_Position = p;
+ vcolor = color;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/CMakeLists.txt Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,31 @@
+find_package(GHC REQUIRED)
+
+set(pas2c_sources
+ Main.hs
+ PascalBasics.hs
+ PascalParser.hs
+ PascalPreprocessor.hs
+ PascalUnitSyntaxTree.hs
+ Pas2C.hs
+ )
+
+set(pas2c_main ${CMAKE_SOURCE_DIR}/tools/pas2c/Main.hs)
+
+set(ghc_flags
+ --make ${pas2c_main}
+ -i${CMAKE_SOURCE_DIR}/tools/pas2c/
+ -o ${EXECUTABLE_OUTPUT_PATH}/pas2c${CMAKE_EXECUTABLE_SUFFIX}
+ -odir ${CMAKE_CURRENT_BINARY_DIR}
+ -hidir ${CMAKE_CURRENT_BINARY_DIR}
+ ${haskell_flags}
+ )
+
+add_custom_command(OUTPUT "${EXECUTABLE_OUTPUT_PATH}/pas2c${CMAKE_EXECUTABLE_SUFFIX}"
+ COMMAND "${GHC_EXECUTABLE}"
+ ARGS ${ghc_flags}
+ MAIN_DEPENDENCY ${hwserv_main}
+ DEPENDS ${hwserver_sources}
+ )
+
+add_custom_target(pas2c ALL DEPENDS "${EXECUTABLE_OUTPUT_PATH}/pas2c${CMAKE_EXECUTABLE_SUFFIX}")
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/Main.hs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,82 @@
+module Main( main ) where
+
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+import System.IO
+import Data.Maybe( fromMaybe, isJust, fromJust )
+import Data.List (find, intercalate)
+import Control.Monad
+import Pas2C
+
+main = do
+ args <- getArgs
+ if length args == 0
+ then do
+ name <- getProgName
+ hPutStrLn stderr $ usageInfo header options
+ exitFailure
+ else do
+ case getOpt RequireOrder options args of
+ (flags, [], []) | enoughFlags flags -> do
+ let m = flag flags isName
+ let i = flag flags isInput
+ let o = flag flags isOutput
+ let a = fromMaybe o $ liftM extractString $ find isAlt flags
+ let symbols = ["PAS2C", "FPC"] ++ (map extractString $ filter isSymbol flags)
+ hPutStrLn stdout $ "--------Pas2C Config--------"
+ hPutStrLn stdout $ "Main module: " ++ m
+ hPutStrLn stdout $ "Input path : " ++ i
+ hPutStrLn stdout $ "Output path: " ++ o
+ hPutStrLn stdout $ "Altern path: " ++ a
+ hPutStrLn stdout $ "Symbols defined: " ++ (intercalate ", " symbols)
+ hPutStrLn stdout $ "----------------------------"
+ pas2C m (i++"/") (o++"/") (a++"/") symbols
+ hPutStrLn stdout $ "----------------------------"
+ | otherwise -> error $ usageInfo header options
+ (_, nonOpts, []) -> error $ "unrecognized arguments: " ++ unwords nonOpts
+ (_, _, msgs) -> error $ usageInfo header options
+ where
+ header = "Freepascal to C conversion! Please specify -n -i -o options.\n"
+ enoughFlags f = and $ map (isJust . flip find f) [isName, isInput, isOutput]
+ flag f = extractString . fromJust . flip find f
+
+
+data Flag = HelpMessage
+ | Name String
+ | Input String
+ | Output String
+ | Alternate String
+ | Symbol String
+
+
+extractString :: Flag -> String
+extractString (Name s) = s
+extractString (Input s) = s
+extractString (Output s) = s
+extractString (Alternate s) = s
+extractString (Symbol s) = s
+extractString _ = undefined
+
+isName, isInput, isOutput, isAlt, isSymbol :: Flag -> Bool
+isName (Name _) = True
+isName _ = False
+isInput (Input _) = True
+isInput _ = False
+isOutput (Output _) = True
+isOutput _ = False
+isAlt (Alternate _) = True
+isAlt _ = False
+isSymbol (Symbol _) = True
+isSymbol _ = False
+
+options :: [OptDescr Flag]
+options = [
+ Option ['h'] ["help"] (NoArg HelpMessage) "print this help message",
+ Option ['n'] ["name"] (ReqArg Name "MAIN") "name of the main Pascal module",
+ Option ['i'] ["input"] (ReqArg Input "DIR") "input directory, where .pas files will be read",
+ Option ['o'] ["output"] (ReqArg Output "DIR") "output directory, where .c/.h files will be written",
+ Option ['a'] ["alternate"] (ReqArg Alternate "DIR") "alternate input directory, for out of source builds",
+ Option ['d'] ["define"] (ReqArg Symbol "SYMBOL") "define symbol"
+ ]
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/Pas2C.hs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,1174 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Pas2C where
+
+import Text.PrettyPrint.HughesPJ
+import Data.Maybe
+import Data.Char
+import Text.Parsec.Prim hiding (State)
+import Control.Monad.State
+import System.IO
+import System.Directory
+import Control.Monad.IO.Class
+import PascalPreprocessor
+import Control.Exception
+import System.IO.Error
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.List (find)
+import Numeric
+
+import PascalParser(pascalUnit)
+import PascalUnitSyntaxTree
+
+
+data InsertOption =
+ IOInsert
+ | IOInsertWithType Doc
+ | IOLookup
+ | IOLookupLast
+ | IOLookupFunction Int
+ | IODeferred
+
+data Record = Record
+ {
+ lcaseId :: String,
+ baseType :: BaseType,
+ typeDecl :: Doc
+ }
+ deriving Show
+type Records = Map.Map String [Record]
+data RenderState = RenderState
+ {
+ currentScope :: Records,
+ lastIdentifier :: String,
+ lastType :: BaseType,
+ isFunctionType :: Bool, -- set to true if the current function parameter is functiontype
+ lastIdTypeDecl :: Doc,
+ stringConsts :: [(String, String)],
+ uniqCounter :: Int,
+ toMangle :: Set.Set String,
+ enums :: [(String, [String])], -- store all declared enums
+ currentUnit :: String,
+ currentFunctionResult :: String,
+ namespaces :: Map.Map String Records
+ }
+
+rec2Records = map (\(a, b) -> Record a b empty)
+
+emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" ""
+
+getUniq :: State RenderState Int
+getUniq = do
+ i <- gets uniqCounter
+ modify(\s -> s{uniqCounter = uniqCounter s + 1})
+ return i
+
+addStringConst :: String -> State RenderState Doc
+addStringConst str = do
+ strs <- gets stringConsts
+ let a = find ((==) str . snd) strs
+ if isJust a then
+ do
+ modify (\s -> s{lastType = BTString})
+ return . text . fst . fromJust $ a
+ else
+ do
+ i <- getUniq
+ let sn = "__str" ++ show i
+ modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})
+ return $ text sn
+
+escapeStr :: String -> String
+escapeStr = foldr escapeChar []
+
+escapeChar :: Char -> ShowS
+escapeChar '"' s = "\\\"" ++ s
+escapeChar '\\' s = "\\\\" ++ s
+escapeChar a s = a : s
+
+strInit :: String -> Doc
+strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
+
+renderStringConsts :: State RenderState Doc
+renderStringConsts = liftM (vcat . map (\(a, b) -> text "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
+ $ gets stringConsts
+
+docToLower :: Doc -> Doc
+docToLower = text . map toLower . render
+
+pas2C :: String -> String -> String -> String -> [String] -> IO ()
+pas2C fn inputPath outputPath alternateInputPath symbols = do
+ s <- flip execStateT initState $ f fn
+ renderCFiles s outputPath
+ where
+ printLn = liftIO . hPutStrLn stdout
+ print = liftIO . hPutStr stdout
+ initState = Map.empty
+ f :: String -> StateT (Map.Map String PascalUnit) IO ()
+ f fileName = do
+ processed <- gets $ Map.member fileName
+ unless processed $ do
+ print ("Preprocessing '" ++ fileName ++ ".pas'... ")
+ fc' <- liftIO
+ $ tryJust (guard . isDoesNotExistError)
+ $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols
+ case fc' of
+ (Left a) -> do
+ modify (Map.insert fileName (System []))
+ printLn "doesn't exist"
+ (Right fc) -> do
+ print "ok, parsing... "
+ let ptree = parse pascalUnit fileName fc
+ case ptree of
+ (Left a) -> do
+ liftIO $ writeFile (outputPath ++ "preprocess.out") fc
+ printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
+ fail "stop"
+ (Right a) -> do
+ printLn "ok"
+ modify (Map.insert fileName a)
+ mapM_ f (usesFiles a)
+
+
+renderCFiles :: Map.Map String PascalUnit -> String -> IO ()
+renderCFiles units outputPath = do
+ let u = Map.toList units
+ let nss = Map.map (toNamespace nss) units
+ --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss)
+ --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss
+ mapM_ (toCFiles outputPath nss) u
+ where
+ toNamespace :: Map.Map String Records -> PascalUnit -> Records
+ toNamespace nss (System tvs) =
+ currentScope $ execState f (emptyState nss)
+ where
+ f = do
+ checkDuplicateFunDecls tvs
+ mapM_ (tvar2C True False True False) tvs
+ toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them
+ currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"}
+ where
+ f = do
+ checkDuplicateFunDecls tvs
+ mapM_ (tvar2C True False True False) tvs
+ toNamespace _ (Program {}) = Map.empty
+ toNamespace nss (Unit (Identifier i _) interface _ _ _) =
+ currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"}
+
+withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
+withState' f sf = do
+ st <- liftM f get
+ let (a, s) = runState sf st
+ modify(\st -> st{
+ lastType = lastType s
+ , uniqCounter = uniqCounter s
+ , stringConsts = stringConsts s
+ })
+ return a
+
+withLastIdNamespace f = do
+ li <- gets lastIdentifier
+ nss <- gets namespaces
+ withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
+
+withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
+withRecordNamespace _ [] = error "withRecordNamespace: empty record"
+withRecordNamespace prefix recs = withState' f
+ where
+ f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
+ records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs
+ un [a] b = a : b
+
+toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()
+toCFiles _ _ (_, System _) = return ()
+toCFiles _ _ (_, Redo _) = return ()
+toCFiles outputPath ns p@(fn, pu) = do
+ hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."
+ toCFiles' p
+ where
+ toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
+ toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do
+ let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}
+ (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
+ enumDecl = (renderEnum2Strs (enums s) False)
+ enumImpl = (renderEnum2Strs (enums s) True)
+ writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl
+ writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl
+ initialState = emptyState ns
+
+ render2C :: RenderState -> State RenderState Doc -> String
+ render2C st p =
+ let (a, s) = runState p st in
+ render a
+
+renderEnum2Strs :: [(String, [String])] -> Bool -> String
+renderEnum2Strs enums implement =
+ render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums
+ where
+ decl id = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id <+> text "enumvar")
+ enum2strBlock en =
+ text "{"
+ $+$
+ (nest 4 $
+ text "switch(enumvar){"
+ $+$
+ (foldl ($+$) empty $ map (\e -> text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en)
+ $+$
+ text "default: assert(0);"
+ $+$
+ (nest 4 $ text "return fpcrtl_make_string(\"nonsense\");")
+ $+$
+ text "}"
+ )
+ $+$
+ text "}"
+
+usesFiles :: PascalUnit -> [String]
+usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses
+usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
+usesFiles (System {}) = []
+usesFiles (Redo {}) = []
+
+pascal2C :: PascalUnit -> State RenderState Doc
+pascal2C (Unit _ interface implementation init fin) =
+ liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
+
+pascal2C (Program _ implementation mainFunction) = do
+ impl <- implementation2C implementation
+ [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" (BTInt True)) False False (SimpleType $ Identifier "int" (BTInt True)) [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction)))
+
+ return $ impl $+$ main
+
+
+-- the second bool indicates whether do normal interface translation or generate variable declarations
+-- that will be inserted into implementation files
+interface2C :: Interface -> Bool -> State RenderState Doc
+interface2C (Interface uses tvars) True = do
+ u <- uses2C uses
+ tv <- typesAndVars2C True True True tvars
+ r <- renderStringConsts
+ return (u $+$ r $+$ tv)
+interface2C (Interface uses tvars) False = do
+ u <- uses2C uses
+ tv <- typesAndVars2C True False False tvars
+ r <- renderStringConsts
+ return tv
+
+implementation2C :: Implementation -> State RenderState Doc
+implementation2C (Implementation uses tvars) = do
+ u <- uses2C uses
+ tv <- typesAndVars2C True False True tvars
+ r <- renderStringConsts
+ return (u $+$ r $+$ tv)
+
+checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
+checkDuplicateFunDecls tvs =
+ modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
+ where
+ initMap = Map.empty
+ --initMap = Map.fromList [("reset", 2)]
+ ins (FunctionDeclaration (Identifier i _) _ _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
+ ins _ m = m
+
+-- the second bool indicates whether declare variable as extern or not
+-- the third bool indicates whether include types or not
+
+typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc
+typesAndVars2C b externVar includeType(TypesAndVars ts) = do
+ checkDuplicateFunDecls ts
+ liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts
+
+setBaseType :: BaseType -> Identifier -> Identifier
+setBaseType bt (Identifier i _) = Identifier i bt
+
+uses2C :: Uses -> State RenderState Doc
+uses2C uses@(Uses unitIds) = do
+
+ mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
+ mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)
+ mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
+ return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
+ where
+ injectNamespace (Identifier i _) = do
+ getNS <- gets (flip Map.lookup . namespaces)
+ modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s})
+
+uses2List :: Uses -> [String]
+uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
+
+
+setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
+
+id2C :: InsertOption -> Identifier -> State RenderState Doc
+id2C IOInsert i = id2C (IOInsertWithType empty) i
+id2C (IOInsertWithType d) (Identifier i t) = do
+ ns <- gets currentScope
+ tom <- gets (Set.member n . toMangle)
+ cu <- gets currentUnit
+ let (i', t') = case (t, tom) of
+ (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t)
+ (BTFunction _ _ _, _) -> (cu ++ i, t)
+ (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')
+ _ -> (i, t)
+ modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
+ return $ text i'
+ where
+ n = map toLower i
+
+id2C IOLookup i = id2CLookup head i
+id2C IOLookupLast i = id2CLookup last i
+id2C (IOLookupFunction params) (Identifier i t) = do
+ let i' = map toLower i
+ v <- gets $ Map.lookup i' . currentScope
+ lt <- gets lastType
+ if isNothing v then
+ error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
+ else
+ let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
+ modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
+ where
+ checkParam (Record _ (BTFunction _ p _) _) = (length p) == params
+ checkParam _ = False
+id2C IODeferred (Identifier i t) = do
+ let i' = map toLower i
+ v <- gets $ Map.lookup i' . currentScope
+ if (isNothing v) then
+ modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
+ else
+ let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
+
+id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
+id2CLookup f (Identifier i t) = do
+ let i' = map toLower i
+ v <- gets $ Map.lookup i' . currentScope
+ lt <- gets lastType
+ if isNothing v then
+ error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
+ else
+ let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
+
+
+
+id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
+id2CTyped = id2CTyped2 Nothing
+
+id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc
+id2CTyped2 md t (Identifier i _) = do
+ tb <- resolveType t
+ case (t, tb) of
+ (_, BTUnknown) -> do
+ error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
+ (SimpleType {}, BTRecord _ r) -> do
+ ts <- type2C t
+ id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r))
+ (_, BTRecord _ r) -> do
+ ts <- type2C t
+ id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))
+ _ -> case md of
+ Nothing -> id2C IOInsert (Identifier i tb)
+ Just ts -> id2C (IOInsertWithType ts) (Identifier i tb)
+
+typeVarDecl2BaseType :: [TypeVarDeclaration] -> State RenderState [(Bool, BaseType)]
+typeVarDecl2BaseType d = do
+ st <- get
+ result <- sequence $ concat $ map resolveType' d
+ put st -- restore state (not sure if necessary)
+ return result
+ where
+ resolveType' :: TypeVarDeclaration -> [State RenderState (Bool, BaseType)]
+ resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar)
+ resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration"
+ resolveTypeHelper' :: State RenderState BaseType -> Bool -> State RenderState (Bool, BaseType)
+ resolveTypeHelper' st b = do
+ bt <- st
+ return (b, bt)
+
+resolveType :: TypeDecl -> State RenderState BaseType
+resolveType st@(SimpleType (Identifier i _)) = do
+ let i' = map toLower i
+ v <- gets $ Map.lookup i' . currentScope
+ if isJust v then return . baseType . head $ fromJust v else return $ f i'
+ where
+ f "uinteger" = BTInt False
+ f "integer" = BTInt True
+ f "pointer" = BTPointerTo BTVoid
+ f "boolean" = BTBool
+ f "float" = BTFloat
+ f "char" = BTChar
+ f "string" = BTString
+ f _ = error $ "Unknown system type: " ++ show st
+resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
+resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
+resolveType (RecordType tv mtvs) = do
+ tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
+ return . BTRecord "" . concat $ tvs
+ where
+ f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
+ f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
+resolveType (ArrayDecl (Just i) t) = do
+ t' <- resolveType t
+ return $ BTArray i (BTInt True) t'
+resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t
+resolveType (FunctionType t a) = do
+ bts <- typeVarDecl2BaseType a
+ liftM (BTFunction False bts) $ resolveType t
+resolveType (DeriveType (InitHexNumber _)) = return (BTInt True)
+resolveType (DeriveType (InitNumber _)) = return (BTInt True)
+resolveType (DeriveType (InitFloat _)) = return BTFloat
+resolveType (DeriveType (InitString _)) = return BTString
+resolveType (DeriveType (InitBinOp {})) = return (BTInt True)
+resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType
+resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True)
+resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
+resolveType (DeriveType _) = return BTUnknown
+resolveType (String _) = return BTString
+resolveType VoidType = return BTVoid
+resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
+resolveType (RangeType _) = return $ BTVoid
+resolveType (Set t) = liftM BTSet $ resolveType t
+resolveType (VarParamType t) = liftM BTVarParam $ resolveType t
+
+
+resolve :: String -> BaseType -> State RenderState BaseType
+resolve s (BTUnresolved t) = do
+ v <- gets $ Map.lookup t . currentScope
+ if isJust v then
+ resolve s . baseType . head . fromJust $ v
+ else
+ error $ "Unknown type " ++ show t ++ "\n" ++ s
+resolve _ t = return t
+
+fromPointer :: String -> BaseType -> State RenderState BaseType
+fromPointer s (BTPointerTo t) = resolve s t
+fromPointer s t = do
+ error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
+
+
+functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
+
+numberOfDeclarations :: [TypeVarDeclaration] -> Int
+numberOfDeclarations = sum . map cnt
+ where
+ cnt (VarDeclaration _ _ (ids, _) _) = length ids
+ cnt _ = 1
+
+hasPassByReference :: [TypeVarDeclaration] -> Bool
+hasPassByReference = or . map isVar
+ where
+ isVar (VarDeclaration v _ (_, _) _) = v
+ isVar _ = error $ "hasPassByReference called not on function parameters"
+
+toIsVarList :: [TypeVarDeclaration] -> [Bool]
+toIsVarList = concatMap isVar
+ where
+ isVar (VarDeclaration v _ (p, _) _) = replicate (length p) v
+ isVar _ = error $ "toIsVarList called not on function parameters"
+
+
+funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc
+funWithVarsToDefine n params = text "#define" <+> text n <> parens abc <+> text (n ++ "__vars") <> parens cparams
+ where
+ abc = hcat . punctuate comma . map (char . fst) $ ps
+ cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps
+ ps = zip ['a'..] (toIsVarList params)
+
+fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
+fun2C _ _ (FunctionDeclaration name inline overload returnType params Nothing) = do
+ t <- type2C returnType
+ t'<- gets lastType
+ bts <- typeVarDecl2BaseType params
+ p <- withState' id $ functionParams2C params
+ n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False bts t') name
+ let decor = if overload then text "__attribute__((overloadable))" else empty
+ return [t empty <+> decor <+> text n <> parens p]
+
+fun2C True rv (FunctionDeclaration name@(Identifier i bt) inline overload returnType params (Just (tvars, phrase))) = do
+ let isVoid = case returnType of
+ VoidType -> True
+ _ -> False
+
+ let res = docToLower $ text rv <> if isVoid then empty else text "_result"
+ t <- type2C returnType
+ t' <- gets lastType
+
+ bts <- typeVarDecl2BaseType params
+ cu <- gets currentUnit
+ notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
+
+ n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name
+ let resultId = if isVoid
+ then n -- void type doesn't have result, solving recursive procedure calls
+ else (render res)
+
+ (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars bts t') else t') empty] $ currentScope st
+ , currentFunctionResult = if isVoid then [] else render res}) $ do
+ p <- functionParams2C params
+ ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
+ return (p, ph)
+
+ let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
+ let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
+ let inlineDecor = if inline then case notDeclared of
+ True -> text "static inline"
+ False -> text "inline"
+ else empty
+ overloadDecor = if overload then text "__attribute__((overloadable))" else empty
+ return [
+ --define
+ -- $+$
+ --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
+ inlineDecor <+> t empty <+> overloadDecor <+> text n <> parens p
+ $+$
+ text "{"
+ $+$
+ nest 4 phrasesBlock
+ $+$
+ text "}"]
+ where
+ phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
+ phrase2C' p = phrase2C p
+ un [a] b = a : b
+ hasVars = hasPassByReference params
+
+fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _) = error $ "nested functions not allowed: " ++ name
+fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
+
+-- the second bool indicates whether declare variable as extern or not
+-- the third bool indicates whether include types or not
+-- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
+tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
+tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _) = do
+ t <- fun2C b name f
+ if includeType then return t else return []
+tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do
+ i <- id2CTyped t i'
+ tp <- type2C t
+ let res = if includeType then [text "typedef" <+> tp i] else []
+ case t of
+ (Sequence ids) -> do
+ modify(\s -> s{enums = (render i, map (\(Identifier i _) -> i) ids) : enums s})
+ return res
+ _ -> return res
+
+tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
+ t' <- liftM ((empty <+>) . ) $ type2C t
+ liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids
+
+tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
+ t' <- liftM (((if isConst then text "static const" else if externVar
+ then text "extern"
+ else empty)
+ <+>) . ) $ type2C t
+ ie <- initExpr mInitExpr
+ lt <- gets lastType
+ case (isConst, lt, ids, mInitExpr) of
+ (True, BTInt _, [i], Just _) -> do
+ i' <- id2CTyped t i
+ return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
+ (True, BTFloat, [i], Just e) -> do
+ i' <- id2CTyped t i
+ ie <- initExpr2C e
+ return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
+ (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
+ (_, BTArray r _ _, [i], _) -> do
+ i' <- id2CTyped t i
+ ie' <- return $ case (r, mInitExpr, ignoreInit) of
+ (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
+ (_, _, _) -> ie
+ result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids
+ case (r, ignoreInit) of
+ (RangeInfinite, False) ->
+ -- if the array is dynamic, add dimension info to it
+ return $ [dimDecl] ++ result
+ where
+ arrayDimStr = show $ arrayDimension t
+ arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")
+ dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp
+
+ (_, _) -> return result
+
+ _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids
+ where
+ initExpr Nothing = return $ empty
+ initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
+ varDeclDecision True True varStr expStr = varStr <+> expStr
+ varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
+ varDeclDecision False False varStr expStr = varStr <+> expStr
+ varDeclDecision True False varStr expStr = empty
+ arrayDimension a = case a of
+ ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t
+ ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
+ _ -> 0
+
+tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
+ r <- op2CTyped op (extractTypes params)
+ fun2C f i (FunctionDeclaration r inline False ret params body)
+
+
+op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
+op2CTyped op t = do
+ t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
+ bt <- gets lastType
+ return $ Identifier (t' ++ "_op_" ++ opStr) bt
+ where
+ opStr = case op of
+ "+" -> "add"
+ "-" -> "sub"
+ "*" -> "mul"
+ "/" -> "div"
+ "/(float)" -> "div"
+ "=" -> "eq"
+ "<" -> "lt"
+ ">" -> "gt"
+ "<>" -> "neq"
+ _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
+
+extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
+extractTypes = concatMap f
+ where
+ f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t
+ f a = error $ "extractTypes: can't extract from " ++ show a
+
+initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc
+initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
+initExpr2C a = initExpr2C' a
+initExpr2C' InitNull = return $ text "NULL"
+initExpr2C' (InitAddress expr) = do
+ ie <- initExpr2C' expr
+ lt <- gets lastType
+ case lt of
+ BTFunction True _ _ -> return $ text "&" <> ie -- <> text "__vars"
+ _ -> return $ text "&" <> ie
+initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr)
+initExpr2C' (InitBinOp op expr1 expr2) = do
+ e1 <- initExpr2C' expr1
+ e2 <- initExpr2C' expr2
+ return $ parens $ e1 <+> text (op2C op) <+> e2
+initExpr2C' (InitNumber s) = do
+ modify(\s -> s{lastType = (BTInt True)})
+ return $ text s
+initExpr2C' (InitFloat s) = return $ text s
+initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
+initExpr2C' (InitString [a]) = return . quotes $ text [a]
+initExpr2C' (InitString s) = return $ strInit s
+initExpr2C' (InitChar a) = return $ text "0x" <> text (showHex (read a) "")
+initExpr2C' (InitReference i) = id2C IOLookup i
+initExpr2C' (InitRecord fields) = do
+ (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
+ return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
+--initExpr2C' (InitArray [InitRecord fields]) = do
+-- e <- initExpr2C $ InitRecord fields
+-- return $ braces $ e
+initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
+ id2C IOLookup i
+ t <- gets lastType
+ case t of
+ BTEnum s -> return . int $ length s
+ BTInt _ -> case i' of
+ "byte" -> return $ int 256
+ _ -> error $ "InitRange identifier: " ++ i'
+ _ -> error $ "InitRange: " ++ show r
+initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
+initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
+initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
+initExpr2C' (InitSet []) = return $ text "0"
+initExpr2C' (InitSet a) = return $ text "<<set>>"
+initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
+ case e of
+ (Identifier "LongInt" _) -> int (-2^31)
+ (Identifier "SmallInt" _) -> int (-2^15)
+ _ -> error $ "BuiltInFunction 'low': " ++ show e
+initExpr2C' (BuiltInFunction "high" [e]) = do
+ initExpr2C e
+ t <- gets lastType
+ case t of
+ (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
+ a -> error $ "BuiltInFunction 'high': " ++ show a
+initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
+initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e
+initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e
+initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e
+initExpr2C' b@(BuiltInFunction _ _) = error $ show b
+initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
+
+
+range2C :: InitExpression -> State RenderState [Doc]
+range2C (InitString [a]) = return [quotes $ text [a]]
+range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
+range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]
+range2C a = liftM (flip (:) []) $ initExpr2C a
+
+baseType2C :: String -> BaseType -> Doc
+baseType2C _ BTFloat = text "float"
+baseType2C _ BTBool = text "bool"
+baseType2C _ BTString = text "string255"
+baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
+
+type2C :: TypeDecl -> State RenderState (Doc -> Doc)
+type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
+type2C t = do
+ r <- type2C' t
+ rt <- resolveType t
+ modify (\st -> st{lastType = rt})
+ return r
+ where
+ type2C' VoidType = return (text "void" <+>)
+ type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
+ type2C' (PointerTo (SimpleType i)) = do
+ i' <- id2C IODeferred i
+ lt <- gets lastType
+ case lt of
+ BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
+ BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
+ _ -> return $ \a -> i' <+> text "*" <+> a
+ type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
+ type2C' (RecordType tvs union) = do
+ t <- withState' f $ mapM (tvar2C False False True False) tvs
+ u <- unions
+ return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
+ where
+ f s = s{currentUnit = ""}
+ unions = case union of
+ Nothing -> return empty
+ Just a -> do
+ structs <- mapM struct2C a
+ return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
+ struct2C tvs = do
+ t <- withState' f $ mapM (tvar2C False False True False) tvs
+ return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
+ type2C' (RangeType r) = return (text "int" <+>)
+ type2C' (Sequence ids) = do
+ is <- mapM (id2C IOInsert . setBaseType bt) ids
+ return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)
+ where
+ bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
+ type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
+ type2C' (ArrayDecl (Just r) t) = do
+ t' <- type2C t
+ lt <- gets lastType
+ ft <- case lt of
+ -- BTFunction {} -> type2C (PointerTo t)
+ _ -> return t'
+ r' <- initExpr2C (InitRange r)
+ return $ \i -> ft i <> brackets r'
+ type2C' (Set t) = return (text "<<set>>" <+>)
+ type2C' (FunctionType returnType params) = do
+ t <- type2C returnType
+ p <- withState' id $ functionParams2C params
+ return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p))
+ type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)
+ type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
+ type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
+ type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
+ type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
+ type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
+ type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
+ type2C' (DeriveType r@(InitReference {})) = do
+ initExpr2C r
+ t <- gets lastType
+ return (baseType2C (show r) t <+>)
+ type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
+
+phrase2C :: Phrase -> State RenderState Doc
+phrase2C (Phrases p) = do
+ ps <- mapM phrase2C p
+ return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
+phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
+phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True
+phrase2C (ProcCall ref params) = error $ "ProcCall"{-do
+ r <- ref2C ref
+ ps <- mapM expr2C params
+ return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
+phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
+ e <- expr2C expr
+ p1 <- (phrase2C . wrapPhrase) phrase1
+ el <- elsePart
+ return $
+ text "if" <> parens e $+$ p1 $+$ el
+ where
+ elsePart | isNothing mphrase2 = return $ empty
+ | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)
+phrase2C asgn@(Assignment ref expr) = do
+ r <- ref2C ref
+ t <- gets lastType
+ case (t, expr) of
+ (BTFunction {}, (Reference r')) -> do
+ e <- ref2C r'
+ return $ r <+> text "=" <+> e <> semi
+ (BTString, _) -> do
+ e <- expr2C expr
+ lt <- gets lastType
+ case lt of
+ -- assume pointer to char for simplicity
+ BTPointerTo _ -> do
+ e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
+ return $ r <+> text "=" <+> e <> semi
+ BTString -> do
+ e <- expr2C expr
+ return $ r <+> text "=" <+> e <> semi
+ _ -> error $ "Assignment to string from " ++ show asgn
+ (BTArray _ _ _, _) -> do
+ case expr of
+ Reference er -> do
+ exprRef <- ref2C er
+ exprT <- gets lastType
+ case exprT of
+ BTArray RangeInfinite _ _ ->
+ return $ text "FIXME: assign a dynamic array to an array"
+ BTArray _ _ _ -> phrase2C $
+ ProcCall (FunCall
+ [
+ Reference $ ref
+ , Reference $ RefExpression expr
+ , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
+ ]
+ (SimpleReference (Identifier "memcpy" BTUnknown))
+ ) []
+ _ -> return $ text "FIXME: assign a non-specific value to an array"
+
+ _ -> return $ text "FIXME: dynamic array assignment 2"
+ _ -> do
+ e <- expr2C expr
+ return $ r <+> text "=" <+> e <> semi
+phrase2C (WhileCycle expr phrase) = do
+ e <- expr2C expr
+ p <- phrase2C $ wrapPhrase phrase
+ return $ text "while" <> parens e $$ p
+phrase2C (SwitchCase expr cases mphrase) = do
+ e <- expr2C expr
+ cs <- mapM case2C cases
+ d <- dflt
+ return $
+ text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
+ where
+ case2C :: ([InitExpression], Phrase) -> State RenderState Doc
+ case2C (e, p) = do
+ ies <- mapM range2C e
+ ph <- phrase2C p
+ return $
+ vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
+ dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
+ | otherwise = do
+ ph <- mapM phrase2C $ fromJust mphrase
+ return [text "default:" <+> nest 4 (vcat ph)]
+
+phrase2C wb@(WithBlock ref p) = do
+ r <- ref2C ref
+ t <- gets lastType
+ case t of
+ (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p
+ a -> do
+ error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb
+phrase2C (ForCycle i' e1' e2' p up) = do
+ i <- id2C IOLookup i'
+ iType <- gets lastIdTypeDecl
+ e1 <- expr2C e1'
+ e2 <- expr2C e2'
+ let inc = if up then "inc" else "dec"
+ let add = if up then "+ 1" else "- 1"
+ let iEnd = i <> text "__end__"
+ ph <- phrase2C . appendPhrase (BuiltInFunctionCall [Reference $ SimpleReference i'] (SimpleReference (Identifier inc BTUnknown))) $ wrapPhrase p
+ return . braces $
+ i <+> text "=" <+> e1 <> semi
+ $$
+ iType <+> iEnd <+> text "=" <+> e2 <> semi
+ $$
+ text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+>
+ text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi
+ where
+ appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
+phrase2C (RepeatCycle e' p') = do
+ e <- expr2C e'
+ p <- phrase2C (Phrases p')
+ return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
+
+phrase2C NOP = return $ text ";"
+
+phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do
+ f <- gets currentFunctionResult
+ if null f then
+ return $ text "return" <> semi
+ else
+ return $ text "return" <+> text f <> semi
+phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi
+phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi
+phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e
+phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e
+phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2)
+phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e
+phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2)
+phrase2C a = error $ "phrase2C: " ++ show a
+
+wrapPhrase p@(Phrases _) = p
+wrapPhrase p = Phrases [p]
+
+expr2C :: Expression -> State RenderState Doc
+expr2C (Expression s) = return $ text s
+expr2C b@(BinOp op expr1 expr2) = do
+ e1 <- expr2C expr1
+ t1 <- gets lastType
+ e2 <- expr2C expr2
+ t2 <- gets lastType
+ case (op2C op, t1, t2) of
+ ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False [(False, t1), (False, t2)] BTString))
+ ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False [(False, t1), (False, t2)] BTString))
+ ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False [(False, t1), (False, t2)] BTString))
+ ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False [(False, t1), (False, t2)] BTString))
+ ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False [(False, t1), (False, t2)] BTBool))
+
+ -- for function/procedure comparision
+ ("==", BTVoid, _) -> procCompare expr1 expr2 "=="
+ ("==", BTFunction _ _ _, _) -> procCompare expr1 expr2 "=="
+
+ ("!=", BTVoid, _) -> procCompare expr1 expr2 "!="
+ ("!=", BTFunction _ _ _, _) -> procCompare expr1 expr2 "!="
+
+ ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False [(False, t1), (False, t2)] BTBool))
+ ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False [(False, t1), (False, t2)] BTBool))
+ ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2
+ ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
+ (_, BTRecord t1 _, BTRecord t2 _) -> do
+ i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)]
+ ref2C $ FunCall [expr1, expr2] (SimpleReference i)
+ (_, BTRecord t1 _, BTInt _) -> do
+ -- aw, "LongInt" here is hwengine-specific hack
+ i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
+ ref2C $ FunCall [expr1, expr2] (SimpleReference i)
+ ("in", _, _) ->
+ case expr2 of
+ SetExpression set -> do
+ ids <- mapM (id2C IOLookup) set
+ modify(\s -> s{lastType = BTBool})
+ return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids
+ _ -> error "'in' against not set expression"
+ (o, _, _) | o `elem` boolOps -> do
+ modify(\s -> s{lastType = BTBool})
+ return $ parens e1 <+> text o <+> parens e2
+ | otherwise -> do
+ o' <- return $ case o of
+ "/(float)" -> text "/(float)" -- pascal returns real value
+ _ -> text o
+ e1' <- return $ case (o, t1, t2) of
+ ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e1
+ _ -> parens e1
+ e2' <- return $ case (o, t1, t2) of
+ ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e2
+ _ -> parens e2
+ return $ e1' <+> o' <+> e2'
+ where
+ boolOps = ["==", "!=", "<", ">", "<=", ">="]
+ procCompare expr1 expr2 op =
+ case (expr1, expr2) of
+ (Reference r1, Reference r2) -> do
+ id1 <- ref2C r1
+ id2 <- ref2C r2
+ return $ (parens id1) <+> text op <+> (parens id2)
+ (_, _) -> error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2
+
+expr2C (NumberLiteral s) = do
+ modify(\s -> s{lastType = BTInt True})
+ return $ text s
+expr2C (FloatLiteral s) = return $ text s
+expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s)
+{-expr2C (StringLiteral [a]) = do
+ modify(\s -> s{lastType = BTChar})
+ return . quotes . text $ escape a
+ where
+ escape '\'' = "\\\'"
+ escape a = [a]-}
+expr2C (StringLiteral s) = addStringConst s
+expr2C (PCharLiteral s) = return . doubleQuotes $ text s
+expr2C (Reference ref) = do
+ isfunc <- gets isFunctionType
+ modify(\s -> s{isFunctionType = False}) -- reset
+ if isfunc then ref2CF ref False else ref2CF ref True
+expr2C (PrefixOp op expr) = do
+ e <- expr2C expr
+ lt <- gets lastType
+ case lt of
+ BTRecord t _ -> do
+ i <- op2CTyped op [SimpleType (Identifier t undefined)]
+ ref2C $ FunCall [expr] (SimpleReference i)
+ BTBool -> do
+ o <- return $ case op of
+ "not" -> text "!"
+ _ -> text (op2C op)
+ return $ o <> parens e
+ _ -> return $ text (op2C op) <> parens e
+expr2C Null = return $ text "NULL"
+expr2C (CharCode a) = do
+ modify(\s -> s{lastType = BTChar})
+ return $ text "0x" <> text (showHex (read a) "")
+expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a
+expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ")
+
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
+ e' <- liftM (map toLower . render) $ expr2C e
+ lt <- gets lastType
+ case lt of
+ BTEnum a -> return $ int 0
+ BTInt _ -> case e' of
+ "longint" -> return $ int (-2147483648)
+ BTArray {} -> return $ int 0
+ _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do
+ e' <- liftM (map toLower . render) $ expr2C e
+ lt <- gets lastType
+ case lt of
+ BTEnum a -> return . int $ length a - 1
+ BTInt _ -> case e' of
+ "longint" -> return $ int (2147483647)
+ BTString -> return $ int 255
+ BTArray (RangeFromTo _ n) _ _ -> initExpr2C n
+ _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = do
+ e'<- expr2C e
+ return $ text "(int)" <> parens e' <> text " - 1"
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
+ e' <- expr2C e
+ lt <- gets lastType
+ modify (\s -> s{lastType = BTInt True})
+ case lt of
+ BTString -> return $ text "fpcrtl_Length" <> parens e'
+ BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'
+ BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
+ _ -> error $ "length() called on " ++ show lt
+expr2C (BuiltInFunCall params ref) = do
+ r <- ref2C ref
+ t <- gets lastType
+ ps <- mapM expr2C params
+ case t of
+ BTFunction _ _ t' -> do
+ modify (\s -> s{lastType = t'})
+ _ -> error $ "BuiltInFunCall lastType: " ++ show t
+ return $
+ r <> parens (hsep . punctuate (char ',') $ ps)
+expr2C a = error $ "Don't know how to render " ++ show a
+
+ref2CF :: Reference -> Bool -> State RenderState Doc
+ref2CF (SimpleReference name) addParens = do
+ i <- id2C IOLookup name
+ t <- gets lastType
+ case t of
+ BTFunction _ _ rt -> do
+ modify(\s -> s{lastType = rt})
+ return $ if addParens then i <> parens empty else i --xymeng: removed parens
+ _ -> return $ i
+ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do
+ i <- ref2C r
+ t <- gets lastType
+ case t of
+ BTFunction _ _ rt -> do
+ modify(\s -> s{lastType = rt})
+ return $ if addParens then i <> parens empty else i
+ _ -> return $ i
+ref2CF r _ = ref2C r
+
+ref2C :: Reference -> State RenderState Doc
+-- rewrite into proper form
+ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
+ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
+ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
+ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
+ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref)
+-- conversion routines
+ref2C ae@(ArrayElement [expr] ref) = do
+ e <- expr2C expr
+ r <- ref2C ref
+ t <- gets lastType
+ case t of
+ (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
+-- (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
+-- (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
+ (BTString) -> modify (\st -> st{lastType = BTChar})
+ (BTPointerTo t) -> do
+ t'' <- fromPointer (show t) =<< gets lastType
+ case t'' of
+ BTChar -> modify (\st -> st{lastType = BTChar})
+ a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
+ a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
+ case t of
+ BTString -> return $ r <> text ".s" <> brackets e
+ _ -> return $ r <> brackets e
+ref2C (SimpleReference name) = id2C IOLookup name
+ref2C rf@(RecordField (Dereference ref1) ref2) = do
+ r1 <- ref2C ref1
+ t <- fromPointer (show ref1) =<< gets lastType
+ r2 <- case t of
+ BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2
+ BTUnit -> error "What??"
+ a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
+ return $
+ r1 <> text "->" <> r2
+ref2C rf@(RecordField ref1 ref2) = do
+ r1 <- ref2C ref1
+ t <- gets lastType
+ case t of
+ BTRecord _ rs -> do
+ r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2
+ return $ r1 <> text "." <> r2
+ BTUnit -> withLastIdNamespace $ ref2C ref2
+ a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
+ref2C d@(Dereference ref) = do
+ r <- ref2C ref
+ t <- fromPointer (show d) =<< gets lastType
+ modify (\st -> st{lastType = t})
+ return $ (parens $ text "*" <> r)
+ref2C f@(FunCall params ref) = do
+ r <- fref2C ref
+ t <- gets lastType
+ case t of
+ BTFunction _ bts t' -> do
+ ps <- liftM (parens . hsep . punctuate (char ',')) $
+ if (length params) == (length bts) -- hot fix for pas2cSystem and pas2cRedo functions since they don't have params
+ then
+ mapM expr2CHelper (zip params bts)
+ else mapM expr2C params
+ modify (\s -> s{lastType = t'})
+ return $ r <> ps
+ _ -> case (ref, params) of
+ (SimpleReference i, [p]) -> ref2C $ TypeCast i p
+ _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t ++ "\n" ++ show ref ++ "\n" ++ show params ++ "\n" ++ show t
+ where
+ fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
+ fref2C a = ref2C a
+ expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc
+ expr2CHelper (e, (_, BTFunction _ _ _)) = do
+ modify (\s -> s{isFunctionType = True})
+ expr2C e
+ expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e
+
+ref2C (Address ref) = do
+ r <- ref2C ref
+ lt <- gets lastType
+ case lt of
+ BTFunction True _ _ -> return $ text "&" <> parens r
+ _ -> return $ text "&" <> parens r
+ref2C (TypeCast t'@(Identifier i _) expr) = do
+ lt <- expr2C expr >> gets lastType
+ case (map toLower i, lt) of
+ ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
+ ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
+ (a, _) -> do
+ e <- expr2C expr
+ t <- id2C IOLookup t'
+ return . parens $ parens t <> e
+ref2C (RefExpression expr) = expr2C expr
+
+
+op2C :: String -> String
+op2C "or" = "|"
+op2C "and" = "&"
+op2C "not" = "~"
+op2C "xor" = "^"
+op2C "div" = "/"
+op2C "mod" = "%"
+op2C "shl" = "<<"
+op2C "shr" = ">>"
+op2C "<>" = "!="
+op2C "=" = "=="
+op2C "/" = "/(float)"
+op2C a = a
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalBasics.hs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,70 @@
+{-# LANGUAGE FlexibleContexts #-}
+module PascalBasics where
+
+import Text.Parsec.Combinator
+import Text.Parsec.Char
+import Text.Parsec.Prim
+import Text.Parsec.Token
+import Text.Parsec.Language
+import Data.Char
+
+builtin = ["succ", "pred", "low", "high", "ord", "inc", "dec", "exit", "break", "continue", "length"]
+
+pascalLanguageDef
+ = emptyDef
+ { commentStart = "(*"
+ , commentEnd = "*)"
+ , commentLine = "//"
+ , nestedComments = False
+ , identStart = letter <|> oneOf "_"
+ , identLetter = alphaNum <|> oneOf "_"
+ , opLetter = letter
+ , reservedNames = [
+ "begin", "end", "program", "unit", "interface"
+ , "implementation", "and", "or", "xor", "shl"
+ , "shr", "while", "do", "repeat", "until", "case", "of"
+ , "type", "var", "const", "out", "array", "packed"
+ , "procedure", "function", "with", "for", "to"
+ , "downto", "div", "mod", "record", "set", "nil"
+ , "cdecl", "external", "if", "then", "else"
+ ] -- ++ builtin
+ , caseSensitive = False
+ }
+
+preprocessorSwitch :: Stream s m Char => ParsecT s u m String
+preprocessorSwitch = do
+ try $ string "{$"
+ s <- manyTill (noneOf "\n") $ char '}'
+ return s
+
+caseInsensitiveString s = do
+ mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s
+ return s
+
+pas = patch $ makeTokenParser pascalLanguageDef
+ where
+ patch tp = tp {stringLiteral = stringL}
+
+comment = choice [
+ char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}')
+ , (try $ string "(*") >> manyTill anyChar (try $ string "*)")
+ , (try $ string "//") >> manyTill anyChar (try newline)
+ ]
+
+comments = do
+ spaces
+ skipMany $ do
+ preprocessorSwitch <|> comment
+ spaces
+
+stringL = do
+ (char '\'')
+ s <- (many $ noneOf "'")
+ (char '\'')
+ ss <- many $ do
+ (char '\'')
+ s' <- (many $ noneOf "'")
+ (char '\'')
+ return $ '\'' : s'
+ comments
+ return $ concat (s:ss)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalParser.hs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,676 @@
+module PascalParser where
+
+import Text.Parsec
+import Text.Parsec.Char
+import Text.Parsec.Token
+import Text.Parsec.Language
+import Text.Parsec.Expr
+import Text.Parsec.Prim
+import Text.Parsec.Combinator
+import Text.Parsec.String
+import Control.Monad
+import Data.Maybe
+import Data.Char
+
+import PascalBasics
+import PascalUnitSyntaxTree
+
+knownTypes = ["shortstring", "ansistring", "char", "byte"]
+
+pascalUnit = do
+ comments
+ u <- choice [program, unit, systemUnit, redoUnit]
+ comments
+ return u
+
+iD = do
+ i <- identifier pas
+ comments
+ when (i == "not") $ unexpected "'not' used as an identifier"
+ return $ Identifier i BTUnknown
+
+unit = do
+ string "unit" >> comments
+ name <- iD
+ semi pas
+ comments
+ int <- interface
+ impl <- implementation
+ comments
+ return $ Unit name int impl Nothing Nothing
+
+
+reference = buildExpressionParser table term <?> "reference"
+ where
+ term = comments >> choice [
+ parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes
+ , try $ typeCast >>= postfixes
+ , char '@' >> liftM Address reference >>= postfixes
+ , liftM SimpleReference iD >>= postfixes
+ ] <?> "simple reference"
+
+ table = [
+ ]
+
+ postfixes r = many postfix >>= return . foldl (flip ($)) r
+ postfix = choice [
+ parens pas (option [] parameters) >>= return . FunCall
+ , char '^' >> return Dereference
+ , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
+ , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference
+ ]
+
+ typeCast = do
+ t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
+ e <- parens pas expression
+ comments
+ return $ TypeCast (Identifier t BTUnknown) e
+
+varsDecl1 = varsParser sepEndBy1
+varsDecl = varsParser sepEndBy
+varsParser m endsWithSemi = do
+ vs <- m (aVarDecl endsWithSemi) (semi pas)
+ return vs
+
+aVarDecl endsWithSemi = do
+ isVar <- liftM (== Just "var") $
+ if not endsWithSemi then
+ optionMaybe $ choice [
+ try $ string "var"
+ , try $ string "const"
+ , try $ string "out"
+ ]
+ else
+ return Nothing
+ comments
+ ids <- do
+ i <- (commaSep1 pas) $ (try iD <?> "variable declaration")
+ char ':'
+ return i
+ comments
+ t <- typeDecl <?> "variable type declaration"
+ comments
+ init <- option Nothing $ do
+ char '='
+ comments
+ e <- initExpression
+ comments
+ return (Just e)
+ return $ VarDeclaration isVar False (ids, t) init
+
+
+constsDecl = do
+ vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
+ comments
+ return vs
+ where
+ aConstDecl = do
+ comments
+ i <- iD
+ t <- optionMaybe $ do
+ char ':'
+ comments
+ t <- typeDecl
+ comments
+ return t
+ char '='
+ comments
+ e <- initExpression
+ comments
+ return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
+
+typeDecl = choice [
+ char '^' >> typeDecl >>= return . PointerTo
+ , try (string "shortstring") >> return (String 255)
+ , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
+ , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
+ , arrayDecl
+ , recordDecl
+ , setDecl
+ , functionType
+ , sequenceDecl >>= return . Sequence
+ , try iD >>= return . SimpleType
+ , rangeDecl >>= return . RangeType
+ ] <?> "type declaration"
+ where
+ arrayDecl = do
+ try $ do
+ optional $ (try $ string "packed") >> comments
+ string "array"
+ comments
+ r <- option [] $ do
+ char '['
+ r <- commaSep pas rangeDecl
+ char ']'
+ comments
+ return r
+ string "of"
+ comments
+ t <- typeDecl
+ if null r then
+ return $ ArrayDecl Nothing t
+ else
+ return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r)
+ recordDecl = do
+ try $ do
+ optional $ (try $ string "packed") >> comments
+ string "record"
+ comments
+ vs <- varsDecl True
+ union <- optionMaybe $ do
+ string "case"
+ comments
+ iD
+ comments
+ string "of"
+ comments
+ many unionCase
+ string "end"
+ return $ RecordType vs union
+ setDecl = do
+ try $ string "set" >> space
+ comments
+ string "of"
+ comments
+ liftM Set typeDecl
+ unionCase = do
+ try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ())
+ char ':'
+ comments
+ u <- parens pas $ varsDecl True
+ char ';'
+ comments
+ return u
+ sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i)
+ functionType = do
+ fp <- try (string "function") <|> try (string "procedure")
+ comments
+ vs <- option [] $ parens pas $ varsDecl False
+ comments
+ ret <- if (fp == "function") then do
+ char ':'
+ comments
+ ret <- typeDecl
+ comments
+ return ret
+ else
+ return VoidType
+ optional $ try $ char ';' >> comments >> string "cdecl"
+ comments
+ return $ FunctionType ret vs
+
+typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
+ where
+ aTypeDecl = do
+ i <- try $ do
+ i <- iD <?> "type declaration"
+ comments
+ char '='
+ return i
+ comments
+ t <- typeDecl
+ comments
+ semi pas
+ comments
+ return $ TypeDeclaration i t
+
+rangeDecl = choice [
+ try $ rangeft
+ , iD >>= return . Range
+ ] <?> "range declaration"
+ where
+ rangeft = do
+ e1 <- initExpression
+ string ".."
+ e2 <- initExpression
+ return $ RangeFromTo e1 e2
+
+typeVarDeclaration isImpl = (liftM concat . many . choice) [
+ varSection,
+ constSection,
+ typeSection,
+ funcDecl,
+ operatorDecl
+ ]
+ where
+
+ fixInit v = concat $ map (\x -> case x of
+ VarDeclaration a b (ids, t) c ->
+ let typeId = (Identifier ((\(Identifier i _) -> i) (head ids) ++ "_tt") BTUnknown) in
+ let res = [TypeDeclaration typeId t, VarDeclaration a b (ids, (SimpleType typeId)) c] in
+ case t of
+ RecordType _ _ -> res -- create a separated type declaration
+ ArrayDecl _ _ -> res
+ _ -> [x]
+ _ -> error ("checkInit:\n" ++ (show v))) v
+
+ varSection = do
+ try $ string "var"
+ comments
+ v <- varsDecl1 True <?> "variable declaration"
+ comments
+ return $ fixInit v
+
+ constSection = do
+ try $ string "const"
+ comments
+ c <- constsDecl <?> "const declaration"
+ comments
+ return $ fixInit c
+
+ typeSection = do
+ try $ string "type"
+ comments
+ t <- typesDecl <?> "type declaration"
+ comments
+ return t
+
+ operatorDecl = do
+ try $ string "operator"
+ comments
+ i <- manyTill anyChar space
+ comments
+ vs <- parens pas $ varsDecl False
+ comments
+ rid <- iD
+ comments
+ char ':'
+ comments
+ ret <- typeDecl
+ comments
+ return ret
+ char ';'
+ comments
+ forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
+ inline <- liftM (any (== "inline;")) $ many functionDecorator
+ b <- if isImpl && (not forward) then
+ liftM Just functionBody
+ else
+ return Nothing
+ return $ [OperatorDeclaration i rid inline ret vs b]
+
+
+ funcDecl = do
+ fp <- try (string "function") <|> try (string "procedure")
+ comments
+ i <- iD
+ vs <- option [] $ parens pas $ varsDecl False
+ comments
+ ret <- if (fp == "function") then do
+ char ':'
+ comments
+ ret <- typeDecl
+ comments
+ return ret
+ else
+ return VoidType
+ char ';'
+ comments
+ forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
+ decorators <- many functionDecorator
+ let inline = any (== "inline;") decorators
+ overload = any (== "overload;") decorators
+ b <- if isImpl && (not forward) then
+ liftM Just functionBody
+ else
+ return Nothing
+ return $ [FunctionDeclaration i inline overload ret vs b]
+
+ functionDecorator = do
+ d <- choice [
+ try $ string "inline;"
+ , try $ caseInsensitiveString "cdecl;"
+ , try $ string "overload;"
+ , try $ string "export;"
+ , try $ string "varargs;"
+ , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"
+ ]
+ comments
+ return d
+
+
+program = do
+ string "program"
+ comments
+ name <- iD
+ (char ';')
+ comments
+ comments
+ u <- uses
+ comments
+ tv <- typeVarDeclaration True
+ comments
+ p <- phrase
+ comments
+ char '.'
+ comments
+ return $ Program name (Implementation u (TypesAndVars tv)) p
+
+interface = do
+ string "interface"
+ comments
+ u <- uses
+ comments
+ tv <- typeVarDeclaration False
+ comments
+ return $ Interface u (TypesAndVars tv)
+
+implementation = do
+ string "implementation"
+ comments
+ u <- uses
+ comments
+ tv <- typeVarDeclaration True
+ string "end."
+ comments
+ return $ Implementation u (TypesAndVars tv)
+
+expression = do
+ buildExpressionParser table term <?> "expression"
+ where
+ term = comments >> choice [
+ builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
+ , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e)
+ , brackets pas (commaSep pas iD) >>= return . SetExpression
+ , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
+ , float pas >>= return . FloatLiteral . show
+ , try $ integer pas >>= return . NumberLiteral . show
+ , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral
+ , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral
+ , stringLiteral pas >>= return . strOrChar
+ , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
+ , char '#' >> many digit >>= \c -> comments >> return (CharCode c)
+ , char '$' >> many hexDigit >>= \h -> comments >> return (HexNumber h)
+ --, char '-' >> expression >>= return . PrefixOp "-"
+ , char '-' >> reference >>= return . PrefixOp "-" . Reference
+ , (try $ string "not" >> notFollowedBy comments) >> unexpected "'not'"
+ , try $ string "nil" >> return Null
+ , reference >>= return . Reference
+ ] <?> "simple expression"
+
+ table = [
+ [ Prefix (reservedOp pas "not">> return (PrefixOp "not"))
+ , Prefix (try (char '-') >> return (PrefixOp "-"))]
+ ,
+ [ Infix (char '*' >> return (BinOp "*")) AssocLeft
+ , Infix (char '/' >> return (BinOp "/")) AssocLeft
+ , Infix (try (string "div") >> return (BinOp "div")) AssocLeft
+ , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
+ , Infix (try (string "in") >> return (BinOp "in")) AssocNone
+ , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
+ , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft
+ , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft
+ ]
+ , [ Infix (char '+' >> return (BinOp "+")) AssocLeft
+ , Infix (char '-' >> return (BinOp "-")) AssocLeft
+ , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
+ ]
+ , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
+ , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
+ , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
+ , Infix (char '<' >> return (BinOp "<")) AssocNone
+ , Infix (char '>' >> return (BinOp ">")) AssocNone
+ ]
+ {-, [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
+ , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
+ ]
+ , [
+ Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
+ ]-}
+ , [
+ Infix (char '=' >> return (BinOp "=")) AssocNone
+ ]
+ ]
+ strOrChar [a] = CharCode . show . ord $ a
+ strOrChar a = StringLiteral a
+
+phrasesBlock = do
+ try $ string "begin"
+ comments
+ p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum)
+ comments
+ return $ Phrases p
+
+phrase = do
+ o <- choice [
+ phrasesBlock
+ , ifBlock
+ , whileCycle
+ , repeatCycle
+ , switchCase
+ , withBlock
+ , forCycle
+ , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
+ , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
+ , procCall
+ , char ';' >> comments >> return NOP
+ ]
+ optional $ char ';'
+ comments
+ return o
+
+ifBlock = do
+ try $ string "if" >> notFollowedBy (alphaNum <|> char '_')
+ comments
+ e <- expression
+ comments
+ string "then"
+ comments
+ o1 <- phrase
+ comments
+ o2 <- optionMaybe $ do
+ try $ string "else" >> space
+ comments
+ o <- option NOP phrase
+ comments
+ return o
+ return $ IfThenElse e o1 o2
+
+whileCycle = do
+ try $ string "while"
+ comments
+ e <- expression
+ comments
+ string "do"
+ comments
+ o <- phrase
+ return $ WhileCycle e o
+
+withBlock = do
+ try $ string "with" >> space
+ comments
+ rs <- (commaSep1 pas) reference
+ comments
+ string "do"
+ comments
+ o <- phrase
+ return $ foldr WithBlock o rs
+
+repeatCycle = do
+ try $ string "repeat" >> space
+ comments
+ o <- many phrase
+ string "until"
+ comments
+ e <- expression
+ comments
+ return $ RepeatCycle e o
+
+forCycle = do
+ try $ string "for" >> space
+ comments
+ i <- iD
+ comments
+ string ":="
+ comments
+ e1 <- expression
+ comments
+ up <- liftM (== Just "to") $
+ optionMaybe $ choice [
+ try $ string "to"
+ , try $ string "downto"
+ ]
+ --choice [string "to", string "downto"]
+ comments
+ e2 <- expression
+ comments
+ string "do"
+ comments
+ p <- phrase
+ comments
+ return $ ForCycle i e1 e2 p up
+
+switchCase = do
+ try $ string "case"
+ comments
+ e <- expression
+ comments
+ string "of"
+ comments
+ cs <- many1 aCase
+ o2 <- optionMaybe $ do
+ try $ string "else" >> notFollowedBy alphaNum
+ comments
+ o <- many phrase
+ comments
+ return o
+ string "end"
+ comments
+ return $ SwitchCase e cs o2
+ where
+ aCase = do
+ e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression)
+ comments
+ char ':'
+ comments
+ p <- phrase
+ comments
+ return (e, p)
+
+procCall = do
+ r <- reference
+ p <- option [] $ (parens pas) parameters
+ return $ ProcCall r p
+
+parameters = (commaSep pas) expression <?> "parameters"
+
+functionBody = do
+ tv <- typeVarDeclaration True
+ comments
+ p <- phrasesBlock
+ char ';'
+ comments
+ return (TypesAndVars tv, p)
+
+uses = liftM Uses (option [] u)
+ where
+ u = do
+ string "uses"
+ comments
+ u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
+ char ';'
+ comments
+ return u
+
+initExpression = buildExpressionParser table term <?> "initialization expression"
+ where
+ term = comments >> choice [
+ liftM (uncurry BuiltInFunction) $ builtInFunction initExpression
+ , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet
+ , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when ((notRecord $ head ia) && (null $ tail ia)) mzero >> return (InitArray ia)
+ , try $ parens pas (sepEndBy recField (char ';' >> comments)) >>= return . InitRecord
+ , parens pas initExpression
+ , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i
+ , try $ float pas >>= return . InitFloat . show
+ , try $ integer pas >>= return . InitNumber . show
+ , stringLiteral pas >>= return . InitString
+ , char '#' >> many digit >>= \c -> comments >> return (InitChar c)
+ , char '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h)
+ , char '@' >> initExpression >>= \c -> comments >> return (InitAddress c)
+ , try $ string "nil" >> return InitNull
+ , itypeCast
+ , iD >>= return . InitReference
+ ]
+
+ notRecord (InitRecord _) = False
+ notRecord _ = True
+
+ recField = do
+ i <- iD
+ spaces
+ char ':'
+ spaces
+ e <- initExpression
+ spaces
+ return (i ,e)
+
+ table = [
+ [
+ Prefix (char '-' >> return (InitPrefixOp "-"))
+ ,Prefix (try (string "not") >> return (InitPrefixOp "not"))
+ ]
+ , [ Infix (char '*' >> return (InitBinOp "*")) AssocLeft
+ , Infix (char '/' >> return (InitBinOp "/")) AssocLeft
+ , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft
+ , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft
+ , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
+ , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
+ , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
+ ]
+ , [ Infix (char '+' >> return (InitBinOp "+")) AssocLeft
+ , Infix (char '-' >> return (InitBinOp "-")) AssocLeft
+ , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
+ ]
+ , [ Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone
+ , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone
+ , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone
+ , Infix (char '<' >> return (InitBinOp "<")) AssocNone
+ , Infix (char '>' >> return (InitBinOp ">")) AssocNone
+ , Infix (char '=' >> return (InitBinOp "=")) AssocNone
+ ]
+ {--, [ Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
+ , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
+ ]
+ , [ Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
+ , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
+ ]--}
+ --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
+ ]
+
+ itypeCast = do
+ t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
+ i <- parens pas initExpression
+ comments
+ return $ InitTypeCast (Identifier t BTUnknown) i
+
+builtInFunction e = do
+ name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin
+ spaces
+ exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e
+ spaces
+ return (name, exprs)
+
+systemUnit = do
+ string "system;"
+ comments
+ string "type"
+ comments
+ t <- typesDecl
+ string "var"
+ v <- varsDecl True
+ return $ System (t ++ v)
+
+redoUnit = do
+ string "redo;"
+ comments
+ string "type"
+ comments
+ t <- typesDecl
+ string "var"
+ v <- varsDecl True
+ return $ Redo (t ++ v)
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalPreprocessor.hs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,130 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module PascalPreprocessor where
+
+import Text.Parsec
+import Control.Monad.IO.Class
+import Control.Monad
+import System.IO
+import qualified Data.Map as Map
+import Control.Exception(catch, IOException)
+import Data.Char
+import Prelude hiding (catch)
+
+-- comments are removed
+comment = choice [
+ char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') >> return ""
+ , (try $ string "(*") >> manyTill anyChar (try $ string "*)") >> return ""
+ , (try $ string "//") >> manyTill anyChar (try newline) >> return "\n"
+ ]
+
+preprocess :: String -> String -> String -> [String] -> IO String
+preprocess inputPath alternateInputPath fn symbols = do
+ r <- runParserT (preprocessFile (inputPath ++ fn)) (Map.fromList $ map (\s -> (s, "")) symbols, [True]) "" ""
+ case r of
+ (Left a) -> do
+ hPutStrLn stderr (show a)
+ return ""
+ (Right a) -> return a
+
+ where
+ preprocessFile fn = do
+ f <- liftIO (readFile fn)
+ setInput f
+ preprocessor
+
+ preprocessor, codeBlock, switch :: ParsecT String (Map.Map String String, [Bool]) IO String
+
+ preprocessor = chainr codeBlock (return (++)) ""
+
+ codeBlock = do
+ s <- choice [
+ switch
+ , comment
+ , char '\'' >> many (noneOf "'\n") >>= \s -> char '\'' >> return ('\'' : s ++ "'")
+ , identifier >>= replace
+ , noneOf "{" >>= \a -> return [a]
+ ]
+ (_, ok) <- getState
+ return $ if and ok then s else ""
+
+ --otherChar c = c `notElem` "{/('_" && not (isAlphaNum c)
+ identifier = do
+ c <- letter <|> oneOf "_"
+ s <- many (alphaNum <|> oneOf "_")
+ return $ c:s
+
+ switch = do
+ try $ string "{$"
+ s <- choice [
+ include
+ , ifdef
+ , if'
+ , elseSwitch
+ , endIf
+ , define
+ , unknown
+ ]
+ return s
+
+ include = do
+ try $ string "INCLUDE"
+ spaces
+ (char '"')
+ fn <- many1 $ noneOf "\"\n"
+ char '"'
+ spaces
+ char '}'
+ f <- liftIO (readFile (inputPath ++ fn) `catch` (\(exc :: IOException) -> readFile (alternateInputPath ++ fn) `catch` (\(_ :: IOException) -> error ("File not found: " ++ fn))))
+ c <- getInput
+ setInput $ f ++ c
+ return ""
+
+ ifdef = do
+ s <- try (string "IFDEF") <|> try (string "IFNDEF")
+ let f = if s == "IFNDEF" then not else id
+
+ spaces
+ d <- identifier
+ spaces
+ char '}'
+
+ updateState $ \(m, b) ->
+ (m, (f $ d `Map.member` m) : b)
+
+ return ""
+
+ if' = do
+ s <- try (string "IF" >> notFollowedBy alphaNum)
+
+ manyTill anyChar (char '}')
+ --char '}'
+
+ updateState $ \(m, b) ->
+ (m, False : b)
+
+ return ""
+
+ elseSwitch = do
+ try $ string "ELSE}"
+ updateState $ \(m, b:bs) -> (m, (not b):bs)
+ return ""
+ endIf = do
+ try $ string "ENDIF}"
+ updateState $ \(m, b:bs) -> (m, bs)
+ return ""
+ define = do
+ try $ string "DEFINE"
+ spaces
+ i <- identifier
+ d <- ((string ":=" >> return ()) <|> spaces) >> many (noneOf "}")
+ char '}'
+ updateState $ \(m, b) -> (if (and b) && (head i /= '_') then Map.insert i d m else m, b)
+ return ""
+ replace s = do
+ (m, _) <- getState
+ return $ Map.findWithDefault s s m
+
+ unknown = do
+ fn <- many1 $ noneOf "}\n"
+ char '}'
+ return $ "{$" ++ fn ++ "}"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalUnitSyntaxTree.hs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,119 @@
+module PascalUnitSyntaxTree where
+
+import Data.Maybe
+import Data.Char
+
+data PascalUnit =
+ Program Identifier Implementation Phrase
+ | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
+ | System [TypeVarDeclaration]
+ | Redo [TypeVarDeclaration]
+ deriving Show
+data Interface = Interface Uses TypesAndVars
+ deriving Show
+data Implementation = Implementation Uses TypesAndVars
+ deriving Show
+data Identifier = Identifier String BaseType
+ deriving Show
+data TypesAndVars = TypesAndVars [TypeVarDeclaration]
+ deriving Show
+data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
+ | VarDeclaration Bool Bool ([Identifier], TypeDecl) (Maybe InitExpression)
+ | FunctionDeclaration Identifier Bool Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
+ | OperatorDeclaration String Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
+ deriving Show
+data TypeDecl = SimpleType Identifier
+ | RangeType Range
+ | Sequence [Identifier]
+ | ArrayDecl (Maybe Range) TypeDecl
+ | RecordType [TypeVarDeclaration] (Maybe [[TypeVarDeclaration]])
+ | PointerTo TypeDecl
+ | String Integer
+ | Set TypeDecl
+ | FunctionType TypeDecl [TypeVarDeclaration]
+ | DeriveType InitExpression
+ | VoidType
+ | VarParamType TypeDecl -- this is a hack
+ deriving Show
+data Range = Range Identifier
+ | RangeFromTo InitExpression InitExpression
+ | RangeInfinite
+ deriving Show
+data Initialize = Initialize String
+ deriving Show
+data Finalize = Finalize String
+ deriving Show
+data Uses = Uses [Identifier]
+ deriving Show
+data Phrase = ProcCall Reference [Expression]
+ | IfThenElse Expression Phrase (Maybe Phrase)
+ | WhileCycle Expression Phrase
+ | RepeatCycle Expression [Phrase]
+ | ForCycle Identifier Expression Expression Phrase Bool -- The last Boolean indicates wether it's up or down counting
+ | WithBlock Reference Phrase
+ | Phrases [Phrase]
+ | SwitchCase Expression [([InitExpression], Phrase)] (Maybe [Phrase])
+ | Assignment Reference Expression
+ | BuiltInFunctionCall [Expression] Reference
+ | NOP
+ deriving Show
+data Expression = Expression String
+ | BuiltInFunCall [Expression] Reference
+ | PrefixOp String Expression
+ | PostfixOp String Expression
+ | BinOp String Expression Expression
+ | StringLiteral String
+ | PCharLiteral String
+ | CharCode String
+ | HexCharCode String
+ | NumberLiteral String
+ | FloatLiteral String
+ | HexNumber String
+ | Reference Reference
+ | SetExpression [Identifier]
+ | Null
+ deriving Show
+data Reference = ArrayElement [Expression] Reference
+ | FunCall [Expression] Reference
+ | TypeCast Identifier Expression
+ | SimpleReference Identifier
+ | Dereference Reference
+ | RecordField Reference Reference
+ | Address Reference
+ | RefExpression Expression
+ deriving Show
+data InitExpression = InitBinOp String InitExpression InitExpression
+ | InitPrefixOp String InitExpression
+ | InitReference Identifier
+ | InitArray [InitExpression]
+ | InitRecord [(Identifier, InitExpression)]
+ | InitFloat String
+ | InitNumber String
+ | InitHexNumber String
+ | InitString String
+ | InitChar String
+ | BuiltInFunction String [InitExpression]
+ | InitSet [InitExpression]
+ | InitAddress InitExpression
+ | InitNull
+ | InitRange Range
+ | InitTypeCast Identifier InitExpression
+ deriving Show
+
+data BaseType = BTUnknown
+ | BTChar
+ | BTString
+ | BTInt Bool -- second param indicates whether signed or not
+ | BTBool
+ | BTFloat
+ | BTRecord String [(String, BaseType)]
+ | BTArray Range BaseType BaseType
+ | BTFunction Bool [(Bool, BaseType)] BaseType -- (Bool, BaseType), Bool indiciates whether var or not
+ | BTPointerTo BaseType
+ | BTUnresolved String
+ | BTSet BaseType
+ | BTEnum [String]
+ | BTVoid
+ | BTUnit
+ | BTVarParam BaseType
+ deriving Show
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/unitCycles.hs Tue Jan 21 22:38:13 2014 +0100
@@ -0,0 +1,46 @@
+module Main where
+
+import PascalParser
+import System
+import Control.Monad
+import Data.Either
+import Data.List
+import Data.Graph
+import Data.Maybe
+
+unident :: Identificator -> String
+unident (Identificator s) = s
+
+extractUnits :: PascalUnit -> (String, [String])
+extractUnits (Program (Identificator name) (Implementation (Uses idents) _ _) _) = ("program " ++ name, map unident idents)
+extractUnits (Unit (Identificator name) (Interface (Uses idents1) _) (Implementation (Uses idents2) _ _) _ _) = (name, map unident $ idents1 ++ idents2)
+
+f :: [(String, [String])] -> String
+f = unlines . map showSCC . stronglyConnComp . map (\(a, b) -> (a, a, b))
+ where
+ showSCC (AcyclicSCC v) = v
+ showSCC (CyclicSCC vs) = intercalate ", " vs
+
+myf :: [(String, [String])] -> String
+myf d = unlines . map (findCycle . fst) $ d
+ where
+ findCycle :: String -> String
+ findCycle searched = searched ++ ": " ++ (intercalate ", " $ fc searched [])
+ where
+ fc :: String -> [String] -> [String]
+ fc curSearch visited = let uses = curSearch `lookup` d; res = dropWhile null . map t $ fromJust uses in if isNothing uses || null res then [] else head res
+ where
+ t u =
+ if u == searched then
+ [u]
+ else
+ if u `elem` visited then
+ []
+ else
+ let chain = fc u (u:visited) in if null chain then [] else u:chain
+
+
+main = do
+ fileNames <- getArgs
+ files <- mapM readFile fileNames
+ putStrLn . myf . map extractUnits . rights . map parsePascalUnit $ files