# HG changeset patch # User koda # Date 1390340293 -3600 # Node ID 4feced261c68eaeb722eb16918a50a2104e3fef8 # Parent 56d2f2d5aad861ba8f750c6c0790b5be230c74a6# Parent 84835d0ceb649141cdf762b03946587bfe6442ea 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. diff -r 56d2f2d5aad8 -r 4feced261c68 .hgignore --- 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* diff -r 56d2f2d5aad8 -r 4feced261c68 CMakeLists.txt --- 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) diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/CMakeLists.txt --- 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}) diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/game.cpp diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/gameuiconfig.cpp diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/gameuiconfig.h diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/hwform.cpp diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/hwform.h diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/net/newnetclient.cpp diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/net/newnetclient.h diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/ui/dialog/input_password.cpp diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/ui/page/pagemain.cpp diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/ui/page/pagevideos.cpp diff -r 56d2f2d5aad8 -r 4feced261c68 QTfrontend/ui/widget/about.cpp diff -r 56d2f2d5aad8 -r 4feced261c68 cmake_modules/CMakePascalInformation.cmake diff -r 56d2f2d5aad8 -r 4feced261c68 cmake_modules/FindClang.cmake --- /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 +# +# 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) + diff -r 56d2f2d5aad8 -r 4feced261c68 cmake_modules/FindGLEW.cmake --- /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 +# +# 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) + diff -r 56d2f2d5aad8 -r 4feced261c68 cmake_modules/paths.cmake diff -r 56d2f2d5aad8 -r 4feced261c68 gameServer/Actions.hs diff -r 56d2f2d5aad8 -r 4feced261c68 gameServer/CMakeLists.txt diff -r 56d2f2d5aad8 -r 4feced261c68 gameServer/HWProtoInRoomState.hs diff -r 56d2f2d5aad8 -r 4feced261c68 gameServer/hedgewars-server.cabal diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/ArgParsers.pas --- 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(); diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/CMakeLists.txt --- 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) diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/LuaPas.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/SDLh.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/adler32.pas --- 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= 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uAIAmmoTests.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uAIMisc.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uAmmos.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uCaptions.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uChat.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uCollisions.pas --- 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); diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uCommandHandlers.pas diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uConsole.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uConsts.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uCursor.pas diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uFloat.pas --- 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. diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uGame.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uGears.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uGearsHandlers.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uGearsHandlersMess.pas --- 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)) 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uGearsList.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uGearsRender.pas --- 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)); diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uGearsUtils.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uIO.pas --- 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. diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uInputHandler.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uLand.pas diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uLandGenMaze.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uLandGraphics.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uLandObjects.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uLandOutline.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uLandPainted.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uLandTemplates.pas diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uLandTexture.pas diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uLocale.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uMatrix.pas --- /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 + * + * 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. diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uMisc.pas --- 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); diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uPhysFSLayer.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uRandom.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uRender.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uRenderUtils.pas --- 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. diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uScript.pas --- 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)); diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uSound.pas --- 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 sndNone) then begin LastVoice.snd:= VoiceList[i].snd; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uStats.pas --- 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); diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uStore.pas --- 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} diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uTeams.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uTouch.pas --- 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); diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uTypes.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uUtils.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uVariables.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uVisualGears.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uVisualGearsHandlers.pas --- 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. diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uVisualGearsList.pas --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 hedgewars/uWorld.pas --- 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; diff -r 56d2f2d5aad8 -r 4feced261c68 misc/liblua/CMakeLists.txt diff -r 56d2f2d5aad8 -r 4feced261c68 misc/liblua/lauxlib.c --- 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); diff -r 56d2f2d5aad8 -r 4feced261c68 misc/libphysfs/CMakeLists.txt diff -r 56d2f2d5aad8 -r 4feced261c68 misc/libphyslayer/CMakeLists.txt --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 misc/libphyslayer/hwpacksmounter.h --- 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 diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/Android-build/CMakeLists.txt diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/frontlib/hwconsts.h diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/frontlib/md5/md5.h diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/frontlib/model/gamesetup.h diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/frontlib/model/map.h diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/frontlib/model/mapcfg.h diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/frontlib/model/room.h diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/frontlib/model/team.h diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/frontlib/net/netconn.h diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/frontlib/net/netconn_internal.h diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/CMakeLists.txt --- /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}) + diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/CMakeLists.txt --- /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) + + + + + diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/GL.h --- /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 +#else +#include "GL/gl.h" +#endif + diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/Math.h --- /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 + diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/SysUtils.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 diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/Types.h --- /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 diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/fileio.c --- /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 +#include +#include +#include + +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); +} + diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/fileio.h --- /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 +#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_ */ diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/fpcrtl.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 +#include +#include +#include +#include + +#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 diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/misc.c --- /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 +#include +#include +#include + +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 diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/misc.h --- /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 +#include + +#ifdef EMSCRIPTEN +#include +#else +#include +#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 diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/pas2c.h --- /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 +#include +#include +#include +#include + +#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} + + diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/pmath.c --- /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 +#include + +/* + * 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; +} diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/pmath.h --- /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 +#include + +#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_ */ diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/system.c --- /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 +#include +#include +#include + +#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); +} + diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/system.h --- /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 +#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_ */ diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/sysutils.c --- /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 +#include +#include +#include + +#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; +} diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/tests/check_check.c --- /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 +#include +#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; +} diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/tests/check_check.h --- /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 diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/tests/check_fileio.c --- /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 +#include +#include +#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; +} diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/tests/check_misc.c --- /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 +#include +#include +#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; +} diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/tests/check_system.c --- /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 +#include +#include +#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; +} + diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/tests/check_sysutils.c --- /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 +#include +#include +#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; +} diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/tests/fileio_test.c --- /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(); +} diff -r 56d2f2d5aad8 -r 4feced261c68 project_files/hwc/rtl/tests/main.c --- /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 +#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 diff -r 56d2f2d5aad8 -r 4feced261c68 share/CMakeLists.txt diff -r 56d2f2d5aad8 -r 4feced261c68 share/hedgewars/Data/CMakeLists.txt --- 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}) diff -r 56d2f2d5aad8 -r 4feced261c68 share/hedgewars/Data/Shaders/CMakeLists.txt --- /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) diff -r 56d2f2d5aad8 -r 4feced261c68 share/hedgewars/Data/Shaders/default.fs --- /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; + } +} diff -r 56d2f2d5aad8 -r 4feced261c68 share/hedgewars/Data/Shaders/default.vs --- /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; +} diff -r 56d2f2d5aad8 -r 4feced261c68 share/hedgewars/Data/Shaders/water.fs --- /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; +} diff -r 56d2f2d5aad8 -r 4feced261c68 share/hedgewars/Data/Shaders/water.vs --- /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; +} diff -r 56d2f2d5aad8 -r 4feced261c68 tools/pas2c/CMakeLists.txt --- /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}") + diff -r 56d2f2d5aad8 -r 4feced261c68 tools/pas2c/Main.hs --- /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" + ] + diff -r 56d2f2d5aad8 -r 4feced261c68 tools/pas2c/Pas2C.hs --- /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 "<>" +initExpr2C' (InitSet []) = return $ text "0" +initExpr2C' (InitSet a) = return $ text "<>" +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 "<>" <+>) + 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 + diff -r 56d2f2d5aad8 -r 4feced261c68 tools/pas2c/PascalBasics.hs --- /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) diff -r 56d2f2d5aad8 -r 4feced261c68 tools/pas2c/PascalParser.hs --- /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) + diff -r 56d2f2d5aad8 -r 4feced261c68 tools/pas2c/PascalPreprocessor.hs --- /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 ++ "}" diff -r 56d2f2d5aad8 -r 4feced261c68 tools/pas2c/PascalUnitSyntaxTree.hs --- /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 diff -r 56d2f2d5aad8 -r 4feced261c68 tools/pas2c/unitCycles.hs --- /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