'OHRRPGCE - the graphics, audio and user input library!
'(C) Copyright 1997-2025 James Paige, Ralph Versteegen, and the OHRRPGCE Developers
'Dual licensed under the GNU GPL v2+ and MIT Licenses. Read LICENSE.txt for terms and disclaimer of liability.
'
'This module is completely bool-clean (bool always used when appropriate)
#include "config.bi"
#include "crt/string.bi"
#include "crt/limits.bi"
#include "string.bi"
#include "common.bi"
#include "allmodex.bi"
#include "gfx.bi"
#include "surface.bi"
#include "matrixMath.bi"
#include "lib/gif.bi"
#include "lib/lodepng.bi"
#include "lib/ujpeg.bi"
#include "lib/jo_jpeg.bi"
#include "music.bi"
#include "reload.bi"
#include "util.bi"
#include "const.bi"
#include "uiconst.bi"
#include "slices.bi"
#include "loading.bi"
#include "cmdline.bi"
#include "steam.bi"
#include "sliceedit.bi"
using Reload
#ifdef IS_GAME
#include "game.bi" 'For exit_gracefully
#endif
#ifdef IS_CUSTOM
#include "cglobals.bi" 'For channel_to_Game
#endif
#ifdef __FB_ANDROID__
'This is gfx_sdl specific, of course, but a lot of the stuff in our fork of the android fork
'of SDL 1.2 would more make sense to live in totally separate java files, which is something we will
'want to do to support SDL 2 on Android.
extern "C"
'Return value is always 1
declare function SDL_ANDROID_EmailFiles(address as zstring ptr, subject as zstring ptr, message as zstring ptr, file1 as zstring ptr = NULL, file2 as zstring ptr = NULL, file3 as zstring ptr = NULL) as integer
end extern
#endif
'Note: While non-refcounted frames work (at last check), it's not used anywhere, and you most probably do not need it
'NOREFC is also used to indicate uncached Palette16's. Note Palette16's are NOT refcounted in the way as frames
'const NOREFC = -1234
const FREEDREFC = -4321
type XYPair_node 'only used for floodfill
x as integer
y as integer
nextnode as XYPair_node ptr
end type
'----------- Local functions ----------
declare sub _frame_copyctor cdecl(dest as Frame ptr ptr, src as Frame ptr ptr)
declare sub init_frame_with_surface(ret as Frame ptr, surf as Surface ptr)
declare sub update_spriteset_global_animations_cache(sprtype as SpriteType)
declare sub empty_spriteset_global_animations_cache()
declare sub frame_draw_internal(src as Frame ptr, masterpal() as RGBcolor, pal as Palette16 ptr = NULL, x as integer, y as integer, trans as bool = YES, dest as Frame ptr, opts as DrawOptions = def_drawoptions)
declare sub draw_clipped(src as Frame ptr, pal as Palette16 ptr = NULL, x as integer, y as integer, trans as bool = YES, dest as Frame ptr, opts as DrawOptions)
declare sub draw_clipped_scaled(src as Frame ptr, pal as Palette16 ptr = NULL, x as integer, y as integer, trans as bool = YES, dest as Frame ptr, opts as DrawOptions)
declare sub draw_clipped_surf(src as Surface ptr, master_pal as RGBcolor ptr, pal as Palette16 ptr = NULL, x as integer, y as integer, trans as bool = YES, dest as Frame ptr, destsurf as Surface ptr, opts as DrawOptions = def_drawoptions)
'declare sub grabrect(page as integer, x as integer, y as integer, w as integer, h as integer, ibuf as ubyte ptr, tbuf as ubyte ptr = 0)
declare function write_bmp_header(filen as string, w as integer, h as integer, bitdepth as integer) as integer
declare function decode_bmp_bitmask(mask as uint32) as integer
declare sub loadbmp32(bf as integer, surf as Surface ptr, infohd as BITMAPV3INFOHEADER)
declare sub loadbmp24(bf as integer, surf as Surface ptr)
declare sub loadbmp8(bf as integer, fr as Frame ptr)
declare sub loadbmp4(bf as integer, fr as Frame ptr)
declare sub loadbmp1(bf as integer, fr as Frame ptr)
declare sub loadbmprle8(bf as integer, fr as Frame ptr)
declare sub loadbmprle4(bf as integer, fr as Frame ptr)
declare function next_unused_screenshot_filename() as string
declare sub snapshot_check(page as integer = -1)
declare function calcblock(tmap as TileMap, x as integer, y as integer, overheadmode as integer, pmapptr as TileMap ptr) as integer
declare function compatpage_internal(pageframe as Frame ptr) as Frame ptr
declare sub screen_size_update ()
declare sub masterpal_changed()
declare sub pollingthread(as any ptr)
declare sub keystate_convert_bit3_to_keybits(keystate() as KeyBits)
declare function read_inputtext () as string
declare sub update_mouse_state ()
declare sub load_replay_header ()
declare sub record_input_tick ()
declare sub replay_input_tick ()
declare sub read_replay_length ()
declare function draw_allmodex_recordable_overlays (page as integer) as bool
declare function draw_allmodex_overlays (page as integer) as bool
declare sub show_replay_overlay()
declare sub hide_overlays ()
declare sub update_fps_counter (skipped as bool)
declare sub allmodex_controls ()
declare sub replay_controls ()
declare function hexptr(p as any ptr) as string
declare sub Palette16_delete(f as Palette16 ptr ptr)
declare function palette16_load_pal_single(fh as integer) as Palette16 ptr
#define POINT_CLIPPED(x, y) ((x) < cliprect.l orelse (x) > cliprect.r orelse (y) < cliprect.t orelse (y) > cliprect.b)
#define FRAMEPIXEL(x, y, fr) fr->image[fr->pitch * (y) + (x)]
' In a function, pass return value on error
' NULL .image ptr indicates that either the Frame is Surface-backed or it's corrupt,
' so might as well check that instead of ->surf. This is misnamed: doesn't allow 8-bit surfaces.
#define CHECK_FRAME_8BIT(fr, retwhat...) FAIL_IF((fr)->image = NULL, " NULL Frame.image", retwhat)
'------------ Global variables ------------
dim modex_initialised as bool = NO
dim vpages() as Frame ptr
dim vpagesp as Frame ptr ptr 'points to vpages(0) for debugging: fbc outputs typeless debugging symbol
dim shared default_page_bitdepth as integer = 8 '8 or 32. Affects allocatepage only, set by switch_to_*bit_vpages()
dim faded_in as bool = YES 'NO when screen is faded to a color, YES when faded to a palette
dim faded_to_color as RGBcolor 'If faded_in=NO, the color the screen is faded to
'Whether the player has at any point toggled fullscreen/windowed in some low-level way
'like alt+enter or window buttons.
dim user_toggled_fullscreen as bool = NO
'The -input-debug cmdline option: causes gfx backends to print info about events and other user/OS input
'(Use set_debugging_io to set)
dim debugging_io as bool = NO
'Amount of time (in seconds) that the user has been actively using the program. Stops counting if no input
dim active_seconds as double
'Seconds without input after which to stop increasing time
dim idle_time_threshold as double = 30.
'When last input arrived
dim shared last_active_time as double
'These are only used in Game, do nothing if not started
dim as MultiTimer main_timer, gfx_op_timer, gfx_slice_timer
dim def_drawoptions as DrawOptions
redim fonts(fontLAST) as Font ptr
'Toggles 0-1 every time dowait is called
dim global_tog as integer
'Convert scancodes to text; Enter does not insert newline!
'This array is a global instead of an internal detail because it's used by charpicker and the font editor
'to work out key mapping for the extended characters. Would be nice if it weren't needed.
'FIXME: discover why this array is filled with empty values on Android
'key2text(0,*): no modifiers
'key2text(1,*): shift
'key2text(2,*): alt
'key2text(3,*): alt+shift
dim key2text(3,53) as zstring*2 => { _
{"", "", "1","2","3","4","5","6","7","8","9","0","-","=","","","q","w","e","r","t","y","u","i","o","p","[","]","","","a","s","d","f","g","h","j","k","l",";","'","`","","\","z","x","c","v","b","n","m",",",".","/"}, _
{"", "", "!","@","#","$","%","^","&","*","(",")","_","+","","","Q","W","E","R","T","Y","U","I","O","P","{","}","","","A","S","D","F","G","H","J","K","L",":","""","~","","|","Z","X","C","V","B","N","M","<",">","?"}, _
{"", "", !"\130",!"\131",!"\132",!"\133",!"\134",!"\135",!"\136",!"\137",!"\138",!"\139",!"\140",!"\141","","",!"\142",!"\143",!"\144",!"\145",!"\146",!"\147",!"\148",!"\149",!"\150",!"\151",!"\152",!"\153","","",!"\154",!"\155",!"\156",!"\157",!"\158",!"\159",!"\160",!"\161",!"\162",!"\163",!"\164",!"\165","",!"\166",!"\167",!"\168",!"\169",!"\170",!"\171",!"\172",!"\173",!"\174",!"\175",!"\176"}, _
{"", "", !"\177",!"\178",!"\179",!"\180",!"\181",!"\182",!"\183",!"\184",!"\185",!"\186",!"\187",!"\188","","",!"\189",!"\190",!"\191",!"\192",!"\193",!"\194",!"\195",!"\196",!"\197",!"\198",!"\199",!"\200","","",!"\201",!"\202",!"\203",!"\204",!"\205",!"\206",!"\207",!"\208",!"\209",!"\210",!"\211",!"\212","",!"\213",!"\214",!"\215",!"\216",!"\217",!"\218",!"\219",!"\220",!"\221",!"\222",!"\223"} _
}
' Translate scancodes scNumpadSlash and up to ASCII.
' Again, Enter is skipped.
' *, -, + are missing, since their scancodes aren't contiguous with the others.
dim shared numpad2text(...) as zstring*2 => {"7","8","9","","4","5","6","","1","2","3","0","."}
' Frame type table
DEFINE_VECTOR_OF_TYPE_COMMON(Frame ptr, Frame_ptr, @_frame_copyctor, @frame_unload)
DEFINE_VECTOR_OF_POD_TYPE(Animation ptr, Animation_ptr)
'--------- Module shared variables ---------
'For each vpage() element, this records whether it shouldn't be resized when the window size changes (normally is)
'(Not fully implemented, as it seems it would only benefit textbox_appearance_editor)
'dim shared fixedsize_vpages() as bool
#ifndef NO_TLS
dim shared tlsKeyClipRect as TLSKey
#endif
'The current internal size of the window (takes effect at next setvispage).
'Should only be modified via set_resolution and unlock_resolution
dim shared windowsize as XYPair = (320, 200)
'Remember gfx scale/zoom when no gfx backend is initialised (default to not changing it)
'Don't use this otherwise! Call gfx_getwindowstate instead.
dim shared remember_scale as integer = -1
'Minimum window size; can't resize width or height below this. Default to (0,0): no bound
'Also equal to (0,0) when window isn't resizeable.
dim shared minwinsize as XYPair
dim shared resizing_requested as bool = NO 'Whether we want the window to be resizable, even if unsupported
dim shared resizing_enabled as bool = NO 'Current backend state (maybe this should be in WindowState instead)
'State for drawing maps (I wish we didn't have any global state)
dim shared bordertile as integer
type SkippedFrame
page as integer = -1
declare sub drop()
declare sub show()
end type
#ifdef __FB_BLACKBOX__
#define BACKEND_GOVERNED_FRAMERATE
#endif
#ifdef BACKEND_GOVERNED_FRAMERATE
#define frame_timer frame_pseudo_timer
#ifdef __FB_BLACKBOX__
#define gfx_native_framerate blackbox_native_framerate
#define gfx_wait_one_frame blackbox_wait_one_frame
#else
'TODO: add gfx function pointers
extern "C"
declare function gfx_sdl2_native_framerate() as double
declare sub gfx_sdl2_wait_one_frame()
end extern
#define gfx_native_framerate gfx_sdl2_native_framerate
#define gfx_wait_one_frame gfx_sdl2_wait_one_frame
#endif
#else
#define frame_timer timer
#endif
#ifdef BACKEND_GOVERNED_FRAMERATE
dim shared frame_pseudo_timer as double
#endif
dim shared waittime as double
dim shared flagtime as double = 0.0
dim shared setwait_called as bool
dim shared tickcount as integer = 0
dim use_speed_control as bool = YES
dim requested_framerate as double 'Set by last setwait, takes into account the fps_multiplier
dim shared base_fps_multiplier as double = 1.0 'Doesn't include effect of shift+tab
dim shared fps_multiplier as double = 1.0 'Effective speed multiplier, affects all setwait/dowaits
dim max_display_fps as integer = 60 'Skip frames if drawing more than this.
dim shared frame_index as integer 'Count number of setvispage calls
dim shared skipped_frame as SkippedFrame 'Records the last setvispage call if it was frameskipped.
dim shared last_setvispage as integer = -1 'Records the last setvispage. -1 if none.
'Virtually always vpage; in fact using anything other than vpage
'would cause a lot of functions like multichoice to glitch.
'Don't use this directly; call getvispage instead!
dim shared log_slow as bool = NO 'Enable spammy debug_if_slow logging
'If this is defined, the effect of vsync on Macs is simulated, where gfx_present
'blocks until vsync occurs. Other OSes might do the same, but generally don't.
'Note: this simulates vsync at 60fps regardless of max_display_fps
'#define SIMULATE_BLOCKING_VSYNC
type InputStateFwd as InputState
' Shared by KeyboardState and JoystickState, this holds down/triggered/new-press
' state of an array of keys/buttons.
type KeyArray extends Object
keys(any) as KeyBits 'State of each key
key_down_ms(any) as integer 'ms each key has been down
arrow_key_down_ms as integer 'Max ms that any arrow key has been down
' Redim the arrays. (Not a constructor, because that's a nuisance for globals)
declare sub init(maxkey as integer)
declare abstract function is_arrow_key(key as integer) as bool
declare sub update_keydown_times(inputst as InputStateFwd)
'In following, key is a KBScancode or JoyButton depending on subclass
declare function key_repeating(key as integer, repeat_wait as integer, repeat_rate as integer, inputst as InputStateFwd) as KeyBits
declare abstract function keyval(key as integer, repeat_wait as integer = 0, repeat_rate as integer = 0, inputst as InputStateFwd, byref down_ms as integer) as KeyBits
declare abstract function anykey(player as integer, inputst as InputStateFwd, byref down_ms as integer) as KeyBits
declare sub clearkeys()
end type
type KeyboardState extends KeyArray
delayed_alt_keydown as bool = NO 'Whether have delayed reporting an ALT keypress
inputtext as string
declare constructor()
declare sub reset()
declare sub update_keybits()
declare function is_arrow_key(key as KBScancode) as bool
declare function numpad_alias_key(key as KBScancode) as KBScancode
declare function keyval(key as KBScancode, repeat_wait as integer = 0, repeat_rate as integer = 0, inputst as InputStateFwd, byref down_ms as integer) as KeyBits
declare function anykey(player as integer, inputst as InputStateFwd, byref down_ms as integer) as KeyBits
end type
dim shared last_setkeys_time as double 'Used to compute real_input.elapsed_ms
dim shared inputtext_enabled as bool = NO 'Whether to fetch real_input.kb.inputtext, not applied to replay_input.kb
dim shared remap_numpad as bool = YES 'If YES, then when numlock is off remap numpad .0-9 to arrows/home/etc
'If true, assume a US keyboard layout (use get_ascii_inputtext instead of calling io_enable_textinput + io_textinput).
'Used as workaround for #1064.
dim shared disable_native_text_input as bool = NO
'True if disable_native_text_input set by a commandline or config option
dim shared overrode_native_text_input as bool = NO
dim shared swap_joystick_use_cancel as optbool = NONBOOL 'NONBOOL if not computed yet
dim shared joysticks_globally_disabled as bool = NO
type JoystickState extends KeyArray
state as IOJoystickState
' Configuration
axis_threshold as integer = AXIS_LIMIT / 2
declare constructor()
declare sub update_keybits(joynum as integer)
declare function is_arrow_key(key as JoyButton) as bool
declare function keyval(key as JoyButton, repeat_wait as integer = 0, repeat_rate as integer = 0, inputst as InputStateFwd, byref down_ms as integer) as KeyBits
declare function anykey(player as integer, inputst as InputStateFwd, byref down_ms as integer) as KeyBits
end type
' Keyboard and joystick state which is separate for recording and replaying.
' (In future will include mouse too, once record/replay is implemented for mouse)
type InputState
'Shared between keyboard and joysticks
elapsed_ms as integer 'Time since last setkeys call (used by key_repeating)
repeat_wait as integer = 500 'ms before keys start to repeat
repeat_rate as integer = 55 'repeat interval, in ms
kb as KeyboardState
'Player i has joystick i+1 so it must always be the case that ubound(joys) + 1 = ubound(keymaps)
joys(maxPlayers - 1) as JoystickState
keymaps(1 to maxPlayers) as PlayerKeymap 'Set of keybinds for each player.
declare function controlkey(player as integer, cc as ccCode, repeat_wait as integer = 0, repeat_rate as integer = 0, byref down_ms as integer, check_keyboard as bool = YES) as KeyBits
declare sub reset_keymaps()
end type
dim shared real_input as InputState 'Always contains real state even if replaying
dim shared replay_input as InputState 'Contains replayed input state while replaying, else unused
'NOTE! Recording/replaying joysticks not implemented yet!
'Singleton type
type ReplayState
active as bool 'Currently replaying input and not paused
paused as bool 'While paused, keyval, etc, act on real_input.kb.
filename as string 'Used only for error messages.
file as integer = -1 'File handle
tick as integer = -1 'Counts number of ticks we've replayed
fpos as integer 'Debugging only: File offset of the tick chunk
nexttick as integer = -1 'If we read the next tickcount from the file before it's needed
'it's stored here. Otherwise -1.
next_tick_ms as integer = 55 'Next tick milliseconds read before it's needed.
debug as bool = NO 'Set to YES by editing this line; maybe add a commandline option
length_ticks as integer 'Length in ticks (max tick num)
length_ms as integer 'Approximate length of the replay, in milliseconds
play_position_ms as integer 'Approximate position in replay in ms (calculated in same way as length_ms)
repeat_count as integer 'Number of times to repeat the playback
repeats_done as integer 'Number of repeats already finished.
end type
'Singleton type for recording input.
type RecordState
file as integer = -1 'File handle
active as bool 'Currently recording input and not paused.
paused as bool 'While paused, calls to setkeys don't affect recording.
tick as integer = -1 'Tick number, starting from zero.
debug as bool = NO 'Set to YES by editing this line; maybe add a commandline option
last_kb as KeyboardState 'Keyboard state during previous recorded tick
end type
dim shared replay as ReplayState
dim shared record as RecordState
dim shared macrofile as string
'Abstract base class for recording a video (eg .gif)
type VideoRecorder extends Object
declare virtual property active() as bool
declare abstract sub stop()
declare abstract sub record_frame(fr as Frame ptr, pal() as RGBcolor)
end type
type GIFRecorder extends VideoRecorder
'active as bool
writer as GifWriter
fname as string
secondscreen as string 'When recording combined editor+player .gif: path to player screen file
last_frame_end_time as double 'Nominal time when the delay for the last frame we wrote ends
declare constructor(outfile as string, secondscreen as string = "")
declare property active() as bool
declare sub stop()
declare sub record_frame(fr as Frame ptr, pal() as RGBcolor)
declare function calc_delay() as integer
end type
'Class for saving a screenshot to a certain file every frame
type ScreenForwarder extends VideoRecorder
fname as string
declare constructor(outfile as string)
declare property active() as bool
declare sub stop()
declare sub record_frame(fr as Frame ptr, pal() as RGBcolor)
end type
dim shared recordvid as VideoRecorder ptr
dim shared gif_max_fps as integer = 30
dim shared screenshot_record_overlays as bool = NO
dim shared gif_show_keys_overlay as bool 'Whether to display pressed keys overlay while recording a gif
dim shared show_mouse_overlay as bool 'Whether to draw mouse location overlay (regardless of gif recording)
dim shared loaded_screenshot_settings as bool = NO
dim shared screenshot_format as string
dim shared use_gfx_screenshot as bool
dim shared closerequest as bool = NO 'It has been requested to close the program.
dim gfxmutex as any ptr '(Global) Coordinates access to globals and gfx backend with the polling thread
dim main_thread_in_gfx_backend as bool '(Global) Whether the main thread has acquired gfxmutex.
'State variables for the pollingthread
type PollingThreadState
threadptr as any ptr 'id of the polling thread
wantquit as bool 'signal the polling thread to quit
keybdstate(scLAST) as KeyBits '"real"time keyboard array
mousebuttons as integer
mouselastbuttons as integer
end type
dim shared pollthread as PollingThreadState
'State of the mouse (set when setkeys is called), includes persistent state
dim shared mouse_state as MouseInfo
dim shared last_mouse_wheel as integer 'mouse_state.wheel at previous update_mouse_state call.
dim shared cursorvisibility as CursorVisibility = cursorDefault
dim shared textfg as integer
dim shared textbg as integer
'Master palette copies internal to allmodex.
'(Length 257 because they double as RGBPalettes)
'master() is usually equal to these two, but does not take effect until setpal or fadein is called.
'displaypal is used for display (including screenshots and gifs), while curmasterpal is for drawing.
'curmasterpal is used for colors drawn to a 32-bit vpage, and for nearcolor lookups when drawing
'to a 8-bit vpage (e.g. drawing with blending), and for exporting.
'In 32-bit mode, displaypal is never used; in 8-bit mode, displaypal gets faded in and out.
dim shared displaypal(0 to 256) as RGBcolor 'Current display palette; in 8-bit mode includes screen fades
extern "C"
dim shared curmasterpal(0 to 256) as RGBcolor 'Palette at last setpal/fadein, excludes any screen fades
end extern
dim shared updatepal as bool 'setpal called, load new palette at next setvispage
dim shared nearcolor_kdtree as GifKDTree ptr 'Use for fast nearest-color lookups into curmasterpal()
dim shared fps_draw_frames as integer = 0 'Frames drawn since fps_time_start
dim shared fps_real_frames as integer = 0 'Frames sent to gfx backend since fps_time_start
dim shared fps_time_start as double = 0.0
dim shared draw_fps as double 'Current measured frame draw rate, per second
dim shared real_fps as double 'Current measured frame display rate, per second
dim shared overlay_showfps as integer = 0 'Draw on overlay? 0 (off), 1 (real fps), or 2 (draw fps)
dim shared overlays_enabled as bool = YES 'Whether to draw overlays in general
dim shared overlay_message as string 'Message to display on screen
dim shared overlay_hide_time as double 'Time at which to hide it
dim shared overlay_replay_display as bool
MAKETYPE_DoubleList(SpriteCacheEntry)
MAKETYPE_DListItem(SpriteCacheEntry)
type SpriteCacheEntry
'cachelist used only if object is a member of sprcacheB
cacheB as DListItem(SpriteCacheEntry)
key as integer 'Used as HashTable key
p as Frame ptr
cost as integer
Bcached as bool
end type
CONST SPRITE_CACHE_MULT = 1000000
#define SPRITE_CACHE_KEY(sprtype, record) (sprtype * SPRITE_CACHE_MULT + record)
dim shared sprcache as HashTable
dim shared sprcacheB as DoubleList(SpriteCacheEntry)
dim shared sprcacheB_used as integer 'number of slots full
'dim shared as integer cachehit, cachemiss
dim shared spriteset_global_animations_cache(sprTypeFirst to sprTypeLast) as AnimationSet ptr
dim shared mouse_grab_requested as bool = NO
dim shared mouse_grab_nested_pauses as integer = 0
dim shared mouse_grab_scrolllock_overridden as bool = NO
dim shared remember_mouse_grab as RectPoints
dim shared remember_title as string 'The window title
dim shared global_sfx_volume as single = 1.
'==========================================================================================
' Initialisation and shutdown
'==========================================================================================
' Initialise anything in this module that's independent from the gfx backend
local sub modex_init()
#ifndef NO_TLS
tlsKeyClipRect = tls_alloc_key()
#endif
gfxmutex = mutexcreate
'Just to ensure nearcolor_kdtree isn't NULL. curmasterpal() is probably empty
masterpal_changed
palette16_reload_cache 'read data/defaultgfx/ohrrpgce.pal
redim vpages(3)
'redim fixedsize_vpages(3) 'Initially all NO
vpagesp = @vpages(0)
for i as integer = 0 to 3
vpages(i) = frame_new(windowsize.w, windowsize.h, , YES)
next
'other vpages slots are for temporary pages
'They are currently still used in tileset_editor, import_export_tilesets,
'and mapedit_linkdoors.
'Except for the first two, they're assumed to be the same size as pages 0/1.
sprcache.construct()
dlist_construct(sprcacheB.generic, offsetof(SpriteCacheEntry, cacheB))
sprcacheB_used = 0
' TODO: tmpdir is shared by all instances of Custom, but when that is fixed this can be removed
macrofile = tmpdir & "macro" & get_process_id() & ".ohrkeys"
end sub
' This is called from init_preferred_gfx_backend before gfx_init/Initialize. gfxbackend is set.
' Note that it can be called repeatedly with different backends.
sub before_gfx_backend_init()
'Tell the backend what resolution/scale to initialise at
if gfx_set_window_size then
gfx_set_window_size(windowsize, remember_scale)
else
' Backends that don't support gfx_set_window_size, which don't
' support non-320x200 anyway. Actually just gfx_directx
' supports changing zoom; gfx_alleg/console don't.
gfx_setoption("zoom", str(remember_scale))
end if
'This for when switching to gfx_directx; sdl/sdl2/fb can read the global
if debugging_io then gfx_setoption("input-debug", "")
end sub
' Initialise stuff specific to the backend (this is called after a successful gfx_init(),
' but not after an unsuccessful one, so isn't called as often as before_backend_init())
local sub after_gfx_backend_init()
'Polling thread variables
pollthread.wantquit = NO
pollthread.mouselastbuttons = 0
pollthread.mousebuttons = 0
if wantpollingthread then
debuginfo "Starting IO polling thread"
pollthread.threadptr = threadcreate(@pollingthread)
end if
io_init()
if overrode_native_text_input = NO then
disable_native_text_input = NO
#ifdef USE_X11
if gfxbackend = "sdl" then
'As a workaround for bug #1064, we disable native text input by default
'on X11 (Linux/BSD) when using gfx_sdl, avoiding SDL_EnableUNICODE
disable_native_text_input = YES
end if
#endif
end if
debuginfo "disable_native_text_input=" & disable_native_text_input
'gfx_fb has bad numpad support and already remaps the numpad anyway,
'so our remapping isn't useful. Also it doesn't report numlock state,
'so remapping would cause text input "4" and scLeft at the same time.
if gfxbackend = "fb" then remap_numpad = NO
fps_time_start = TIMER
fps_draw_frames = 0
fps_real_frames = 0
if gfx_supports_variable_resolution() = NO then
debuginfo "Resolution changing not supported"
resizing_enabled = NO
windowsize = XY(320, 200)
'In case we're called from switch_gfx, resize video pages
screen_size_update
else
if resizing_requested then
resizing_enabled = gfx_set_resizable(YES, minwinsize.w, minwinsize.h)
else
resizing_enabled = gfx_set_resizable(NO, 0, 0)
end if
end if
end sub
' Initialise this module and backends, create a window
' (set_resolution can be called before this to set initial resolution. Other functions generally can't!)
sub setmodex()
modex_init()
'Select and initialise a graphics/io backend; calls before_gfx_backend_init()
init_preferred_gfx_backend()
after_gfx_backend_init()
modex_initialised = YES
end sub
' Cleans up anything in this module which is independent of the graphics backend
local sub modex_quit()
stop_recording_input
stop_recording_video
for i as integer = 0 to ubound(vpages)
frame_unload(@vpages(i))
next
for i as integer = 0 to ubound(fonts)
font_unload(@fonts(i))
next
sprcache.destruct()
'debug "cachehit = " & cachehit & " mis == " & cachemiss
releasestack
safekill macrofile
mutexdestroy gfxmutex
#ifndef NO_TLS
tls_free_key(tlsKeyClipRect) 'Leaking the ClipState, don't care
#endif
end sub
' Cleans up everything that ought to be done before calling gfx_close()
local sub before_gfx_backend_quit()
'clean up io stuff
if pollthread.threadptr then
pollthread.wantquit = YES
threadwait pollthread.threadptr
pollthread.threadptr = NULL
end if
skipped_frame.drop()
flush_gfx_config_settings
end sub
' Deinitialise this module and backends, destroy the window
sub restoremode()
if modex_initialised = NO then exit sub
if main_thread_in_gfx_backend then
'This can happen when quitting from crash handler. Likely to deadlock
debug "skipping gfx_close"
exit sub
end if
modex_initialised = NO
debuginfo "Closing gfx backend & allmodex..."
before_gfx_backend_quit()
gfx_close()
modex_quit()
debuginfo "...done"
end sub
' Switch to a different gfx backend. Returns true if successfully switched
function switch_gfx(backendname as string) as bool
debuginfo "switch_gfx " & backendname
dim ret as bool
before_gfx_backend_quit()
'This will call before_gfx_backend_init()
ret = switch_gfx_backend(backendname)
after_gfx_backend_init()
if not ret then return NO
' Re-apply settings (this is very incomplete)
setwindowtitle remember_title
io_setmousevisibility(cursorvisibility)
return ret
end function
'Force config settings to be reloaded, since they may be game- or backend-specific
sub flush_gfx_config_settings()
loaded_screenshot_settings = NO
'The default keymap depends on the env.asiabuttons config
swap_joystick_use_cancel = NONBOOL
reset_keymaps
end sub
sub settemporarywindowtitle (title as string)
'just like setwindowtitle but does not memorize the title
GFX_ENTER
gfx_windowtitle(title)
GFX_EXIT
end sub
sub setwindowtitle (title as string)
remember_title = title
GFX_ENTER
gfx_windowtitle(title)
GFX_EXIT
end sub
local sub set_debugging_io(state as bool)
debugging_io = state
'sdl/sdl2/fb access the debugging_io global, but gfx_directx does not
if gfx_setoption then
gfx_setoption(@"input-debug", iif(state, @"1", @"0"))
end if
end sub
function allmodex_setoption(opt as string, arg as string) as integer
if opt = "no-native-kbd" then
disable_native_text_input = YES
overrode_native_text_input = YES
debuginfo "Native text input disabled"
return 1
elseif opt = "native-kbd" then
disable_native_text_input = NO
overrode_native_text_input = YES
debuginfo "Native text input enabled"
return 1
elseif opt = "runfast" then
debuginfo "Running without speed control"
use_speed_control = NO
return 1
elseif opt = "maxfps" then
dim fps as integer = str2int(arg, -1)
if fps > 0 then
max_display_fps = fps
return 2
else
display_help_string "--maxfps: invalid fps"
return 1
end if
elseif opt = "giffps" then
dim fps as integer = str2int(arg, -1)
if fps > 0 then
gif_max_fps = fps
else
display_help_string "--giffps: invalid fps"
end if
return 2
elseif opt = "recordoverlays" then
screenshot_record_overlays = YES
return 1
elseif opt = "hideoverlays" then
overlays_enabled = NO
return 1
elseif opt = "recordinput" then
dim fname as string = absolute_with_orig_path(arg)
if fileiswriteable(fname) then
start_recording_input fname
else
display_help_string "input cannot be recorded to """ & fname & """ because the file is not writeable." & LINE_END
end if
return 2
elseif opt = "replayinput" then
dim fname as string = absolute_with_orig_path(arg)
if fileisreadable(fname) then
start_replaying_input fname
else
display_help_string "input cannot be replayed from """ & fname & """ because the file is not readable." & LINE_END
end if
return 2
elseif opt = "nojoy" then
debuginfo "Joystick/gamepad disabled by -nojoy"
joysticks_globally_disabled = YES
return 1 'arg not used
elseif opt = "nonumpad" then
debuginfo "Numpad remapping disabled by -nonumpad"
remap_numpad = NO
return 1 'arg not used
elseif opt = "showkeys" then
gif_show_keys_overlay = YES
return 1
elseif opt = "showmouse" then
show_mouse_overlay = YES
return 1
elseif opt = "input-debug" orelse opt = "debug-input" then
set_debugging_io YES
return 1
elseif opt = "logslow" then
log_slow = YES
return 1
end if
end function
property VideoRecorder.active() as bool
return NO
end property
sub stop_recording_video()
if recordvid then
recordvid->stop()
delete recordvid
end if
recordvid = NULL
end sub
'==========================================================================================
' Video pages
'==========================================================================================
' Convert all videopages to 32 bit. Preserves their content
sub switch_to_32bit_vpages ()
if default_page_bitdepth = 32 then exit sub
default_page_bitdepth = 32
for i as integer = 0 to ubound(vpages)
'Skip duplicated ('holdscreen') pages
if vpages(i) andalso vpages(i)->fixeddepth = 0 then
if vpages(i)->isview = NO then
frame_convert_to_32bit vpages(i), curmasterpal()
'Any view onto the page will now be invalid (containing an invalid ptr)
else
'Hack: assume the page is a compatpage (view of vpage) and i > vpage
frame_assign @vpages(i), compatpage_internal(vpages(vpage))
end if
end if
next
end sub
' Convert all videopages to 8 bit Frames (not backed by Surfaces).
' WIPES their contents!
sub switch_to_8bit_vpages ()
if default_page_bitdepth = 8 then exit sub
default_page_bitdepth = 8
for i as integer = 0 to ubound(vpages)
'Skip duplicated ('holdscreen') pages
if vpages(i) andalso vpages(i)->fixeddepth = 0 then
if vpages(i)->isview = NO then
'frame_assign @vpages(i), frame_new(vpages(i)->w, vpages(i)->h)
'Safer to use this, as it keeps extra state like .noresize
frame_drop_surface vpages(i)
clearpage i
else
'Hack: assume the page is a compatpage (view of vpage) and i > vpage
frame_assign @vpages(i), compatpage_internal(vpages(vpage))
end if
end if
next
end sub
'Returns whether pages are now 32-bit color
function toggle_32bit_vpages () as bool
if vpages_are_32bit then
switch_to_8bit_vpages
show_overlay_message "Switched to 8-bit color", 1.2
return NO
else
switch_to_32bit_vpages
show_overlay_message "Switched to 32-bit color", 1.2
return YES
end if
end function
function vpages_are_32bit () as bool
return default_page_bitdepth = 32
end function
sub freepage (page as integer)
if page < 0 orelse page > ubound(vpages) orelse vpages(page) = NULL then
showbug "Tried to free unallocated/invalid page " & page
exit sub
end if
frame_unload(@vpages(page))
end sub
'Adds a Frame ptr to vpages(), returning its index.
function registerpage (spr as Frame ptr) as integer
if spr->refcount <> NOREFC then spr->refcount += 1
for i as integer = 0 to ubound(vpages)
if vpages(i) = NULL then
vpages(i) = spr
' Mark as fixed size, so it won't be resized when the window resizes.
'fixedsize_vpages(i) = YES
return i
end if
next
redim preserve vpages(ubound(vpages) + 1)
vpagesp = @vpages(0)
vpages(ubound(vpages)) = spr
'redim preserve fixedsize_vpages(ubound(vpages) + 1)
'fixedsize_vpages(ubound(vpages)) = YES
return ubound(vpages)
end function
'Create a new video page and return its index.
'bitdepth: 8 for a regular Frame, 32 for a 32-bit Surface-backed page, or -1 to use the default
'Note: the page is filled with color 0, unlike clearpage, which defaults to uiBackground!
function allocatepage(w as integer = -1, h as integer = -1, bitdepth as integer = -1) as integer
if w < 0 then w = windowsize.w
if h < 0 then h = windowsize.h
if bitdepth < 0 then bitdepth = default_page_bitdepth
if bitdepth <> 8 and bitdepth <> 32 then
showbug "allocatepage: Bad bitdepth " & bitdepth
end if
dim fr as Frame ptr = frame_new(w, h, , YES, , bitdepth = 32)
dim ret as integer = registerpage(fr)
frame_unload(@fr) 'we're not hanging onto it, vpages() is
return ret
end function
'creates a copy of a page, registering it (must be freed)
'The copy will be unaffected by switch_to_8/32bit_vpages so that it is preserved.
function duplicatepage (page as integer) as integer
dim fr as Frame ptr = frame_duplicate(vpages(page))
fr->fixeddepth = 1 'Preserve contents instead of swapping from 8<->32 bit
dim ret as integer = registerpage(fr)
frame_unload(@fr) 'we're not hanging onto it, vpages() is
return ret
end function
'Copy contents of one page onto another
'should copying to a page of different size resize that page?
sub copypage (src as integer, dest as integer)
'if vpages(src)->w <> vpages(dest)->w or vpages(src)->h <> vpages(dest)->h then
' debug "warning, copied to page of unequal size"
'end if
frame_draw vpages(src), , 0, 0, NO, vpages(dest)
end sub
sub clearpage (page as integer, colour as integer = -1)
if colour = -1 then colour = uilook(uiBackground)
frame_clear vpages(page), colour
end sub
'The contents are either trimmed or extended with colour uilook(uiBackground).
sub resizepage (page as integer, w as integer, h as integer)
BUG_IF(vpages(page) = NULL, "NULL page")
frame_assign @vpages(page), frame_resized(vpages(page), w, h, 0, 0, uilook(uiBackground))
end sub
local function compatpage_internal(pageframe as Frame ptr) as Frame ptr
return frame_new_view(vpages(vpage), (vpages(vpage)->w - 320) / 2, (vpages(vpage)->h - 200) / 2, 320, 200)
end function
'Return a video page which is a view on vpage that is 320x200 (or smaller) and centred.
'In order to use this, draw to the returned page, but call setvispage(vpage).
'Do not swap dpage and vpage!
'WARNING: if a menu using compatpage calls another one that does swap dpage and
'vpage, things will break 50% of the time!
function compatpage() as integer
dim fakepage as integer
dim centreview as Frame ptr
centreview = compatpage_internal(vpages(vpage))
fakepage = registerpage(centreview)
frame_unload @centreview
return fakepage
end function
'==========================================================================================
' Resolution changing
'==========================================================================================
'First check if the window was resized by the user,
'then if windowsize has changed (possibly by a call to unlock_resolution/set_resolution)
'resize all videopages (except compatpages) and the Screen slice to the new window size.
'The videopages are either trimmed or extended with colour 0.
local sub screen_size_update ()
'Modifies windowsize to requested size if user or possibly something else
'(e.g. get_set_window_size) tried to resize. Does nothing else.
if gfx_get_resize(windowsize) then
'debuginfo "User window resize to " & windowsize.wh
show_overlay_message windowsize.w & " x " & windowsize.h, 0.7
end if
'Clamping windowsize to the minwinsize here means trying to override user
'resizes (specific to the case where the backend doesn't support giving the WM
'a min size hint).
'However unfortunately gfx_sdl can't reliably override it, at least with X11+KDE,
'because the window size can't be changed while the user is still dragging the window
'frame.
'So just accept whatever the backend says the actual window size is.
'windowsize.w = large(windowsize.w, minwinsize.w)
'windowsize.h = large(windowsize.h, minwinsize.h)
dim oldvpages(ubound(vpages)) as Frame ptr
for page as integer = 0 to ubound(vpages)
oldvpages(page) = vpages(page)
next
'oldvpages pointers will be invalidated
'Resize dpage and vpage (I think it's better to hardcode 0 & 1 rather
'than using dpage and vpage variables in case the later are temporarily changed)
'Update size of all real pages. I think it's better to do so to all pages rather
'than just page 0 and 1, as other pages are generally used as 'holdpages'.
'The alternative is to update all menus using holdpages to clear the screen
'before copying the holdpage over.
'All pages which are not meant to be the same size as the screen
'currently don't persist to the next frame.
for page as integer = 0 to ubound(vpages)
dim vp as Frame ptr = vpages(page)
if vp andalso vp->isview = NO andalso vp->noresize = NO then
if vp->w <> windowsize.w or vp->h <> windowsize.h then
'debug "screen_size_update: resizing page " & page & " -> " & windowsize.wh
resizepage page, windowsize.w, windowsize.h
end if
end if
next
'Scan for compatpages (we're assuming all views are compatpages, which isn't true in
'general, but currently true when setvispage is called) and replace each with a new view
'onto the center of the same page if it changed.
for page as integer = 0 to ubound(vpages)
if vpages(page) andalso vpages(page)->isview then
for page2 as integer = 0 to ubound(oldvpages)
if vpages(page)->base = oldvpages(page2) and vpages(page2) <> oldvpages(page2) then
'debug "screen_size_update: updating view page " & page & " to new compatpage onto " & page2
frame_unload @vpages(page)
vpages(page) = compatpage_internal(vpages(page2))
exit for
end if
next
'If no match found, do nothing
end if
next
'Update the size of the Screen slice.
'This removes the need to call UpdateScreenSlice in all menus, but you can
'still call it to find out if the size changed.
UpdateScreenSlice NO 'clear_changed_flag=NO
end sub
'Set the size of a video page and keep it from being resized as the window size changes,
'and also stop it from changing bitdepth if switch_to_8/32bit_vpages is called (which
'multichoice, etc do), which would otherwise delete the contents on a 32->8 change!
'TODO: delete this after tileset_editor and import_export_tilesets stop using video pages 2 and 3
sub lock_page_size(page as integer, w as integer, h as integer)
resizepage page, w, h
vpages(page)->noresize = 1
vpages(page)->fixeddepth = 1
end sub
'Revert a video page to following the size of the window
'TODO: delete this after tileset_editor and import_export_tilesets stop using video pages 2 and 3
sub unlock_page_size(page as integer)
resizepage page, windowsize.w, windowsize.h
vpages(page)->noresize = 0
vpages(page)->fixeddepth = 0
end sub
'Makes the window resizable, and sets a minimum size.
'Whenever the window is resized all videopages (except compatpages) are resized to match.
'Returns true if was actually successful in making the window resizable, false
'if backend doesn't support it. (Note: won't return false just because we're fullscreen)
function unlock_resolution (min_w as integer, min_h as integer) as bool
resizing_requested = YES
minwinsize = XY(min_w, min_h)
if gfx_supports_variable_resolution() = NO then
resizing_enabled = NO
return NO
end if
debuginfo "unlock_resolution(" & minwinsize & ")"
resizing_enabled = gfx_set_resizable(YES, minwinsize.w, minwinsize.h)
windowsize.w = large(windowsize.w, minwinsize.w)
windowsize.h = large(windowsize.h, minwinsize.h)
screen_size_update 'Update page size
return resizing_enabled
end function
'Disable window resizing.
sub lock_resolution ()
debuginfo "lock_resolution()"
resizing_requested = NO
resizing_enabled = gfx_set_resizable(NO, 0, 0) 'Hard to imagine this could return YES
minwinsize = XY(0, 0)
end sub
'Returns whether unlock_resolution was called to make the window to be resizable,
'regardless of whether the backend supports it.
function resolution_unlocked () as bool
return resizing_requested
end function
'Set the window size, if possible, subject to min size bound. Doesn't modify resizability state.
'This will resize all videopages (except compatpages) to the new window size.
sub set_resolution (w as integer, h as integer)
if gfx_supports_variable_resolution andalso gfx_supports_variable_resolution() = NO then
exit sub
end if
debuginfo "set_resolution " & w & "*" & h
windowsize.w = large(w, minwinsize.w)
windowsize.h = large(h, minwinsize.h)
if modex_initialised = NO then
'We will tell the backend what resolution to initialise at in before_gfx_backend_init
exit sub
end if
'Ignore any pending resize request
gfx_get_resize(XY(0,0))
'Update page size
screen_size_update
'Tell the gfx backend about the new page size. If we delayed this then a following
'call to set_scale_factor would change scale and recenter window using wrong window size,
'requiring manual recenter.
'TODO: not ideal, should tell backend about size and scale at same time.
setvispage vpage, NO
end sub
'The current internal window size in pixels (actual window updated at next setvispage)
function get_resolution() as XYPair
return windowsize
end function
'Get resolution of the (primary) monitor. On Windows, this excludes size of the taskbar.
sub get_screen_size (byref screenwidth as integer, byref screenheight as integer)
screenwidth = 0
screenheight = 0
if gfxbackend = "sdl2" then
'Prefer gfx_sdl2 because it has a dedicated API for getting the usable size
'(excluding taskbar, etc) of the main display. (gfx_directx is also good.)
gfx_get_screen_size(@screenwidth, @screenheight)
end if
if screenwidth <= 0 or screenheight <= 0 then
'On Windows and Mac os_get_screen_size also returns the usable
'size of the main display.
os_get_screen_size(@screenwidth, @screenheight)
end if
if screenwidth <= 0 or screenheight <= 0 then
'gfx_sdl is particularly bad, reports resolution of the whole desktop
'at init time rather than the current size.
debuginfo "Falling back to gfx_get_screen_size"
gfx_get_screen_size(@screenwidth, @screenheight)
end if
debuginfo "Desktop resolution: " & screenwidth & "*" & screenheight
end sub
'Set the size that a pixel appears on the screen (i.e. the zoom), while windowed.
'Usually no effect if fullscreened, until switching back to windowed.
'Supported by all backends except gfx_alleg.
'If change_windowsize = YES, this changes the window size and keeps the same resolution,
'otherwise it changes the resolution and keeps the same window size
sub set_scale_factor (scale as integer, change_windowsize as bool = YES)
'gfx_sdl and gfx_fb, which use blit.cpp scaling, are limited to 1x-16x
scale = bound(scale, 1, 16)
debuginfo "Setting graphics scaling to x" & scale & " change_windowsize=" & change_windowsize
'If we don't have a gfx backend yet need to store it in an otherwise redundant global
remember_scale = scale
if modex_initialised = NO then
'We effectively force change_windowsize = YES
exit sub
end if
dim changed_zoom as bool = NO
if change_windowsize = NO then
dim winstate as WindowState ptr = gfx_getwindowstate()
if winstate->structsize >= 8 THEN 'winstate->windowsize valid
debuginfo " ...current window size " & winstate->windowsize
dim newresolution as XYPair = winstate->windowsize \ scale
dim toosmall as bool = (newresolution < XY(320, 200))
newresolution = large(newresolution, XY(320, 200))
if gfx_set_window_size then
'Set both resolution and scale at the same time if the gfx backend supports it
gfx_set_window_size(newresolution, scale)
changed_zoom = YES
elseif toosmall then
debuginfo " ...too small, increasing res"
'Don't allow a tiny resolution: change both resolution and window size
set_resolution newresolution.w, newresolution.h
change_windowsize = YES
end if
end if
end if
if change_windowsize then
if gfx_set_window_size then
gfx_set_window_size( , scale)
changed_zoom = YES
end if
end if
if changed_zoom = NO then
' Backends that don't support gfx_set_window_size... actually just gfx_directx.
' gfx_alleg/console don't allow changing zoom either
gfx_setoption("zoom", str(scale))
end if
'The resolution might have changed size (probably only if change_windowsize=NO)
'so update to avoid a one-tick flicker.
screen_size_update
end sub
'Returns true if successfully queries the fullscreen state, in which case 'fullscreen' is set.
'(Note: gfx_fb doesn't know for certain whether it's fullscreen; can't catch alt+enter.
function try_check_fullscreen(byref fullscreen as bool) as bool
dim winstate as WindowState ptr = gfx_getwindowstate()
if winstate andalso winstate->structsize >= 4 then
fullscreen = winstate->fullscreen
return YES
end if
return NO
end function
'Whether this platform has separate windowed and fullscreen modes. False on consoles and android, but not web.
function windowed_platform() as bool
#if defined(__FB_JS__)
return YES
#elseif defined(__FB_ANDROID__) or defined(MINIMAL_OS)
return NO
#else
return YES
#endif
end function
function supports_fullscreen_toggling_well () as bool
'Return YES if we should show the fullscreen/windowed menu options
'and obey a game's fullscreen/windowed setting.
'Note: even if this returns false, you can still try to fullscreen using alt-tab
'or the --fullscreen arg and it might be supported.
if windowed_platform() = NO then
return NO
end if
#IFDEF __GNU_LINUX__
' At least for me with KDE 4 and xfce4, fbgfx gives horrible results,
' turning off my 2nd monitor and lots of garbage and desktop resolution changing,
' and often gets stuck with a fullscreen black screen, or ignoring all input
' and becoming unquitable from inside X11.
' SDL 1.2 does something milder (causing the 2nd monitor to switch to mirrored)
' but only when the window size is smaller than the desktop.
' So probably the solution in gfx_sdl is to set the requested resolution to
' be equal to the desktop resolution and add black bars.
if gfxbackend = "fb" then
return NO
end if
#ENDIF
return YES
end function
'==========================================================================================
' setvispage and Fading
'==========================================================================================
declare sub present_internal_frame(drawpage as integer)
declare sub present_internal_surface(drawpage as integer)
sub SkippedFrame.drop()
'if page >= 0 then freepage page
page = -1
end sub
' If the last setvispage was skipped, display it
sub SkippedFrame.show ()
' Note: setvispage will call SkippedFrame.drop() after displaying the page
if page > -1 then
setvispage page, NO
end if
end sub
'Decide whether to skip a frame, in order to meet max_display_fps limit
function should_skip_frame() as bool
static lastframe as double
'Make sure we still draw under --runfast
if frame_timer > lastframe + 1. / max_display_fps then
lastframe = timer
return NO
end if
'How many times will setvispage be called per non-skipped frame?
dim frames_per_gfx_present as double = requested_framerate / max_display_fps
if frames_per_gfx_present <= 1 then return NO 'No need to skip
'Per frames_per_gfx_present frames, draw one frame and skip the rest
frame_index and= INT_MAX 'Avoid overflow to negative
if fmod(frame_index, frames_per_gfx_present) > 1 then
return YES
end if
lastframe = frame_timer
'Maybe we should have an option to also skip frames if we're running at
'100% cpu, although that will only save a little time because we still
'draw each frame.
end function
' The last/currently displayed videopage (or a substitute: guaranteed to be valid)
function getvispage() as integer
if last_setvispage >= 0 andalso last_setvispage <= ubound(vpages) _
andalso vpages(last_setvispage) then
return last_setvispage
end if
return vpage
end function
'Display a videopage. May modify the page!
'Also resizes all videopages to match the window size
'skippable: if true, allowed to frameskip this frame at high framerates
sub setvispage (page as integer, skippable as bool = YES)
' Remember last page
last_setvispage = page
' Drop frames to reduce CPU usage if FPS too high
frame_index += 1
if skippable andalso should_skip_frame() then
skipped_frame.drop()
skipped_frame.page = page
' To be really cautious we could save a copy, but because page should
' not get modified until it's time to draw the next frame, this isn't really needed.
'skipped_frame.page = duplicatepage(page)
update_fps_counter YES
exit sub
end if
update_fps_counter NO
dim starttime as double = timer
if gfx_supports_variable_resolution() = NO then
'Safety check. We must stick to 320x200, otherwise the backend could crash.
'In future backends should be updated to accept other sizes even if they only support 320x200
'(Actually gfx_directx appears to accept other sizes, but I can't test)
if vpages(page)->w <> 320 or vpages(page)->h <> 200 then
resizepage page, 320, 200
showbug "setvispage: page was not 320x200 even though gfx backend forbade it"
end if
end if
' The page to which to draw overlays, and display.
dim drawpage as integer
if vpages_are_32bit() andalso faded_in = NO then
' In 32-bit mode, we always draw to the vpage using curmasterpal (not faded out),
' so that we have something to fade back in if a fade happens.
' This means we need to hide the fact that the vpage palette isn't actually faded out.
drawpage = allocatepage(vpages(page)->w, vpages(page)->h)
gfx_surfaceFill(faded_to_color.col, NULL, vpages(drawpage)->surf)
else
' We could skip this duplication if there are no overlays to draw. But even at 60fps
' it's not significant: in my test, at 1920x1080 and 2x zoom, this duplicatepage
' is only 0.5% of runtime.
drawpage = duplicatepage(page)
end if
'Draw those overlays that are always recorded in .gifs/screenshots
draw_allmodex_recordable_overlays drawpage
if screenshot_record_overlays = YES then
draw_allmodex_overlays drawpage
end if
'F12 for screenshots handled here (uses real_keyval)
snapshot_check drawpage
if recordvid then
recordvid->record_frame vpages(drawpage), displaypal()
end if
if screenshot_record_overlays = NO then
draw_allmodex_overlays drawpage
end if
starttime -= timer 'Stop timer
dim starttime2 as double = timer
'fb_gfx may deadlock if it collides with the polling thread because of
'FB bug https://sourceforge.net/p/fbc/bugs/885/
GFX_ENTER
if vpages(page)->surf then
present_internal_surface drawpage
else
present_internal_frame drawpage
end if
GFX_EXIT
#ifdef BACKEND_GOVERNED_FRAMERATE
frame_pseudo_timer += 1 / gfx_native_framerate()
#endif
#ifdef SIMULATE_BLOCKING_VSYNC
'For testing: simulate gfx_present blocking until vsync.
dim vsynctime as double, nowtime as double = timer
vsynctime = 1e3 * ((1. / 60) - fmod(nowtime, (1. / 60)))
sleep vsynctime
'?"sleep " & vsynctime & "... slept " & 1e3 * (timer - nowtime)
#endif
' This gets triggered a lot under Win XP because the program freezes while moving
' the window (in all backends, although in gfx_fb it freezes readmouse instead)
if log_slow then debug_if_slow(starttime2, 0.008, "gfx_present")
starttime += timer 'Restart timer
freepage drawpage
skipped_frame.drop() 'Delay dropping old frame; skipped_frame.show() might have called us
'After presenting the page this is a good time to check for window size changes and
'resize the videopages as needed before the next frame is rendered.
screen_size_update
if log_slow then debug_if_slow(starttime, 0.005, "")
end sub
'setvispage internal function for presenting a regular Frame page on the screen
local sub present_internal_frame(drawpage as integer)
dim surf as Surface ptr
if gfx_surfaceCreateFrameView(vpages(drawpage), @surf) then return
dim surface_pal as RGBPalette ptr
if surf->format = SF_8bit then
' Need to provide a palette
surface_pal = masterpal_to_gfxpal(displaypal())
'gfx_paletteFromRGB(@displaypal(0), @surface_pal)
end if
gfx_present(surf, surface_pal)
updatepal = NO 'We just did
gfx_paletteDestroy(@surface_pal)
gfx_surfaceDestroy(@surf)
end sub
'setvispage internal function for presenting a Surface-backed page on the screen
local sub present_internal_surface(drawpage as integer)
dim drawsurf as Surface ptr = vpages(drawpage)->surf
dim surface_pal as RGBPalette ptr
if drawsurf->format = SF_8bit then
' Need to provide a palette
surface_pal = masterpal_to_gfxpal(displaypal())
'gfx_paletteFromRGB(@displaypal(0), @surface_pal)
end if
gfx_present(drawsurf, surface_pal)
updatepal = NO 'We just did
gfx_paletteDestroy(@surface_pal)
end sub
local sub masterpal_changed()
delete_KDTree(nearcolor_kdtree)
'Build tree which excludes color 0 (callers to nearcolor_fast rely on this)
nearcolor_kdtree = make_KDTree_for_palette(@curmasterpal(0), 8, 1)
memset(@nearcolor_cache(0), 0, ubound(nearcolor_cache) + 1)
end sub
'For checking whether master() has changed since last setpal/setdrawpal/fadein
function masterpal_has_changed(pal() as RGBcolor) as bool
return memcmp(@pal(0), @curmasterpal(0), 256 * SIZEOF(RGBcolor)) <> 0
end function
'Change the palette used for drawing, but don't end a fade out yet.
'This should be called before drawing the screen and calling fadein/fadetopal,
'unless you're fading back in the same palette that you faded out from.
'(It's also mostly necessary only in 32-bit mode)
sub setdrawpal(pal() as RGBcolor)
memcpy(@curmasterpal(0), @pal(0), 256 * SIZEOF(RGBcolor))
masterpal_changed
end sub
'Switch to a palette immediately without a fade in. Ends a fade out.
'(Unlike how it used to work, only takes effect at the next setvispage call or at start of fadein)
sub setpal(pal() as RGBcolor)
setdrawpal pal()
memcpy(@displaypal(0), @pal(0), 256 * SIZEOF(RGBcolor))
updatepal = YES
faded_in = YES
end sub
'Immediately change to a faded out state.
'The difference from calling setpal is:
'-preserves curmasterpal, for nearcolor & transparency effects
'-Sets faded_in = NO, not YES
'The difference from calling fadetocolor with fadems=0 is just that it doesn't
'immediately redraw the screen.
sub setpal_to_color(col as RGBcolor = TYPE(0))
col.a = 255
faded_to_color = col
if vpages_are_32bit() = NO then
for i as integer = 0 to 255
displaypal(i) = col
next
end if
'Do not update curmasterpal
updatepal = YES
faded_in = NO
end sub
' A gfx_setpal wrapper which may perform frameskipping to limit fps
local sub maybe_do_gfx_setpal()
frame_index += 1
if should_skip_frame() then
update_fps_counter YES
updatepal = YES
exit sub
end if
update_fps_counter NO
updatepal = NO
GFX_ENTER
gfx_setpal(@displaypal(0))
GFX_EXIT
end sub
'A fade in or out.
'This modifies displaypal() only in 8-bit color mode
'pal() is used only in 8-bit mode. fadecol is used only in 32-bit mode
'so don't support fading between two master palettes!
local sub fadetopal_internal(pal() as RGBcolor, col as RGBcolor, fadems as integer, fading_in as bool)
dim vispage as integer = getvispage()
dim is32bit as bool = vpages_are_32bit()
dim was_faded_in as bool = faded_in
dim prev_fade_color as RGBcolor = faded_to_color
skipped_frame.show() 'If we frame-skipped last frame, better show it
if updatepal then
if is32bit = NO then maybe_do_gfx_setpal
if recordvid then
recordvid->record_frame vpages(vispage), displaypal()
end if
end if
dim holdscreen as integer
dim startpal(255) as RGBcolor
if is32bit then
holdscreen = duplicatepage(vispage)
else
'This will be equal to curmasterpal unless we're faded out
memcpy(@startpal(0), @displaypal(0), 256 * SIZEOF(RGBcolor))
end if
dim ticks as integer = large(1, fadems / 16.67)
for tick as integer = 1 to ticks
setwait 16.67
'Use a symmetric cubic smoothing function. The slope is at a
'minimum at x=0 and x=1, where it's 1/2 of the linear
'interpolation slope, and it's at a maximum at x=1/2.
dim x as double = tick / ticks
dim fraction as double = x / 2 + 3 * x*x / 2 - x*x*x
if is32bit then
'Draw a transparent rect over vispage
if fading_in then fraction = 1 - fraction
if was_faded_in andalso fading_in then fraction = 0 'noop
if was_faded_in = NO andalso fading_in = NO then
'Fading between two colors
gfx_surfaceFill(prev_fade_color.col, NULL, vpages(vispage)->surf)
else
copypage holdscreen, vispage
end if
trans_rectangle vpages(vispage), XYWH(0,0,rWidth,rHeight), col, fraction
faded_in = YES 'Needed to stop setvispage from doing its own fade handling
setvispage vispage
else
'Don't modify vispage, instead modify displaypal and redisplay with that
for j as integer = 0 to 255
displaypal(j).r = pal(j).r * fraction + startpal(j).r * (1 - fraction)
displaypal(j).g = pal(j).g * fraction + startpal(j).g * (1 - fraction)
displaypal(j).b = pal(j).b * fraction + startpal(j).b * (1 - fraction)
next
maybe_do_gfx_setpal
end if
if tick mod 3 = 0 then
' We're assuming that the page hasn't been modified since the last setvispage
if recordvid then
recordvid->record_frame vpages(vispage), displaypal()
end if
end if
dowait
next
if is32bit then
copypage holdscreen, vispage
freepage holdscreen
end if
'This function was probably called in the middle of timed loop, call
'setwait to avoid "dowait called without setwait" warnings
setwait 0
end sub
sub fadetocolor(col as RGBcolor, fadems as integer = 500)
col.a = 255
dim pal(255) as RGBcolor
for j as integer = 0 to 255
pal(j) = col
next
fadetopal_internal pal(), col, fadems, NO
faded_in = NO
faded_to_color = col
'In 8-bit mode, displaypal() is now equal to pal()/col. In 32-bit mode, not modified
'Do not update curmasterpal, it contains non-faded palette
end sub
'NOTE: In 32-bit mode we don't support fading between two master palettes, only out and back in to the original palette!
sub fadetopal(pal() as RGBcolor, fadems as integer = 500)
fadetopal_internal pal(), faded_to_color, fadems, YES
faded_in = YES
memcpy(@displaypal(0), @pal(0), 256 * SIZEOF(RGBcolor))
'If fadetopal/fadein is used, it means setpal wasn't called, so we need to replicate
'the other thing setpal does: update curmasterpal
memcpy(@curmasterpal(0), @pal(0), 256 * SIZEOF(RGBcolor))
masterpal_changed
end sub
sub fadein (fadems as integer = 500)
fadetopal master(), fadems
end sub
sub fadeout (palidx as integer, fadems as integer = 500)
fadetocolor master(palidx), fadems
end sub
sub fadeout (red as integer, green as integer, blue as integer, fadems as integer = 500)
dim col as RGBcolor
col.r = red
col.g = green
col.b = blue
fadetocolor col, fadems
end sub
'Blend between two video pages... unless the screen is faded out, in which case blends in to newpage, ignoring oldpage
sub fadetopage(oldpage as integer, newpage as integer, fadems as integer = 500)
dim was_faded_in as bool = faded_in
dim prev_fade_color as RGBcolor = faded_to_color
skipped_frame.show() 'If we frame-skipped last frame, better show it
if updatepal then
if vpages_are_32bit() = NO then maybe_do_gfx_setpal
if recordvid then
recordvid->record_frame vpages(getvispage()), displaypal()
end if
end if
dim drawpage as integer = allocatepage(vpages(oldpage)->w, vpages(oldpage)->h)
dim drawopts as DrawOptions
drawopts.with_blending = YES
dim ticks as integer = large(1, fadems / 16.67)
for tick as integer = 1 to ticks
setwait 16.67
'Use a symmetric cubic smoothing function. The slope is at a
'minimum at x=0 and x=1, where it's 1/2 of the linear
'interpolation slope, and it's at a maximum at x=1/2.
dim x as double = tick / ticks
drawopts.opacity = x / 2 + 3 * x*x / 2 - x*x*x
if was_faded_in then
copypage oldpage, drawpage
else
if vpages_are_32bit() then
gfx_surfaceFill(faded_to_color.col, NULL, vpages(drawpage)->surf)
else
clearpage drawpage, nearcolor_master(faded_to_color)
end if
end if
frame_draw vpages(newpage), , 0, 0, NO, drawpage, drawopts
faded_in = YES
setvispage drawpage
if tick mod 3 = 0 then
' We're assuming that the page hasn't been modified since the last setvispage
if recordvid then
recordvid->record_frame vpages(drawpage), displaypal()
end if
end if
dowait
next
copypage newpage, vpage
freepage drawpage
'This function was probably called in the middle of timed loop, call
'setwait to avoid "dowait called without setwait" warnings
setwait 0
end sub
'==========================================================================================
' Waits/Framerate
'==========================================================================================
'Set number of milliseconds from now when the next call to dowait returns.
'This number is treated as a desired framewait, so actual target wait varies from 0.5-1.5x requested.
'ms: number of milliseconds
'flagms: if nonzero, is a count in milliseconds for the secondary timer, whether this has triggered
' is accessed as the return value from dowait.
sub setwait (ms as double, flagms as double = 0)
if use_speed_control = NO then ms = 0.001
ms /= fps_multiplier
'flagms /= fps_multiplier
requested_framerate = 1000. / ms
dim thetime as double = frame_timer
dim target as double
'This clamping also is needed on the first tick to initialize waittime
target = bound(waittime + ms / 1000, thetime + 0.5 * ms / 1000, thetime + 1.5 * ms / 1000)
/'
if thetime > waittime + 0.001 then
debuginfo strprintf("Missed setwait by %.1fms. Waiting %.1fms", _
1e3 * (thetime - waittime), 1e3 * (target - thetime))
end if
'/
waittime = target
if flagms <= 0 then
flagms = ms
end if
if thetime > flagtime then
flagtime = bound(flagtime + flagms / 1000, thetime + 0.0165, thetime + 1.5 * flagms / 1000)
end if
setwait_called = YES
end sub
'Returns seconds left until the deadline set by the last setwait. Will
'be negative if it's already been missed.
function setwait_time_remaining() as double
return waittime - frame_timer
end function
' Returns number of dowait calls
function get_tickcount() as integer
return tickcount
end function
function dowait () as bool
'wait until alarm time set in setwait()
'returns true if the flag time has passed (since the last time it was passed)
'In freebasic, sleep is in 1000ths, and a value of less than 100 will not
'be exited by a keypress, so sleep for 5ms until timer > waittime.
tickcount += 1
global_tog XOR= 1
dim starttime as double = frame_timer
do while frame_timer <= waittime - 0.0005
var prev_subtimer = main_timer.switch(TimerIDs.IOBackend)
io_waitprocessing()
Steam.run_frame 'FIXME: what if we're overtime?
main_timer.switch(TimerIDs.Pause)
#ifdef BACKEND_GOVERNED_FRAMERATE
gfx_wait_one_frame()
frame_pseudo_timer += 1 / gfx_native_framerate()
#else
sleep bound((waittime - frame_timer) * 1000, 1, 5)
#endif
main_timer.switch(prev_subtimer) 'resume
loop
' dowait might be called after waittime has already passed, ignore that
' (the time printed is the unwanted delay).
' On Windows FB sleep calls winapi Sleep(), which has a default of 15.6ms, adjustable
' with timeBeginPeriod(). 15.6ms is very coarse for 60fps games, so we probably
' should request a higher frequency. (Also, Win XP rounds the sleep period up to the
' following tick, while Win 7+ rounds it down, although that probably makes no
' difference due to the avoid while loop. See
' https://randomascii.wordpress.com/2013/04/02/sleep-variation-investigated/
' If there's a long delay here it's because the system is busy; not interesting.
#ifndef BACKEND_GOVERNED_FRAMERATE
if log_slow then debug_if_slow(large(starttime, waittime), 0.1, "")
#endif
'This could probably be done always, but don't want to risk that change right now.
#ifdef BACKEND_GOVERNED_FRAMERATE
'Round off so we don't randomly jump frames
if abs(frame_timer - waittime) < 0.0005 then
frame_timer = waittime
end if
#endif
if setwait_called then
setwait_called = NO
else
'debuginfo "dowait called without setwait"
end if
return frame_timer >= flagtime
end function
'==========================================================================================
' Music
'==========================================================================================
sub setupmusic
debuginfo "Initialising music_" + musicbackend + "..."
music_init
sound_init
musicbackendinfo = music_get_info
debuginfo musicbackendinfo
end sub
sub closemusic ()
debuginfo "Closing music backend..."
music_close
sound_close
debuginfo "...done"
end sub
sub loadsong (songname as string)
var prev_subtimer = main_timer.switch(TimerIDs.FileIO)
music_play(songname, getmusictype(songname))
main_timer.switch(prev_subtimer)
end sub
'In Game, call wrappedsong instead.
sub playsongnum (byval songnum as integer)
dim songfile as string = find_music_lump(songnum)
if songfile = "" then exit sub
loadsong songfile
end sub
'Doesn't work in SDL_mixer for MIDI music, so avoid
'sub pausesong ()
' music_pause()
'end sub
'
'sub resumesong ()
' music_resume
'end sub
function get_music_volume () as single
return music_getvolume
end function
sub set_music_volume (vol as single)
music_setvolume(vol)
end sub
'==========================================================================================
' Sound effects
'==========================================================================================
' loopcount N to play N+1 times, -1 to loop forever
' See set_sfx_volume for description of volume_mult.
sub playsfx (num as integer, loopcount as integer = 0, volume_mult as single = 1.)
var prev_subtimer = main_timer.switch(TimerIDs.FileIO)
dim slot as integer
' If already loaded can reuse without reloading.
' TODO: However this preempts it if still playing; shouldn't force that
' NOTE: backends vary, music_sdl does nothing if too many sfx playing,
' music_audiere has no limit.
slot = sound_slot_with_id(num)
if slot = -1 then
slot = sound_load(find_sfx_lump(num), num)
if slot = -1 then exit sub
end if
'debug "playsfx volume_mult=" & volume_mult & " global_sfx_volume " & global_sfx_volume
sound_play(slot, loopcount, volume_mult * global_sfx_volume)
IF_PTR(sound_slotdata(slot))->original_volume = volume_mult
main_timer.switch(prev_subtimer)
end sub
sub resetsfx ()
' Stops playback and unloads cached sound effects
sound_reset
end sub
sub stopsfx (num as integer)
dim slot as integer
slot = sound_slot_with_id(num)
if slot = -1 then exit sub
sound_stop(slot)
end sub
sub pausesfx (num as integer)
dim slot as integer
slot = sound_slot_with_id(num)
if slot = -1 then exit sub
sound_pause(slot)
end sub
' This returns the actual effective sfx volume 0. - 1., combining all volume
' settings and any fade effects the backend might be doing (nothing like
' that is implemented yet).
function effective_sfx_volume (num as integer) as single
dim slot as integer
slot = sound_slot_with_id(num)
if slot = -1 then return 0.
return sound_getvolume(slot)
end function
/' Is this needed?
function get_sfx_volume (num as integer) as single
dim slot as integer
slot = sound_slot_with_id(num)
if slot = -1 then return 0.
return sound_getslot(slot)->original_volume
end function
'/
' Set the volume of a sfx to some multiple of its default volume,
' which is the global sfx volume * the volume adjustment defined in Custom
sub set_sfx_volume (num as integer, volume_mult as single)
dim slot as integer
slot = sound_slot_with_id(num)
if slot = -1 then exit sub
sound_setvolume(slot, volume_mult * global_sfx_volume)
IF_PTR(sound_slotdata(slot))->original_volume = volume_mult
end sub
' Set the global volume multiplier for sound effects.
' The backends only support a max volume of 1.0,
' but the global volume can be set higher, amplifying
' any sfx with a volume less than 1.0.
sub set_global_sfx_volume (volume as single)
global_sfx_volume = volume
' Update all SFX
for slot as integer = 0 to sound_lastslot()
dim slotdata as SFXCommonData ptr
slotdata = sound_slotdata(slot)
if slotdata = 0 then continue for
'debug "set_global_sfx_volume: refresh volume for " _
' & slotdata->effectID & " to " & (slotdata->original_volume * global_sfx_volume)
sound_setvolume slot, slotdata->original_volume * global_sfx_volume
next
end sub
function get_global_sfx_volume () as single
return global_sfx_volume
end function
' Only used by Custom's importing interface
sub freesfx (num as integer)
sound_free(num)
end sub
function sfxisplaying(num as integer) as bool
dim slot as integer
slot = sound_slot_with_id(num)
if slot = -1 then return NO
return sound_playing(slot)
end function
'==========================================================================================
' Keyboard input
'==========================================================================================
'======================================= keyval API =======================================
'Read keyboard/joystick input for either a single player or player 0 (default/all).
'Reads replayed state, if any, unless real_keys = YES
'key: any scancode, including cc* constants and joystick buttons
'player: 0 to maxPlayers. 0 for any input device. Player 1 has the keyboard, each has one
' joystick and possibly some mapped keyboard keys.
'down_ms: set to max(down_ms, ms1, ms2, ...) where ms# are how long each of the keys/buttons
' mapped to 'key' have been depressed, in milliseconds.
'check_keyboard: pass false to ignore keyboard input (this is used to map joy buttons to keys)
'
'except for possibly certain special keys (like capslock), each key reports 3 bits:
'
'bit 0: key was down at the last setkeys call
'bit 1: keypress event (either new keypress, or key-repeat) during last setkey-setkey interval
'bit 2: new keypress during last setkey-setkey interval
'
'Note: Alt/Ctrl keys may behave strangely with gfx_fb:
'You won't see Left/Right keypresses even when scAlt/scCtrl is pressed, so do not
'check "keyval(scLeftAlt) > 0 or keyval(scRightAlt) > 0" instead of "keyval(scAlt) > 0"
function player_keyval(key as KBScancode, player as integer = 0, byref down_ms as integer = 0, repeat_wait as integer = 0, repeat_rate as integer = 0, check_keyboard as bool = YES, real_keys as bool = NO) as KeyBits
BUG_IF(player < 0, "Invalid player " & player, 0)
if player > maxPlayers then return 0 'Not an error
BUG_IF(key < scKEYVAL_FIRST orelse key > scKEYVAL_LAST, "bad scancode " & key, 0)
dim ret as KeyBits
if player = 0 then
'Merge all return values and find the max down_ms value
for player = 1 to maxPlayers
ret or= player_keyval(key, player, down_ms, repeat_wait, repeat_rate, check_keyboard, real_keys)
next
return ret
end if
dim inputst as InputState ptr
if replay.active andalso real_keys = NO then
inputst = @replay_input
else
inputst = @real_input
end if
if key < 0 then 'Control key
'Compute it. The reason we do this on every keyval call rather than once in setkeys is so
'that you can change the keymap or clear keys and have an immediate effect: scripts especially
'want to do that.
ret = inputst->controlkey(player, key, repeat_wait, repeat_rate, down_ms, check_keyboard)
elseif key <= scLAST then 'Keyboard key
'player > 1 can only see keys which are mapped to one of their controls
if check_keyboard andalso (player = 1 orelse inputst->keymaps(player).find(key) > -1) then
ret = inputst->kb.keyval(key, repeat_wait, repeat_rate, *inputst, down_ms)
end if
else 'Joystick button
dim button as integer = keybd_to_joy_scancode(key) '0 if invalid
dim joynum as integer = player - 1
if joynum > ubound(inputst->joys) then return 0
ret = inputst->joys(joynum).keyval(button, repeat_wait, repeat_rate, *inputst, down_ms)
end if
return ret
end function
'This keyval() variant always returns the real input, rather than replayed input
function real_keyval (key as KBScancode) as KeyBits
return player_keyval(key, 0, , , , , YES)
end function
function keyval (key as KBScancode) as KeyBits
'Using a wrapper rather than an alias for player_keyval has the advantage of
'decreasing executable size, since this function is called in zillions of places!
return player_keyval(key, 0)
end function
'Simple keyval() variant with modified key repeat rate (in milliseconds), and no repeat delay
function slowkey (key as KBScancode, ms as integer) as bool
return player_keyval(key, 0, , ms, ms) > 1
end function
sub setkeyrepeat (repeat_wait as integer = 500, repeat_rate as integer = 55)
' Not actually used anywhere yet, but give the replay and real states
' separate repeat rates to avoid desync issues
dim inputst as InputState ptr = iif(replay.active, @replay_input, @real_input)
inputst->repeat_wait = repeat_wait
inputst->repeat_rate = repeat_rate
end sub
'How long a key has been depressed, in milliseconds. Or max time, if multiple
'keys map to 'key'.
function keypress_time(key as KBScancode, player as integer = 0, real_keys as bool = NO) as integer
dim down_ms as integer = 0
player_keyval(key, player, down_ms, , , , real_keys)
return down_ms
end function
'Translate a sc* constant to a joy* constant
function keybd_to_joy_scancode(key as KBScancode) as JoyButton
ERROR_IF(key < scJoyButton1 orelse key > scJoyLAST, "Bad scancode " & key, 0)
return key - scJoyOFFSET
end function
'=============================== keyval implementation ====================================
'Return numpad scancode that's an alias to 'key'
local function KeyboardState.numpad_alias_key(key as KBScancode) as KBScancode
if remap_numpad = NO then return 0
if (this.keys(scNumLock) and 1) xor (this.keys(scShift) and 1) then
return 0
end if
select case key
case scLeft: return scNumpad4
case scRight: return scNumpad6
case scUp: return scNumpad8
case scDown: return scNumpad2
case scHome: return scNumpad7
case scEnd: return scNumpad1
case scPageUp: return scNumpad9
case scPageDown: return scNumpad3
case scDelete: return scNumpadPeriod
case scInsert: return scNumpad0
'Skip - + (already handled in intgrabber) * / Enter (already handled by AnyEnter)
'(no good reason to do so).
end select
return 0
end function
'Ignores suspended state of keybinds, as that would create too many weird edgecases.
function KeyboardState.anykey(player as integer, inputst as InputState, byref down_ms as integer) as KeyBits
dim ret as KeyBits
if player < 1 orelse player > maxPlayers then return 0
if player = 1 then
'Player 1 can press any KB key that isn't bound to another player and isn't a weird Lock key
'Cache the list of keys bound to another player
dim bound_keys(scKEYVAL_LAST) as boolean
for otherplayer as integer = 2 to maxPlayers
with inputst.keymaps(otherplayer)
for idx as integer = 0 to ubound(.controls)
dim key as KBScancode = .controls(idx).scancode
BUG_IF(key < 0 orelse key > scKEYVAL_LAST, "Bad Keybind.scancode", 0)
bound_keys(key) = true
next
end with
next
for key as KBScancode = 0 to scLAST
select case key
case scNumLock, scCapsLock, scScrollLock
case else
if bound_keys(key) = false then
ret or= this.keyval(key, , , inputst, down_ms)
end if
end select
next
else
'Other players can only press their bound keys
with inputst.keymaps(player)
for idx as integer = 0 to ubound(.controls)
dim key as KBScancode = .controls(idx).scancode
if key <= scLAST then 'Not a joystick button
ret or= this.keyval(key, , , inputst, down_ms)
end if
next
end with
end if
return ret
end function
'This doesn't check all joystick buttons, only ones mapped in controls()
'semi-intentionally, so you can ignore stuck keys or uncentered sticks.
'Ignores suspended state of keybinds, as that would create too many weird edgecases.
function JoystickState.anykey(player as integer, inputst as InputState, byref down_ms as integer) as KeyBits
dim ret as KeyBits
with inputst.keymaps(player)
for idx as integer = 0 to ubound(.controls)
dim button as JoyButton = .controls(idx).scancode - scJoyOFFSET
if button >= joyButton1 andalso button <= joyLAST then 'Check not a keyboard key
ret or= this.keyval(button, , , inputst, down_ms)
end if
next
end with
'for button as JoyButton = joyButton1 to joyLAST
' ret or= this.keyval(button, repeat_wait, repeat_rate, inputst)
'next
return ret
end function
'Calculate value of a control key for one player, bitwise-ORing all non-suspended (except anykey) keys mapped to it
'player: 1 to 4.
'cc: ccFIRST <= cc < 0
'check_keyboard: pass false to ignore keyboard input
'down_ms: set to max down_ms of any key or initial value.
function InputState.controlkey (player as integer, cc as ccCode, repeat_wait as integer = 0, repeat_rate as integer = 0, byref down_ms as integer, check_keyboard as bool = YES) as KeyBits
if player < 1 orelse player > maxPlayers then return 0
dim ret as KeyBits
if cc = ccAny then
'Note: repeat_wait and repeat_rate are ignored
if check_keyboard then
ret = this.kb.anykey(player, this, down_ms)
end if
ret or= this.joys(player - 1).anykey(player, this, down_ms)
return ret
end if
for idx as integer = 0 to ubound(this.keymaps(player).controls)
with this.keymaps(player).controls(idx)
if cc = .ckey andalso .suspended = NO then
'Shouldn't happen; if the Keybind is blank then .ckey=0
BUG_IF(.scancode <= 0 orelse .scancode > scJoyLAST, "Bad Keybind.scancode " & .scancode, 0)
if .scancode <= scLAST then 'Keyboard
if check_keyboard then
ret or= this.kb.keyval(.scancode, repeat_wait, repeat_rate, this, down_ms)
end if
else 'Joystick
ret or= this.joys(player - 1).keyval(.scancode - scJoyOFFSET, repeat_wait, repeat_rate, this, down_ms)
end if
end if
end with
next
return ret
end function
'Get state of a real keyboard key: cc* and joy* scancodes not supported
function KeyboardState.keyval(key as KBScancode, repeat_wait as integer = 0, repeat_rate as integer = 0, inputst as InputState, byref down_ms as integer) as KeyBits
dim check_repeat as bool = YES
'if key = scAlt then
'alt can repeat (probably a bad idea not to), but only if nothing else has been pressed
'for i as KBScancode = 1 to scLAST
' if this.keys(i) > 1 then check_repeat = NO
'next
'if delayed_alt_keydown = NO then check_repeat = NO
'end if
'Don't fire repeat presses for special toggle keys (note: these aren't actually
'toggle keys in all backends, eg. gfx_fb)
if key = scNumlock orelse key = scCapslock orelse key = scScrolllock then check_repeat = NO
down_ms = large(down_ms, this.key_down_ms(key))
if check_repeat then
dim ret as KeyBits
ret = this.key_repeating(key, repeat_wait, repeat_rate, inputst)
'Wait, there's more! When numlock is off, numpad keys double as other keys; is 'key' one?
dim key2 as KBScancode = this.numpad_alias_key(key)
if key2 then
ret or= this.key_repeating(key2, repeat_wait, repeat_rate, inputst)
down_ms = large(down_ms, this.key_down_ms(key2))
end if
return ret
else
return this.keys(key)
'Num/caps/scrolllock don't have any alias keys on the numpad
end if
end function
function JoystickState.keyval (key as JoyButton, repeat_wait as integer = 0, repeat_rate as integer = 0, inputst as InputState, byref down_ms as integer) as KeyBits
down_ms = large(down_ms, this.key_down_ms(key))
return this.key_repeating(key, repeat_wait, repeat_rate, inputst)
end function
'Return state of a key plus key repeat bit. (Should only be called from keyval)
'repeat_wait and repeat_rate can override inputst settings.
function KeyArray.key_repeating(key as integer, repeat_wait as integer, repeat_rate as integer, inputst as InputState) as KeyBits
dim result as KeyBits = this.keys(key)
if result and 1 then
'Check key repeat
if repeat_wait = 0 then repeat_wait = inputst.repeat_wait
if repeat_rate = 0 then repeat_rate = inputst.repeat_rate
dim down_ms as integer
'Ensure arrow keys/buttons repeat on the same tick
down_ms = iif(is_arrow_key(key), this.arrow_key_down_ms, this.key_down_ms(key))
if down_ms >= repeat_wait then
'Keypress event at "wait + i * rate" ms after keydown
dim temp as integer = down_ms - repeat_wait
if temp \ repeat_rate > (temp - inputst.elapsed_ms) \ repeat_rate then
result or= 2
end if
end if
end if
return result
end function
'======================================= clearkey =========================================
'Erase a keypress event from the keyboard state, and optionally cancel key repeat. Does not affect key-down state.
'FIXME: have to clear numpad keys too, if remapped!
'NOTE: clearing scShift/Alt/Ctrl doesn't clear scLeft/RightShift/Alt/Ctrl. That's probably fine.
sub clearkey(k as KBScancode, clear_key_repeat as bool = YES)
dim inputst as InputState ptr = iif(replay.active, @replay_input, @real_input)
inputst->kb.keys(k) and= 1
if clear_key_repeat then
inputst->kb.key_down_ms(k) = 0
end if
end sub
'Erase a new keypress bit and optionally cancel key repeat from the real keyboard state,
'even if replaying recorded input.
sub real_clearkey(k as KBScancode, clear_key_repeat as bool = YES)
real_input.kb.keys(k) and= 1
if clear_key_repeat then
real_input.kb.key_down_ms(k) = 0
end if
end sub
'Erase all new keypress bits and cancel key repeat. Does not affect key-down state.
sub KeyArray.clearkeys()
for scancode as integer = 0 to ubound(keys)
keys(scancode) and= 1
next
flusharray key_down_ms()
end sub
'Clear keypress events for all keyboard keys and joystick buttons, including cancelling
'key repeat, and clear mouse clicks. Doesn't change the 'down' state of keys/buttons.
'Note: an alternative is to call setkeys, which will also wipe & update the "new keypress" bits
sub clearkeys()
dim inputst as InputState ptr = iif(replay.active, @replay_input, @real_input)
inputst->kb.clearkeys()
for joynum as integer = 0 to ubound(inputst->joys)
inputst->joys(joynum).clearkeys()
next
mouse_state.clearclick(mouseLeft)
mouse_state.clearclick(mouseRight)
mouse_state.clearclick(mouseMiddle)
end sub
'====================================== Text Input ========================================
' Get text input by assuming a US keyboard layout and reading scancodes rather than using the io backend.
' Also supports alt- combinations for the high 128 characters
' Always returns real input, even if replaying input.
function get_ascii_inputtext () as string
dim shift as integer = 0
dim ret as string
if real_keyval(scCtrl) > 0 then return ""
if real_keyval(scShift) and 1 then shift += 1
if real_keyval(scAlt) and 1 then shift += 2 'for characters 128 and up
for i as integer = 0 to 53
dim effective_shift as integer = shift
if shift <= 1 andalso real_keyval(scCapsLock) > 0 then
select case i
case scQ to scP, scA to scL, scZ to scM
effective_shift xor= 1
end select
end if
if real_keyval(i) > 1 then
ret &= key2text(effective_shift, i)
end if
next i
' Space and numpad are missing from key2text
if real_keyval(scSpace) > 1 then ret &= " "
' Note: On Windows, if numlock is on and you press Shift and 0-9 or . on the numpad
' then Shift will appear unpressed! Backend independent, happens in Win XP and 10.
' Not a keyboard artifact.
' We do this even if remap_numpad = NO, because that's how native text input works.
if (real_keyval(scNumLock) and 1) xor (shift and 1) then
'NOTE: When NumLock is off, numpad is mapped to Left, Home, etc, by keyval
'but when it's on we *don't* map it to 1, +, etc! That's because we want
'the option of having numpad separate. And you should ideally be reading
'text input rather than checking sc1, etc.
if real_keyval(scNumpadAsterisk) > 1 then ret &= "*"
if real_keyval(scNumpadMinus) > 1 then ret &= "-"
if real_keyval(scNumpadPlus) > 1 then ret &= "+"
' (Bug: gfx_fb reports both scSlash and scNumpadSlash)
if gfxbackend <> "fb" and real_keyval(scNumpadSlash) > 1 then ret &= "/"
' (Bug: gfx_fb on Windows never reports scNumpad5 at all!)
for i as integer = 0 to ubound(numpad2text)
if real_keyval(scNumpad7 + i) > 1 then
ret &= numpad2text(i)
end if
next
end if
' Note, OSes differ on when they report text input from numpad keys (this seems
' to be backend-independent):
' X11 (both FB and SDL): when numlock XOR shift is pressed
' Windows (FB, SDL, directx): only when numlock on and shift not pressed
' (Also, on Windows, status of numlock is buggy: for gfx_sdl and gfx_directx,
' after user turns it off, state doesn't update until next keypress,
' while gfx_fb doesn't report it at all)
return ret
end function
' Returns text input from the backend since the last call.
' Always returns real input, even if replaying input.
local function read_inputtext () as string
if disable_native_text_input then
return get_ascii_inputtext()
end if
'AFAIK, this is will still work on all platforms except X11 with SDL
'even if inputtext was not enabled; however you'll get a warning when
'getinputtext is called.
dim w_in as wstring * 64
if io_textinput then io_textinput(w_in, 64)
'OK, so here's the hack: one of the alt keys (could be either) might be used
'as a 'shift' or compose key, but if it's not, we want to support the old
'method of entering extended characters (128 and up) using it. This will
'backfire if the key face/base characters aren't ASCII
dim force_native_input as bool = NO
for i as integer = 0 to len(w_in) - 1
if w_in[i] > 127 then force_native_input = YES
next
if force_native_input = NO andalso real_keyval(scAlt) and 1 then
'Throw away w_in
return get_ascii_inputtext()
end if
dim as integer icons_low, icons_high
if get_font_type(current_font()) = ftypeLatin1 then
icons_low = 127
icons_high = 160
else
icons_low = 127
icons_high = 255
end if
if io_textinput then
'if len(w_in) then print #fh, "input :" & w_in
' Now we need to convert from unicode to the game's character set (7-bit ascii or Latin-1)
dim ret as string = ""
dim force_shift as bool = NO
for i as integer = 0 to len(w_in) - 1
if w_in[i] > 255 then
select case w_in[i]
case &hF700 to &hF746:
'Ignore Mac unicode for arrow keys, pgup+pgdown,
' delete, misc other keys. I don't know if the
' upper bound of &hF746 is high enough, but it
' blocks all the keys I could find on my keyboard.
' --James
continue for
case 304:
'Ignore COMBINING MACRON on most platforms, but
'use it to shift the next char on Android
#IFDEF __FB_ANDROID__
force_shift = YES
#ENDIF
continue for
end select
'debug "unicode char " & w_in[i]
ret += "?"
elseif w_in[i] = 127 then
'Delete (only sent on OSX). Ignore; we use scancodes instead.
elseif w_in[i] >= icons_low and w_in[i] <= icons_high then
ret += "?"
elseif w_in[i] < 32 then
'Control character. What a waste of 8-bit code-space!
'Note that we ignore newlines... because we've always done it that way
else
dim ch as string = chr(w_in[i])
if force_shift then
force_shift = NO
ch = UCASE(ch)
select case ch
'FIXME: it would be better to loop through the key2text array
'here, but it fails to initialize on Android
'(But both this and key2text assume US keyboard so really shouldn't
'be doing this. Is SDL 1.2 text input on Android just plain broken?)
case "1": ch = "!"
case "2": ch = "@"
case "3": ch = "#"
case "4": ch = "$"
case "5": ch = "%"
case "6": ch = "^"
case "7": ch = "&"
case "8": ch = "*"
case "9": ch = "("
case "0": ch = ")"
case "-": ch = "_"
case "=": ch = "+"
case "[": ch = "{"
case "]": ch = "}"
case ";": ch = ":"
case "'": ch = """"
case "`": ch = "~"
case "\": ch = "|"
case ",": ch = "<"
case ".": ch = ">"
case "/": ch = "?"
end select
end if
ret += ch
end if
next
return ret
else
return get_ascii_inputtext()
end if
end function
'If using gfx_sdl and gfx_directx this is Latin-1, while gfx_fb doesn't currently support even that
function getinputtext () as string
if replay.active then
return replay_input.kb.inputtext
end if
if disable_native_text_input = NO then
'Only show this message if getinputtext is called incorrectly twice in a row,
'to filter out instances when a menu with inputtext disabled exits back to
'one that expects it enabled, and getinputtext is called before the next call to setkeys.
static last_call_was_bad as bool = NO
if inputtext_enabled = NO and last_call_was_bad then
debuginfo "getinputtext: not enabled"
end if
last_call_was_bad = (inputtext_enabled = NO)
end if
return real_input.kb.inputtext
end function
'==========================================================================================
' Checking/waiting for keypresses
'==========================================================================================
'Checks the keyboard and optionally joystick for keypress events.
'trigger_level: 1 to trigger on a held key,
' 2 to trigger on keypress (inc. repeat)
' 4 to trigger only on new keypress.
'Returns scancode if one is found, 0 otherwise.
'Use this instead of looping over all keys, to make sure alt filtering and joysticks work
function anykeypressed (checkjoystick as bool = YES, checkmouse as bool = YES, trigger_level as KeyBits = 2) as KBScancode
for i as KBScancode = 0 to scLAST
'check scAlt only, so Alt-filtering (see setkeys) works
if i = scLeftAlt or i = scRightAlt or i = scUnfilteredAlt then continue for
' Ignore capslock and numlock because they always appear pressed when on,
' and it doesn't really matter if they doesn't work for 'press a key' prompts.
' To be on the safe said, ignore scroll lock too. Though with gfx_sdl,
' on Windows howing down scrolllock causes SDL to report key_up/key_down
' wait every tick, while on linux it seems to behave like a normal key
if i = scCapsLock or i = scNumLock or i = scScrollLock then continue for
if keyval(i) >= trigger_level then
return i
end if
next
if checkjoystick then
'Note that keyval(ccAny) only checks joystick buttons mapped to controls
for key as KBScancode = scJoyButton1 to scJoyLAST
if keyval(key) >= trigger_level then
return key
end if
next
end if
if checkmouse then
'If trigger_level=1, check both release or currently down, eg. to ensure
'waitforkeyrelease hides mouse button release.
dim bitvec as integer = mouse_state.release
if trigger_level = 1 then bitvec or= mouse_state.buttons
for button as integer = 0 to 15
if bitvec and (1 shl button) then
return scMouseLeft + button
end if
next button
end if
end function
'Waits for a new keyboard key, mouse or joystick button press. Clears the keypress and returns the scancode.
'If wait_for_resize = YES, also returns scResize if the window was resized.
'By default waits for a new keypress, adjust with trigger_level
function waitforanykey (wait_for_resize as bool = NO, trigger_level as KeyBits = 4, clearkeypress as bool = YES) as KBScancode
dim key as KBScancode
dim sleepjoymouse as integer = 5
dim remem_speed_control as bool = use_speed_control
dim original_resolution as XYPair = windowsize
use_speed_control = YES
skipped_frame.show() 'If we frame-skipped last frame, better show it
'setkeys
do
setwait 55, 200
io_pollkeyevents()
setkeys
key = anykeypressed(sleepjoymouse = 0, sleepjoymouse = 0, trigger_level)
if key then
snapshot_check 'In case F12 pressed, otherwise it wouldn't work
if clearkeypress then setkeys 'Clear the keypress
use_speed_control = remem_speed_control
return key
end if
if sleepjoymouse > 0 then
'Delay before checking joystick so user has time to return
'stick to center, and delay mouse because mouse button might be pressed
'when called, and releasing it counts as input.
sleepjoymouse -= 1
end if
if wait_for_resize andalso windowsize <> original_resolution then
use_speed_control = remem_speed_control
return scResize
end if
if dowait then
' Redraw the screen occasionally in case something like an overlay is drawn
setvispage getvispage
end if
loop
end function
'Wait for all keys, and joystick and mouse buttons to be released
sub waitforkeyrelease ()
setkeys
'anykeypressed checks scAlt instead of scUnfilteredAlt
dim ticks as integer = 0
dim sc as integer = anykeypressed(YES, YES, 1)
while sc or keyval(scUnfilteredAlt)
if getquitflag() then exit sub
if ticks > 60 then
edgeprint "Waiting for release: " & scancodename(sc), 0, pBottom, uilook(uiText), getvispage
setvispage getvispage
end if
io_pollkeyevents()
setwait 15
setkeys
ticks += 1
dowait
sc = anykeypressed(YES, YES, 1)
wend
end sub
'Without changing the results of keyval or readmouse, check whether a key has been pressed,
'mouse button clicked, or window close requested since the last call to setkeys.
'NOTE: any such keypresses or mouse clicks are lost! This is OK for the current purposes
'NOTE: This checks the real keyboard state while replaying input.
function interrupting_keypress () as bool
dim starttime as double = timer
dim ret as bool = NO
io_pollkeyevents()
dim keybd_dummy(scLAST) as KeyBits
dim mouse as MouseInfo
'Note: This use of gfxmutex is necessary even if FB bug 885 gets fixed (see r642 & r708)
GFX_ENTER
io_keybits(@keybd_dummy(0))
io_mousebits(mouse.x, mouse.y, mouse.wheel, mouse.buttons, mouse.clicks)
GFX_EXIT
debug_if_slow(starttime, 0.005, "")
' Check for attempt to quit program
if keybd_dummy(scPageup) > 0 and keybd_dummy(scPagedown) > 0 and keybd_dummy(scEsc) > 1 then closerequest = YES
if closerequest then
#ifdef IS_GAME
exit_gracefully()
#else
ret = YES
#endif
end if
for i as KBScancode = 0 to scLAST
'Check for new keypresses
if keybd_dummy(i) and 2 then ret = YES
next
if mouse.clicks then ret = YES
if ret then
'Crap, this is going to desync the replay since the result of interrupting_keypress isn't recorded
'(No problem if paused)
if record.active then
stop_recording_input "Recording ended by interrupting keypress"
end if
if replay.active then
stop_replaying_input "Replay ended by interrupting keypress"
end if
end if
return ret
end function
'==========================================================================================
' setkeys (update input state)
'==========================================================================================
sub KeyArray.init(maxkey as integer)
redim keys(maxkey)
redim key_down_ms(maxkey)
end sub
constructor KeyboardState()
init(scLAST)
end constructor
sub KeyboardState.reset()
init(ubound(keys))
delayed_alt_keydown = NO
inputtext = ""
end sub
constructor JoystickState()
init(joyLAST)
end constructor
'======================================== Keymaps ========================================
'Setup default keyboard and gamepad keybinds
'FIXME: this is called before main() to initialise the real_input/replay_input globals, but depends on
'global_config_file, which won't be properly initialised. So flush_gfx_config_settings calls again
'(via reset_keymaps), however that will throws away customisation when switching gfx backend.
sub PlayerKeymap.reset (player as integer)
if player = 1 then
redim controls(21)
else
redim controls(8)
end if
dim as JoyButton usebut, menubut
if swap_joystick_use_cancel = NONBOOL then
'Cache setting
'This is a Blackbox setting, "0" or "1", true on Nintendo and player-configurable on PS
swap_joystick_use_cancel = (str2int(read_environment_key("asiabuttons"), 0) <> 0)
end if
if swap_joystick_use_cancel then
usebut = scJoy(B)
menubut = scJoy(A)
else
usebut = scJoy(A) 'Cross
menubut = scJoy(B) 'Circle
end if
controls(0) = TYPE(scJoy(Up), ccUp)
controls(1) = TYPE(scJoy(Down), ccDown)
controls(2) = TYPE(scJoy(Left), ccLeft)
controls(3) = TYPE(scJoy(Right), ccRight)
controls(4) = TYPE(usebut, ccUse)
controls(5) = TYPE(menubut, ccCancel)
controls(6) = TYPE(menubut, ccMenu)
controls(7) = TYPE(scJoy(Start), ccMenu)
controls(8) = TYPE(menubut, ccRun)
if player = 1 then
controls(9) = TYPE(scUp, ccUp)
controls(10) = TYPE(scDown, ccDown)
controls(11) = TYPE(scLeft, ccLeft)
controls(12) = TYPE(scRight, ccRight)
#ifdef IS_GAME
controls(13) = TYPE(scCtrl, ccUse) 'Wiped by reset_to_basic_keymap
#endif
controls(14) = TYPE(scSpace, ccUse)
controls(15) = TYPE(scEnter, ccUse)
#ifdef IS_GAME
controls(16) = TYPE(scAlt, ccMenu) 'Wiped by reset_to_basic_keymap
controls(17) = TYPE(scAlt, ccCancel) 'Wiped by reset_to_basic_keymap
#endif
controls(18) = TYPE(scEsc, ccMenu)
controls(19) = TYPE(scEsc, ccCancel)
controls(20) = TYPE(scEsc, ccFlee)
controls(21) = TYPE(scTab, ccFlee) 'Who knew?
end if
end sub
sub InputState.reset_keymaps ()
for player as integer = 1 to ubound(this.keymaps)
this.keymaps(player).reset(player)
next
end sub
sub reset_keymaps ()
real_input.reset_keymaps
replay_input.reset_keymaps
end sub
'Sets up player 1's keymap the way Custom does (unlike Game, which allows Ctrl for Use
'and Alt for Cancel)
sub reset_to_basic_keymap ()
dim byref keymap as PlayerKeymap = get_keymap(1)
keymap.reset(1)
keymap.remove(scCtrl)
keymap.remove(scAlt)
end sub
'Returns an index in controls() that matches a ccCode and/or KBScancode, or -1 if not found,
'or if count = -1 then returns number of matches.
'count tells which index to return if multiple match, counting from 0 for the first.
'Pass either a cc* constant, a sc* constant, or both cc* and sc* (in that order). That is:
'cc_or_sc is a cc* constant, sc omitted: matches all keybinds to that control
'cc_or_sc is a sc* constant, sc omitted: matches all keybinds from that scancode
'cc_or_sc is a cc* constant, sc is a sc* constant: matches all keybinds from that scancode to control
function PlayerKeymap.find (cc_or_sc as KBScancode, sc as KBScancode = 0, count as integer = 0) as integer
for i as integer = 0 to ubound(this.controls)
with this.controls(i)
if sc = 0 then
if .ckey = cc_or_sc orelse .scancode = cc_or_sc then
if count = 0 then return i
count -= 1
end if
else
if .ckey = cc_or_sc andalso .scancode = sc then
if count = 0 then return i
count -= 1
end if
end if
end with
next
if count < 0 then return -count - 1 'Number of matches
return -1
end function
'Bind a keyboard key or joystick button to a control.
'If the exactly same keybind already exists, nothing is done.
'controlc: which control to add a binding for.
'scanc: a sc* or scJoy* constant, not a cc* constant.
sub PlayerKeymap.add (controlc as ccCode, scanc as KBScancode)
if in_bound(controlc, ccFIRST, ccLAST) = NO then
debug strprintf("PlayerKeymap.add: invalid control=%d", controlc)
exit sub
elseif in_bound(scanc, 1, scJoyLAST) = NO then
'Not a KB or joy scancode
debug strprintf("PlayerKeymap.add: invalid key %d (for control=%d)", scanc, controlc)
exit sub
end if
'Only add if doesn't already exist
dim idx as integer = this.find(controlc, scanc)
if idx < 0 then
'Reuse any deleted slot
idx = this.find(0, 0)
if idx < 0 then
idx = ubound(this.controls) + 1
redim preserve this.controls(idx)
end if
with this.controls(idx)
.ckey = controlc
.scancode = scanc
end with
end if
end sub
'Delete (blank out) all matching keybinds; see PlayerKeymap.find() about matching.
sub PlayerKeymap.remove (cc_or_sc as KBScancode, sc as KBScancode = 0)
do
dim idx as integer = this.find(cc_or_sc, sc)
if idx < 0 then exit sub
with this.controls(idx)
.ckey = 0
.scancode = 0
.suspended = NO
end with
loop
end sub
'Suspends all matching keybinds; see PlayerKeymap.find() about matching.
sub PlayerKeymap.suspend (cc_or_sc as KBScancode, sc as KBScancode = 0)
do
dim idx as integer = this.find(cc_or_sc, sc)
if idx < 0 then exit sub
this.controls(idx).suspended = YES
loop
end sub
'Resumes all matching keybinds; see PlayerKeymap.find() about matching.
sub PlayerKeymap.resume (cc_or_sc as KBScancode, sc as KBScancode = 0)
do
dim idx as integer = this.find(cc_or_sc, sc)
if idx < 0 then exit sub
this.controls(idx).suspended = NO
loop
end sub
'Return the keymap object (key bindings) for a player
function get_keymap (player as integer = 1) byref as PlayerKeymap
dim inputst as InputState ptr = iif(replay.active, @replay_input, @real_input)
BUG_IF(player < 1 orelse player > maxPlayers, "get_keymap bad player #" & player, inputst->keymaps(1))
return inputst->keymaps(player)
end function
'Overwrite the current key bindings for a player. Probably only needed to save and restore, not for manipulation.
sub set_keymap (player as integer = 1, byref keymap as PlayerKeymap)
dim inputst as InputState ptr = iif(replay.active, @replay_input, @real_input)
BUG_IF(player < 1 orelse player > maxPlayers, "set_keymap bad player #" & player)
inputst->keymaps(player) = keymap
end sub
'============================ Update KB/joys from backend =================================
'Poll io backend to update key state bits, and then handle all special scancodes.
'keybd() should be dimmed at least (0 to scLAST)
sub KeyboardState.update_keybits()
dim winstate as WindowState ptr
winstate = gfx_getwindowstate()
GFX_ENTER
io_keybits(@keys(0))
GFX_EXIT
'State of keys(0 to scLAST) at this point:
'bit 0: key currently down
'bit 1: key down since last io_keybits call
'bit 2: zero
'debug "raw scEnter = " & keys(scEnter) & " scAlt = " & keys(scAlt)
'DELETEME (after a lag period): This is a temporary fix for gfx_directx not knowing about scShift
'(or any other of the new scancodes, but none of the rest matter much (maybe
'scPause) since there are no games that use them).
'(Ignore bit 2, because that isn't set yet)
if ((keys(scLeftShift) or keys(scRightShift)) and 3) <> (keys(scShift) and 3) then
keys(scShift) = keys(scLeftShift) or keys(scRightShift)
end if
'TODO: Actually, wouldn't it make more sense to set all the combined scancodes here instead of
'duplicating that in all backends?
'These two scancodes are set here instead of in backends...
keys(scAnyEnter) = keys(scEnter) or keys(scNumpadEnter)
keys(scMeta) = keys(scLeftMeta) or keys(scRightMeta)
'Backends don't know about scAlt, only scUnfilteredAlt
keys(scAlt) = keys(scUnfilteredAlt)
'Don't fire ctrl presses when alt down due to large number of WM shortcuts containing ctrl+alt
'(Testing delayed_alt_keydown is just a hack to add one tick delay after alt up,
'which is absolutely required)
if (keys(scAlt) and 1) or delayed_alt_keydown then
if keys(scEnter) and 6 then
keys(scEnter) and= 1
delayed_alt_keydown = NO
end if
keys(scCtrl) and= 1
keys(scLeftCtrl) and= 1
keys(scRightCtrl) and= 1
end if
'Calculate new "new keypress" bit (bit 2)
for key as KBScancode = 0 to scLAST
keys(key) and= 3
if key = scAlt then
'Special behaviour for alt, to ignore pesky WM shortcuts like alt+tab, alt+enter:
'Wait until alt has been released, without losing focus, before
'causing a key-down event.
'Also, special case for alt+enter, since that doesn't remove focus
'Note: this is only for scAlt, not scLeftAlt, scRightAlt, which aren't used by
'the engine, only by games. Maybe those shoudl be blocked too
'Note: currently keyval causes key-repeat events for alt if delayed_alt_keydown = YES
if keys(scAlt) and 2 then
if delayed_alt_keydown = NO then
keys(scAlt) -= 2
end if
delayed_alt_keydown = YES
end if
/'
for scancode as integer = 0 to scLAST
if scancode <> scUnfilteredAlt and scancode <> scAlt and scancode <> scLeftAlt and scancode <> scRightAlt and (keys(scancode) and 1) then
delayed_alt_keydown = NO
end if
next
'/
if winstate andalso winstate->focused = NO then
delayed_alt_keydown = NO
end if
if (keys(scAlt) and 1) = 0 andalso delayed_alt_keydown then
keys(scAlt) or= 6
delayed_alt_keydown = NO
end if
'elseif key = scCtrl or key = scLeftCtrl or key = scRightCtrl then
else
'Duplicate bit 1 to bit 2
keys(key) or= (keys(key) and 2) shl 1
end if
next
end sub
sub joy_axes_to_buttons(jx as integer, jy as integer, byref keyup as KeyBits, byref keydown as KeyBits, byref keyleft as KeyBits, byref keyright as KeyBits, axis_threshold as integer)
'Instead of treating X and Y separately, which would divide the range of possible values
'into quadrants, we divide it into a circular dead zone and 8 surrounding sectors
dim as double angle, norm
norm = sqr(jx ^ 2 + jy ^ 2)
angle = atan2(-jy, jx) * 6 / 3.14159265 'range -6.0 - 6.0, 0 is right, 3 is up, -3 is down
'if jx or jy then ? strprintf("%d,%d -> norm %f ang %f",jx, jy, norm, angle)
if norm >= axis_threshold then
if angle > 1 andalso angle < 5 then keyup or= 8
if angle > -5 andalso angle < -1 then keydown or= 8
if angle > -2 andalso angle < 2 then keyright or= 8
if angle > 4 orelse angle < -4 then keyleft or= 8
end if
end sub
'This is similar to io_keybits for a single joystick:
'it updates a JoystickState with currently-down and new-keypress bits.
'Basically it does a similar thing to the pollingthread, emulating new-keypress
'bits since the backend may not report them.
sub JoystickState.update_keybits(joynum as integer)
if joysticks_globally_disabled then exit sub
memset(@state, 0, SIZEOF(state))
state.structsize = IOJOYSTICKSTATE_SZ
dim starttime as double = timer
GFX_ENTER
if io_get_joystick_state then
dim ret as integer
ret = io_get_joystick_state(joynum, @state)
if ret > 0 then
'Failed to read/not present. Continue, wiping keys()
end if
elseif io_readjoysane then
dim as integer jx, jy
if io_readjoysane(joynum, state.buttons_down, jx, jy) = 0 then
'Failed to read/not present. Continue, wiping keys()
'(Warning: if gfx_directx can't read a joystick, it is removed and the others
'are renumbered)
else
'io_readjoysane reports -100 to 100, not -1000 to 1000
state.axes(axisX) = jx * AXIS_LIMIT / 100
state.axes(axisY) = jy * AXIS_LIMIT / 100
end if
else
'Backend doesn't support joysticks! Continue, wiping keys()
end if
GFX_EXIT
debug_if_slow(starttime, 0.01, joynum)
' Unless the gfx backend reports state.buttons_new (only gfx_sdl2),
' it only tells us which buttons are currently down,
' like io_updatekeys, not which have new keypresses, like io_keybits,
' so this is similar to the former (as handled in pollingthread).
' Clear bits 1 (keypress event) and 2 (new keypress), leave bit 0 (key down)
for scancode as JoyButton = 0 to ubound(keys)
keys(scancode) and= 1
next
' Set pressed buttons
' Map axes 0, 1 to dpad buttons
if prefbit(53) = NO then ' "!Map joystick (left) stick to dpad"
joy_axes_to_buttons state.axes(axisX), state.axes(axisY), keys(joyUp), _
keys(joyDown), keys(joyLeft), keys(joyRight), axis_threshold
end if
' Convenience buttons for using right thumbstick
joy_axes_to_buttons state.axes(axisRightX), state.axes(axisRightY), keys(joyRStickUp), _
keys(joyRStickDown), keys(joyRStickLeft), keys(joyRStickRight), axis_threshold
if state.info andalso state.info->have_bindings then
' These two trigger buttons are reported as axes, not buttons, by XInput and SDL2
if state.axes(axisL2) > axis_threshold then keys(joyL2) or= 8
if state.axes(axisR2) > axis_threshold then keys(joyR2) or= 8
else
' If we don't have button bindings also map the first hat as the dpad, which is univerally
' correct for gamepads.
' (E.g. on this here PSX controller with thumbsticks, using a usb adaptor, the
' dpad reports as axes 0/1 with analog off, and as hat 0 (or dpad under SDL2) with analog on)
for bitn as integer = 0 to 3
if state.hats(0) and (1 shl bitn) then keys(joyLeft + bitn) or= 8
next
end if
for btn as integer = 0 to 31
if state.buttons_down and (1 shl btn) then
keys(joyButton1 + btn) or= 8
end if
next
' Convert those bits we just set into KeyBits bits 0 & 1 (detecting new keypresses)
keystate_convert_bit3_to_keybits(keys())
' Duplicate bit 1 (key event) to bit 2 (new keypress)
for scancode as JoyButton = 0 to ubound(keys)
dim byref key as KeyBits = keys(scancode)
key = (key and 3) or ((key and 2) shl 1)
next
' Add in explicit new-keypress (mirror to key-event) bits from the backend, if reported
for btn as integer = 0 to 31
if state.buttons_new and (1 shl btn) then
keys(joyButton1 + btn) or= 6
end if
next
end sub
function KeyboardState.is_arrow_key (key as KBScancode) as bool
return (key = scLeft orelse key = scRight orelse key = scUp orelse key = scDown)
end function
function JoystickState.is_arrow_key (key as JoyButton) as bool
'Any of joy[RStick]Up/Down/Left/Right
return (key >= joyLeft andalso key <= joyRStickDown)
end function
' Updates kbstate.key_down_ms and arrow_key_down_ms
sub KeyArray.update_keydown_times (inputst as InputState)
arrow_key_down_ms = 0
for key as KBScancode = 0 to ubound(keys)
if (keys(key) and 4) or (keys(key) and 1) = 0 then
key_down_ms(key) = 0
end if
if keys(key) and 1 then
key_down_ms(key) += inputst.elapsed_ms
end if
if is_arrow_key(key) then
arrow_key_down_ms = large(arrow_key_down_ms, key_down_ms(key))
end if
next
end sub
sub setkeys (enable_inputtext as bool = NO)
'Updates the keyboard state to reflect new keypresses
'since the last call, also clears all keypress events (except key-is-down)
'
'Also calls allmodex_controls() to handle key hooks which work everywhere.
'
'enable_inputtext needs to be true for getinputtext to work;
'however there is a one tick delay before coming into effect.
'Passing enable_inputtext may cause certain "combining" keys to stop reporting
'key presses. Currently this only happens with gfx_sdl on X11 (it is an X11
'limitation). And it probably only effects punctuation keys such as ' or ~
'(naturally those keys could be anywhere, but a good rule of thumb seems to be
'to avoid QWERTY punctuation keys)
'For more, see http://en.wikipedia.org/wiki/Dead_key
'
'Note that key repeat is NOT added to kb.keys() (it's done by "post-processing" in keyval)
dim starttime as double = timer
if replay.active = NO and disable_native_text_input = NO then
if enable_inputtext then enable_inputtext = YES
if inputtext_enabled <> enable_inputtext then
inputtext_enabled = enable_inputtext
io_enable_textinput(inputtext_enabled)
end if
end if
'While playing back a recording we still poll for keyboard
'input, but this goes in the separate real_input.kb.keys() array so it's
'invisible to the game.
dim time_passed as double = TIMER - last_setkeys_time
real_input.elapsed_ms = bound(1000 * time_passed, 0, 255)
last_setkeys_time = TIMER
' Get real joystick state. Do this before keyboard, because
' setkeys_update_keybd will call map_joystick_to_keys
for joynum as integer = 0 to ubound(real_input.joys)
real_input.joys(joynum).update_keybits joynum
real_input.joys(joynum).update_keydown_times real_input
next
' Get real keyboard state
real_input.kb.update_keybits
real_input.kb.update_keydown_times real_input
real_input.kb.inputtext = read_inputtext()
if replay.active then
' Updates replay_input.kb.keys(), .kb.inputtext, .elapsed_ms
' FUTURE: updates replay_input.joys
replay_input_tick
' Updates kb.key_down_ms()
replay_input.kb.update_keydown_times replay_input
' Update replay_input.joys().key_down_ms()
for joynum as integer = 0 to ubound(replay_input.joys)
replay_input.joys(joynum).update_keydown_times(replay_input)
next
end if
'Taking a screenshot with gfx_directx is very slow, so avoid timing that
if log_slow then debug_if_slow(starttime, 0.005, replay.active)
'Handle special keys, possibly clear or add keypresses. Might recursively call setkeys.
allmodex_controls()
' Record input, after filtering of keys by allmodex_controls.
if record.active then
record_input_tick ()
end if
' Call io_mousebits
update_mouse_state()
' Update active_seconds, if have been active within some interval
if anykeypressed() THEN
last_active_time = last_setkeys_time
end if
if last_setkeys_time < last_active_time + idle_time_threshold then
active_seconds += time_passed
end if
' Custom/Game-specific global controls, done last so that there can't be interference
#if defined(IS_GAME) or defined(IS_CUSTOM)
static entered as bool
if entered = NO then
entered = YES
global_setkeys_hook
entered = NO
end if
#endif
end sub
sub setquitflag (newstate as bool = YES)
closerequest = newstate
end sub
function getquitflag () as bool
return closerequest
end function
' This callback is used by backends, possibly from another thread.
' Returns INT_MIN if the event was not understood, otherwise return value is event-dependent.
function post_event cdecl (event as EventEnum, arg1 as intptr_t = 0, arg2 as intptr_t = 0) as integer
select case event
case eventTerminate
closerequest = YES
return 0
case eventFullscreened
'arg1 is the new state
user_toggled_fullscreen = YES
return 0
end select
debuginfo "post_event: unknown event " & event & " " & arg1 & " " & arg2
return INT_MIN
end function
sub post_terminate_signal cdecl ()
closerequest = YES
end sub
'==========================================================================================
' Mouse
'==========================================================================================
function havemouse() as bool
'atm, all backends support the mouse, or don't know
'Tip: It's much more useful to check readmouse().active instead.
return YES
end function
' Cause mouse cursor to be always hidden
sub hidemousecursor ()
io_setmousevisibility(cursorHidden)
cursorvisibility = cursorHidden
end sub
' Cause mouse cursor to be always visible, except on touchscreen devices
sub showmousecursor ()
io_setmousevisibility(cursorVisible)
cursorvisibility = cursorVisible
end sub
' Use when the mouse is not in use:
' Hide the mouse cursor in fullscreen, and show it when windowed.
sub defaultmousecursor ()
io_setmousevisibility(cursorDefault)
cursorvisibility = cursorDefault
end sub
sub setcursorvisibility (state as CursorVisibility)
select case state
case cursorVisible, cursorHidden, cursorDefault
io_setmousevisibility(state)
cursorvisibility = state
case else
showbug "Bad setcursorvisibility(" & state & ") call"
end select
end sub
function getcursorvisibility () as CursorVisibility
return cursorvisibility
end function
local sub check_for_released_mouse_button(buttonnum as MouseButton)
if (mouse_state.last_buttons and buttonnum) andalso (mouse_state.buttons and buttonnum) = 0 then
'If the button was released since the last tick, turn on .release
mouse_state.release or= buttonnum
else
'All the rest of the time, .release should be off
mouse_state.release and= not buttonnum
end if
end sub
' Called from setkeys to update the internal mouse state
sub update_mouse_state ()
dim starttime as double = timer
mouse_state.lastpos = mouse_state.pos
mouse_state.last_buttons = mouse_state.buttons
GFX_ENTER 'Just in case
io_mousebits(mouse_state.x, mouse_state.y, mouse_state.wheel, mouse_state.buttons, mouse_state.clicks)
GFX_EXIT
'Ignore mouse clicks that focus the window. If you clicked, it's already
'focused, so we consider the previous focus state instead.
'(Not necessary for gfx_sdl2, already filters those clicks out.)
static prev_focus_state as bool
dim window_state as WindowState ptr = gfx_getwindowstate()
if mouse_state.buttons = 0 then
prev_focus_state = window_state->focused
elseif prev_focus_state = NO then
mouse_state.buttons = 0
mouse_state.clicks = 0
mouse_state.release = 0
mouse_state.last_buttons = 0
end if
for button as integer = 0 to 15
check_for_released_mouse_button(1 shl button)
next
if (mouse_state.buttons and mouseLeft) orelse (mouse_state.release and mouseLeft) then
mouse_state.left_click_age += 1
else
mouse_state.left_click_age = 0
end if
mouse_state.wheel *= -1
mouse_state.wheel_delta = mouse_state.wheel - last_mouse_wheel
mouse_state.wheel_clicks = mouse_state.wheel \ 120 - last_mouse_wheel \ 120
last_mouse_wheel = mouse_state.wheel
'In the following, "offscreen" includes over the window decorations or
'whenever the window doesn't have mouse focus even if mouse is over it.
'
'==Mouse position while offscreen, when NOT dragging from inside the window==
'
'gfx_sdl/alleg:
' Return last onscreen position when the mouse is offscreen.
'gfx_sdl2:Returns last onscreen position when the mouse is outside the window.
' Returns real position if the mouse is over the window even if it
' it isn't focused.
'gfx_fb: Backend returns either the last onscreen position (not necessarly on
' the border), or the first offscreen (due to freezing mouse input
' fractionally late) clamped to the window.
' gfx_getwindowstate->mouse_over always false when the window doesn't
' have focus.
'directx: Unknown.
'
'==Mouse buttons & wheel while offscreen==
'
'gfx_fb: If you release a mouse button offscreen, it becomes stuck until
' either the mouse moves back onscreen or the window loses focus.
' [wheel scrolls offscreen are registered when you move back onscreen?
' I can't reproduce that anymore.]
'gfx_alleg: button state continues to work offscreen but wheel scrolls are not registered
'gfx_sdl/sdl2: Doesn't report buttons offscreen (unless dragging). Wheel movement
' is reported if the mouse is over the window, even if it's not focused.
' SDL 1.2 doesn't know about the OS's wheel speed setting.
'directx: Unknown.
mouse_state.moved = mouse_state.lastpos <> mouse_state.pos
dim diff as XYPair = mouse_state.lastpos - mouse_state.pos
mouse_state.moved_dist = sqrt(diff.x * diff.x + diff.y * diff.y)
mouse_state.active = window_state->mouse_over and window_state->focused
'==Behaviour of clicking and dragging from inside the window to outside==
'
'gfx_sdl/fb: mouse.active is false while dragging off the window
'gfx_sdl2: mouse.active is true while dragging off the window
'gfx_fb: Mouse input goes dead while outside until moved back into window.
' (So mouse.dragging doesn't become false until back over window.)
'gfx_sdl/sdl2: Mouse acts as if clipped to the window while button is down and
' button state continues to be reported, until button is released.
'directx: Mouse is truely clipped to the window while button is down.
' (So mouse.active is true while dragging off the window?)
'gfx_alleg:Unknown.
if mouse_state.dragging then
'Test whether drag ended
if (mouse_state.clicks and mouse_state.dragging) orelse (mouse_state.buttons and mouse_state.dragging) = 0 then
mouse_state.dragging = 0
'Preserve .clickstart so that you can see what the drag was upon release
else
mouse_state.drag_dist += mouse_state.moved_dist
end if
else
'Dragging is only tracked for a single button at a time, and clickstart is not updated
'while dragging either. So we may now test for new drags or clicks.
for button as integer = 0 to 15
dim mask as MouseButton = 1 shl button
if mouse_state.clicks and mask then
'Do not flag as dragging until the second tick
mouse_state.clickstart = mouse_state.pos
elseif mouse_state.buttons and mask then
'Button still down
mouse_state.dragging = mask
exit for
end if
next
'Note that we delay zeroing this until the tick after a drag ends
mouse_state.drag_dist = 0
end if
' If you released a mouse grab (mouserect) and then click on the
' window, resume the mouse grab. (This is, and should be, called even if someone else
' also called pause_mouserect)
if mouse_state.clicks <> 0 andalso mouse_grab_scrolllock_overridden then
mouse_grab_scrolllock_overridden = NO
resume_mouserect
end if
if log_slow then debug_if_slow(starttime, 0.005, mouse_state.clicks)
end sub
' Get the state of the mouse at the last setkeys call (or after putmouse, mouserect).
' So make sure you call this AFTER setkeys.
function readmouse () byref as MouseInfo
return mouse_state
end function
sub MouseInfo.clearclick(button as MouseButton)
clicks and= not button
release and= not button
' Cancel for good measure, but not really needed
dragging and= not button
end sub
sub movemouse (x as integer, y as integer)
'Maybe we shouldn't cause the mouse to jump back to our window if it's not over it? (mouse_state.active)
GFX_ENTER
io_setmouse(x, y)
GFX_EXIT
' Don't call io_mousebits to get the new state, since that will cause clicks and movements to get lost,
' and is difficult to support in .ohrkeys.
mouse_state.x = x
mouse_state.y = y
end sub
'Restrict the mouse to a rectangle (xmax, ymax are inclusive).
'Call mouserect(-1, -1, -1, -1) to end.
sub mouserect (xmin as integer, xmax as integer, ymin as integer, ymax as integer)
dim norect as bool = (xmin = -1 and xmax = -1 and ymin = -1 and ymax = -1)
if norect then
mouse_grab_requested = NO
else
remember_mouse_grab = TYPE<RectPoints>(XY(xmin, ymin), XY(xmax, ymax))
mouse_grab_requested = YES
'Nested mouserects are not supported.
mouse_grab_nested_pauses = 0
end if
' Set window title to tell the player about scrolllock to escape mouse-grab
' gfx_directx does this itself, including handling scroll lock
if gfxbackend <> "directx" then
if norect then
settemporarywindowtitle remember_title
else
#IFDEF __FB_DARWIN__
settemporarywindowtitle remember_title & " (F14 to free mouse)"
#ELSE
settemporarywindowtitle remember_title & " (ScrlLock to free mouse)"
#ENDIF
end if
end if
GFX_ENTER
io_mouserect(xmin, xmax, ymin, ymax)
GFX_EXIT
if norect = NO then
' Don't call io_mousebits to get the new state, since that will cause clicks and movements to get lost,
' and is difficult to support in .ohrkeys.
mouse_state.x = bound(mouse_state.x, xmin, xmax)
mouse_state.y = bound(mouse_state.y, ymin, ymax)
end if
end sub
'If mouserect is in effect, free the mouse. Nestable; resume_mouserect should be called the
'same number of times (you can't nest mouserect calls, however).
'Note this does not pause mouse input or show the mouse cursor.
sub pause_mouserect
if mouse_grab_requested then
mouserect -1, -1, -1, -1
mouse_grab_requested = YES
mouse_grab_nested_pauses += 1
end if
end sub
'Undoes one call to pause_mouserect
sub resume_mouserect
if mouse_grab_requested then
mouse_grab_nested_pauses -= 1
if mouse_grab_nested_pauses <= 0 then
mouse_grab_nested_pauses = 0
with remember_mouse_grab
mouserect .p1.x, .p2.x, .p1.y, .p2.y
end with
end if
end if
end sub
'==========================================================================================
' Extra Joystick API
'==========================================================================================
'This is also, currently, the number of players
'TODO: this always returns maxPlayers = 4!
function num_joysticks () as integer
dim inputst as InputState ptr = iif(replay.active, @replay_input, @real_input)
return ubound(inputst->joys) + 1
end function
'Returns a value from -1000 to 1000
'player: 0 means merge input from all joysticks together; 1-4 is an individual joystick
function joystick_axis (axis as integer, player as integer = 0) as integer
dim inputst as InputState ptr = iif(replay.active, @replay_input, @real_input)
if player = 0 then 'Merge
dim ret as integer
for player = 1 to num_joysticks()
dim value as integer = joystick_axis(axis, player)
if abs(value) > abs(ret) then ret = value
next
return ret
end if
dim joynum as integer = player - 1
if joynum < 0 or joynum > ubound(inputst->joys) then return 0 'Not an error
dim byref joy as JoystickState = inputst->joys(joynum)
if axis < 0 orelse axis > ubound(joy.state.axes) then return 0
'info ptr will be NULL if not supported by backend, or not even called yet
if joy.state.info andalso axis >= joy.state.info->num_axes then return 0
return joy.state.axes(axis)
end function
'Can return NULL
'Player 0 just returns info on the first joystick (player 1)
function joystick_info (player as integer) as JoystickInfo ptr
dim inputst as InputState ptr = iif(replay.active, @replay_input, @real_input)
dim joynum as integer = large(0, player - 1)
if joynum > ubound(inputst->joys) then return NULL 'Not an error
return inputst->joys(joynum).state.info
end function
/' Not used yet
sub disable_joystick_input ()
joysticks_globally_disabled = YES
end sub
sub enable_joystick_input ()
joysticks_globally_disabled = NO
end sub
'/
'==========================================================================================
' Compat layer for old graphics backend IO API
'==========================================================================================
' These functions are used to supplement gfx backends not supporting
' io_mousebits or io_keybits.
'io_keybits implementation provided via the polling thread
'This is called while gfxmutex is held
sub io_amx_keybits cdecl (keybdarray as KeyBits ptr)
for a as KBScancode = 0 to scLAST
keybdarray[a] = pollthread.keybdstate(a)
pollthread.keybdstate(a) and= 1
next
end sub
'io_mousebits implementation provided via the polling thread
'This is called while gfxmutex is held
sub io_amx_mousebits cdecl (byref mx as integer, byref my as integer, byref mwheel as integer, byref mbuttons as integer, byref mclicks as integer)
with pollthread
'get the mouse state one last time, for good measure
io_getmouse(mx, my, mwheel, mbuttons)
mclicks = .mousebuttons or (mbuttons and not .mouselastbuttons)
.mouselastbuttons = mbuttons
.mousebuttons = 0
mbuttons = mbuttons or mclicks
end with
end sub
'Input: a key array with bit 3 (1<<3 == 8) set for currently pressed keys (from io_updatekeys)
' and bit 0 set for keys pressed last tick
'Output: key array with only bits 0 and 1 set (like io_keybits)
local sub keystate_convert_bit3_to_keybits(keystate() as KeyBits)
for scancode as integer = 0 to ubound(keystate)
dim byref key as KeyBits = keystate(scancode)
if (key and 9) = 8 then
'Key is pressed, wasn't pressed last time. This is a new keypress
key or= 2
end if
'move the bit (clearing it) that io_updatekeys sets from 8 to 1
key = (key and 2) or ((key shr 3) and 1)
next
end sub
local sub pollingthread(unused as any ptr)
with pollthread
while .wantquit = NO
mutexlock gfxmutex
dim starttime as double = timer
'Sets bit 3 (1<<3 == 8) for currently pressed keys
io_updatekeys(@.keybdstate(0))
if log_slow then debug_if_slow(starttime, 0.005, "io_updatekeys")
starttime = timer
'Convert from io_updatekeys bits (bit 3) to io_keybits bits (bits 0 and 1)
keystate_convert_bit3_to_keybits(.keybdstate())
dim as integer dummy, buttons
io_getmouse(dummy, dummy, dummy, buttons)
.mousebuttons = .mousebuttons or (buttons and not .mouselastbuttons)
.mouselastbuttons = buttons
mutexunlock gfxmutex
if log_slow then debug_if_slow(starttime, 0.005, "io_getmouse")
sleep 15
wend
end with
end sub
'==========================================================================================
' Backend wrapper functions
'==========================================================================================
'gfx_set_settings wrapper returning true if *all* attempted changes to settings succeeded.
'As usual, must be used after initialising the GfxSettings with gfx_get_settings.
function gfx_try_set_settings(settings as GfxSettings) as bool
gfx_set_settings(settings)
dim newsettings as GfxSettings
gfx_get_settings(newsettings)
'Relying on FB initialising any padding.
return memcmp(@settings, @newsettings, sizeof(GfxSettings)) = 0
end function
'==========================================================================================
' Engine Settings menu
'==========================================================================================
type EngineSettingsMenu extends ModularMenu
gfx_settings as GfxSettings
got_gfx_settings as bool 'gfx_settings have been initialised (by the current backend)
declare sub update()
declare function each_tick() as bool
end type
sub EngineSettingsMenu.update()
clear_menu
add_item -1, , "Exit menu"
header " Music Backend: music_" & musicbackend
add_wrapped_items 0, , musicbackendinfo, NO, , YES
header " Graphics Backend: gfx_" & gfxbackend
' gfx_sdl2's info string has a long list of available drivers, hide it.
dim gfxinfo as string = split_chunk(gfxbackendinfo, 0, " // ")
add_wrapped_items 0, , gfxinfo, NO, , YES
add_item 10, , "Switch backend..."
'Initialise to invalid values. gfx_get_settings then overwrites the settings it supports
with gfx_settings
.constructor() 'Zero everything
.resizable_window = -2 'Not user editable
.resizable_resolution = -2 'ditto
.preserve_ratio = -2
'.min/max_resolution = 0 already; not user editable
.upscaler = -1
'.upscaler_zoom = 0 already
.bilinear = -2
.vsync = -2
gfx_get_settings(gfx_settings)
got_gfx_settings = YES
if .upscaler <> -1 then
add_item 11, , "Upscaler: " & iif(.upscaler, "smooth", "nearest-neighbour")
end if
if .upscaler_zoom <> 0 then
dim caption as string
dim disabled as bool = NO
if .bilinear <> NO orelse .upscaler > 0 then
caption = .upscaler_zoom & "x"
if .upscaler_zoom = 1 then caption &= " (disabled)"
else
caption = "N/A"
disabled = YES
end if
add_item 12, , "Upscaler zoom: " & caption, , , disabled
end if
if .bilinear <> -2 then
add_item 13, , "Bilinear filtering: " & yesorno(.bilinear)
end if
if .vsync <> -2 then
add_item 14, , "V-sync: " & yesorno(.vsync)
end if
if .preserve_ratio <> -2 then
add_item 15, , "Aspect ratio: " & iif(.preserve_ratio, "preserve", "changeable")
end if
end with
end sub
function EngineSettingsMenu.each_tick() as bool
dim activate as bool = enter_space_click(state)
select case itemtypes(state.pt)
case -1
if activate then return YES
case 10
if activate then
copypage holdscreen, vpage 'Hide this menu
gfx_backend_menu
got_gfx_settings = NO
state.need_update = YES
end if
case 11
state.need_update or= intgrabber(gfx_settings.upscaler, 0, 1)
case 12
state.need_update or= intgrabber(gfx_settings.upscaler_zoom, 1, 4)
case 13
state.need_update or= boolgrabber(gfx_settings.bilinear, state)
case 14
state.need_update or= boolgrabber(gfx_settings.vsync, state)
case 15
state.need_update or= boolgrabber(gfx_settings.preserve_ratio, state)
end select
if state.need_update andalso got_gfx_settings then
gfx_set_settings(gfx_settings)
end if
end function
sub engine_settings_menu()
push_and_reset_gfxio_state
dim menu as EngineSettingsMenu
menu.title = "Engine Settings"
menu.helpkey = "shared_engine_settings"
menu.floating = YES
menu.use_selectable = YES
menu.menuopts.edged = YES
menu.run()
pop_gfxio_state
end sub
'==========================================================================================
' Low-level overlays, control keys and menus
'==========================================================================================
'Called from setkeys. This handles keypresses which are global throughout the engine.
'(Note that backends also have some hooks, especially gfx_sdl.bas for OSX-specific stuff)
local sub allmodex_controls()
dim ctrl as KeyBits = real_keyval(scCtrl)
dim shift as KeyBits = real_keyval(scShift)
dim ctrlshift as Keybits = ctrl or shift
'Check to see if the backend has received a request
'to close the window (eg. clicking the window frame's X).
'This form of input isn't recorded, but the ESCs fired in Custom will be recorded,
'so there's no need to check the recorded key state for pageup+pagedown+esc
if real_keyval(scPageup) > 0 andalso real_keyval(scPagedown) > 0 andalso real_keyval(scEsc) > 1 then
closerequest = YES
end if
#ifdef IS_CUSTOM
'Fire ESC keypresses to exit every menu
if closerequest then
if replay.active or replay.paused then
stop_replaying_input "Replay ended by quit request"
end if
real_input.kb.keys(scEsc) = 7
end if
#elseif defined(IS_GAME)
'Quick abort (could probably do better, just moving this here for now)
if closerequest then
exit_gracefully()
end if
#endif
if shift > 0 andalso real_keyval(scTab) > 0 then
' Crash the program! For testing
if real_keyval(scF3) > 1 then
*cast(integer ptr, &hff) = 42
end if
' A breakpoint. If not running under gdb, this will terminate the program
if real_keyval(scF4) > 1 then
interrupt_self ()
end if
if real_keyval(scF5) > 1 then
fatalerror "User hit Tab-Shift-F5"
end if
if real_keyval(scF6) > 1 then
dim x as integer ptr
*x = 42 'In -exx builds, FB throws an error rather than SIGSEGV
end if
end if
if ctrlshift > 0 andalso (real_keyval(scF7) and 4) then
'gfx_backend_menu
engine_settings_menu
end if
'Ctrl-Shift-I: toggle IO debug
if ctrl > 0 andalso shift > 0 andalso (real_keyval(scI) and 4) then
set_debugging_io (debugging_io xor YES)
show_overlay_message "Gfx backend/Input debug logging " & onoroff(debugging_io xor YES)
end if
'Ctrl-Shift-N: toggle numpad remapping
if ctrl > 0 andalso shift > 0 andalso (real_keyval(scN) and 4) then
remap_numpad xor= YES
show_overlay_message "Numpad remapping " & onoroff(remap_numpad xor YES)
end if
'Ctrl/Shift-F8: Open debug log
if ctrlshift > 0 andalso (real_keyval(scF8) and 4) then
open_document log_dir & *app_log_filename
end if
' F12 screenshots are handled in setvispage, not here.
' Ctrl/Shift+F12 to start/stop recording a .gif
if ctrlshift > 0 andalso (real_keyval(scF12) and 4) then
toggle_recording_gif
end if
if ctrl > 0 andalso real_keyval(scTilde) and 4 then
toggle_fps_display
end if
fps_multiplier = base_fps_multiplier
if shift > 0 and real_keyval(scTab) > 0 then 'speed up while held down
fps_multiplier *= 6.
end if
if replay.active then replay_controls()
if ctrlshift > 0 and real_keyval(scF11) > 1 then
real_clearkey(scF11)
macro_controls()
end if
'This is a pause that doesn't show up in recorded input
'Overrides the in-game & in-battle Pause key/screen.
if (replay.active or record.active) andalso real_keyval(scPause) > 1 then
real_clearkey(scPause)
pause_replaying_input
pause_recording_input
notification "Replaying/recording is PAUSED"
resume_replaying_input
resume_recording_input
end if
'gfx backend/window settings
if keyval(scShift) > 0 and keyval(sc1) > 0 then
'Old testing keys
/'
if keyval(scRightBrace) > 1 then
set_resolution windowsize.w + 10, windowsize.h + 10
end if
if keyval(scLeftBrace) > 1 then
set_resolution windowsize.w - 10, windowsize.h - 10
end if
'/
'Change scaling settings
dim changed_scaling as bool
dim settings as GfxSettings
gfx_get_settings(settings)
if keyval(scU) > 1 then
settings.upscaler xor= 1
changed_scaling = YES
end if
if keyval(scB) > 1 then
settings.bilinear = iif(settings.bilinear, NO, YES)
changed_scaling = YES
end if
if keyval(scZ) > 1 then
loopvar settings.upscaler_zoom, 1, 4
changed_scaling = YES
end if
if changed_scaling then
gfx_set_settings(settings)
settings = GfxSettings() 'Zero out
gfx_get_settings(settings) 'Confirm what settings the backend actually supports
dim tempmsg as string
if settings.bilinear = NO then
tempmsg = "Nearest-neighbour "
elseif settings.upscaler = 0 andalso settings.upscaler_zoom >= 1 then
tempmsg = "1/" & settings.upscaler_zoom & " bilinear "
else
tempmsg = "Bilinear "
end if
if settings.upscaler > 0 then
tempmsg &= "+ " & settings.upscaler_zoom & "x upscaler "
end if
show_overlay_message tempmsg + "scaling"
end if
'Toggle window resizability independently of resolution resizability
/'
if keyval(scW) > 1 then
settings.resizable_window = iif(settings.resizable_window, NO, YES)
if gfx_try_set_settings(settings) then
show_overlay_message "Resizable window: " & yesorno(settings.resizable_window)
end if
end if
'/
'Toggle resolution resizability
if keyval(scR) > 1 then
'Note: there's also an option in the F8 menu in-game.
if resizing_enabled then
lock_resolution
else
unlock_resolution 0, 0 'Loses the min window size setting
end if
show_overlay_message "Resizable resolution: " & yesorno(resizing_enabled)
end if
end if
'gfx_directx handles ScollLock to pause mouse grab itself
if mouse_grab_requested andalso mouse_grab_nested_pauses <= 0 andalso gfxbackend <> "directx" then
#IFDEF __FB_DARWIN__
if keyval(scF14) > 1 then
clearkey(scF14)
#ELSE
if keyval(scScrollLock) > 1 then
clearkey(scScrollLock)
#ENDIF
pause_mouserect
mouse_grab_scrolllock_overridden = YES
end if
end if
end sub
'Show the menu that comes up when pressing ESC while replaying
local sub replay_menu ()
dim menu(...) as string = {"Resume Replay", "End Replay"}
dim choice as integer
pause_replaying_input
dim previous_speed as double = base_fps_multiplier
base_fps_multiplier = 1.
choice = multichoice("Stop replaying recorded input?", menu(), 0, 0)
if choice = 0 then
base_fps_multiplier = previous_speed
resume_replaying_input
elseif choice = 1 then
stop_replaying_input "Playback cancelled."
end if
end sub
'Controls available while replaying input.
'Called from inside setkeys; but it's OK to call setkeys from here if
'pause_replaying_input is called first. If FB had co-routines, this would be implemented as one.
local sub replay_controls ()
'We call show_help which calls setkeys which calls us.
static reentering as bool = NO
BUG_IF(reentering, "Reentry shouldn't happen")
reentering = YES
if real_keyval(scF1) > 1 then
dim remem as bool = overlay_replay_display
pause_replaying_input()
hide_overlays()
base_fps_multiplier = 1.
show_help("share_replay")
setkeys
overlay_replay_display = remem
resume_replaying_input()
end if
if real_keyval(scSpace) > 1 then
overlay_replay_display xor= YES
end if
if real_keyval(ccCancel) > 1 then
replay_menu
end if
'Also scPause, handled in setkeys because it affects record too.
if real_keyval(ccLeft) > 1 then
base_fps_multiplier *= 0.5
show_replay_overlay()
end if
if real_keyval(ccRight) > 1 then
base_fps_multiplier *= 2
show_replay_overlay()
end if
base_fps_multiplier = bound(base_fps_multiplier, 0.5^3, 2.^9)
reentering = NO
end sub
' Menu of options for playback/recording of macros
local sub macro_menu ()
pause_replaying_input
pause_recording_input
ensure_normal_palette
dim holdscreen as integer = allocatepage
copypage vpage, holdscreen
dim choice as integer = 3 'Default to playback
do
'browse() and inputfilename() clobber vpage
copypage holdscreen, vpage
fuzzyrect 0, 0, , , uilook(uiBackground), vpage, 40
redim menu(2) as string
menu(0) = "Cancel"
menu(1) = "Load macro from file"
menu(2) = "Start recording macro"
if isfile(macrofile) then
redim preserve menu(5)
menu(3) = "Play back last recorded macro"
menu(4) = "Play back last recorded macro # times"
menu(5) = "Save last recorded macro to file"
end if
dim msg as string
msg = !"Macro Recording & Replay\n(See F1 help file for information.)"
if ubound(menu) < 3 then
msg += !"\nNo macro recorded yet."
end if
choice = multichoice(msg, menu(), choice, 0, "share_macro_menu")
if choice = 1 then
dim macfile as string
macfile = browse(browseAny, "", "*.ohrkeys")
if len(macfile) then
if not copyfile(macfile, macrofile) THEN
showerror "Couldn't make a copy of " & macfile
end if
end if
continue do
elseif choice = 2 then
show_overlay_message "Recording macro, Shift/Ctrl+F11 to stop", 2.
start_recording_input macrofile
elseif choice = 3 then
show_overlay_message "Replaying macro"
start_replaying_input macrofile
elseif choice = 4 then
dim repeats as string
prompt_for_string repeats, "Number of macro repetitions?"
dim repeat_count as integer = str2int(repeats, -1)
if repeat_count <= 0 then
exit sub
end if
show_overlay_message "Replaying macro " & replay.repeat_count & " time(s)"
start_replaying_input macrofile, repeat_count
elseif choice = 5 then
dim macfile as string
macfile = inputfilename("Input a filename to save to", ".ohrkeys", "", "")
'setkeys
if len(macfile) then
if not copyfile(macrofile, macfile + ".ohrkeys") THEN
showerror "Couldn't write to " & macfile & ".ohrkeys"
end if
end if
continue do
end if
exit do
loop
copypage holdscreen, vpage
freepage holdscreen
restore_previous_palette
resume_replaying_input
resume_recording_input
end sub
'Handles Ctrl+F11 key for macro recording and replay.
'Called from inside setkeys, but it's OK to call setkeys from here as we disallow reentry.
'This can also be called from the in-game debug menu.
sub macro_controls ()
static reentering as bool = NO
if reentering then exit sub
reentering = YES
if record.active then
stop_recording_input "Recorded macro, Shift/Ctrl+F11 to play", errInfo
elseif replay.active then
show_overlay_message "Ended macro playback early", 2.
stop_replaying_input
else
macro_menu
end if
reentering = NO
end sub
'Display a message above everything else; by default doesn't appear in screenshots.
'Intended for use here in allmodex, but pragmaticlly, can be used in Custom too.
'Note that in-game, you should set gam.showtext/gam.showtext_ticks instead.
sub show_overlay_message (msg as string, seconds as double = 3.)
overlay_message = msg
overlay_hide_time = timer + seconds
overlay_replay_display = NO
end sub
function overlay_message_visible () as bool
return len(overlay_message) > 0 and overlay_hide_time > timer
end function
'Show the overlay for replaying input
local sub show_replay_overlay ()
overlay_replay_display = YES
end sub
local sub hide_overlays ()
overlay_message = ""
overlay_replay_display = NO
end sub
local function ms_to_string (ms as integer) as string
return seconds2str(cint(ms * 0.001), "%h:%M:%S")
end function
sub toggle_fps_display ()
overlay_showfps = (overlay_showfps + 1) MOD 3
end sub
' Called every time a frame is drawn.
' skipped: true if this frame was frameskipped.
local sub update_fps_counter (skipped as bool)
fps_draw_frames += 1
if not skipped then
fps_real_frames += 1
end if
dim nowtime as double = timer
if nowtime > fps_time_start + 1 then
draw_fps = fps_draw_frames / (nowtime - fps_time_start)
real_fps = fps_real_frames / (nowtime - fps_time_start)
fps_time_start = nowtime
fps_draw_frames = 0
fps_real_frames = 0
end if
end sub
'Draw crosshairs at the mouse position plus left/right buttons; used by --showmouse cmdline option
sub draw_basic_mouse_cursor (page as integer)
with mouse_state
dim col as integer = uilook(uiSelectedItem + global_tog)
rectangle .x - 4, .y, 9, 1, col, page
rectangle .x, .y - 4, 1, 9, col, page
if .buttons and mouseLeft then
rectangle .x - 3, .y - 3, 3, 3, col, page
end if
if .buttons and mouseRight then
rectangle .x + 1, .y - 3, 3, 3, col, page
end if
end with
end sub
private function keys_overlay_cooldown(inputst as InputState ptr, scancode as KBScancode, bits as KeyBits, keydown as integer) as integer
const DISPLAY_MS = 400
static recent_key_cooldowns(scJoyLAST) as integer 'cooldown ticks
'If the key was down for only a short time, wait a little
'before the display of the key disappears
dim byref cooldown as integer = recent_key_cooldowns(scancode)
if bits > 0 then
cooldown = DISPLAY_MS - keydown 'Total display time DISPLAY_MS
else
cooldown -= inputst->elapsed_ms
end if
if cooldown < 0 then cooldown = 0
return cooldown
end function
'Print the pressed keys at the top-right of the page. Returns true if anything drawn.
function draw_keys_overlay(page as integer) as bool
' Build up two strings describing keypresses, so that modifiers like LShift
' are sorted to the front.
dim as string modifiers, keys
dim inputst as InputState ptr = iif(replay.active, @replay_input, @real_input)
with inputst->kb
for idx as KBScancode = 0 to ubound(.keys)
dim cooldown as integer = keys_overlay_cooldown(inputst, idx, .keys(idx), .key_down_ms(idx))
if cooldown = 0 andalso .keys(idx) = 0 then continue for
'TODO: Would be nice to show "Left" instead of "Numpad 4" if
'numlock is off and that's what it's acting as.
dim keyname as string = scancodename(idx)
if idx <> scLeft andalso idx <> scRight then
replacestr keyname, "Left", "L" 'Shorten the name of modifiers
replacestr keyname, "Right", "R"
replacestr keyname, " ", ""
end if
if .keys(idx) = 0 then
'In cooldown period, show darker text because key isn't down
keyname = fgcol_text(keyname, uilook(uiMenuItem))
end if
select case idx
case scLeftShift, scRightShift, scLeftAlt, scRightAlt, scLeftCtrl, scRightCtrl
modifiers &= " " & keyname
case scShift, scAlt, scUnfilteredAlt, scCtrl, scAnyEnter
'Ignore these duplicates
case scNumLock, scCapsLock, scScrollLock
'May appear pressed continuously
case else
keys &= " " & keyname
end select
next idx
end with
for joynum as integer = 0 to ubound(inputst->joys)
with inputst->joys(joynum)
for idx as JoyButton = 0 to ubound(.keys)
dim scancode as KBScancode = idx + scJoyOFFSET
dim cooldown as integer = keys_overlay_cooldown(inputst, scancode, .keys(idx), .key_down_ms(idx))
if cooldown = 0 andalso .keys(idx) = 0 then continue for
dim keyname as string = scancodename(scancode)
replacestr keyname, "Gamepad ", "J" & joynum & "-"
if .keys(idx) = 0 then
'In cooldown period, show darker text because key isn't down
keyname = fgcol_text(keyname, uilook(uiMenuItem))
end if
keys &= " " & keyname
next
end with
next
dim keysmsg as string = trim(modifiers & keys)
if len(keysmsg) then
rectangle pRight, pTop, textwidth(keysmsg) + 2, 10, uilook(uiBackground), page
edgeprint keysmsg, pRight - 1, pTop, uilook(uiText), page, YES 'withtags=YES
return YES
end if
end function
'Draw stuff on top of the video page about to be shown; specially those things
'that are included in .gifs/screenshots even without --recordoverlays
'Returns true if something was drawn.
local function draw_allmodex_recordable_overlays (page as integer) as bool
dim dirty as bool = NO
if show_mouse_overlay then
draw_basic_mouse_cursor page
dirty = YES
end if
if gif_show_keys_overlay andalso recordvid andalso recordvid->active then
dirty = draw_keys_overlay(page)
end if
return dirty
end function
'Draw stuff on top of the video page about to be shown.
'Returns true if something was drawn.
local function draw_allmodex_overlays (page as integer) as bool
if overlays_enabled = NO then return NO
dim dirty as bool = NO
if overlay_showfps then
dim fpsstring as string
if overlay_showfps = 2 then
fpsstring = "Draw:" & format(draw_fps, "0.0") & " FPS"
else
fpsstring = "Display:" & format(real_fps, "0.0") & " FPS"
end if
' Move the FPS a little to the left, because on OSX+gfx_sdl the handle for resizable
' windows is drawn in the bottom right corner by SDL (not the OS).
edgeprint fpsstring, pRight - 14, iif(overlay_replay_display, pTop, pBottom), uilook(uiText), page
dirty = YES
end if
if overlay_replay_display then
overlay_hide_time = 0. 'Hides any other message
dim repeat_str as string
if replay.repeat_count > 1 then
repeat_str = "#" & (1 + replay.repeats_done) & "/" & replay.repeat_count
end if
overlay_message = "Pos: " & ms_to_string(replay.play_position_ms) & "/" & ms_to_string(replay.length_ms) & _
" " & rpad(replay.tick & "/" & replay.length_ticks, " ", 9) & repeat_str & _
!"\nSpeed: " & rpad(fps_multiplier & "x", " ", 5) & "FPS:" & format(draw_fps, "0.0") & " [F1 for help]"
elseif overlay_hide_time < timer then
overlay_message = ""
end if
if len(overlay_message) then
basic_textbox overlay_message, uilook(uiText), page, rBottom + ancBottom - 2, , YES
dirty = YES
end if
' For chasing Surface memory leaks
'edgeprint gfx_debugSurfaces_SW() & " surfaces", pLeft, pBottom, uilook(uiText), page
'dirty = YES
return dirty
end function
'==========================================================================================
' Recording and replay
'==========================================================================================
sub start_recording_input (filename as string)
if replay.active or replay.paused then
debug "Can't record input because already replaying input!"
exit sub
end if
if isfile(filename) then
debug "Replacing the input recording that already existed at """ & filename & """"
end if
record.constructor() 'Clear data
if openfile(filename, for_binary + access_write, record.file) then
stop_recording_input "Couldn't open " & filename
record.file = -1
exit sub
end if
dim header as string = "OHRRPGCEkeys"
put #record.file,, header
dim ohrkey_ver as integer = 4
put #record.file,, ohrkey_ver
dim seed as double = TIMER * 1e9
reseed_prng seed
put #record.file,, seed
record.active = YES
debuginfo "Recording keyboard input to: """ & filename & """"
end sub
sub stop_recording_input (msg as string="", errorlevel as ErrorLevelEnum = errError)
if msg <> "" then
debugc errorlevel, msg
show_overlay_message msg
end if
if record.active or record.paused then
close #record.file
record.active = NO
record.paused = NO
debuginfo "STOP recording input"
end if
end sub
' While recording is paused you can call setkeys without updating the recorded state.
' The keyboard state before pausing is restored when resuming, so it's safe to pause
' and resume recording anywhere.
sub pause_recording_input
if record.active then
record.active = NO
record.paused = YES
record.last_kb = real_input.kb
end if
end sub
sub resume_recording_input
if record.paused then
record.active = YES
record.paused = NO
real_input.kb = record.last_kb
end if
end sub
' Start replaying again from the beginning, used for loop
sub restart_replaying_input ()
replay.tick = -1
replay.nexttick = -1
replay.play_position_ms = 0
seek replay.file, 1
load_replay_header()
end sub
sub start_replaying_input (filename as string, num_repeats as integer = 1)
if record.active or record.paused then
debug "Can't replay input because already recording input!"
exit sub
end if
replay.constructor() 'Reset (TODO: does this leak the filename string?)
replay.filename = filename
replay_input.kb.reset()
if openfile(filename, for_binary + access_read, replay.file) then
stop_replaying_input "Couldn't open " & filename
replay.file = -1
exit sub
end if
replay.active = YES
replay.repeat_count = num_repeats
load_replay_header()
end sub
sub load_replay_header ()
dim header as string = STRING(12, 0)
GET #replay.file,, header
if header <> "OHRRPGCEkeys" then
stop_replaying_input "No OHRRPGCEkeys header in """ & replay.filename & """"
exit sub
end if
dim ohrkey_ver as integer = -1
GET #replay.file,, ohrkey_ver
if ohrkey_ver <> 4 then
stop_replaying_input "Unknown ohrkey version code " & ohrkey_ver & " in """ & replay.filename & """. Only know how to understand version 4"
exit sub
end if
dim seed as double
GET #replay.file,, seed
reseed_prng seed
debuginfo "Replaying keyboard input from: """ & replay.filename & """"
read_replay_length()
if replay.repeats_done = 0 then
show_replay_overlay()
end if
end sub
sub stop_replaying_input (msg as string="", errorlevel as ErrorLevelEnum = errError)
if msg <> "" then
debugc errorlevel, msg
show_overlay_message msg
end if
if replay.active or replay.paused then
close #replay.file
replay.file = -1
replay.active = NO
replay.paused = NO
debugc errorlevel, "STOP replaying input"
use_speed_control = YES
end if
' Cancel any speedup
base_fps_multiplier = 1.
end sub
' While replay is paused you can call setkeys without changing the replay state,
' and keyval, etc, return the real state of the keyboard.
' (Safe to try pausing/resuming when not replaying)
sub pause_replaying_input
' The replay state is preserved in replay_input.kb, so pausing and resuming is easy.
if replay.active then
replay.active = NO
replay.paused = YES
end if
end sub
sub resume_replaying_input
if replay.paused then
replay.active = YES
replay.paused = NO
end if
end sub
sub record_input_tick ()
record.tick += 1
dim presses as ubyte = 0
dim keys_down as integer = 0
for i as KBScancode = 0 to scLAST
if real_input.kb.keys(i) <> record.last_kb.keys(i) then
presses += 1
end if
if real_input.kb.keys(i) then keys_down += 1 'must record elapsed_ms
next i
if presses = 0 andalso keys_down = 0 andalso len(real_input.kb.inputtext) = 0 then exit sub
dim debugstr as string
if record.debug then debugstr = "L:" & (SEEK(record.file) - 1) & " T:" & record.tick & " ms:" & real_input.elapsed_ms & " ("
put #record.file,, record.tick
dim byt as ubyte = cubyte(real_input.elapsed_ms)
put #record.file,, byt
put #record.file,, presses
for i as ubyte = 0 to scLAST
if real_input.kb.keys(i) <> record.last_kb.keys(i) then
put #record.file,, i
byt = real_input.kb.keys(i)
put #record.file,, byt
if record.debug then debugstr &= " " & scancodename(i, YES) & "=" & real_input.kb.keys(i)
end if
next i
'Currently inputtext is Latin-1, format will need changing in future
byt = len(real_input.kb.inputtext)
put #record.file,, byt
put #record.file,, real_input.kb.inputtext
if record.debug then
debugstr &= " )"
if len(real_input.kb.inputtext) then debugstr &= " input: '" & real_input.kb.inputtext & "'"
debuginfo debugstr
end if
record.last_kb = real_input.kb
end sub
' Scan the replay file to find its length, setting replay.length_ms and replay.length_ticks
' Assumes replay.file is at start of the data stream.
local sub read_replay_length ()
dim as integer tick, nexttick
dim as ubyte tick_ms = 55, presses, input_len
dim initial_pos as integer = seek(replay.file)
replay.length_ms = 0
do
get #replay.file,, nexttick
if eof(replay.file) then exit do
if nexttick < tick then
visible_debug "Replay corrupt: tick " & replay.nexttick & " occurs after " & tick
exit do
end if
' Assume any skipped ticks are the same length as the next one, seems to give a vastly better
' estimate than using the previous tick.
' (This could be way off, some ticks are 0ms or 255+ms)
get #replay.file,, tick_ms
replay.length_ms += tick_ms * (nexttick - tick)
' if (nexttick - tick) > 1 and (tick_ms < 50 or tick_ms > 60) then
' debug "dubious tick_ms estimate " & tick_ms & " at " & tick & " for " & (nexttick - tick) & " ticks"
' end if
tick = nexttick
get #replay.file,, presses
if presses > scLAST + 1 then
visible_debug "Replay corrupt: presses=" & presses
exit do
end if
seek #replay.file, seek(replay.file) + 2 * presses
GET #replay.file,, input_len
if input_len then
seek #replay.file, seek(replay.file) + input_len
end if
loop
replay.length_ticks = tick
seek #replay.file, initial_pos
end sub
sub replay_input_tick ()
replay.tick += 1
do
if EOF(replay.file) then
replay.repeats_done += 1
'show_overlay_message "Finished replay " & replay.repeats_done & " of " & replay.repeat_count
if replay.repeats_done >= replay.repeat_count then
stop_replaying_input "The end of the playback file was reached.", errInfo
exit sub
else
restart_replaying_input
end if
end if
'Check whether it's time to play the next recorded tick in the replay file
'(ticks on which nothing happened aren't saved)
if replay.nexttick = -1 then
replay.fpos = seek(replay.file) - 1
GET #replay.file,, replay.nexttick
' Grab the next tick_ms already, because for some reason it gives far more accurate .play_position_ms estimation
dim tick_ms as ubyte
GET #replay.file,, tick_ms
replay.next_tick_ms = tick_ms
end if
if replay.nexttick < replay.tick then
debug "input replay late for tick " & replay.nexttick & " (" & replay.nexttick - replay.tick & ")"
elseif replay.nexttick > replay.tick then
'debug "saving replay input tick " & replay.nexttick & " until its time has come (+" & replay.nexttick - replay.tick & ")"
for i as KBScancode = 0 to scLAST
'Check for a corrupt file
if replay_input.kb.keys(i) then
' There ought to be a tick in the input file so that we can set setkeys_elapsed_ms correctly
debug "bad recorded key input: key " & i & " is down, but expected tick " & replay.tick & " is missing"
exit for
end if
next
' Otherwise, this doesn't matter as it won't be used
replay_input.elapsed_ms = 1
' Increment how much we've played so far - not actual play time but at same rate as the .length_ms estimate
replay.play_position_ms += replay.next_tick_ms
replay_input.kb.inputtext = ""
exit sub
end if
replay_input.elapsed_ms = replay.next_tick_ms
replay.play_position_ms += replay.next_tick_ms
dim presses as ubyte
GET #replay.file,, presses
if presses > scLAST + 1 then
stop_replaying_input "input replay tick " & replay.nexttick & " has invalid number of keypresses " & presses
exit sub
end if
dim as string info
if replay.debug then
info = "L:" & replay.fpos & " T:" & replay.nexttick & " ms:" & replay_input.elapsed_ms & " ("
end if
dim key as ubyte
dim keybits as ubyte
for i as integer = 1 to presses
GET #replay.file,, key
GET #replay.file,, keybits
replay_input.kb.keys(key) = keybits
if replay.debug then info &= " " & scancodename(key) & "=" & keybits
next i
if replay.debug then info &= " )"
dim input_len as ubyte
GET #replay.file,, input_len
if input_len then
'Currently inputtext is Latin-1, format will need changing in future
replay_input.kb.inputtext = space(input_len)
GET #replay.file,, replay_input.kb.inputtext
if replay.debug then info &= " input: '" & replay_input.kb.inputtext & "'"
else
replay_input.kb.inputtext = ""
end if
if replay.debug then debuginfo info
'In case the replay somehow became out of sync, keep looping until we catch up
'(Probably hopeless though)
if replay.nexttick = replay.tick then
replay.nexttick = -1
exit sub
end if
replay.nexttick = -1
loop
end sub
'==========================================================================================
' Map rendering
'==========================================================================================
function readblock (map as TileMap, x as integer, y as integer, default as integer = 112343211) as integer
if x < 0 orelse x >= map.wide orelse y < 0 orelse y >= map.high then
if default <> 112343211 then return default
onetime_debug errShowBug, "illegal readblock call " & x & " " & y
exit function
end if
return map.data[x + y * map.wide]
end function
sub writeblock (map as TileMap, x as integer, y as integer, v as integer)
if x < 0 orelse x >= map.wide orelse y < 0 orelse y >= map.high then
onetime_debug errShowBug, "illegal writeblock call " & x & " " & y & " " & v
exit sub
end if
map.data[x + y * map.wide] = v
end sub
'Calculate which tile to display
local function calcblock (tmap as TileMap, x as integer, y as integer, overheadmode as integer, pmapptr as TileMap ptr) as integer
'returns -1 to draw no tile
'overheadmode = 0 : ignore overhead tile bit; draw normally;
'overheadmode = 1 : draw non overhead tiles only (to avoid double draw)
'overheadmode = 2 : draw overhead tiles only
dim block as integer
'check bounds
if bordertile = -1 then
'wrap
while y < 0
y = y + tmap.high
wend
while y >= tmap.high
y = y - tmap.high
wend
while x < 0
x = x + tmap.wide
wend
while x >= tmap.wide
x = x - tmap.wide
wend
else
if (y < 0) or (y >= tmap.high) or (x < 0) or (x >= tmap.wide) then
if tmap.layernum = 0 and overheadmode <= 1 then
'only draw the border tile once!
return bordertile
else
return -1
end if
end if
end if
block = readblock(tmap, x, y)
if block = 0 and tmap.layernum > 0 then 'This could be an argument, maybe we could get rid of layernum
return -1
end if
if overheadmode > 0 then
if pmapptr = NULL then
showbug "calcblock: overheadmode but passmap ptr is NULL"
block = -1
elseif x >= pmapptr->wide or y >= pmapptr->high then
'Impossible if the passmap is the same size
if overheadmode = 2 then block = -1
elseif ((readblock(*pmapptr, x, y) and passOverhead) <> 0) xor (overheadmode = 2) then
block = -1
end if
end if
return block
end function
'drawmap helper: initialize animoffsets() from tileset animation state
local sub setup_tile_anim (animoffsets() as integer, tileset as TilesetData ptr)
for i as integer = 0 to 1
animoffsets(i) = POSMOD(tileset->tanim_state(i).cycle + tileset->tanim(i).range_start, 160)
next
end sub
'Given a tile number, possibly animated, translate it to the static tile to display
'tileset ptr can be NULL
local function translate_animated_tile(animoffsets() as integer, tileset as TilesetData ptr, todraw as integer, byref drawoffset as XYPair) as integer
drawoffset.x = 0
drawoffset.y = 0
if todraw >= 208 then
if tileset then
drawoffset = tileset->tanim_state(1).drawoffset
end if
return (todraw - 48 + animoffsets(1)) mod 160
elseif todraw >= 160 then
if tileset then
drawoffset = tileset->tanim_state(0).drawoffset
end if
return (todraw + animoffsets(0)) mod 160
else
return todraw
end if
end function
sub drawmap (tmap as TileMap, x as integer, y as integer, tileset as TilesetData ptr, p as integer, trans as bool = NO, overheadmode as integer = 0, pmapptr as TileMap ptr = NULL, ystart as integer = 0, yheight as integer = -1, pal as Palette16 ptr = NULL, opts as DrawOptions = def_drawoptions)
drawmap tmap, x, y, tileset->spr, tileset, p, trans, overheadmode, pmapptr, ystart, yheight, , pal, opts
end sub
sub drawmap (tmap as TileMap, x as integer, y as integer, tilesetsprite as Frame ptr, tilesetanims as TilesetData ptr = NULL, p as integer, trans as bool = NO, overheadmode as integer = 0, pmapptr as TileMap ptr = NULL, ystart as integer = 0, yheight as integer = -1, largetileset as bool = NO, pal as Palette16 ptr = NULL, opts as DrawOptions = def_drawoptions)
'Draw a single map layer; see overload below for args.
'ystart is the distance from the top to start drawing, yheight the number of lines. yheight=-1 indicates extend to bottom of screen
'There are no options in the X direction because they've never been used, and I don't forsee them being (can use Frames or slices instead)
dim mapview as Frame ptr
'Drawing onto mapview will reset the cliprect, so save it. Also we need to shift the cliprect by ystart.
'TODO: it would be more efficient to shrink mapview to the cliprect. Then we could also avoid having
'to clip each individual tile.
dim saveclip as ClipState = get_cliprect(vpages(p))
mapview = frame_new_view(vpages(p), 0, ystart, vpages(p)->w, iif(yheight = -1, vpages(p)->h, yheight))
setclip saveclip.l, saveclip.t - ystart, saveclip.r, saveclip.b - ystart, mapview
drawmap tmap, x, y, tilesetsprite, tilesetanims, mapview, trans, overheadmode, pmapptr, largetileset, pal, opts
frame_unload @mapview
get_cliprect() = saveclip
end sub
sub drawmap (tmap as TileMap, x as integer, y as integer, tilesetsprite as Frame ptr, tilesetanims as TilesetData ptr = NULL, dest as Frame ptr, trans as bool = NO, overheadmode as integer = 0, pmapptr as TileMap ptr = NULL, largetileset as bool = NO, pal as Palette16 ptr = NULL, opts as DrawOptions = def_drawoptions)
'Draw a single map layer.
'This version of drawmap paints over the entire dest Frame given to it.
'x and y are the camera position at the top left corner of the Frame, not
'the position at which the top left of the map is drawn: this is the OPPOSITE
'to all other drawing commands!
'trans : Whether color 0 is transparent; doesn't affect treatment of tile 0.
'overheadmode = 0 : draw all tiles normally
'overheadmode = 1 : draw non overhead tiles only (to avoid double draw)
'overheadmode = 2 : draw overhead tiles only
'largetileset : A hack which disables tile animation, instead using tilesets with 256 tiles
'opts : Note that DrawOptions.scale is not yet supported
'tilesetanims : tileset animations (.tanim()) and state (.tanim_state) are taken from this TilesetData
dim subtimer as TimerIDs
if opts.with_blending then
' Does nothing if timing not enabled
subtimer = gfx_op_timer.substart(TimerIDs.Blend)
end if
dim animoffsets(1) as integer
if tilesetanims then
setup_tile_anim animoffsets(), tilesetanims
end if
dim destpos as XYPair 'Position on dest Frame of current tile
dim start_destpos as XYPair 'Position on dest Frame of top-left tile
dim xpos as integer 'Tilemap coords of current tile
dim ypos as integer
dim xstart as integer 'xpos at start of each row
'Find the first tile to draw at the top-left
'Division rounded to negative infinity
if x < 0 then
xstart = (x - 19) \ 20
else
xstart = x \ 20
end if
start_destpos.x = -(x - xstart*20) ' == -POSMOD(x, 20)
'We start drawing not at 0,0 but at -maxTileOffset,-maxTileOffset in case
'of tiles just out-of-view that are shifted into it by a tile animation
while start_destpos.x > -maxTileOffset
'So draw an extra tile
start_destpos.x -= 20
xstart -= 1
wend
if y < 0 then
ypos = (y - 19) \ 20
else
ypos = y \ 20
end if
start_destpos.y = -(y - ypos*20) ' == -POSMOD(y, 20)
while start_destpos.y > -maxTileOffset
start_destpos.y -= 20
ypos -= 1
wend
dim tileframe as Frame
tileframe.refcount = NOREFC
tileframe.w = 20
tileframe.h = 20
tileframe.pitch = 20
dim drawoffset as XYPair
destpos.y = start_destpos.y
while destpos.y < dest->h + maxTileOffset
destpos.x = start_destpos.x
xpos = xstart
while destpos.x < dest->w + maxTileOffset
dim todraw as integer
todraw = calcblock(tmap, xpos, ypos, overheadmode, pmapptr)
if largetileset = NO then
todraw = translate_animated_tile(animoffsets(), tilesetanims, todraw, drawoffset)
end if
'get the tile
if (todraw >= 0) then
tileframe.image = tilesetsprite->image + todraw * 20 * 20
if tilesetsprite->mask then 'just in case it happens some day
tileframe.mask = tilesetsprite->mask + todraw * 20 * 20
else
tileframe.mask = NULL
end if
'draw it on the map
var where = destpos + drawoffset
frame_draw_internal(@tileframe, curmasterpal(), pal, where.x, where.y, trans, dest, opts)
end if
destpos.x += 20
xpos += 1
wend
destpos.y += 20
ypos += 1
wend
gfx_op_timer.substop subtimer
end sub
'Sets global state used by drawmap, yuck
'-2: draw nothing beyond the map edge
'-1: wrap map
'0+: draw this tile beyong the map edge (but only when drawing layer 0)
sub setoutside (defaulttile as integer)
bordertile = defaulttile
end sub
' Draws all map layers at a single tile coordinate. Used for drawing the minimap.
' Respects setoutside.
sub draw_layers_at_tile(composed_tile as Frame ptr, tiles as TileMap ptr vector, tilesets as TilesetData ptr vector, tx as integer, ty as integer, pmapptr as TileMap ptr = NULL)
BUG_IF(v_len(tiles) <> v_len(tilesets), "mismatched vectors")
dim drawoffset as XYPair 'Unused
for idx as integer = 0 to v_len(tiles) - 1
'It's possible that layer <> idx if for example drawing a minimap of a single map layer
dim layer as integer = tiles[idx]->layernum
dim animoffsets(1) as integer
setup_tile_anim animoffsets(), tilesets[idx]
with *tilesets[idx]
dim todraw as integer = calcblock(*tiles[idx], tx, ty, 0, 0)
if todraw < 0 then continue for
'TODO: drawoffset is ignored for minimaps, as are shifted map layers
todraw = translate_animated_tile(animoffsets(), tilesets[idx], todraw, drawoffset)
frame_draw .spr, , 0, -todraw * 20, (layer > 0), composed_tile
'Note: readblock() must be called with a default for OOB reads, because
'a number of ancient .rpgs have passmaps that are 2 rows shorter than the tilemap
if layer = 0 andalso pmapptr andalso (readblock(*pmapptr, tx, ty, 0) and passOverhead) then
' If an overhead tile, return just the layer 0 tile
exit for
end if
end with
next
end sub
'==========================================================================================
' Old allmodex IO
'==========================================================================================
sub storemxs (fil as string, record as integer, fr as Frame ptr)
'saves a screen page to a file. Doesn't support non-320x200 pages
dim f as integer
dim as integer x, y
dim sptr as ubyte ptr
dim plane as integer
CHECK_FRAME_8BIT(fr)
if openfile(fil, for_binary + access_read_write, f) then exit sub
'skip to index
seek #f, (record*64000) + 1 'will this work with write access?
'modex format, 4 planes
for plane = 0 to 3
for y = 0 to 199
sptr = fr->image + fr->pitch * y + plane
for x = 0 to (80 - 1) '1/4 of a row
put #f, , *sptr
sptr = sptr + 4
next
next
next
close #f
end sub
'For compatibility: load into an existing Frame.
'NOTE: Don't use this in new code. It bypasses the cache. Use frame_load
sub loadmxs (filen as string, record as integer, dest as Frame ptr)
dim temp as Frame ptr
temp = frame_load_mxs(filen, record)
frame_clear dest
if temp then
frame_draw temp, , 0, 0, NO, dest
frame_unload @temp
end if
end sub
'Loads a 320x200 mode X format page from a file.
'This should probably only be called directly when loading from file outside an .rpg,
'otherwise use frame_load.
function frame_load_mxs (filen as string, record as integer) as Frame ptr
dim starttime as double = timer
dim fh as integer
dim as integer x, y
dim sptr as ubyte ptr
dim plane as integer
dim dest as Frame ptr
'Return blank Frame on failure
dest = frame_new(320, 200, , YES)
if record < 0 then
debugc errBug, "frame_load_mxs: attempted to read a negative record number " & record
return dest
end if
if openfile(filen, for_binary + access_read, fh) then
debugerror "frame_load_mxs: Couldn't open " & filen
return dest
end if
if lof(fh) < (record + 1) * 64000 then
debugerror "frame_load_mxs: wanted page " & record & "; " & filen & " is only " & lof(fh) & " bytes"
lazyclose fh
return dest
end if
'skip to index
seek #fh, (record*64000) + 1
dim quarter_row(79) as ubyte
'modex format, 4 planes
for plane = 0 to 3
for y = 0 to 200 - 1
sptr = dest->image + dest->pitch * y + plane
'1/4 of a row
get #fh, , quarter_row()
for x = 0 to 80 - 1
sptr[x * 4] = quarter_row(x)
next
next
next
lazyclose fh
debug_if_slow(starttime, 0.1, filen)
return dest
end function
'==========================================================================================
' Graphics primitives
'==========================================================================================
'No clipping!!
'c is either an 8 bit or 32 bit RGBColor value
sub putpixel (spr as Frame ptr, x as integer, y as integer, c as integer)
if x < 0 orelse x >= spr->w orelse y < 0 orelse y >= spr->h then
exit sub
end if
if spr->image then
FRAMEPIXEL(x, y, spr) = c
exit sub
end if
ERROR_IF(spr->surf = NULL, "NULL image and surface")
with *spr->surf
ERROR_IF(.format <> SF_32bit, "surf isn't 32bit")
cast(integer ptr, .pColorData)[.pitch * y + x] = c
end with
end sub
sub putpixel (x as integer, y as integer, c as integer, p as integer)
dim byref cliprect as ClipState = get_cliprect(vpages(p))
if POINT_CLIPPED(x, y) then
'debug "attempt to putpixel off-screen " & x & "," & y & "=" & c & " on page " & p
exit sub
end if
putpixel vpages(p), x, y, c
end sub
'Returns either an 8 bit, or 32 bit RGBColor value
function readpixel (spr as Frame ptr, x as integer, y as integer) as integer
if x < 0 orelse x >= spr->w orelse y < 0 orelse y >= spr->h then
return -1
end if
if spr->image then
return FRAMEPIXEL(x, y, spr)
end if
ERROR_IF(spr->surf = NULL, "NULL image and surface", -1)
with *spr->surf
ERROR_IF(.format <> SF_32bit, "surf isn't 32bit", -1)
return cast(integer ptr, .pColorData)[.pitch * y + x]
end with
end function
function readpixel (x as integer, y as integer, p as integer) as integer
dim byref cliprect as ClipState = get_cliprect(vpages(p))
if POINT_CLIPPED(x, y) then
'debug "attempt to readpixel off-screen " & x & "," & y & " on page " & p
return -1
end if
return readpixel(vpages(p), x, y)
end function
sub drawbox (x as RelPos, y as RelPos, w as RelPos, h as RelPos, col as integer, thickness as integer = 1, p as integer)
drawbox vpages(p), x, y, w, h, col, thickness
end sub
'Draw a hollow box, with given edge thickness
'Increasing the thickness causes the lines to fatten towards the interior of the
'box; w/h is always the external size - meaning x+w and y+h are exclusive, while
'x and y are inclusive
sub drawbox (dest as Frame ptr, x as RelPos, y as RelPos, w as RelPos, h as RelPos, col as integer, thickness as integer = 1)
w = relative_pos(w, dest->w)
h = relative_pos(h, dest->h)
if w < 0 then x = x + w + 1: w = -w
if h < 0 then y = y + h + 1: h = -h
if w = 0 or h = 0 then exit sub
x = relative_pos(x, dest->w, w)
y = relative_pos(y, dest->h, h)
dim as integer thickx = small(thickness, w), thicky = small(thickness, h)
rectangle dest, x, y, w, thicky, col
IF h > thicky THEN
rectangle dest, x, y + h - thicky, w, thicky, col
end IF
rectangle dest, x, y, thickx, h, col
IF w > thickx THEN
rectangle dest, x + w - thickx, y, thickx, h, col
end IF
end sub
'Draw a box in perspective, its top 'offset' from its bottom; 12 lines in total
'Note, thickness doesn't affect the four angled lines
sub drawcube(dest as Frame ptr, rect as RectType, off as XYPair, col as integer, thickness as integer = 1)
drawbox dest, rect.x, rect.y, rect.wide, rect.high, col, thickness
dim shifted as XYPair = rect.xy + off
drawbox dest, shifted.x, shifted.y, rect.wide, rect.high, col, thickness
dim br as XYPair = rect.topleft + rect.size - 1 'bottom-right
drawline dest, rect.x, rect.y, rect.x + off.x, rect.y + off.y, col
drawline dest, rect.x, br.y, rect.x + off.x, br.y + off.y, col
drawline dest, br.x, rect.y, br.x + off.x, rect.y + off.y, col
drawline dest, br.x, br.y, br.x + off.x, br.y + off.y, col
end sub
' This function is slightly different from drawbox/rectangle, in that draws boxes with
' width/height 0 as width/height 1 instead of not at all.
' color is the main highlight color; if -1, use default
' FIXME: this function doesn't respect clipping!
sub drawants(dest as Frame ptr, x as RelPos, y as RelPos, wide as RelPos, high as RelPos, color as integer = -1)
if color = -1 then color = uilook(uiText)
dim as integer color2 = uilook(uiBackground)
if dest->surf andalso dest->surf->format = SF_32bit then
'putpixel takes BGRA, not master palette index
color = curmasterpal(color).col
color2 = curmasterpal(color2).col
end if
' Decode relative positions/sizes to absolute
wide = relative_pos(wide, dest->w)
high = relative_pos(high, dest->h)
x = relative_pos(x, dest->w, wide)
y = relative_pos(y, dest->h, high)
if wide < 0 then x = x + wide + 1: wide = -wide
if high < 0 then y = y + high + 1: high = -high
'if wide <= 0 or high <= 0 then exit sub
dim col as integer
'--Draw verticals
for idx as integer = 0 to large(high - 1, 0)
select case (idx + x + y + tickcount) mod 3
case 0: continue for
case 1: col = color
case 2: col = color2
end select
putpixel dest, x, y + idx, col
if wide > 0 then
putpixel dest, x + wide - 1, y + idx, col
end if
next idx
'--Draw horizontals
for idx as integer = 0 to large(wide - 1, 0)
select case (idx + x + y + tickcount) mod 3
case 0: continue for
case 1: col = color
case 2: col = color2
end select
putpixel dest, x + idx, y, col
if high > 0 then
putpixel dest, x + idx, y + high - 1, col
end if
next idx
end sub
'Ensure rect is contained within the cliprect and has non-negative width/height.
'Used by rectangle, trans_rectangle, fuzzyrect.
'x/y_start tells how many pixels the x/y location was moved by.
sub clip_rectangle_draw(dest as Frame ptr, byref rect as RelRectType, byref x_start as integer = 0, byref y_start as integer = 0)
dim byref cliprect as ClipState = get_cliprect(dest)
' Decode relative positions/sizes to absolute
rect.wide = relative_pos(rect.wide, dest->w)
rect.high = relative_pos(rect.high, dest->h)
rect.x = relative_pos(rect.x, dest->w, rect.wide)
rect.y = relative_pos(rect.y, dest->h, rect.high)
if rect.wide < 0 then
rect.x = rect.x + rect.wide + 1
rect.wide = -rect.wide
end if
if rect.high < 0 then
rect.y = rect.y + rect.high + 1
rect.high = -rect.high
end if
'clip
if rect.x + rect.wide > cliprect.r then rect.wide = (cliprect.r - rect.x) + 1
if rect.y + rect.high > cliprect.b then rect.high = (cliprect.b - rect.y) + 1
if rect.x < cliprect.l then
x_start = cliprect.l - rect.x
rect.wide -= x_start
rect.x = cliprect.l
end if
if rect.y < cliprect.t then
y_start = cliprect.t - rect.y
rect.high -= y_start
rect.y = cliprect.t
end if
end sub
'Draw a transparent rectangle. 8- or 32-bit
'alpha is 0 for transparent, 1. for opaque
sub trans_rectangle(dest as Frame ptr, byval rect as RelRectType, byval col as RGBcolor, alpha as double)
'gfx_surfaceFillAlpha and frame_new_view also clip to the Frame bounds,
'but we need to clip by the cliprect anyway.
clip_rectangle_draw dest, rect
if rect.wide <= 0 orelse rect.high <= 0 then exit sub
if dest->surf then
BUG_IF(dest->surf->format <> SF_32bit, "8-bit Surface backed Frame not supported")
dim srect as SurfaceRect = (rect.x, rect.y, rect.x + rect.wide - 1, rect.y + rect.high - 1)
gfx_surfaceFillAlpha(col, alpha, @srect, dest->surf)
else
dim pal as Palette16 ptr = palette16_new_identity(256)
Palette16_mix_n_match pal, col, alpha, mixBlend
'Drawing onto the view Frame will reset the cliprect
dim saveclip as ClipState = get_cliprect()
'Draw a piece of the dest frame onto itself, effectively remapping by pal.
dim viewfr as Frame ptr = frame_new_view(dest, rect.x, rect.y, rect.wide, rect.high)
frame_draw viewfr, pal, 0, 0, NO, viewfr
frame_unload @viewfr
palette16_unload @pal
get_cliprect() = saveclip
end if
end sub
sub rectangle (x as RelPos, y as RelPos, w as RelPos, h as RelPos, c as integer, p as integer)
rectangle vpages(p), x, y, w, h, c
end sub
sub rectangle (fr as Frame Ptr, x_ as RelPos, y_ as RelPos, w_ as RelPos, h_ as RelPos, c as integer)
rectangle fr, XYWH(x_, y_, w_, h_), c
end sub
'Draw a solid rectangle (use drawbox for a hollow one)
'Top/left edges are inclusive, bottom/right are exclusive
sub rectangle (fr as Frame Ptr, byval rect as RelRectType, c as integer)
clip_rectangle_draw fr, rect
if rect.wide <= 0 orelse rect.high <= 0 then exit sub
if fr->surf then
dim srect as SurfaceRect = (rect.x, rect.y, rect.x + rect.wide - 1, rect.y + rect.high - 1)
dim col as uint32 = c
if fr->surf->format = SF_32bit then
col = curmasterpal(c).col
end if
gfx_surfaceFill(col, @srect, fr->surf)
else
dim sptr as ubyte ptr = fr->image + (rect.y * fr->pitch) + rect.x
while rect.high > 0
memset(sptr, c, rect.wide)
sptr += fr->pitch
rect.high -= 1
wend
end if
end sub
sub fuzzyrect (x as RelPos, y as RelPos, w as RelPos = rWidth, h as RelPos = rHeight, c as integer, p as integer, fuzzfactor as integer = 50, stationary as bool = NO, zoom as integer = 1, offset as integer = 0)
fuzzyrect vpages(p), XYWH(x, y, w, h), c, fuzzfactor, stationary, zoom, offset
end sub
'Draw a dithered rectangle
'Top/left edges are inclusive, bottom/right are exclusive
'stationary (originally "match_pattern"):
' By default if you draw two fuzzy rectangles touching, the patterns
' might not match up. Specify YES to force them to match up, but then
' changing x,y will not make the pattern appear to shift.
'zoom:
' Amount to scale up the pattern by (size of each pixel)
'offset:
' Used for animating scrolling patterns by offseting them; non-negative
' (see draw_background()).
sub fuzzyrect (fr as Frame Ptr, byval rect as RelRectType, c as integer, fuzzfactor as integer = 50, stationary as bool = NO, zoom as integer = 1, offset as integer = 0)
'How many magic constants could you wish for?
'These were half generated via magic formulas, and half hand picked (with magic criteria)
static grain_table(50) as integer = {_
50, 46, 42, 38, 38, 40, 41, 39, 26, 38, 30, 36, _
42, 31, 39, 38, 41, 26, 27, 28, 40, 35, 35, 31, _
39, 50, 41, 30, 29, 28, 45, 37, 24, 43, 23, 42, _
21, 28, 11, 16, 20, 22, 18, 17, 19, 32, 17, 16, _
15, 14, 50}
fuzzfactor = bound(fuzzfactor, 1, 99)
zoom = large(zoom, 1)
dim as integer x_start = 0, y_start = 0
clip_rectangle_draw fr, rect, x_start, y_start
if rect.wide <= 0 orelse rect.high <= 0 then exit sub
if stationary then
x_start = rect.x
y_start = rect.y
end if
x_start += offset
y_start += offset
dim grain as integer
if fuzzfactor <= 50 then
grain = grain_table(fuzzfactor)
else
grain = grain_table(100 - fuzzfactor)
end if
'if w = 99 then grain = h mod 100 'for hand picking
'startr is the initial value of r, multiplied by zoom, at the top-left of the rect,
'and the start of every line thereafter
dim startr as integer = 0
'These +1's are unneeded, they are only here to make the results identical to previous versions
startr = (((x_start \ zoom) + 1) * fuzzfactor + ((y_start \ zoom) + 1) * grain) mod 100
x_start = x_start mod zoom
y_start = y_start mod zoom
'Get image pointer
dim sptr as ubyte ptr
dim pitch as integer
dim pixelbytes as integer = 1
dim pixformat as SurfaceFormat
if fr->image then
sptr = fr->image
pitch = fr->pitch
pixformat = SF_8bit
elseif fr->surf then
sptr = fr->surf->pRawData
pitch = fr->surf->pitch
pixformat = fr->surf->format
if pixformat = SF_32bit then
pitch *= 4
pixelbytes = 4
c = curmasterpal(c).col
end if
else
showbug "fuzzyrect: bad dest Frame"
exit sub
end if
sptr += rect.y * pitch + rect.x * pixelbytes
while rect.high > 0
dim r as integer = startr
if r < fuzzfactor then r += 100
y_start += 1
if y_start = zoom then
startr = (startr + grain) mod 100
y_start = 0
end if
'Whether we are currently drawing, or not
dim drawpix as bool = r >= 100
if drawpix then r -= 100
'Number of times left to draw 'drawpix' on this row
dim repeats as integer = zoom - x_start
for i as integer = 0 to rect.wide - 1
if drawpix then
if pixformat = SF_8bit then
sptr[i] = c
else
cast(int32 ptr, sptr)[i] = c
end if
end if
if repeats = 1 then
'Advance to next pixel
repeats = zoom
r += fuzzfactor
drawpix = (r >= 100)
if drawpix then r -= 100
else
repeats -= 1
end if
next
rect.high -= 1
sptr += pitch
wend
end sub
'Draw a fuzzy rect over the whole clipping rect (normally, the whole screen) except for the given rectangle.
sub antifuzzyrect(fr as Frame Ptr, rect as RelRectType, col as integer, fuzzfactor as integer = 50, zoom as integer = 1)
'Top 3 ninths
fuzzyrect fr, XYWH(0, 0, 999999, rect.y), col, fuzzfactor, YES, zoom
'Left ninth
fuzzyrect fr, XYWH(0, rect.y, rect.x, rect.high), col, fuzzfactor, YES, zoom
'Right ninth
fuzzyrect fr, XYWH(rect.x + rect.wide, rect.y, 999999, rect.high), col, fuzzfactor, YES, zoom
'Bottom 3 ninths
fuzzyrect fr, XYWH(0, rect.y + rect.high, 999999, 999999), col, fuzzfactor, YES, zoom
end sub
'Draw either a rectangle or a scrolling chequer pattern.
'bgcolor is either between 0 and 255 (a colour), bgChequerScroll (a scrolling chequered
'background), or bgChequer (a non-scrolling chequered background)
'chequer_scroll is a counter variable which the calling function should increment once per tick.
'(If chequer_scroll isn't provided, than bgChequerScroll acts like bgChequer.)
'wide and high default to the whole dest Frame.
sub draw_background (dest as Frame ptr, bgcolor as bgType = bgChequerScroll, byref chequer_scroll as integer = 0, x as RelPos = 0, y as RelPos = 0, wide as RelPos = rWidth, high as RelPos = rHeight)
const zoom = 3 'Chequer pattern zoom, fixed
const rate = 4 'ticks per pixel scrolled, fixed
'static chequer_scroll as integer
'chequer_scroll = POSMOD(chequer_scroll, (zoom * rate * 6))
wide = relative_pos(wide, dest->w)
high = relative_pos(high, dest->h)
x = relative_pos(x, dest->w, wide)
y = relative_pos(y, dest->h, high)
if bgcolor >= 0 then
rectangle dest, x, y, wide, high, bgcolor
else
dim offset as integer = 0
if bgcolor = bgChequerScroll then offset = chequer_scroll \ rate
rectangle dest, XYWH(x, y, wide, high), uilook(uiBackground)
fuzzyrect dest, XYWH(x, y, wide, high), uilook(uiDisabledItem), 25, , zoom, offset
end if
end sub
sub drawline (x1 as integer, y1 as integer, x2 as integer, y2 as integer, c as integer, p as integer, dash_cycle as integer = 0, dash_len as integer = 0)
drawline vpages(p), x1, y1, x2, y2, c, dash_cycle, dash_len
end sub
'dash_cycle:
' If nonzero, draw dots/dashes. The cycle length is the number of
' pixels from the start of one dash to the next one. Should be >= 2.
'dash_len:
' Dash length in pixels. Shoudl be < dash_cycle.
sub drawline (dest as Frame ptr, x1 as integer, y1 as integer, x2 as integer, y2 as integer, c as integer, dash_cycle as integer = 0, dash_len as integer = 0)
'Uses Bresenham's algorithm
dim byref cliprect as ClipState = get_cliprect(dest)
if y1 > y2 then
'swap ends, we only draw downwards
swap y1, y2
swap x1, x2
end if
dim as integer stepX, stepY
if x2 > x1 then
stepX = 1
elseif x2 < x1 then
stepX = -1
else
stepX = 0
end if
if y2 > y1 then
stepY = 1
else
stepY = 0
end if
'If the line is mostly-horizontal, then the 'major' direction
'is X and the minor is Y.
'All the deltas are fractions of a pixel scaled to integers
'by multiplying by 2*deltaMAJOR
dim as integer deltaX, deltaY
deltax = abs(x2 - x1)
deltay = y2 - y1 'is positive due to above swap
dim as integer delta 'Accumulated fraction of a pixel error
dim as integer delta_add, delta_sub
dim as integer length, majorstep, minorstep
if deltaX > deltaY then
length = deltaX
delta_add = 2*deltaY
delta_sub = 2*deltaX
minorstep = stepY * dest->pitch
majorstep = stepX
else
length = deltaY
delta_add = 2*deltaX
delta_sub = 2*deltaY
minorstep = stepX
majorstep = stepY * dest->pitch
end if
delta = -delta_sub \ 2 'Start at the center of a pixel
/'
'Perform clipping (not correct/finished)
dim itstart as integer
if y1 < cliprect.t then
if y2 < cliprect.t then exit sub 'Ensures delta_add & delta_sub > 0
if deltaX > deltaY then
delta += (cliprect.t - y1) * delta_add
itstart = delta \ delta_add
delta = delta mod delta_sub
else
itstart = cliprect.t - y1
delta += itstart * delta_add
x1 += stepX * (delta mod delta_sub)
delta = delta mod delta_sub
if delta > 0 then
x1 += stepX
'sptr += minorstep
delta -= delta_sub
end if
end if
y1 = cliprect.t
end if
'/
dim sptr as ubyte ptr
dim sptr32 as RGBcolor ptr
dim is32bit as bool
if dest->image then
sptr = dest->image + (y1 * dest->pitch) + x1
is32bit = NO
elseif dest->surf then
ERROR_IF(dest->surf->format <> SF_32bit, "surf not 32bit")
ERROR_IF(dest->surf->pitch <> dest->pitch, "mismatched pitch")
sptr32 = dest->surf->pColorData + (y1 * dest->surf->pitch) + x1
sptr = cast(ubyte ptr, sptr32)
minorstep *= 4
majorstep *= 4
c = curmasterpal(c).col
is32bit = YES
else
showbug "drawline: bad Frame"
exit sub
end if
dim dash_accum as integer
for it as integer = 0 to length
if POINT_CLIPPED(x1, y1) = NO then
if dash_cycle = 0 then
if is32bit then
*cast(integer ptr, sptr) = c
else
*sptr = c
end if
else
if dash_accum < dash_len then
if is32bit then
*cast(integer ptr, sptr) = c
else
*sptr = c
end if
end if
dash_accum += 1
if dash_accum = dash_cycle then dash_accum = 0
end if
end if
delta += delta_add
if delta > 0 then
sptr += minorstep
delta -= delta_sub
if deltaX > deltaY then y1 += stepY else x1 += stepX
end if
sptr += majorstep
if deltaX > deltaY then x1 += stepX else y1 += stepY
next
end sub
sub paintat (dest as Frame ptr, x as integer, y as integer, c as integer)
'a floodfill.
dim tcol as integer
dim queue as XYPair_node ptr = null
dim tail as XYPair_node ptr = null
dim as integer w, e 'x coords west and east
dim i as integer
dim tnode as XYPair_node ptr = null
CHECK_FRAME_8BIT(dest)
dim byref cliprect as ClipState = get_cliprect(dest)
if POINT_CLIPPED(x, y) then exit sub
tcol = readpixel(dest, x, y) 'get target colour
'prevent infinite loop if you fill with the same colour
if tcol = c then exit sub
queue = callocate(sizeof(XYPair_node))
queue->x = x
queue->y = y
queue->nextnode = null
tail = queue
'we only let coordinates within the clip bounds get onto the queue, so there's no need to check them
do
if FRAMEPIXEL(queue->x, queue->y, dest) = tcol then
FRAMEPIXEL(queue->x, queue->y, dest) = c
w = queue->x
e = queue->x
'find western limit
while w > cliprect.l and FRAMEPIXEL(w-1, queue->y, dest) = tcol
w -= 1
FRAMEPIXEL(w, queue->y, dest) = c
wend
'find eastern limit
while e < cliprect.r and FRAMEPIXEL(e+1, queue->y, dest) = tcol
e += 1
FRAMEPIXEL(e, queue->y, dest) = c
wend
'add bordering XYPair_nodes
for i = w to e
if queue->y > cliprect.t then
'north
if FRAMEPIXEL(i, queue->y-1, dest) = tcol then
tail->nextnode = callocate(sizeof(XYPair_node))
tail = tail->nextnode
tail->x = i
tail->y = queue->y-1
tail->nextnode = null
end if
end if
if queue->y < cliprect.b then
'south
if FRAMEPIXEL(i, queue->y+1, dest) = tcol then
tail->nextnode = callocate(sizeof(XYPair_node))
tail = tail->nextnode
tail->x = i
tail->y = queue->y+1
tail->nextnode = null
end if
end if
next
end if
'advance queue pointer, and delete behind us
tnode = queue
queue = queue->nextnode
deallocate(tnode)
loop while queue <> null
'should only exit when queue has caught up with tail
end sub
sub ellipse (fr as Frame ptr, x as double, y as double, radius as double, col as integer, fillcol as integer = -1, semiminor as double = 0.0, angle as double = 0.0)
'radius is the semimajor axis if the ellipse is not a circle
'angle is the angle of the semimajor axis to the x axis, in radians counter-clockwise
if fr->surf andalso fr->surf->format = SF_32bit then
'putpixel takes BGRA, not master palette index
col = curmasterpal(col).col
if fillcol <> -1 then
fillcol = curmasterpal(fillcol).col
end if
end if
dim byref cliprect as ClipState = get_cliprect(fr)
'x,y is the pixel to centre the ellipse at - that is, the centre of that pixel, so add half a pixel to
'radius to put the perimeter halfway between two pixels
x += 0.5
y += 0.5
radius += 0.5
if semiminor = 0.0 then
semiminor = radius
else
semiminor += 0.5
end if
dim as double ypart
ypart = fmod(y, 1.0) - 0.5 'Here we add in the fact that we test for intercepts with a line offset 0.5 pixels
dim as double sin_2, cos_2, sincos
sin_2 = sin(-angle) ^ 2
cos_2 = cos(-angle) ^ 2
sincos = sin(-angle) * cos(-angle)
'Coefficients of the general conic quadratic equation Ax^2 + Bxy + Cy^2 + Dx + Ey + F = 0 (D,E = 0)
'Aprime, Cprime are of the unrotated version
dim as double Aprime, Cprime
Aprime = 1.0 / radius ^ 2
Cprime = 1.0 / semiminor ^ 2
dim as double A, B, C, F
A = Aprime * cos_2 + Cprime * sin_2
B = 2 * (Cprime - Aprime) * sincos
C = Aprime * sin_2 + Cprime * cos_2
F = -1.0
dim as integer xstart = 999999999, xend = -999999999, lastxstart = 999999999, lastxend = -999999999, xs, yi, ys, maxr = large(radius, semiminor) + 1
for yi = maxr to -maxr step -1
'Note yi is cartesian coordinates, with the centre of the ellipsis at the origin, NOT screen coordinates!
'xs, ys are in screen coordinates
ys = int(y) - yi
if ys < cliprect.t - 1 or ys > cliprect.b + 1 then continue for
'Fix y (scanline) and solve for x using quadratic formula (coefficients:)
dim as double qf_a, qf_b, qf_c
qf_a = A
qf_b = B * (yi + ypart)
qf_c = C * (yi + ypart) ^ 2 + F
dim as double discrim
discrim = qf_b^2 - 4.0 * qf_a * qf_c
if discrim >= 0.0 then
discrim = sqr(discrim)
'This algorithm is very sensitive to which way XXX.5 is rounded (normally towards even)...
xstart = -int(-(x + (-qf_b - discrim) / (2.0 * qf_a) - 0.5)) 'ceil(x-0.5), ie. round 0.5 down
xend = int(x + (-qf_b + discrim) / (2.0 * qf_a) - 0.5) 'floor(x-0.5), ie. round 0.5 up, and subtract 1
if xstart > xend then 'No pixel centres on this scanline lie inside the ellipse
if lastxstart <> 999999999 then
xend = xstart 'We've already started drawing, so must draw at least one pixel
end if
end if
end if
'Reconsider the previous scanline
for xs = lastxstart to xstart - 1
putpixel(fr, xs, ys - 1, col)
next
for xs = xend + 1 to lastxend
putpixel(fr, xs, ys - 1, col)
next
dim canskip as bool = YES
for xs = xstart to xend
putpixel(fr, xs, ys, col)
if canskip andalso xs >= lastxstart - 1 then
'Draw the bare minimum number of pixels (some of these might be needed, but won't know until next scanline)
dim jumpto as integer = small(xend - 1, lastxend)
if fillcol <> -1 then
for xs = xs + 1 to jumpto
putpixel(fr, xs, ys, fillcol)
next
end if
xs = jumpto
canskip = NO 'Skipping more than once causes infinite loops
end if
next
lastxstart = xstart
lastxend = xend
if discrim >= 0 then xend = xstart - 1 'To draw the last scanline, in the next loop
next
end sub
'==========================================================================================
' Palette manipulation
'==========================================================================================
'Replaces one colour with another, OR if swapcols is true, swaps the two colours.
sub replacecolor (fr as Frame ptr, c_old as integer, c_new as integer, swapcols as bool = NO)
CHECK_FRAME_8BIT(fr)
dim byref cliprect as ClipState = get_cliprect(fr)
for yi as integer = cliprect.t to cliprect.b
dim sptr as ubyte ptr = fr->image + (yi * fr->pitch)
for xi as integer = cliprect.l to cliprect.r
if sptr[xi] = c_old then
sptr[xi] = c_new
elseif swapcols and (sptr[xi] = c_new) then
sptr[xi] = c_old
end if
next
next
end sub
sub swapcolors(fr as Frame ptr, col1 as integer, col2 as integer)
replacecolor fr, col1, col2, YES
end sub
'Changes a Frame in-place, applying a remapping
sub remap_to_palette (fr as Frame ptr, pal as Palette16 ptr)
CHECK_FRAME_8BIT(fr)
dim byref cliprect as ClipState = get_cliprect(fr)
for y as integer = cliprect.t to cliprect.b
for x as integer = cliprect.l to cliprect.r
FRAMEPIXEL(x, y, fr) = pal->col(FRAMEPIXEL(x, y, fr))
next
next
end sub
sub remap_to_palette (fr as Frame ptr, palmapping() as integer)
dim pal as Palette16 ptr = Palette16_new_from_indices(palmapping())
remap_to_palette fr, pal
Palette16_unload @pal
end sub
' Count the number of occurrences of a color in a Frame (just the clipped region)
function countcolor (fr as Frame ptr, col as integer) as integer
CHECK_FRAME_8BIT(fr, 0)
dim byref cliprect as ClipState = get_cliprect(fr)
dim ret as integer = 0
for yi as integer = cliprect.t to cliprect.b
for xi as integer = cliprect.l to cliprect.r
if FRAMEPIXEL(xi, yi, fr) = col then ret += 1
next
next
return ret
end function
'Loads into pal() a 256-color palette from a 16x16 image (normally 24/32-bit)
'so, pixel (0,0) holds colour 0, (0,1) has colour 16, and (15,15) has colour 255
sub palette_from_16x16_image (filename as string, pal() as RGBcolor)
dim surf as Surface ptr
surf = image_import_as_surface(filename, YES)
if surf = 0 then exit sub
if surf->width <> 16 or surf->height <> 16 then
showerror "Can't load palette from " & filename & ": not 16x16"
else
dim idx as integer
for y as integer = 0 to 15
for x as integer = 0 to 15
pal(idx) = surf->pColorData[x + y * surf->pitch]
idx += 1
next
next
end if
gfx_surfaceDestroy(@surf)
end sub
'==========================================================================================
' Text routines
'==========================================================================================
#define TEXTDBG(message) if state.debug then ? message
function get_font(fontnum as integer, show_err as bool = NO) as Font ptr
if fontnum < 0 orelse fontnum > ubound(fonts) orelse fonts(fontnum) = null then
if show_err then
showbug "invalid font num " & fontnum
end if
return fonts(0)
else
return fonts(fontnum)
end if
end function
'Parses a code like ${Foo123} into action (eg 'FOO') and arg (eg 123) and find closing }.
'Pass a string, a 0-based offset of the start of the contents (eg. after "${"),
'and action and arg pointer, to fill with the parse results. (Action in UPPERCASE)
'Returns 0 for an invalidly formed tag, otherwise the (0-based) offset of the closing }.
function parse_tag(z as string, offset as integer, byref action as string, arg as int32 ptr) as integer
dim closebrace as integer = instr((offset + 2) + 1, z, "}") - 1
if closebrace <> -1 then
z[closebrace] = 0
dim ret as bool = split_str_int(@z[offset], action, *arg)
z[closebrace] = asc("}")
action = ucase(action)
if ret then return closebrace
end if
return 0
end function
'Used for iterating over the valid text markup tags (e.g. "${K4}") in a string.
'Considers markup valid only when render_text would (ignores ones with invalid parameters and embed codes).
'offset is input/output, tagend is output.
'On the first call, pass in offset = 1 (it's a 1-based position).
'If there is another tag at or after offset, returns true and sets offset to the
'start of the tag and tagend to one past end (1-based).
'Returns false when no more, and doesn't set offset/tagend.
function next_text_markup(text as string, byref offset as integer, byref tagend as integer) as bool
while offset <= len(text) - 3
if text[offset - 1] = asc("$") andalso text[offset] = asc("{") then
dim action as string
dim intarg as int32
tagend = parse_tag(text, (offset - 1) + 2, action, @intarg)
debug "at " & offset & " tagend " & (tagend + 1)
if tagend = 0 then return NO
tagend += 2 'Convert from 0- to 1-based index, and move 1 past closing }
dim ok as bool = NO
if action = "F" then 'Font
'Assume won't have null ptrs in font()
ok = (intarg >= -1 andalso intarg <= ubound(fonts))
elseif action = "K" then 'Foreground colour
ok = (intarg <= 255)
elseif action = "KI" then 'Permanent foreground colour change
ok = (intarg >= 0 andalso intarg <= 255)
elseif action = "KB" then 'Background colour
ok = (intarg <= 255)
elseif action = "KP" then 'Font palette
ok = (intarg >= 0 andalso intarg <= gen(genMaxPal))
elseif action = "LM" then
ok = YES
elseif action = "RM" then
ok = YES
end if
if ok then return YES
offset = tagend
continue while
end if
offset += 1
wend
return NO
end function
'FIXME: refactor, making use of OO which we can now use
type PrintStrState
'Public members (may set before passing to render_text)
as Font ptr thefont
as long fgcolor 'Used when resetting localpal. May be -1 for none
as long bgcolor 'Only used if not_transparent
as bool not_transparent 'Force non-transparency of layer 1
'as bool debug 'Print debug statements (also need to uncomment this and TEXTDBG lines)
'Internal members
as Font ptr initial_font 'Used when resetting thefont
as long leftmargin
as long rightmargin
union
as XYPair pos
type
as long x, y
end type
end union
as long startx
as long charnum
'Internal members used only if drawing, as opposed to laying out/measuring
as Palette16 ptr localpal 'NULL if not initialised
as long initial_fgcolor 'Used when resetting fgcolor
as long initial_bgcolor 'Used when resetting bgcolor
as bool initial_not_trans 'Used when resetting bgcolor
declare constructor()
declare constructor(rhs as PrintStrState)
declare destructor()
declare sub duplicate_from(rhs as PrintStrState)
end type
' Need a default ctor just because there is a copy ctor
constructor PrintStrState()
end constructor
constructor PrintStrState(rhs as PrintStrState)
memcpy(@this, @rhs, sizeof(PrintStrState))
if localpal then
this.localpal->refcount += 1
end if
end constructor
'Unlike the copy ctor, this duplicates the palette instead of incrementing refcount.
sub PrintStrState.duplicate_from(rhs as PrintStrState)
memcpy(@this, @rhs, sizeof(PrintStrState))
if localpal then
this.localpal = Palette16_duplicate(rhs.localpal)
end if
end sub
destructor PrintStrState()
Palette16_unload @localpal
end destructor
'Special signalling characters
#define tcmdFirst 15
#define tcmdState 15 'Special argument format (6 bytes)
'All following tcmds must have one argument
#define tcmdPalette 16 '1 argument
#define tcmdFont 17 '1 argument: the font number (possibly -1)
#define tcmdLastWithArg 17
'All following tcmds must have zero arguments
#define tcmdRepalette 18 'Call build_text_palette
#define tcmdLast 18
'Invisible argument: state. (member should not be . prefixed, unfortunately)
'Modifies state, and appends a control sequence to the string outbuf to duplicate the change
'Note: in order to support members that are less than 4 bytes (eg palette colours) some hackery is done, and
'members greater than 4 bytes aren't supported
#macro UPDATE_STATE(outbuf, member, value)
'Ugh! FB doesn't allow sizeof in #if conditions!
#if typeof(state.member) <> integer and typeof(state.member) <> long
#error "UPDATE_STATE: bad member type"
#endif
outbuf += CHR(tcmdState) & " "
*Cast(short ptr, @outbuf[len(outbuf) - 6]) = Offsetof(PrintStrState, member)
*Cast(long ptr, @outbuf[len(outbuf) - 4]) = Cast(long, value)
state.member = value
#endmacro
'Interprets a control sequence (at 0-based offset ch in outbuf) written by UPDATE_STATE,
'modifying a member of state.
#define READ_MEMBER(state, outbuf, ch) _
/' dim offset as long = *Cast(short ptr, @outbuf[ch + 1]) '/ _
/' dim newval as long = *Cast(long ptr, @outbuf[ch + 3]) '/ _
*Cast(long ptr, Cast(byte ptr, @state) + *Cast(short ptr, @outbuf[ch + 1])) = _
*Cast(long ptr, @outbuf[ch + 3]) : _
ch += 6 '7 bytes in total, assume inside FOR loop that increments ch
#define APPEND_CMD0(outbuf, cmd_id) _
outbuf += CHR(cmd_id)
#define APPEND_CMD1(outbuf, cmd_id, value) _
outbuf += CHR(cmd_id) & " " : _
*Cast(long ptr, @outbuf[len(outbuf) - 4]) = Cast(long, value)
#define READ_VALUE(variable, outbuf, ch) _
variable = *Cast(long ptr, @outbuf[ch + 1]) : _
ch += 4 '5 bytes in total, assume inside FOR loop that increments ch
'Processes starting from z[state.charnum] until the end of the line, returning a string
'which describes a line fragment. It contains printing characters plus command sequences
'for modifying state. state is passed byval (upon wrapping we would have to undo changes
'to the state, which is too hard).
'endchar is 0 based, and exclusive - normally len(z). FIXME: endchar appears broken
'We also compute the line_height (height of the tallest font on the line) and the line_width
'of the line fragment. You have to know the line height before you can know the y
'coordinate of each character on the line.
'Updates to .x, .y are not written because they can be recreated from the character stream,
'nor is .charnum for printing characters (unless updatecharnum is true) because it's too
'expensive. However, .x, .y and .charnum are updated at the end.
'If updatecharnum is true, it is updated only when .charnum jumps; you still need to
'increment after every printing character yourself.
local function layout_line_fragment(z as string, endchar as integer, byval state as PrintStrState, byref line_width as integer, byref line_height as integer, wide as integer, withtags as bool, withnewlines as bool, updatecharnum as bool = NO) as string
dim lastspace as integer = -1
dim lastspace_x as integer
dim lastspace_outbuf_len as integer
dim lastspace_line_height as integer
dim endchar_x as integer 'state.x at endchar
dim endchar_outbuf_len as integer = 999999 'Length of outbuf at endchar
dim ch as integer 'We use this instead of modifying .charnum
dim visible_chars as integer 'Number non-control chars we will return
dim outbuf as string
'Appending characters one at a time to outbuf is slow, so we delay it.
'chars_to_add counts the number of delayed characters
dim chars_to_add as integer = 0
'Avoid overflow
if state.rightmargin = INT_MAX then state.rightmargin = 999999
with state
'TEXTDBG("layout '" & z & "' from " & .charnum & " at " & .x & "," & .y)
line_height = .thefont->line_h
for ch = .charnum to len(z) - 1
'We keep going past endchar until the end of the line, to figure out where to linebreak
if ch >= endchar andalso endchar_outbuf_len = 999999 then
'If the final character is a newline (and maybe other cases?), or if endchar
'isn't len(z), then we need to record this.
'We might skip over ch = endchar because it's in the middle of markup.
'TEXTDBG("hit endchar, x=" & .x)
endchar_x = .x
endchar_outbuf_len = len(outbuf) + chars_to_add
end if
if z[ch] = 10 and withnewlines then 'newline
'TEXTDBG("add " & chars_to_add & " chars before " & ch & " : '" & Mid(z, 1 + ch - chars_to_add, chars_to_add) & "'")
outbuf += Mid(z, 1 + ch - chars_to_add, chars_to_add)
chars_to_add = 0
'Skip past the newline character, but don't add to outbuf
ch += 1
if ch - 1 >= endchar then
'FIXME: If the final character is a newline, we don't add a blank line.
'But text slices do! We should probably do the same here, e.g. removing
'this if block (and much more work).
'However, it's difficult to change that, due to other functions depending
'this one.
'FIXME: On the other hand when wrapping with wide=8, currently we will add
'a blank line every time we encounter a space, but text slices don't! We
'shouldn't add spaces.
outbuf = left(outbuf, endchar_outbuf_len)
line_width = endchar_x
UPDATE_STATE(outbuf, x, endchar_x)
else
line_width = .x
UPDATE_STATE(outbuf, x, .startx)
end if
'Purposefully past endchar
UPDATE_STATE(outbuf, charnum, ch)
'Reset margins for next paragraph? No.
'UPDATE_STATE(outbuf, leftmargin, 0)
'UPDATE_STATE(outbuf, rightmargin, wide)
return outbuf
elseif z[ch] = 8 then ' ^H, hide tag
if z[ch + 1] = asc("{") then
dim closebrace as integer = instr((ch + 2) + 1, z, "}") - 1
if closebrace <> -1 then
'Add delayed characters first
'TEXTDBG("add " & chars_to_add & " chars before " & ch & " : '" & Mid(z, 1 + ch - chars_to_add, chars_to_add) & "'")
outbuf += Mid(z, 1 + ch - chars_to_add, chars_to_add)
chars_to_add = 0
ch = closebrace
if updatecharnum then
UPDATE_STATE(outbuf, charnum, ch + 1)
end if
continue for
end if
end if
elseif z[ch] >= tcmdFirst and z[ch] <= tcmdLast then ' special signalling characters. Not allowed! (FIXME: delete this)
'TEXTDBG("add " & chars_to_add & " chars before " & ch & " : '" & Mid(z, 1 + ch - chars_to_add, chars_to_add) & "'")
outbuf += Mid(z, 1 + ch - chars_to_add, chars_to_add)
chars_to_add = 0
ch += 1 'skip
if updatecharnum then
UPDATE_STATE(outbuf, charnum, ch + 1)
end if
continue for
elseif z[ch] = asc("$") then
if withtags and z[ch + 1] = asc("{") then
dim action as string
dim intarg as int32
dim closebrace as integer = parse_tag(z, ch + 2, action, @intarg)
if closebrace then
'Add delayed characters first
'TEXTDBG("add " & chars_to_add & " chars before " & ch & " : '" & Mid(z, 1 + ch - chars_to_add, chars_to_add) & "'")
outbuf += Mid(z, 1 + ch - chars_to_add, chars_to_add)
chars_to_add = 0
if action = "F" then
'Font
'Let's preserve the position offset when changing fonts. That way, plain text in
'the middle of edgetext is also offset +1,+1, so that it lines up visually with it
'.pos += fonts(intarg)->offset - .thefont->offset
if intarg >= -1 andalso intarg <= ubound(fonts) then
if intarg = -1 then
'UPDATE_STATE(outbuf, thefont, .initial_font)
.thefont = .initial_font
elseif fonts(intarg) then
'UPDATE_STATE(outbuf, thefont, fonts(intarg))
.thefont = fonts(intarg)
else
goto badtexttag
end if
APPEND_CMD1(outbuf, tcmdFont, intarg)
line_height = large(line_height, .thefont->line_h)
else
goto badtexttag
end if
elseif action = "K" then
'Foreground colour
dim col as integer
if intarg <= -1 then
col = .initial_fgcolor
elseif intarg <= 255 THEN
col = intarg
else
goto badtexttag
end if
'UPDATE_STATE(outbuf, localpal.col(1), col)
UPDATE_STATE(outbuf, fgcolor, col)
APPEND_CMD0(outbuf, tcmdRepalette)
'No need to update localpal here by calling build_text_palette
elseif action = "KI" then
'Permanent foreground colour change
if intarg < 0 orelse intarg > 255 then
goto badtexttag
end if
'UPDATE_STATE(outbuf, localpal.col(1), intarg)
UPDATE_STATE(outbuf, fgcolor, intarg)
UPDATE_STATE(outbuf, initial_fgcolor, intarg)
APPEND_CMD0(outbuf, tcmdRepalette)
'No need to update localpal here by calling build_text_palette
elseif action = "KB" then
'Background colour
dim col as integer
if intarg <= -1 then
col = .initial_bgcolor
if .not_transparent <> .initial_not_trans then
UPDATE_STATE(outbuf, not_transparent, .initial_not_trans)
end if
elseif intarg <= 255 THEN
col = intarg
if .not_transparent = NO then
UPDATE_STATE(outbuf, not_transparent, YES)
end if
else
goto badtexttag
end if
'UPDATE_STATE(outbuf, localpal.col(0), col)
UPDATE_STATE(outbuf, bgcolor, col)
APPEND_CMD0(outbuf, tcmdRepalette)
'No need to update localpal here by calling build_text_palette
elseif action = "KP" then
'Font palette
if intarg >= 0 and intarg <= gen(genMaxPal) then
APPEND_CMD1(outbuf, tcmdPalette, intarg)
'No need up update palette or fgcolor here
'(don't want to duplicate that logic here)
else
goto badtexttag
end if
elseif action = "LM" then
UPDATE_STATE(outbuf, leftmargin, intarg)
elseif action = "RM" then
UPDATE_STATE(outbuf, rightmargin, wide - intarg)
else
goto badtexttag
end if
ch = closebrace
if updatecharnum then
UPDATE_STATE(outbuf, charnum, ch + 1)
end if
continue for
end if
badtexttag:
end if
elseif z[ch] = asc(" ") then
lastspace = ch
lastspace_outbuf_len = len(outbuf) + chars_to_add
lastspace_x = .x
lastspace_line_height = line_height
end if
.x += .thefont->w(z[ch])
if .x > .startx + .rightmargin then
'TEXTDBG("rm = " & .rightmargin & " lm = " & .leftmargin)
if lastspace > -1 and .x - lastspace_x < 3 * (.rightmargin - .leftmargin) \ 5 then
'Split at the last space
if chars_to_add then
'TEXTDBG("add " & chars_to_add & " chars before " & ch & " : '" & Mid(z, 1 + ch - chars_to_add, chars_to_add) & "'")
outbuf += Mid(z, 1 + ch - chars_to_add, chars_to_add)
end if
outbuf = left(outbuf, small(endchar_outbuf_len, lastspace_outbuf_len))
if lastspace < endchar then
line_width = lastspace_x
UPDATE_STATE(outbuf, x, .startx + .leftmargin)
else
line_width = endchar_x
end if
line_height = lastspace_line_height
UPDATE_STATE(outbuf, charnum, lastspace + 1)
return outbuf
else
'Split the word instead, it would just look ugly to break the line
if visible_chars = 0 then
'Always output at least one character
chars_to_add += 1
ch += 1
end if
exit for
end if
end if
'Add this character to outbuf. But not immediately.
chars_to_add += 1
visible_chars += 1
next
'Hit end of text, or splitting word
if chars_to_add then
'TEXTDBG("add " & chars_to_add & " chars before " & ch & " : '" & Mid(z, 1 + ch - chars_to_add, chars_to_add) & "'")
outbuf += Mid(z, 1 + ch - chars_to_add, chars_to_add)
end if
'Set final x and charnum, and trim off outbuf anything parsed after endchar
if endchar_outbuf_len = 999999 then 'ch <= endchar then
'Didn't reach endchar
'TEXTDBG("exiting layout_line_fragment, ch = " & ch & ", .x = " & .x)
line_width = .x
UPDATE_STATE(outbuf, x, .startx + .leftmargin)
else
'Reached endchar and continued
'TEXTDBG("exiting layout_line_fragment, ch = " & ch & ", endchar_x = " & endchar_x)
outbuf = left(outbuf, endchar_outbuf_len)
line_width = endchar_x
UPDATE_STATE(outbuf, x, endchar_x)
end if
UPDATE_STATE(outbuf, charnum, ch)
'Preserve .leftmargin and .rightmargin
return outbuf
end with
end function
'Build state.localpal
sub build_text_palette(byref state as PrintStrState, srcpal as Palette16 ptr)
with state
if state.localpal = NULL then
state.localpal = Palette16_new()
end if
if srcpal then
memcpy(@.localpal->col(0), @srcpal->col(0), srcpal->numcolors)
.localpal->numcolors = srcpal->numcolors
end if
.localpal->col(0) = .bgcolor
if .fgcolor > -1 then
.localpal->col(1) = .fgcolor
end if
if srcpal = NULL and .fgcolor = -1 then
debug "render_text: Drawing a font without a palette or foreground colour!"
end if
'TEXTDBG("build_text_palette: bg = " & .bgcolor & " fg = "& .fgcolor & " outline = " & .thefont->outline_col)
'Outline colours are a hack, hopefully temp.
if .thefont->outline_col > 0 then
.localpal->col(.thefont->outline_col) = uilook(uiOutline)
end if
end with
end sub
'Processes a parsed line, updating the state passed to it, and also optionally draws one of the layers (if reallydraw)
sub draw_line_fragment(dest as Frame ptr, byref state as PrintStrState, layer as integer, parsed_line as string, reallydraw as bool)
dim arg as integer
dim as Frame charframe
charframe.mask = NULL
charframe.refcount = NOREFC
dim byref cliprect as ClipState = get_cliprect()
with state
'TEXTDBG("draw frag: x=" & .x & " y=" & .y & " char=" & .charnum & " reallydraw=" & reallydraw & " layer=" & layer)
for ch as integer = 0 to len(parsed_line) - 1
if parsed_line[ch] = tcmdState then
'Control sequence. Make a change to state, and move ch past the sequence
READ_MEMBER(state, parsed_line, ch)
elseif parsed_line[ch] = tcmdFont then
READ_VALUE(arg, parsed_line, ch)
if arg >= -1 andalso arg <= ubound(fonts) then
if arg = -1 then
'UPDATE_STATE(outbuf, thefont, .initial_font)
.thefont = .initial_font
elseif fonts(arg) then
'UPDATE_STATE(outbuf, thefont, fonts(arg))
.thefont = fonts(arg)
else
'This should be impossible, because layout_line_fragment has already checked this
showbug "draw_line_fragment: NULL font!"
end if
else
'This should be impossible, because layout_line_fragment has already checked this
showbug "draw_line_fragment: invalid font!"
end if
if reallydraw then
'In case .fgcolor == -1 and .thefont->pal == NULL. Palette changes are per-font,
'so reset the colour.
if .fgcolor = -1 then .fgcolor = .initial_fgcolor
'We rebuild the local palette using either the font's palette or from scratch
build_text_palette state, .thefont->pal
end if
elseif parsed_line[ch] = tcmdPalette then
READ_VALUE(arg, parsed_line, ch)
if reallydraw then
dim pal as Palette16 ptr
pal = Palette16_load(arg)
if pal then
'Palettes override the foreground colour (but not background or outline)
.fgcolor = -1
build_text_palette state, pal
Palette16_unload @pal
end if
'FIXME: in fact pal should be kept around, for tcmdRepalette
end if
elseif parsed_line[ch] = tcmdRepalette then
if reallydraw then
'FIXME: if we want to support switching to a non-font palette, then
'that palette should be stored in state and used here
build_text_palette state, .thefont->pal
end if
else
'Draw a character
'Fun hack! Console support
if layer = 1 and gfx_printchar <> NULL then
gfx_printchar(parsed_line[ch], .x, .y, .fgcolor)
end if
'Print one character past the end of the line
if reallydraw and .x <= cliprect.r then
if .thefont->layers(layer) <> NULL then
with .thefont->layers(layer)->chdata(parsed_line[ch])
charframe.image = state.thefont->layers(layer)->spr->image + .offset
charframe.w = .w
charframe.h = .h
charframe.pitch = .w
'debug " <" & (state.x + .offx) & "," & (state.y + .offy) & ">"
dim trans as bool = YES
'FIXME: why do we only allow 1-layer fonts to be non transparent?
'(2-layer fonts would need layer 0 to be opaque)
'ALSO, this would stuff up ${KB#} on 2-layer fonts
if layer = 1 and state.not_transparent then trans = NO
frame_draw_internal(@charframe, curmasterpal(), state.localpal, state.x + .offx, state.y + .offy - state.thefont->line_h, trans, dest)
end with
end if
end if
'Note: do not use charframe.w, that's just the width of the sprite
.x += .thefont->w(parsed_line[ch])
end if
next
end with
end sub
'Draw a string. You will normally want to use one of the friendlier overloads for this,
'probably the most complicated function in the engine.
'
'Arguments:
'
'Pass in a reference to a (fresh!!) PrintStrState object with .thefont and .fgcolor set
'.fgcolor can be -1 for no colour (just use font palette).
'.not_transparent and .bgcolor (only used if .not_transparent) may also be set
'
'At least one of <s>pal and</s> the (current) font pal and .fgcolor must be not NULL/-1.
'This can be ensured by starting with either a palette or a .fgcolor!=-1
'FIXME: pal is currently disabled; palette handling needs rewriting.
'
'endchar shouldn't be used; currently broken?
'
'If withtags is false then no tags are processed.
'If withtags is true, the follow "basic texttags" are processed:
' (These will change!)
'-${F#} changes to font # or return to initial font if # == -1
'-${K#} changes foreground/first colour, or return to initial colour if # == -1
' (Note that this does disable the foreground colour, unless the initial fg colour was -1!)
'-${KI#} changes foreground colour and makes it the new initial colour
' (This is a kludge until we have a stack of active tags)
'-${KB#} changes the background colour, and turns on not_transparent.
' Specify -1 to restore previous background colour and transparency
' FIXME: ${KB0} does NOT switch to transparency, but an initial bgcol of 0 IS transparent!
'-${KP#} changes to palette # (-1 is invalid) (Maybe should make ${F-1} return to the default)
' (Note, palette changes are per-font, and expire when the font changes)
'-${LM#} sets left margin for the current line, in pixels
'-${RM#} sets right margin for the current line, in pixels
'Purposefully no way to set background colour.
'Unrecognised and invalid basic texttags are printed as normal.
'ASCII character 8 can be used to hide texttags by overwriting the $, like so: \008{X#}
'
'Clipping and wrapping:
'If you specify a page width (the default is "infinite"), then text automatically wraps according
'to current margins. Otherwise there is no limit on the right (not even the edge of the screen).
'xpos is the left limit, and xpos+wide is the right limit from which margins are measured (inwards).
'Drawn text is NOT clipped to this region, use setclip or frame_new_view for that.
'This region may be larger than the clip area.
'If withnewlines is true, then newlines (ASCII character 10) are respected
'instead of printed as normal characters.
'
'If you want to skip some number of lines, you should clip, and draw some number of pixels
'above the clipping rectangle.
'
sub render_text (dest as Frame ptr, byref state as PrintStrState, text as string, endchar as integer = 999999, xpos as RelPos, ypos as RelPos, wide as RelPos = 999999, pal as Palette16 ptr = NULL, withtags as bool = YES, withnewlines as bool = YES)
', cached_state as PrintStrStatePtr = NULL, use_cached_state as bool = YES)
'static tog as integer = 0
'tog xor= 1
'dim t as double = timer
BUG_IF(dest = null, "NULL dest")
dim byref cliprect as ClipState = get_cliprect(dest)
'check bounds skipped because this is now quite hard to tell (checked in draw_clipped)
'TEXTDBG("printstr '" & text & "' (len=" & len(text) & ") wide = " & wide & " tags=" & withtags & " nl=" & withnewlines)
wide = relative_pos(wide, dest->w)
' Only pre-compute the text dimensions if required for anchoring, as it's quite expensive
dim as AlignType xanchor, yanchor, xshow, yshow
RelPos_decode xpos, 0, 0, xanchor, xshow
RelPos_decode ypos, 0, 0, yanchor, yshow
dim finalsize as StringSize
if xanchor <> alignLeft or yanchor <> alignLeft or xshow <> alignCenter or yshow <> alignCenter then
text_layout_dimensions @finalsize, text, endchar, , wide, state.thefont, withtags, withnewlines
end if
with state
/'
if cached_state <> NULL and use_cached_state then
state = *cached_state
cached_state = NULL
else
'/
'if pal then
' build_text_palette state, pal
'else
build_text_palette state, .thefont->pal
'end if
.initial_font = .thefont
.initial_fgcolor = .fgcolor
.initial_bgcolor = .bgcolor
.initial_not_trans = .not_transparent
.charnum = 0
.pos = relative_pos(XY(xpos, ypos), dest->size, finalsize.size) + .thefont->offset
.startx = .x
'Margins are measured relative to xpos
.leftmargin = 0
.rightmargin = wide
'end if
dim as bool visibleline 'Draw this line of text?
'We have to process both layers, even if the current font has only one layer,
'in case the string switches to a font that has two!
'That's why we use two copies of state.
'Make sure to use a separate Palette16.
dim prev_state as PrintStrState
prev_state.duplicate_from(state)
dim prev_parse as string
dim prev_visible as bool
dim draw_layer1 as bool = NO 'Don't draw on first loop
if endchar > len(text) then endchar = len(text)
do
dim line_height as integer
dim parsed_line as string = layout_line_fragment(text, endchar, state, 0, line_height, wide, withtags, withnewlines)
'TEXTDBG("parsed: " + parsed_line)
'Print at least one extra line above and below the visible region, in case the
'characters are big (we only approximate this policy, with the current font height)
visibleline = (.y + line_height > cliprect.t - .thefont->char_h AND .y < cliprect.b + .thefont->char_h)
'if tog then visibleline = NO
'debug "vis: " & visibleline
'FIXME: state caching was meant to kick in after the first visible line of text, not here;
'however need to rethink how it should work
/'
if cached_state then
*cached_state = state
cached_state = NULL 'Don't save again
end if
'/
.y += line_height
'Update state while drawing layer 0 (if visible)
draw_line_fragment(dest, state, 0, parsed_line, visibleline)
if draw_layer1 then
'Now update prev_state (to the beginning of THIS line) while drawing layer 1
'for the previous line. Afterwards, prev_state will be identical to state
'as it was at the start of this loop.
draw_line_fragment(dest, prev_state, 1, prev_parse, prev_visible)
'TEXTDBG("prev.charnum=" & prev_state.charnum)
if prev_state.charnum >= endchar then /'debug "text end" :'/ exit do
if prev_state.y > cliprect.b + prev_state.thefont->char_h then exit do
end if
draw_layer1 = YES
prev_parse = parsed_line
prev_visible = visibleline
prev_state.y += line_height
loop
end with
't = timer - t
'debug "prinstr" & tog & " len " & len(text) & " in " & t*1000 & "ms"
end sub
'Calculate size of part of a block of text when drawn, returned in retsize
'endchar and endline can be used to trim the string.
'endchar is the number of chars (bytes), not a 1-based string position!
'NOTE: Edged font has width 1 pixel more than Plain font, due to .offset.x.
sub text_layout_dimensions (retsize as StringSize ptr, z as string, endchar as integer = 999999, endline as integer = 999999, wide as integer = 999999, fontp as Font ptr, withtags as bool = YES, withnewlines as bool = YES)
'debug "[text_layout_dimensions] endchar=" & endchar
dim state as PrintStrState
with state
'.localpal/?gcolor/initial_?gcolor/transparency non-initialised
.thefont = fontp
.initial_font = .thefont
.charnum = 0
.pos = .thefont->offset
'Margins are measured relative to xpos
.leftmargin = 0
.rightmargin = wide
dim maxwidth as integer = 0
dim line_width as integer = 0
dim line_height as integer = 0
retsize->lines = 0
if endchar > len(z) then endchar = len(z)
while .charnum < len(z)
if .charnum > endchar orelse retsize->lines >= endline then exit while
'If .charnum = endchar, the last line is zero length, but should be included.
'(That sounds wrong. Doesn't it actually mean endchar points at a newline?)
'.charnum won't advance, so need extra check to prevent infinite loop!
dim exitloop as bool = (.charnum = endchar)
dim parsed_line as string = layout_line_fragment(z, endchar, state, line_width, line_height, wide, withtags, withnewlines)
retsize->lines += 1
'TEXTDBG("parsed a line, line_width =" & line_width)
maxwidth = large(maxwidth, line_width)
'if .debug then edgeprint STR(line_width), pRight, .y, 10, vpage
'Update state
.y += line_height
draw_line_fragment(NULL, state, 0, parsed_line, NO) 'reallydraw=NO
'TEXTDBG("now " & .charnum & " at " & .pos)
if exitloop then exit while
wend
'layout_line_fragment sets .charnum to the beginning of the next line. It's a 0-based
'index. Instead we return it as a 1-based index to the end of the current line
'(char on which the line wraps).
retsize->lineend = .charnum
retsize->size = XY(maxwidth, .y)
retsize->lastw = line_width
retsize->lasth = line_height
retsize->finalfont = .thefont
'debug "[/text_layout_dimensions] charnum=" & .charnum
end with
end sub
'Returns the length in pixels of the longest line of a *non-autowrapped* string.
function textwidth(text as string, fontnum as integer = fontPlain, withtags as bool = YES, withnewlines as bool = YES) as integer
dim retsize as StringSize
text_layout_dimensions @retsize, text, , , , get_font(fontnum), withtags, withnewlines
return retsize.size.w
end function
'Returns the width and height of an autowrapped string.
'Specify the wrapping width; 'wide' might include rWidth for the width of the screen
'(which is what the page arg is for).
function textsize(text as string, wide as RelPos = rWidth, fontnum as integer = fontPlain, withtags as bool = YES, page as integer = -1) as XYPair
if page = -1 then page = vpage
wide = relative_pos(wide, vpages(page)->w)
dim retsize as StringSize
text_layout_dimensions @retsize, text, , , wide, get_font(fontnum), withtags, YES
return retsize.size
end function
function str_rect(s as string, byval x as integer, byval y as integer) as RectType
dim r as RectType
r.size = textsize(s, rWidth) 'Wrapped to screen size
r.xy = relative_pos(XY(x, y), vpages(vpage)->size, r.size)
return r
end function
'Returns the default height of a line of text of a certain font.
'Warning: this currently returns 10 for 8x8 fonts, because that's what text slices use. Sigh.
'However standardmenu (calc_menu_rect) by default uses 9 for fontEdged and 8 for fontPlain
'and draw_menu by default uses 10. Nonstandard menus use 8-10.
function lineheight(fontnum as integer = fontEdged) as integer
return get_font(fontnum, YES)->line_h
end function
'Pixel size of a character in a font
function charsize(char as integer, fontp as Font ptr) as XYPair
dim w as integer
if char <= 0 then 'This happens when we index 1 past the end of the string
w = fontp->w(ASC(" ")) 'Dummy value
else
w = fontp->w(char)
end if
return XY(w, fontp->char_h)
end function
function charsize(char as integer, fontnum as integer) as XYPair
return charsize(char, get_font(fontnum))
end function
'Calculate the position at which a certain character in a block of text will be drawn
'FIXME: this returns the wrong position for a space/newline at the end of a line (it
'returns the start of the next line).
'To fix, render_text (or maybe layout_line_fragment?) needs to be changed.
sub find_text_char_position(retsize as StringCharPos ptr, text as string, charnum as integer, wide as RelPos = rWidth, fontnum as integer = fontPlain, withtags as bool = YES, page as integer = -1)
if page = -1 then page = vpage
wide = relative_pos(wide, vpages(page)->w)
dim size as StringSize
text_layout_dimensions @size, text, charnum, , wide, get_font(fontnum), withtags, YES
with *retsize
.charnum = charnum
.exacthit = YES 'Maybe return NO if it's at the end of the line?
.pos.x = size.lastw
.pos.y = size.size.h - size.lasth
.size = charsize(iif(charnum >= len(text), 0, text[charnum]), size.finalfont)
.lineh = size.lasth
end with
end sub
'Calculate character position in string from pixel position.
'draw_pos is where the text was drawn... redundant to subtracting that out of seekpt,
'but in future we might cache render_text state.
'NOTE: draw_pos is NOT a RelPosXY, unlike render_text! Because we don't know the size of the dest Frame.
sub find_point_in_text (retsize as StringCharPos ptr, seekpt as XYPair, z as string, wide as integer = 999999, draw_pos as XYPair = XY(0,0), fontnum as integer, withtags as bool = YES, withnewlines as bool = YES)
dim state as PrintStrState
with state
'.localpal/?gcolor/initial_?gcolor/transparency non-initialised
.thefont = get_font(fontnum)
.initial_font = .thefont
.charnum = 0
.pos = draw_pos + .thefont->offset
'.pos = relative_pos(draw_pos, destfr->size, finalsize.size) + .thefont->offset
.startx = .x
'Margins are measured relative to draw_pos.x
.leftmargin = 0
.rightmargin = wide
'if left(z,11) = "${K15}Press" then .debug = YES
dim delayedmatch as bool = NO
dim line_width as integer
dim line_height as integer
dim arg as integer
retsize->exacthit = NO
while .charnum < len(z)
dim parsed_line as string = layout_line_fragment(z, len(z), state, line_width, line_height, wide, withtags, withnewlines, YES)
.y += line_height
'.y now points to 1 pixel past the bottom of the line fragment
'Update state
'Note: .charnum is character in original text, ch is character in parser output
for ch as integer = 0 to len(parsed_line) - 1
dim char as integer = parsed_line[ch]
if char = tcmdState then
'Make a change to the state
'TEXTDBG("READ_MEMBER: ch=" & ch & " charnum=" & .charnum)
READ_MEMBER(state, parsed_line, ch)
elseif char >= tcmdFirst andalso char <= tcmdLast then
'TEXTDBG("CMD(" & char & "): ch=" & ch & " charnum=" & .charnum)
if char <= tcmdLastWithArg then
READ_VALUE(arg, parsed_line, ch)
'TEXTDBG("READ_VALUE: arg=" & arg)
if char = tcmdFont then
.thefont = fonts(arg)
end if
end if
'All other commands: ignore
else
'TEXTDBG("CHAR(" & char & " " & CHR(char) & ") ch=" & ch & " charnum = " & .charnum & " x = " & .x)
dim w as integer = .thefont->w(char)
'Draw a character
if delayedmatch then
'retsize->w = w
exit while
end if
.x += w
if .y > seekpt.y andalso .x > seekpt.x then
'TEXTDBG("HIT w/ x=" & .x & " ch=" & ch & " charnum=" & .charnum)
'retsize->w = w
retsize->exacthit = YES
.x -= w
exit while
end if
.charnum += 1
end if
next
'TEXTDBG("After parsing: charnum = " & .charnum & " line_width = " & line_width & " x = " & .x)
if .y > seekpt.y then
'Position was off the (right-hand) end of the line
if .charnum > 0 then
dim lastchar as ubyte = z[.charnum - 1]
if lastchar = 32 or (lastchar = 10 andalso withnewlines) then
'This point is actually on a space/newline, which was
'not added to parsed_string. So don't delay.
retsize->exacthit = YES
.x = line_width
.charnum -= 1
exit while
end if
end if
delayedmatch = YES
'TEXTDBG("FIND IN: delayed")
end if
wend
retsize->charnum = .charnum
retsize->pos.x = .x
retsize->pos.y = .y - .thefont->line_h
retsize->size = charsize(z[.charnum], .thefont) '.charnum = len(z) is OK
retsize->lineh = line_height
end with
end sub
'the old printstr -- no autowrapping
sub printstr (text as string, x as RelPos, y as RelPos, page as integer, withtags as bool = NO, fontnum as integer = fontPlain)
dim state as PrintStrState
state.thefont = get_font(fontnum)
if textbg <> 0 then state.not_transparent = YES
state.bgcolor = textbg
state.fgcolor = textfg
render_text (vpages(page), state, text, , x, y, , , withtags, NO)
end sub
'this doesn't autowrap either
sub edgeprint (text as string, x as RelPos, y as RelPos, col as integer, page as integer, withtags as bool = NO, withnewlines as bool = NO)
'preserve the old behaviour (edgeprint used to call textcolor)
textfg = col
textbg = 0
dim state as PrintStrState
state.thefont = fonts(fontEdged)
state.fgcolor = col
render_text (vpages(page), state, text, , x, y, , , withtags, withnewlines)
end sub
'A flexible edgeprint/printstr replacement.
'Either specify the colour, or omit it and use textcolor().
'Wraps the text at 'wide'; pass "rWidth - x" to wrap at the right edge of the screen.
sub wrapprint (text as string, x as RelPos, y as RelPos, col as integer = -1, page as integer, wide as RelPos = rWidth, withtags as bool = YES, fontnum as integer = fontEdged)
dim state as PrintStrState
state.thefont = fonts(fontnum)
if col = -1 then
state.fgcolor = textfg
state.bgcolor = textbg
if textbg <> 0 then state.not_transparent = YES
else
state.fgcolor = col
state.bgcolor = 0
end if
render_text (vpages(page), state, text, , x, y, wide, , withtags, YES)
end sub
'Like wrapprint except (optionally, by default) a transparent rectangle is drawn
'behind the text.
'TODO: this is a temporary solution, this ought to be handled by the standard
'text drawing functions, and there ought to be a markup code to enable it.
'Note that draw_menu duplicates this for MenuDef.drawbg menus.
sub wrapprintbg (text as string, x as RelPos, y as RelPos, col as integer = -1, page as integer, drawbg as bool = YES, wrapx as RelPos = rWidth, withtags as bool = YES, fontnum as integer = fontEdged)
if drawbg then
dim rect as RectType
rect.topleft = XY(x, y)' - fonts(fontnum)->offset
rect.size = textsize(text, wrapx, fontnum, withtags, page)
rect.y -= fonts(fontnum)->offset.y
rect.h -= fonts(fontnum)->offset.y 'FIXME: why is textsize.h too large for edged font?
trans_rectangle vpages(page), rect, master(uilook(uiBackground)), 0.55
end if
wrapprint text, x, y, col, page, wrapx, withtags, fontnum
end sub
sub textcolor (fg as integer, bg as integer)
textfg = fg
textbg = bg
end sub
'Redundant to fgtag
'Warning: returns to the initial colour, not the previous colour. Use ${KI#} to change the initial colour.
function fgcol_text(text as string, colour as integer) as string
return "${K" & colour & "}" & text & "${K-1}"
end function
'Redundant to bgtag
function bgcol_text(text as string, colour as integer) as string
return "${KB" & colour & "}" & text & "${KB-1}"
end function
'Remove all the valid text markup (not embed codes) like ${K-1} from a string.
function remove_markup(text as string) as string
dim offset as integer = 1
dim tagend as integer
dim ret as string
do
dim last as integer = offset
if next_text_markup(text, offset, tagend) = NO then
ret &= mid(text, last)
return ret
end if
ret &= mid(text, last, offset - last)
offset = tagend 'Skip over tag
loop
end function
'Remove everything except valid text markup (not embed codes) from a string.
'Useful for skipping over text but getting the same effects
function just_markup(text as string) as string
dim offset as integer = 1
dim tagend as integer
dim ret as string
do
if next_text_markup(text, offset, tagend) = NO then return ret
ret &= mid(text, offset, tagend - offset)
offset = tagend 'Skip over tag
loop
end function
'==========================================================================================
' Fonts
'==========================================================================================
constructor FontLayer()
refcount = 1
end constructor
constructor FontLayer(src as FontLayer ptr)
memcpy(@this, src, sizeof(FontLayer)) 'Copy chdata
spr = frame_duplicate(src->spr)
refcount = 1
end constructor
'Decrement refcount, and null out the ptr
sub fontlayer_unload (layerpp as FontLayer ptr ptr)
BUG_IF(layerpp = NULL, "NULL ptr")
if *layerpp then
(*layerpp)->refcount -= 1
if (*layerpp)->refcount <= 0 then
delete *layerpp
end if
*layerpp = NULL
end if
end sub
destructor FontLayer()
frame_unload @spr
end destructor
constructor Font()
end constructor
'A copy of a Font which shares the layers with the original Font
constructor Font(src as Font ptr)
memcpy(@this, src, sizeof(Font))
for idx as integer = 0 to 1
if layers(idx) then layers(idx)->refcount += 1
next
end constructor
'This deletes a Font object pointed to by a pointer. It's OK to call on a ptr to a NULL ptr
sub font_unload (fontpp as Font ptr ptr)
BUG_IF(fontpp = NULL, "NULL font")
dim fontp as Font ptr = *fontpp
if fontp = null then exit sub
delete fontp
*fontpp = NULL
end sub
destructor Font()
for i as integer = 0 to 1
fontlayer_unload @layers(i)
next
Palette16_unload @pal
end destructor
'Create a version of a font with an outline around each character (in a new palette colour)
function font_create_edged (basefont as Font ptr) as Font ptr
BUG_IF(basefont = NULL, "NULL font", NULL)
BUG_IF(basefont->layers(1) = NULL, "blank font", NULL)
CHECK_FRAME_8BIT(basefont->layers(1)->spr, NULL)
dim newfont as Font ptr = new Font()
newfont->layers(0) = new FontLayer()
'Share layer 1
newfont->layers(1) = basefont->layers(1)
newfont->layers(1)->refcount += 1
dim size as integer
'since you can only WITH one thing at a time
dim bchr as FontChar ptr
bchr = @basefont->layers(1)->chdata(0)
dim as integer ch
for ch = 0 to 255
newfont->w(ch) = basefont->w(ch)
with newfont->layers(0)->chdata(ch)
.offset = size
.offx = bchr->offx - 1
.offy = bchr->offy - 1
.w = bchr->w + 2
.h = bchr->h + 2
size += .w * .h
end with
bchr += 1
next
'This is a hack; create a size*1 size frame, which we use as a buffer for pixel data
newfont->layers(0)->spr = frame_new(size, 1, , YES)
newfont->char_h = basefont->char_h + 2
newfont->line_h = basefont->line_h 'This is for backcompat with text slices...
newfont->offset = basefont->offset
newfont->cols = basefont->cols
if basefont->outline_col = 0 then
'Doesn't already have an outline colour
newfont->cols += 1
newfont->outline_col = newfont->cols
else
newfont->outline_col = basefont->outline_col
end if
'Stuff currently hardcoded to keep edged font working as before
newfont->offset.x = 1
newfont->offset.y = 1
'dim as ubyte ptr maskp = basefont->layers(0)->spr->mask
dim as ubyte ptr sptr
dim as ubyte ptr srcptr = newfont->layers(1)->spr->image
dim as integer x, y
for ch = 0 to 255
with newfont->layers(0)->chdata(ch)
sptr = newfont->layers(0)->spr->image + .offset + .w + 1
for y = 1 to .h - 2
for x = 1 to .w - 2
if *srcptr then
sptr[-.w + 0] = newfont->outline_col
sptr[ 0 - 1] = newfont->outline_col
sptr[ 0 + 1] = newfont->outline_col
sptr[ .w + 0] = newfont->outline_col
end if
'if *sptr = 0 then *maskp = 0 else *maskp = &hff
sptr += 1
srcptr += 1
'maskp += 8
next
sptr += 2
next
end with
next
return newfont
end function
'Create a version of a font with a drop shadow (in a new palette colour)
function font_create_shadowed (basefont as Font ptr, xdrop as integer = 1, ydrop as integer = 1) as Font ptr
BUG_IF(basefont = NULL, "NULL font", NULL)
BUG_IF(basefont->layers(1) = NULL, "blank font", NULL)
CHECK_FRAME_8BIT(basefont->layers(1)->spr, NULL)
dim newfont as Font ptr = new Font(basefont)
'Layer 0 is a copy of layer 1 from the old font
fontlayer_unload @newfont->layers(0)
newfont->layers(0) = new FontLayer(basefont->layers(1))
'Layer 1 is shared with the base font
if newfont->outline_col = 0 then
'Doesn't already have an outline colour
newfont->cols += 1
newfont->outline_col = newfont->cols
end if
for ch as integer = 0 to 255
with newfont->layers(0)->chdata(ch)
.offx += xdrop
.offy += ydrop
end with
next
with *newfont->layers(0)->spr
for i as integer = 0 to .w * .h - 1
if .image[i] then
.image[i] = newfont->outline_col
end if
next
end with
return newfont
end function
function font_loadold1bit (fontdata as ubyte ptr) as Font ptr
dim newfont as Font ptr = new Font()
newfont->layers(1) = new FontLayer()
newfont->layers(1)->spr = frame_new(8, 256 * 8)
newfont->char_h = 8
newfont->line_h = 10 'I would have said 9, but this is what was used in text slices
newfont->offset.x = 0
newfont->offset.y = 0
newfont->cols = 1
newfont->outline_col = 0 'None
'dim as ubyte ptr maskp = newfont->layers(1)->spr->mask
dim as ubyte ptr sptr = newfont->layers(1)->spr->image
dim as integer ch, x, y
dim as integer fi 'font index
dim as integer fstep
for ch = 0 to 255
newfont->w(ch) = 8
with newfont->layers(1)->chdata(ch)
.w = 8
.h = 8
.offset = 64 * ch
end with
'find fontdata index, bearing in mind that the data is stored
'2-bytes at a time in 4-byte integers, due to QB->FB quirks,
'and fontdata itself is a byte pointer. Because there are
'always 8 bytes per character, we will always use exactly 4
'ints, or 16 bytes, making the initial calc pretty simple.
fi = ch * 16
'fi = ch * 8 'index to fontdata
fstep = 1 'used because our indexing is messed up, see above
for x = 0 to 7
for y = 0 to 7
*sptr = (fontdata[fi] shr y) and 1
'if *sptr = 0 then *maskp = 0 else *maskp = &hff
sptr += 8
'maskp += 8
next
fi = fi + fstep
fstep = iif(fstep = 1, 3, 1) 'uneven steps due to 2->4 byte thunk
sptr += 1 - 8 * 8
'maskp += 1 - 8 * 8
next
sptr += 8 * 8 - 8
'maskp += 8 * 8 - 8
next
return newfont
end function
'Load each character from an individual BMP in a directory, falling back to some other
'font for missing BMPs
'This function is for testing purposes only, and will be removed unless this shows some use:
'uses hardcoded values
function font_loadbmps (directory as string, fallback as Font ptr = null) as Font ptr
dim newfont as Font ptr = new Font()
newfont->layers(0) = null
newfont->layers(1) = new FontLayer()
'Hacky: start by allocating 4096 pixels, expand as needed
newfont->layers(1)->spr = frame_new(1, 4096)
newfont->cols = 1 'hardcoded
newfont->outline_col = 0 'None
dim maxheight as integer
if fallback then
maxheight = fallback->char_h
newfont->offset.x = fallback->offset.x
newfont->offset.y = fallback->offset.y
newfont->cols = fallback->cols
end if
dim as ubyte ptr image = newfont->layers(1)->spr->image
dim as ubyte ptr sptr
dim as integer size = 0
dim as integer i
dim f as string
dim tempfr as Frame ptr
dim bchr as FontChar ptr
if fallback andalso fallback->layers(1) then
bchr = @fallback->layers(1)->chdata(0)
end if
for i = 0 to 255
with newfont->layers(1)->chdata(i)
f = finddatafile(directory & SLASH & i & ".bmp", NO)
if isfile(f) then
'FIXME: awful stuff
tempfr = image_import_as_frame_raw(f) ', master())
.offset = size
.offx = 0
.offy = 0
.w = tempfr->w
.h = tempfr->h
if .h > maxheight then maxheight = .h
newfont->w(i) = .w
size += .w * .h
image = reallocate(image, size)
sptr = image + .offset
memcpy(sptr, tempfr->image, .w * .h)
frame_unload @tempfr
else
if bchr = NULL then
visible_debug "font_loadbmps: " & i & ".bmp missing and fallback font not provided"
font_unload @newfont
return null
end if
.offset = size
.offx = bchr->offx
.offy = bchr->offy
.w = bchr->w
.h = bchr->h
newfont->w(i) = .w
size += .w * .h
image = reallocate(image, size)
memcpy(image + .offset, fallback->layers(1)->spr->image + bchr->offset, .w * .h)
end if
end with
bchr += 1
next
newfont->layers(1)->spr->image = image
newfont->char_h = maxheight
newfont->line_h = maxheight + 2
return newfont
end function
'Load a font from an image which contains all 256 characters in a 16x16 grid (all characters the same size)
function font_load_16x16 (filename as string) as Font ptr
dim image as Frame ptr
image = image_import_as_frame_raw(filename)
FAIL_IF(image = NULL, "couldn't load file", NULL)
if image->w MOD 16 ORELSE image->h MOD 16 then
debug "font_load_16x16: " & filename & ": bad dimensions " & image->size
frame_unload @image
return null
end if
dim newfont as Font ptr = new Font()
dim as integer charw, charh
charw = image->w \ 16
charh = image->h \ 16
newfont->char_h = charh
newfont->line_h = charh + 2
newfont->offset.x = 0
newfont->offset.y = 0
newfont->outline_col = 0 'None
newfont->layers(0) = null
newfont->layers(1) = new FontLayer()
'"Linearise" the characters. In future this will be unnecessary
newfont->layers(1)->spr = frame_new(charw, charh * 256)
dim as integer size = 0
for i as integer = 0 to 255
with newfont->layers(1)->chdata(i)
.offset = size
.offx = 0
.offy = 0
.w = charw
.h = charh
newfont->w(i) = .w
size += .w * .h
dim tempview as Frame ptr
tempview = frame_new_view(image, charw * (i mod 16), charh * (i \ 16), charw, charh)
'setclip , charh * i, , charh * (i + 1) - 1, newfont->layers(1)->spr
frame_draw tempview, , 0, charh * i, NO, newfont->layers(1)->spr
frame_unload @tempview
end with
next
'Find number of used colours
newfont->cols = 0
dim as ubyte ptr imptr = image->image
for i as integer = 0 to image->pitch * image->h - 1
if imptr[i] > newfont->cols then newfont->cols = imptr[i]
next
frame_unload @image
return newfont
end function
sub setfont (ohf_font() as integer)
font_unload @fonts(fontPlain)
font_unload @fonts(fontEdged)
font_unload @fonts(fontShadow)
fonts(fontPlain) = font_loadold1bit(cast(ubyte ptr, @ohf_font(0)))
fonts(fontEdged) = font_create_edged(fonts(fontPlain))
fonts(fontShadow) = font_create_shadowed(fonts(fontPlain), 1, 2)
end sub
sub set_builtin_font (ohf_font() as integer)
font_unload @fonts(fontBuiltinPlain)
font_unload @fonts(fontBuiltinEdged)
fonts(fontBuiltinPlain) = font_loadold1bit(cast(ubyte ptr, @ohf_font(0)))
fonts(fontBuiltinEdged) = font_create_edged(fonts(fontBuiltinPlain))
end sub
'NOTE: the following two functions are for the old style fonts, they will
'be removed when switching to the new system supporting unicode fonts
'These old style fonts store the type of the font in first integer (part of character
'0). The default "Latin-1.ohf" and "OHRRPGCE Default.ohf" fonts are marked as Latin 1, so
'any font derived from them will be too (ability to change the type only added in Callipygous)
function get_font_type (ohf_font() as integer) as fontTypeEnum
if ohf_font(0) <> ftypeASCII andalso ohf_font(0) <> ftypeLatin1 then
showerror "Unknown font type ID " & ohf_font(0)
return ftypeASCII
end if
return ohf_font(0)
end function
sub set_font_type (ohf_font() as integer, ty as fontTypeEnum)
BUG_IF(ty <> ftypeASCII andalso ty <> ftypeLatin1, "bad type " & ty)
ohf_font(0) = ty
end sub
'==========================================================================================
' BMP routines
'==========================================================================================
sub surface_export_bmp (f as string, surf as Surface Ptr, maspal() as RGBcolor)
if surf->format = SF_32bit then
surface_export_bmp24(f, surf)
elseif surf->base_frame then
frame_export_bmp8(f, surf->base_frame, maspal())
else
showbug "surface_export_bmp: SF_8bit not supported"
end if
end sub
sub surface_export_bmp24 (f as string, surf as Surface Ptr)
dim argb as RGBQUAD
dim as integer of, y, i, skipbytes
dim as RGBcolor ptr sptr
dim as ubyte buf(3)
if surf->format <> SF_32bit then
showbug "surface_export_bmp24 got 8bit Surface"
exit sub
end if
of = write_bmp_header(f, surf->width, surf->height, 24)
if of = -1 then exit sub
skipbytes = 4 - (surf->width * 3 mod 4)
if skipbytes = 4 then skipbytes = 0
sptr = surf->pColorData + (surf->height - 1) * surf->pitch
for y = surf->height - 1 to 0 step -1
'put is possibly the most screwed up FB builtin; the use of the fput wrapper soothes the soul
for x as integer = 0 to surf->width - 1
fput(of, , @sptr[x], 3)
next
sptr -= surf->pitch
'pad to 4-byte boundary
fput(of, , @buf(0), skipbytes)
next
close #of
end sub
sub frame_export_bmp8 (f as string, fr as Frame Ptr, maspal() as RGBcolor)
dim argb as RGBQUAD
dim as integer of, y, i, skipbytes
dim as ubyte ptr sptr
CHECK_FRAME_8BIT(fr)
of = write_bmp_header(f, fr->w, fr->h, 8)
if of = -1 then exit sub
for i = 0 to 255
argb.rgbRed = maspal(i).r
argb.rgbGreen = maspal(i).g
argb.rgbBlue = maspal(i).b
put #of, , argb
next
skipbytes = 4 - (fr->w mod 4)
if skipbytes = 4 then skipbytes = 0
sptr = fr->image + (fr->h - 1) * fr->pitch
for y = fr->h - 1 to 0 step -1
'put is possibly the most screwed up FB builtin; the use of the fput wrapper soothes the soul
fput(of, , sptr, fr->w) 'equivalent to "put #of, , *sptr, fr->w"
sptr -= fr->pitch
'write some interesting dummy data
fput(of, , fr->image, skipbytes)
next
close #of
end sub
'Write a 4-bit BMP; pal should have at most 16 colours in use
sub frame_export_bmp4 (f as string, fr as Frame Ptr, maspal() as RGBcolor, pal as Palette16 ptr)
dim argb as RGBQUAD
dim as integer of, x, y, i, skipbytes
dim as ubyte ptr sptr
dim as ubyte pix
CHECK_FRAME_8BIT(fr)
of = write_bmp_header(f, fr->w, fr->h, 4)
if of = -1 then exit sub
for i = 0 to 15
argb.rgbRed = maspal(pal->col(i)).r
argb.rgbGreen = maspal(pal->col(i)).g
argb.rgbBlue = maspal(pal->col(i)).b
put #of, , argb
next
'Each row must be a multiple of 4 bytes
skipbytes = 4 - ((fr->w + 1) \ 2) mod 4
if skipbytes = 4 then skipbytes = 0
sptr = fr->image + (fr->h - 1) * fr->pitch
for y = fr->h - 1 to 0 step -1
for x = 0 to fr->w - 1
if (x and 1) = 0 then
pix = sptr[x] shl 4
else
pix or= sptr[x]
put #of, , pix
end if
next
if fr->w mod 2 then
put #of, , pix
end if
sptr -= fr->pitch
'write some interesting dummy data
fput(of, , fr->image, skipbytes)
next
close #of
end sub
' Generic 4/8/24-bit BMP export
sub frame_export_bmp (fname as string, fr as Frame ptr, maspal() as RGBcolor, pal as Palette16 ptr = NULL)
if pal then
frame_export_bmp4 fname, fr, maspal(), pal
elseif fr->surf then
surface_export_bmp fname, fr->surf, maspal()
else
frame_export_bmp8 fname, fr, maspal()
end if
end sub
'Creates a new file and writes the bmp headers to it.
'Returns a file handle, or -1 on error.
local function write_bmp_header(filen as string, w as integer, h as integer, bitdepth as integer) as integer
dim header as BITMAPFILEHEADER
dim info as BITMAPINFOHEADER
dim as integer of, imagesize, imageoff
imagesize = ((w * bitdepth + 31) \ 32) * 4 * h
imageoff = 54
if bitdepth <= 8 then
'Palette in front of the image data
imageoff += (1 shl bitdepth) * 4
end if
header.bfType = 19778
header.bfSize = imageoff + imagesize
header.bfReserved1 = 0
header.bfReserved2 = 0
header.bfOffBits = imageoff
info.biSize = 40
info.biWidth = w
info.biHeight = h
info.biPlanes = 1
info.biBitCount = bitdepth
info.biCompression = BI_RGB
info.biSizeImage = imagesize
info.biXPelsPerMeter = &hB12
info.biYPelsPerMeter = &hB12
if bitdepth <= 8 then
info.biClrUsed = 1 shl bitdepth
info.biClrImportant = 1 shl bitdepth
end if
if openfile(filen, for_binary + access_write, of) then 'Truncate
debugerror "write_bmp_header: couldn't open " & filen
return -1
end if
put #of, , header
put #of, , info
return of
end function
'Open a BMP file, read its headers, and return a file handle (>= 0),
'or -1 if invalid, or -2 if unsupported.
'Only 1, 4, 8, 24, and 32 bit BMPs are accepted
'Afterwards, the file is positioned at the start of the palette, if there is one
function open_bmp_and_read_header(bmp as string, byref header as BITMAPFILEHEADER, byref info as BITMAPV3INFOHEADER, byref errmsg as string = "") as integer
dim bf as integer
if openfile(bmp, for_binary + access_read, bf) then
debug "open_bmp_and_read_header: couldn't open " & bmp
errmsg = "Couldn't open file"
return -1
end if
get #bf, , header
if header.bfType <> 19778 then
close #bf
errmsg = "Is not a BMP file"
debuginfo bmp & ": " & errmsg
return -1
end if
dim bisize as integer
get #bf, , bisize
seek #bf, seek(bf) - 4
if biSize = 12 then
'debuginfo "Ancient BMP2 file"
dim info_old as BITMAPCOREHEADER
get #bf, , info_old
info.biSize = biSize
info.biCompression = BI_RGB
info.biBitCount = info_old.bcBitCount
info.biWidth = info_old.bcWidth
info.biHeight = info_old.bcHeight
elseif biSize < 40 then
close #bf
errmsg = "Unsupported DIB header size " & biSize
debuginfo bmp & ": " & errmsg
return -2
else
'A BITMAPINFOHEADER or one of its extensions
get #bf, , info
if biSize >= 56 then
'BITMAPV3INFOHEADER or one of its extensions
'We don't support any of those extension features but none of them are important
elseif biSize = 52 then
'BITMAPV2INFOHEADER, alpha bitmask doesn't exist
info.biAlphaMask = 0
else
'Assumably BITMAPINFOHEADER
info.biRedMask = 0
info.biGreenMask = 0
info.biBlueMask = 0
info.biAlphaMask = 0
end if
end if
if info.biClrUsed <= 0 and info.biBitCount <= 8 then
info.biClrUsed = 1 shl info.biBitCount
end if
'debuginfo bmp & " header size: " & bisize & " size: " & info.biWidth & "*" & info.biHeight & " bitdepth: " & info.biBitCount & " compression: " & info.biCompression & " colors: " & info.biClrUsed
select case info.biBitCount
case 1, 4, 8, 24, 32
case else
close #bf
errmsg = "Unsupported bitdepth " & info.biBitCount
debuginfo bmp & ": " & errmsg
if info.biBitCount = 2 or info.biBitcount = 16 then
return -2
else
'Invalid
return -1
end if
end select
if (info.biCompression = BI_RLE4 and info.biBitCount <> 4) or (info.biCompression = BI_RLE8 and info.biBitCount <> 8) then
close #bf
errmsg = "Invalid compression scheme " & info.biCompression & " in " & info.biBitCount & "bpp BMP"
debuginfo bmp & ": " & errmsg
return -1
end if
if info.biCompression = BI_BITFIELDS and info.biBitCount = 32 then
'16 bit (but not 24 bit) BMPs can also use BI_BITFIELDS, but we don't support them.
'Check whether the bitmasks are simple 8 bit masks, aside from the alpha
'mask, which can be 0 (not present)
if decode_bmp_bitmask(info.biRedMask) = -1 or _
decode_bmp_bitmask(info.biGreenMask) = -1 or _
decode_bmp_bitmask(info.biBlueMask) = -1 or _
(info.biAlphaMask <> 0 and decode_bmp_bitmask(info.biAlphaMask) = -1) then
close #bf
errmsg = "Unsupported BMP RGBA bitmasks " & _
HEX(info.biRedMask) & " " & _
HEX(info.biGreenMask) & " " & _
HEX(info.biBlueMask) & " " & _
HEX(info.biAlphaMask)
debuginfo bmp & ": " & errmsg
return -2
end if
elseif info.biCompression <> BI_RGB and info.biCompression <> BI_RLE4 and info.biCompression <> BI_RLE8 then
close #bf
errmsg = "Unsupported compression scheme " & info.biCompression & " in " & info.biBitCount & "-bit BMP"
debuginfo bmp & ": " & errmsg
return -2
end if
if info.biHeight < 0 then
'A negative height indicates that the image is not stored upside-down. Unimplemented
close #bf
errmsg = "Unsupported non-flipped image"
debuginfo bmp & ": " & errmsg
return -2
end if
'Seek to palette
'(some extra data might sit between the header and the palette only if the compression is BI_BITFIELDS
seek #bf, 1 + sizeof(BITMAPFILEHEADER) + biSize
return bf
end function
'Loads any supported .bmp file as a Surface, returning NULL on error.
'always_32bit: load paletted BMPs as 32 bit Surfaces instead of 8-bit ones
'(in the latter case, you have to load the palette yourself).
'The alpha channel if any is ignored
function surface_import_bmp(bmp as string, always_32bit as bool) as Surface ptr
dim header as BITMAPFILEHEADER
dim info as BITMAPV3INFOHEADER
dim bf as integer
bf = open_bmp_and_read_header(bmp, header, info)
if bf <= -1 then return 0
'navigate to the beginning of the bitmap data
seek #bf, header.bfOffBits + 1
dim ret as Surface ptr
if info.biBitCount < 24 then
dim paletted as Frame ptr
paletted = frame_import_bmp_raw(bmp) 'Opens the file a second time
if paletted then
if always_32bit then
dim bmppal(255) as RGBcolor
loadbmppal(bmp, bmppal())
' Convert it to 32bit
ret = frame_to_surface32(paletted, bmppal())
else
' Keep 8-bit. We don't load the palette
gfx_surfaceCreateFrameView(paletted, @ret) 'Increments refcount
end if
frame_unload @paletted
end if
else
gfx_surfaceCreate(info.biWidth, info.biHeight, SF_32bit, SU_Staging, @ret)
if info.biBitCount = 24 then
loadbmp24(bf, ret)
elseif info.biBitCount = 32 then
loadbmp32(bf, ret, info)
end if
end if
close #bf
return ret
end function
function frame_import_bmp_raw(bmp as string) as Frame ptr
'load a 1-, 4- or 8-bit .BMP, ignoring the palette
dim header as BITMAPFILEHEADER
dim info as BITMAPV3INFOHEADER
dim bf as integer
dim ret as Frame ptr
bf = open_bmp_and_read_header(bmp, header, info)
if bf <= -1 then return 0
if info.biBitCount > 8 then
close #bf
showbug "frame_import_bmp_raw should not have been called!"
return 0
end if
'use header offset to get to data
seek #bf, header.bfOffBits + 1
ret = frame_new(info.biWidth, info.biHeight, , YES)
if info.biBitCount = 1 then
loadbmp1(bf, ret)
elseif info.biBitCount = 4 then
'call one of two loaders depending on compression
if info.biCompression = BI_RGB then
loadbmp4(bf, ret)
elseif info.biCompression = BI_RLE4 then
frame_clear(ret)
loadbmprle4(bf, ret)
else
debug "frame_import_bmp_raw should not have been called, bad 4-bit compression"
end if
else
if info.biCompression = BI_RGB then
loadbmp8(bf, ret)
elseif info.biCompression = BI_RLE8 then
frame_clear(ret)
loadbmprle8(bf, ret)
else
debug "frame_import_bmp_raw should not have been called, bad 8-bit compression"
end if
end if
close #bf
return ret
end function
'Given a mask with 8 consecutive bits such as &hff00 returns the number of zero
'bits to the right of the bits. Returns -1 if the mask isn't of this form.
local function decode_bmp_bitmask(mask as uint32) as integer
for shift as integer = 0 to 24
if mask shr shift = &hFF then
return shift
end if
next
return -1
end function
'Takes an open file handle pointing at start of pixel data and an already sized Surface to load into
local sub loadbmp32(bf as integer, surf as Surface ptr, infohd as BITMAPV3INFOHEADER)
dim bitspix as uint32
dim quadpix as RGBQUAD
dim sptr as RGBcolor ptr
dim tempcol as RGBcolor
dim as integer rshift, gshift, bshift, ashift
tempcol.a = 255 'Opaque
if infohd.biCompression = BI_BITFIELDS then
' The bitmasks have already been verified to be supported, except
' alpha might be missing
rshift = decode_bmp_bitmask(infohd.biRedMask)
gshift = decode_bmp_bitmask(infohd.biGreenMask)
bshift = decode_bmp_bitmask(infohd.biBlueMask)
ashift = decode_bmp_bitmask(infohd.biAlphaMask)
end if
for y as integer = surf->height - 1 to 0 step -1
sptr = surf->pColorData + y * surf->pitch
for x as integer = 0 to surf->width - 1
if infohd.biCompression = BI_BITFIELDS then
get #bf, , bitspix
tempcol.r = bitspix shr rshift
tempcol.g = bitspix shr gshift
tempcol.b = bitspix shr bshift
if ashift <> -1 then
tempcol.a = bitspix shr ashift
end if
*sptr = tempcol
else
'Layout of RGBQUAD and RGBcolor are the same
get #bf, , quadpix
*sptr = *cast(RGBcolor ptr, @quadpix)
end if
sptr += 1
next
next
end sub
'Takes an open file handle pointing at start of pixel data and an already sized Surface to load into
local sub loadbmp24(bf as integer, surf as Surface ptr)
dim pix as RGBTRIPLE
dim ub as ubyte
dim sptr as RGBcolor ptr
dim pad as integer
'data lines are padded to 32-bit boundaries
pad = 4 - ((surf->width * 3) mod 4)
if pad = 4 then pad = 0
for y as integer = surf->height - 1 to 0 step -1
sptr = surf->pColorData + y * surf->pitch
for x as integer = 0 to surf->width - 1
get #bf, , pix
sptr->r = pix.rgbtRed
sptr->g = pix.rgbtGreen
sptr->b = pix.rgbtBlue
sptr->a = 255
sptr += 1
next
'padding to dword boundary
for w as integer = 0 to pad-1
get #bf, , ub
next
next
end sub
local sub loadbmp8(bf as integer, fr as Frame ptr)
'takes an open file handle and an already size Frame pointer, should only be called within loadbmp
dim ub as ubyte
dim as integer w, h
dim sptr as ubyte ptr
dim pad as integer
pad = 4 - (fr->w mod 4)
if pad = 4 then pad = 0
for h = fr->h - 1 to 0 step -1
sptr = fr->image + h * fr->pitch
for w = 0 to fr->w - 1
'read the data
get #bf, , ub
*sptr = ub
sptr += 1
next
'padding to dword boundary
for w = 0 to pad-1
get #bf, , ub
next
next
end sub
local sub loadbmp4(bf as integer, fr as Frame ptr)
'takes an open file handle and an already size Frame pointer, should only be called within loadbmp
dim ub as ubyte
dim as integer w, h
dim sptr as ubyte ptr
dim pad as integer
dim numbytes as integer = (fr->w + 1) \ 2 'per line
pad = 4 - (numbytes mod 4)
if pad = 4 then pad = 0
for h = fr->h - 1 to 0 step -1
sptr = fr->image + h * fr->pitch
for w = 0 to fr->w - 1
if (w and 1) = 0 then
'read the data
get #bf, , ub
*sptr = (ub and &hf0) shr 4
else
'2nd nybble in byte
*sptr = ub and &h0f
end if
sptr += 1
next
'padding to dword boundary
for w = 0 to pad - 1
get #bf, , ub
next
next
end sub
local sub loadbmprle4(bf as integer, fr as Frame ptr)
'takes an open file handle and an already size Frame pointer, should only be called within loadbmp
dim pix as ubyte
dim ub as ubyte
dim as integer w, h
dim i as integer
dim as ubyte bval, v1, v2
w = 0
h = fr->h - 1
'read bytes until we're done
while not eof(bf)
'get command byte
get #bf, , ub
select case ub
case 0 'special, check next byte
get #bf, , ub
select case ub
case 0 'end of line
w = 0
h -= 1
case 1 'end of bitmap
exit while
case 2 'delta (how can this ever be used?)
get #bf, , ub
w = w + ub
get #bf, , ub
h = h + ub
case else 'absolute mode
for i = 1 to ub
if i and 1 then
get #bf, , pix
bval = (pix and &hf0) shr 4
else
bval = pix and &h0f
end if
putpixel(fr, w, h, bval)
w += 1
next
if (ub mod 4 = 1) or (ub mod 4 = 2) then
get #bf, , ub 'pad to word bound
end if
end select
case else 'run-length
get #bf, , pix '2 colours
v1 = (pix and &hf0) shr 4
v2 = pix and &h0f
for i = 1 to ub
if i and 1 then
bval = v1
else
bval = v2
end if
putpixel(fr, w, h, bval)
w += 1
next
end select
wend
end sub
local sub loadbmprle8(bf as integer, fr as Frame ptr)
'takes an open file handle and an already size Frame pointer, should only be called within loadbmp
dim pix as ubyte
dim ub as ubyte
dim as integer w, h
dim i as integer
dim as ubyte bval
w = 0
h = fr->h - 1
'read bytes until we're done
while not eof(bf)
'get command byte
get #bf, , ub
select case ub
case 0 'special, check next byte
get #bf, , ub
select case ub
case 0 'end of line
w = 0
h -= 1
case 1 'end of bitmap
exit while
case 2 'delta (how can this ever be used?)
get #bf, , ub
w = w + ub
get #bf, , ub
h = h + ub
case else 'absolute mode
for i = 1 to ub
get #bf, , pix
putpixel(fr, w, h, pix)
w += 1
next
if ub mod 2 then
get #bf, , ub 'pad to word boundary
end if
end select
case else 'run-length
get #bf, , pix
for i = 1 to ub
putpixel(fr, w, h, pix)
w += 1
next
end select
wend
end sub
local sub loadbmp1(bf as integer, fr as Frame ptr)
'takes an open file handle and an already sized Frame pointer, should only be called within loadbmp
dim ub as ubyte
dim as integer w, h
dim sptr as ubyte ptr
dim pad as integer
dim numbytes as integer = (fr->w + 7) \ 8 'per line
pad = 4 - (numbytes mod 4)
if pad = 4 then pad = 0
for h = fr->h - 1 to 0 step -1
sptr = fr->image + h * fr->pitch
for w = 0 to fr->w - 1
if (w mod 8) = 0 then
get #bf, , ub
end if
*sptr = ub shr 7
ub = ub shl 1
sptr += 1
next
'padding to dword boundary
for w = 0 to pad - 1
get #bf, , ub
next
next
end sub
'Loads the palette of a 1-bit, 4-bit or 8-bit bmp into pal().
'Returns the number of bits, or 0 if the file can't be read.
'Ignores alpha channel
function loadbmppal (f as string, pal() as RGBcolor) as integer
dim header as BITMAPFILEHEADER
dim info as BITMAPV3INFOHEADER
dim col3 as RGBTRIPLE
dim col4 as RGBQUAD
dim bf as integer
dim i as integer
bf = open_bmp_and_read_header(f, header, info)
if bf <= -1 then return 0
for i = 0 to ubound(pal)
pal(i).r = 0
pal(i).g = 0
pal(i).b = 0
next
'debug "loadbmppal(" & f & "): table at " & (seek(bf) - 1) & " = " & hex(seek(bf) - 1)
if info.biBitCount <= 8 then
for i = 0 to (1 shl info.biBitCount) - 1
if info.biSize = 12 then 'BITMAPCOREHEADER
get #bf, , col3
pal(i).r = col3.rgbtRed
pal(i).g = col3.rgbtGreen
pal(i).b = col3.rgbtBlue
pal(i).a = 255
else
get #bf, , col4
pal(i).r = col4.rgbRed
pal(i).g = col4.rgbGreen
pal(i).b = col4.rgbBlue
' Some BMP documentation states col4.rgbReserved "must be zero"
pal(i).a = 255
end if
next
else
debugc errBug, "loadbmppal shouldn't have been called!"
end if
close #bf
return info.biBitCount
end function
'Returns 0 if invalid, otherwise fills 'info' and returns 1 if valid but unsupported, 2 if supported
function bmpinfo (f as string, byref info as BITMAPV3INFOHEADER, byref errmsg as string = "") as integer
dim header as BITMAPFILEHEADER
dim bf as integer
bf = open_bmp_and_read_header(f, header, info, errmsg)
if bf = -1 then return 0
if bf = -2 then return 1
close #bf
return 2
end function
sub bmpinfo (filename as string, byref iminfo as ImageFileInfo)
iminfo.imagetype = imBMP
dim bmpd as BitmapV3InfoHeader
dim support as integer = bmpinfo(filename, bmpd, iminfo.error)
iminfo.supported = (support = 2)
iminfo.valid = (support >= 1)
iminfo.size.w = bmpd.biWidth
iminfo.size.h = bmpd.biHeight
iminfo.bpp = bmpd.biBitCount
iminfo.paletted = (iminfo.bpp <= 8)
'It's also possible for the palette to define an alpha for each color
iminfo.alpha = (iminfo.bpp = 32)
end sub
'==========================================================================================
' PNG
'==========================================================================================
private function lodepngerr(errornum as integer, funcname as zstring ptr) as integer
if errornum then
debuginfo *funcname & ": error " & errornum & " " & *lodepng_error_text(errornum)
end if
return errornum
end function
#define PNGCHKERR(funccall) lodepngerr(funccall, @__FUNCTION__)
sub pnginfo (filename as string, byref iminfo as ImageFileInfo)
iminfo.imagetype = imPNG
'lodepng_inspect only inspects the PNG header, which is always 33 bytes. Load into memory
dim header(32) as byte
' if PNGCHKERR(lodepng_buffer_file(@header(0), 33, strptr(filename))) then
' exit sub
' end if
dim fh as integer
if openfile(filename, for_binary + access_read, fh) then
debug "Couldn't open " & filename
exit sub
end if
get #fh, , header()
close fh
dim state as LodePNGState
dim errornum as integer
errornum = lodepng_inspect(@iminfo.size.w, @iminfo.size.h, @state, @header(0), 33)
if PNGCHKERR(errornum) then
iminfo.error = *lodepng_error_text(errornum)
exit sub
end if
iminfo.valid = YES
iminfo.supported = YES
'Look at color mode info.
'lodepng_inspect doesn't read other chunks, including PLTE, so
'can't tell us how large the palette is. It can tell us the color key though
'EDIT: lodepng_inspect_chunk has been added, which would now allow loading the palette
dim cinfo as LodePNGColorMode ptr = @state.info_png.color
iminfo.bpp = lodepng_get_bpp(cinfo)
if lodepng_is_palette_type(cinfo) then
'Excludes non-paletted 8-bit greyscale images
iminfo.paletted = YES
end if
if lodepng_can_have_alpha(cinfo) then 'lodepng_is_alpha_type(cinfo) then
'Image type with wholy or partially transparent pixels
'(Either RGBA or grey+alpha or has a colorkey, or has a palette with alpha)
iminfo.alpha = YES
end if
lodepng_state_cleanup(@state)
end sub
'Import a paletted PNG as a Frame, and load the palette into pal().
'Returns NULL if not paletted.
function frame_import_paletted_png(filename as string, pal() as RGBcolor) as Frame ptr
dim ret as Frame ptr
dim pixelbuf as byte ptr
dim size as XYPair
dim filebuf as byte ptr
dim filebufsize as size_t
log_openfile filename
if PNGCHKERR(lodepng_load_file(@filebuf, @filebufsize, strptr(filename))) then
deallocate filebuf
return NULL
end if
dim state as LodePNGState
lodepng_state_init(@state)
' The type of image we want to read
state.info_raw.colortype = LCT_PALETTE
state.info_raw.bitdepth = 8
if PNGCHKERR(lodepng_decode(@pixelbuf, @size.w, @size.h, @state, filebuf, filebufsize)) = 0 then
ret = frame_new(size.w, size.h)
if ret then
memcpy(ret->image, pixelbuf, size.w * size.h)
end if
with state.info_png.color
'redim pal(.palettesize - 1)
for cidx as integer = 0 to .palettesize - 1
'Oddly although PNG supports 1..16 bit color depth, palettes are always 8-bit
pal(cidx).r = .palette[cidx * 4 + 0]
pal(cidx).g = .palette[cidx * 4 + 1]
pal(cidx).b = .palette[cidx * 4 + 2]
pal(cidx).a = .palette[cidx * 4 + 3] '255=opaque
next
for cidx as integer = .palettesize to ubound(pal)
pal(cidx).col = 0
next
end with
end if
deallocate filebuf
deallocate pixelbuf
lodepng_state_cleanup(@state)
return ret
end function
'Loads any supported .png file as a Surface, returning NULL on error.
'always_32bit: load paletted PNGs as 32 bit Surfaces instead of 8-bit ones
'(in the latter case, you have to load the palette yourself).
'The alpha channel if any is ignored, as is the palette if always_32bit=NO.
function surface_import_png(filename as string, always_32bit as bool) as Surface ptr
'Calling pnginfo, which means we open the file twice, is a lot less work than this...
/'
dim bufsize as size_t
'Read the file into memory
if PNGCHKERR(lodepng_load_file(@buf, @bufsize, strptr(filename)) then return NULL
'etc, see lodepng_decode_memory() for other steps
'/
dim iminfo as ImageFileInfo
pnginfo filename, iminfo
if iminfo.supported = NO then return NULL
dim ret as Surface ptr
if iminfo.paletted = NO orelse always_32bit then
dim buf as byte ptr
dim size as XYPair
log_openfile filename
if PNGCHKERR(lodepng_decode_file(@buf, @size.w, @size.h, strptr(filename), LCT_RGB, 8)) then
return NULL
end if
'Convert RGB to BGRA
ret = surface32_from_pixels(buf, size.w, size.h, PIXFMT_RGB)
deallocate buf
else
'The palette is ignored
dim pal(255) as RGBColor
dim fr as Frame ptr = frame_import_paletted_png(filename, pal())
gfx_surfaceCreateFrameView(fr, @ret) 'Increments refcount
frame_unload @fr
end if
return ret
end function
'Write a Surface to a .png file.
'8-bit Surfaces: preserves palette indices. pal is optional.
'32-bit Surfaces: masterpal() and pal and the alpha channel are ignored.
' The output .png will be paletted if the input has <= 256 colors.
'compress is 0, 1, 2, higher values are slower but compress better.
function surface_export_png(surf as Surface ptr, filename as string, masterpal() as RGBcolor, pal as Palette16 ptr = NULL, compress as integer = 1) as bool
dim filebuf as byte ptr
dim filebufsize as size_t
dim pixelbuf as byte ptr
dim state as LodePNGState
lodepng_state_init(@state)
state.info_raw.bitdepth = 8
state.info_png.color.bitdepth = 8
'LodePNG's default is 2048. 8192 and above are much slower, because they're size-optimised
state.encoder.zlibsettings.windowsize = iif(compress <= 0, 512, iif(compress >= 2, 32768, 4096))
if surf->format = SF_8bit then
state.info_raw.colortype = LCT_PALETTE
state.info_png.color.colortype = LCT_PALETTE
' When writing a paletted image, to preserve palette indices for
' re-import, disallow LodePNG from shuffling the palette to get
' a lower bitdepth (eg writing as monochrome images as 2-bit)
state.encoder.auto_convert = 0
lodepng_palette_clear(@state.info_png.color)
dim ncols as integer = iif(pal, pal->numcolors, 256)
for cidx as integer = 0 to ncols - 1
with masterpal(iif(pal, pal->col(cidx), cidx))
lodepng_palette_add(@state.info_png.color, .r, .g, .b, 255)
end with
next
lodepng_color_mode_copy(@state.info_raw, @state.info_png.color)
if ncols <= 16 then
state.info_png.color.bitdepth = 4 'Only for better compression
end if
pixelbuf = surf->pPaletteData
else
state.info_raw.colortype = LCT_RGB 'LCT_RGBA
'state.info_png.color.colortype unspecified, will be auto-selected
'BGRA to RGB
pixelbuf = surface32_to_pixels(surf, PIXFMT_RGB)
end if
'Encode and write to file
lodepng_encode(@filebuf, @filebufsize, pixelbuf, surf->width, surf->height, @state)
if state.error = 0 then
state.error = lodepng_save_file(filebuf, filebufsize, strptr(filename))
end if
PNGCHKERR(state.error)
dim ret as bool = (state.error = 0)
'? (surf->width * surf->height) & " pix in " & CINT(1e6 * time) & !"us \twinsize = " & state.encoder.zlibsettings.windowsize & " fsize " & filebufsize
'Cleanup
lodepng_state_cleanup(@state)
deallocate filebuf
if surf->format = SF_32bit then
deallocate pixelbuf
end if
return ret
end function
'Write a Frame to a paletted .png file, preserving palette indices. pal is optional.
'compress: amount of compression (affects speed), 0, 1 or 2
function frame_export_png(fr as Frame ptr, filename as string, masterpal() as RGBcolor, pal as Palette16 ptr = NULL, compress as integer = 1) as bool
dim surf as Surface ptr
if gfx_surfaceCreateFrameView(fr, @surf) then return NO
dim ret as bool
ret = surface_export_png(surf, filename, masterpal(), pal, compress)
gfx_surfaceDestroy(@surf)
return ret
end function
#undef PNGCHKERR
'==========================================================================================
' JPEG
'==========================================================================================
'Caches result of find_helper_app("jpegtran")
function get_jpegtran() as string
static checked as bool
static ret as string
if checked = NO then
checked = YES
'First check without attempting to download, so that we can show
'a helpful message before the download prompt
ret = find_helper_app("jpegtran")
if len(ret) = 0 then
visible_debug "Can only read progressive JPEGs using the jpegtran program (part of libjpeg-progs)"
ret = find_helper_app("jpegtran", YES, "http://jpegclub.org/jpegtran.zip")
end if
end if
return ret
end function
sub jpeginfo (filename as string, byref iminfo as ImageFileInfo)
iminfo.imagetype = imJPEG
dim jpeg as ujImage
jpeg = ujCreate()
ujDisableDecoding(jpeg)
log_openfile filename
ujDecodeFile(jpeg, strptr(filename))
dim errcode as integer = ujGetError()
dim bad as bool = (ujIsValid(jpeg) = 0)
if errcode = UJ_PROGRESSIVE then
if len(get_jpegtran()) then bad = NO
end if
if bad then 'invalid or not supported
if errcode = UJ_NO_JPEG then
iminfo.error = "Not a JPEG file"
elseif errcode = UJ_IO_ERROR then
iminfo.error = "Could not read file, IO error"
elseif errcode = UJ_PROGRESSIVE then
iminfo.valid = YES
iminfo.error = "Progressive, jpegtran not installed"
else
if errcode = UJ_UNSUPPORTED or errcode >= UJ_UNKNOWN_SEGM then
'Other unsupported features or extensions
iminfo.valid = YES
end if
iminfo.error = "Error code " & hex(errcode)
end if
else
if errcode = UJ_PROGRESSIVE then
iminfo.info = "Progressive"
end if
iminfo.valid = YES
iminfo.supported = YES
iminfo.size.w = ujGetWidth(jpeg)
iminfo.size.h = ujGetHeight(jpeg)
iminfo.bpp = iif(ujIsColor(jpeg), 24, 8)
end if
ujFree(jpeg)
end sub
'Attempt to losslessly turn a progressive or arithmetically coded JPEG to a
'baseline JPEG which can be read using uJPEG, using the jpegtran tool, which is
'part of the libjpeg-progs suite of tools.
'jpegtran will strip out metadata blocks, except for comments, unless "-copy all" is given.
'Returns a temp filename or "".
function jpeg_convert_to_baseline(filename as string) as string
debuginfo "jpeg_convert_to_baseline"
dim jpegtran as string = get_jpegtran()
if len(jpegtran) = 0 then return ""
dim outfile as string = tmpdir & "jpegtran_" & trimpath(filename)
safe_shell jpegtran & " -outfile " & escape_filename(outfile) & " " & escape_filename(filename)
if not isfile(outfile) then
debug "jpegtran failed"
return ""
end if
return outfile
end function
'Loads any supported JPEG file as a Surface, returning NULL on error.
function surface_import_jpeg(filename as string) as Surface ptr
dim jpeg as ujImage
jpeg = ujCreate()
log_openfile filename
ujDecodeFile(jpeg, strptr(filename))
if ujGetError() = UJ_PROGRESSIVE then
'uJPEG doesn't support progressive JPEGs, but they can be
'losslessly translated to baseline JPEGs
filename = jpeg_convert_to_baseline(filename)
if len(filename) = 0 then return NULL
ujDecodeFile(jpeg, strptr(filename))
killfile filename
end if
dim errcode as integer = ujGetError()
if errcode <> UJ_OK orelse ujIsValid(jpeg) = 0 then
debug "ujDecodeFile error " & errcode & " in " & filename
ujFree(jpeg)
return NULL
end if
dim pixformat as PixelFormat
pixformat = iif(ujIsColor(jpeg), PIXFMT_RGB, PIXFMT_GREY)
dim size as XYPair = (ujGetWidth(jpeg), ujGetHeight(jpeg))
dim ret as Surface ptr
dim buf as byte ptr
buf = ujGetImage(jpeg, NULL)
if buf = NULL then
debug "ujGetImage error " & ujGetError() & " importing " & filename
else
'Need to convert RGB to our BGRA
ret = surface32_from_pixels(buf, size.w, size.h, pixformat)
end if
ujFree(jpeg)
return ret
end function
function surface_export_jpeg(surf as Surface ptr, filename as string, quality as integer = 95) as bool
BUG_IF(surf->format = SF_8bit, "8-bit surfaces not supported", NO) 'TODO. Use frame_export_jpeg instead.
BUG_IF(surf->width <> surf->pitch, "Unsupported image pitch", NO)
dim pixelbuf as byte ptr
'BGRA to RGB
pixelbuf = surface32_to_pixels(surf, PIXFMT_RGB)
dim ret as bool = YES
if jo_write_jpg(strptr(filename), pixelbuf, surf->width, surf->height, 3, quality) = 0 then
'Only other possible error condition is a zero size image or null ptr
debug "Couldn't write to " & filename
ret = NO
end if
deallocate pixelbuf
return ret
end function
'Write a Frame to a paletted .png file, preserving palette indices. pal is optional.
function frame_export_jpeg(fr as Frame ptr, filename as string, masterpal() as RGBcolor, pal as Palette16 ptr = NULL, quality as integer = 95) as bool
dim surf as Surface ptr
surf = frame_to_surface32(fr, masterpal(), pal)
if surf = NULL then return NO
dim ret as bool
ret = surface_export_jpeg(surf, filename, quality)
gfx_surfaceDestroy(@surf)
return ret
end function
'==========================================================================================
' Generic image file interface
'==========================================================================================
'Indexed by ImageFileTypes
dim shared image_type_strings(...) as zstring ptr = {@"Invalid", @"BMP", @"GIF", @"PNG", @"JPEG", @"DDS"}
function image_file_type (filename as string) as ImageFileTypes
select case lcase(justextension(filename))
case "bmp" : return imBMP
case "png" : return imPNG
case "gif" : return imGIF
case "jpg", "jpeg" : return imJPEG
end select
return imUnknown
end function
function image_read_info (filename as string) as ImageFileInfo
dim ret as ImageFileInfo
ret.imagetype = image_file_type(filename)
if ret.imagetype = imBMP then
bmpinfo filename, ret
elseif ret.imagetype = imPNG then
pnginfo filename, ret
elseif ret.imagetype = imJPEG then
jpeginfo filename, ret
else
ret.error = "Unsupported file extension" 'Includes .dds
end if
ret.imagetype_name = *image_type_strings(ret.imagetype)
dim info as string
if ret.valid = NO then
info = "Invalid "
elseif ret.supported = NO then
info = "Unsupported "
end if
info &= ret.imagetype_name
if ret.supported orelse ret.size.w > 0 then
info &= ", " & ret.size.wh & " pixels, " & ret.bpp & "-bit color"
if ret.size.w > maxFrameSize orelse ret.size.h > maxFrameSize then
ret.supported = NO
if ret.error = "" then ret.error = "Too large!"
end if
end if
if ret.valid then
if ret.alpha then info &= ", alpha"
if ret.paletted then info &= ", paletted"
end if
if len(ret.info) then info &= ", " & ret.info
ret.info = info
return ret
end function
'Loads the palette of a <= 8-bit image file into pal().
'Returns the number of bits, or 0 if the file can't be read or isn't paletted.
function image_load_palette (filename as string, pal() as RGBcolor) as integer
select case image_file_type(filename)
case imBMP
return loadbmppal(filename, pal())
case imPNG
'<s>LodePNG doesn't have a way to read just the palette without the image</s>
'EDIT: loadpng_inspect_chunk was added, which can now do that. But it doesn't
'look like it's worth the time to switch to that.
dim fr as Frame ptr
fr = frame_import_paletted_png(filename, pal())
if fr = 0 then
return 0
else
frame_unload @fr
return 8 'Don't care
end if
case else
debug "load_image_palette: Unrecognised: " & filename
return 0
end select
end function
'Loads any supported image file as a Surface, returning NULL on error.
'always_32bit: load paletted images as 32 bit Surfaces instead of 8-bit ones
'(in the latter case, you have to load the palette yourself).
'The alpha channel if any is ignored
function image_import_as_surface(filename as string, always_32bit as bool) as Surface ptr
select case image_file_type(filename)
case imBMP
return surface_import_bmp(filename, always_32bit)
case imPNG
return surface_import_png(filename, always_32bit)
case imJPEG
return surface_import_jpeg(filename)
case else
debug "image_import_as_surface: Unrecognised: " & filename
return NULL
end select
end function
'Loads a 24/32-bit image as 8-bit Frame.
'pal() is an output if options.compute_palette=YES, otherwise an input.
'See quantize_surface() for full documentation.
'It doesn't make sense to call this on paletted images, as it's unnecessarily very slow.
'If there is an alpha channel, fully transparent pixels are mapped to index 0.
function image_import_as_frame_quantized(filename as string, pal() as RGBcolor, options as QuantizeOptions = TYPE(0, -1)) as Frame ptr
dim surf as Surface ptr
surf = image_import_as_surface(filename, YES)
if surf = NULL then return NULL
return quantize_surface(surf, pal(), options)
end function
'Load a paletted image as a Frame, and load the palette into pal(), a length-256 array.
'An error to call for non-paletted images.
function image_import_as_frame_paletted (filename as string, pal() as RGBColor) as Frame ptr
select case image_file_type(filename)
case imBMP
dim ret as Frame ptr
ret = frame_import_bmp_raw(filename)
if ret then
loadbmppal(filename, pal())
end if
return ret
case imPNG
return frame_import_paletted_png(filename, pal())
case else
showerror "image_import_as_frame_paletted: invalid image type " & filename
return NULL
end select
end function
'Load a paletted image as a Frame and a Palette16 mapped into master() using nearest-matching; returns success.
'Deletes any existing pointers in ret.
'Unlike image_import_as_frame_8bit() this preserves the original colour indices.
'ret.pal will have at least 16 colors, possibly up to 256, but enough to cover all pixel values,
'but is NULL when the image is unpaletted.
'defaultpal is used for breaking nearest-match ties.
'Alpha values in image palette ignored.
function image_import_as_frame_and_palette16 (byref ret as GraphicPair, filename as string, defaultpal as Palette16 ptr = NULL) as bool
unload_sprite_and_pal ret
dim info as ImageFileInfo
info = image_read_info(filename)
if info.supported = NO then return NULL ' Unreadable, invalid, or unsupported
if info.paletted then
dim imgpal(255) as RGBColor
ret.sprite = image_import_as_frame_paletted(filename, imgpal())
if ret.sprite = NULL then return NO
'Map from impsprite colors to master pal indices
dim ncols as integer = 1 shl info.bpp
if ncols < 16 then ncols = 16
dim palmapping(ncols - 1) as integer
if defaultpal then
'Put color index hints in palmapping(), which are used if they are an exact match.
for i as integer = 0 TO small(ncols, defaultpal->numcolors) - 1
palmapping(i) = defaultpal->col(i)
next
end if
find_palette_mapping(imgpal(), curmasterpal(), palmapping())
ret.pal = Palette16_new_from_indices(palmapping())
else
ret.sprite = image_import_as_frame_quantized(filename, curmasterpal())
if ret.sprite = NULL then return NO
'Leave ret.pal blank, we don't need it
'ret.pal = Palette16_new_identity(256)
end if
return YES
end function
'Load a paletted image as a Frame, ignoring the palette. An error to call for non-paletted images.
function image_import_as_frame_raw (filename as string) as Frame ptr
dim pal(255) as RGBColor
return image_import_as_frame_paletted(filename, pal())
end function
'Loads any image as an (optionally transparent) 8-bit Frame (ie. with no Palette16),
'remapped to the given master palette. Returns NULL on error.
'Nonpaletted images will have RGB pixels equal to the 'transparency' color (transparency.a should be 0)
'mapped to masterpal() index 0 (by default nothing); 'keep_col0' is ignored.
'Also, in images with an alpha channel, fully transparent pixels are mapped to index 0.
'Paletted images get palette index 0 mapped to color 0 if 'keep_col0' is true,
'otherwise they have no color 0 pixels; 'transparency' is ignored.
function image_import_as_frame_8bit(filename as string, masterpal() as RGBcolor, keep_col0 as bool = YES, byval transparency as RGBcolor = TYPE(-1)) as Frame ptr
dim info as ImageFileInfo
info = image_read_info(filename)
if info.supported = NO then return NULL ' Unreadable, invalid, or unsupported
if info.paletted then
dim ret as Frame ptr
dim imgpal(255) as RGBColor
ret = image_import_as_frame_paletted(filename, imgpal())
if ret = NULL then return NULL
' Drop the palette, remapping to the master palette
' (Can't use frame_draw, since we have an array instead of a Palette16)
dim palindices(255) as integer
find_palette_mapping(imgpal(), masterpal(), palindices(), 1)
if keep_col0 then
palindices(0) = 0
end if
remap_to_palette ret, palindices()
return ret
else
dim options as QuantizeOptions = (1, transparency)
return image_import_as_frame_quantized(filename, masterpal(), options)
end if
end function
'Returns a Frame backed by a 32-bit Surface
function image_import_as_frame_32bit(filename as string) as Frame ptr
dim surf as Surface ptr
surf = image_import_as_surface(filename, YES)
if surf = NULL then return NULL
dim ret as Frame ptr
ret = frame_with_surface(surf)
gfx_surfaceDestroy(@surf)
return ret
end function
'Output file format is determined from the filename.
sub frame_export_image (fr as Frame ptr, filename as string, masterpal() as RGBcolor, pal as Palette16 ptr = NULL)
select case image_file_type(filename)
case imBMP
frame_export_bmp filename, fr, masterpal(), pal
case imPNG
frame_export_png fr, filename, masterpal(), pal
case imGIF
frame_export_gif fr, filename, masterpal(), pal, NO 'transparent = NO
case imJPEG
frame_export_jpeg fr, filename, masterpal(), pal
'Update load_screenshot_settings when adding more formats
case else
debug "Can't write image: unknown or unsupported file extension: " & filename
end select
end sub
'Export a 32-bit Surface. Output file format is determined from the filename.
sub surface_export_image (surf as Surface ptr, filename as string)
select case image_file_type(filename)
case imBMP
'Supports only 8bit Surfaces with backing Frame
surface_export_bmp filename, surf, curmasterpal()
case imPNG
'Supports 8bit Surfaces
surface_export_png surf, filename, curmasterpal() ' masterpal(), pal
case imGIF
'Doesn't support 8bit
surface_export_gif surf, filename
case imJPEG
'Doesn't support 8bit
surface_export_jpeg surf, filename
case else
debug "Can't write image: unknown or unsupported file extension: " & filename
end select
end sub
'==========================================================================================
' Image quantization
'==========================================================================================
'Returns a non-negative integer which is 0 if both colors in a color table are the same
function color_distance(pal() as RGBcolor, index1 as integer, index2 as integer) as integer
with pal(index1)
dim as integer rdif, bdif, gdif, rmean
rmean = (.r + pal(index2).r) shr 1
rdif = .r - pal(index2).r
gdif = .g - pal(index2).g
bdif = .b - pal(index2).b
'Formula taken from https://www.compuphase.com/cmetric.htm
return (((512 + rmean)*rdif*rdif) shr 8) + 4*gdif*gdif + (((767-rmean)*bdif*bdif) shr 8)
end with
end function
function nearcolor(pal() as RGBcolor, red as integer, green as integer, blue as integer, firstindex as integer = 0, indexhint as integer = -1, avoidcol as integer = -1) as ubyte
'Figure out nearest palette colour in range [firstindex..255] using an approximate perceptual color distance
'A perfect match against pal(indexhint) is tried first
'Never returns avoidcol or any other color the same as it.
dim as integer i, diff, best, save, rdif, bdif, gdif, cappedred, rmean
if indexhint > -1 and indexhint <= ubound(pal) and indexhint >= firstindex then
with pal(indexhint)
if red = .r and green = .g and blue = .b then return indexhint
end with
end if
if red < 0 then
cappedred = 0
elseif red > 255 then
cappedred = 255
else
cappedred = red
end if
dim avoidrgb as RGBcolor
if avoidcol > -1 then avoidrgb = pal(avoidcol)
best = 1000000
save = 0
for i = firstindex to 255
with pal(i)
if avoidcol > -1 andalso .col = avoidrgb.col then continue for
rmean = (cappedred + .r) shr 1
rdif = red - .r
gdif = green - .g
bdif = blue - .b
end with
'Formula taken from https://www.compuphase.com/cmetric.htm
'It is an interpolation between
'diff = 3*rdif*rdif + 4*gdif*gdif + 2*bdif*bdif
' and
'diff = 2*rdif*rdif + 4*gdif*gdif + 3*bdif*bdif
diff = (((512 + rmean)*rdif*rdif) shr 8) + 4*gdif*gdif + (((767-rmean)*bdif*bdif) shr 8)
if diff = 0 then
'early out on direct hit
save = i
exit for
end if
if diff < best then
save = i
best = diff
end if
next
return save
end function
function nearcolor(pal() as RGBcolor, index as integer, firstindex as integer = 0) as ubyte
with pal(index)
return nearcolor(pal(), .r, .g, .b, firstindex)
end with
end function
extern "C"
function nearcolor_master(byval col as RGBcolor, firstindex as integer = 0) as ubyte
return nearcolor(curmasterpal(), col.r, col.g, col.b, firstindex)
end function
'Find the nearest color in the current palette (curmasterpal(), set by setpal). Alpha ignored.
'This may produce slightly worse results than nearcolor because it uses a slightly different
'color distance function. However it's over 10x faster. (Try nearcolor_faster if you need more.)
'This never returns color 0 (firstindex=1).
function nearcolor_fast(byval col as RGBcolor) as ubyte
return query_KDTree(nearcolor_kdtree, col)
end function
end extern
'Version which supports out-of-bounds r/g/b values. Note that this behaves
'differently to nearcolor, which can search for a color "bluer than blue".
'This never returns color 0 (firstindex=1).
function nearcolor_fast(r as integer, g as integer, b as integer) as ubyte
dim col as RGBcolor = any
col.b = iif(b > 255, 255, iif(b < 0, 0, b))
col.g = iif(g > 255, 255, iif(g < 0, 0, g))
col.r = iif(r > 255, 255, iif(r < 0, 0, r))
return query_KDTree(nearcolor_kdtree, col)
end function
'Find the nearest match palette mapping from inputpal() into
'the master palette masterpal(), and store it in mapping(), an array of masterpal() indices.
'Alpha values ignored.
'mapping() may contain initial values, used as hints which are used if an exact match.
'Pass firstindex = 1 to prevent anything from getting mapped to colour 0.
sub find_palette_mapping(inputpal() as RGBcolor, masterpal() as RGBcolor, mapping() as integer, firstindex as integer = 0)
for i as integer = 0 to small(ubound(mapping), ubound(inputpal))
with inputpal(i)
mapping(i) = nearcolor(masterpal(), .r, .g, .b, firstindex, mapping(i))
end with
next
end sub
declare sub quantize_surface_threshold(surf as Surface ptr, ret as Frame ptr, pal() as RGBcolor, options as QuantizeOptions, quantizing as bool)
'Convert a 32 bit Surface to a paletted Frame.
'Frees surf.
'If options.compute_palette=NO (the default) the palette to use should be given as pal(),
'otherwise a suitable palette is computed and returned in pal().
'Only colours options.firstindex..255 in pal() are used.
'Any pixels with alpha=0 are mapped to 0; otherwise alpha is ignored.
'Optionally, any RGB colour matching options.transparency gets mapped to index 0 (by default none);
'the Surface's alpha is ignored and options.transparency.a must be 0 or it won't be matched.
function quantize_surface(byref surf as Surface ptr, pal() as RGBcolor, options as QuantizeOptions) as Frame ptr
if surf->format <> SF_32bit then
showbug "quantize_surface only works on 32 bit Surfaces (bad image_import_as_frame_quantized call?)"
gfx_surfaceDestroy(@surf)
return NULL
end if
dim ret as Frame ptr
ret = frame_new(surf->width, surf->height)
if options.dither orelse options.compute_palette then
if surf->pitch <> surf->width or ret->pitch <> surf->width then
showbug "Can't call dither_image due to pitch mismatch"
else
'We can set the max error to 0 to disable dithering
dim maxerr as integer = iif(options.dither, options.dither_maxerror, 0)
dither_image(surf->pColorData, surf->width, surf->height, ret->image, _
options.compute_palette, @pal(0), 8, options.firstindex, maxerr)
'Handle options.transparency
quantize_surface_threshold(surf, ret, pal(), options, NO)
end if
else
'This is not the same as options.dither_maxerror = 0, because it
'uses nearcolor, which is slower but maybe slightly better results,
'compared to the less "perceptual" comparison done in lib/gif.h.
quantize_surface_threshold(surf, ret, pal(), options, YES)
end if
gfx_surfaceDestroy(@surf)
return ret
end function
'If quantizing=YES, converting the image to 8 bit, otherwise only post-processing result from dither_image
'to handle options.transparency.
local sub quantize_surface_threshold(surf as Surface ptr, ret as Frame ptr, pal() as RGBcolor, options as QuantizeOptions, quantizing as bool)
dim inptr as RGBcolor ptr
dim outptr as ubyte ptr
for y as integer = 0 to surf->height - 1
inptr = surf->pColorData + y * surf->pitch
outptr = ret->image + y * ret->pitch
for x as integer = 0 to surf->width - 1
' Ignore alpha
if (inptr->col and &h00ffffff) = options.transparency.col then
*outptr = 0
elseif inptr->a = 0 then
*outptr = 0
elseif quantizing then
if options.to_master then
*outptr = nearcolor_fast(*inptr) 'Never 0
else
*outptr = nearcolor(pal(), inptr->r, inptr->g, inptr->b, options.firstindex)
end if
end if
inptr += 1
outptr += 1
next
next
end sub
'==========================================================================================
' GIF
'==========================================================================================
'Number of bits needed for this many colors.
function bitdepth_needed(colors as integer) as integer
dim bits as integer = 0
colors -= 1
while colors > 0
bits += 1
colors shr= 1
wend
return bits
end function
' Create a GifPalette from either the master palette or a Palette16 mapped onto
' a master palette, as needed for calling lib/gif.bi functions directly
sub GifPalette_from_pal (byref gpal as GifPalette, masterpal() as RGBcolor, pal as Palette16 ptr = NULL)
if pal then
' Color 0 used for transparency by gif encoder so the palette's
' color 0 gets remapped to the nearest match, so if possible add
' an extra color to end of palette to provide exact match
dim palcolors as integer = pal->numcolors
if pal->numcolors < 256 then
palcolors += 1
end if
gpal.bitDepth = bitdepth_needed(palcolors)
for idx as integer = 0 to palcolors - 1
' The extra color, if any, is color 0
dim masteridx as integer = pal->col(iif(idx = pal->numcolors, 0, idx))
gpal.colors(idx) = masterpal(masteridx)
next
else
' Again color 0 will be remapped, but with 256 colours to choose from there's likely
' to be a good match
gpal.bitDepth = 8
for idx as integer = 0 to 255
gpal.colors(idx) = masterpal(idx)
next
end if
end sub
' Export a 32 bit Surface as a single-frame .gif (alpha ignored)
sub surface_export_gif (surf as Surface Ptr, fname as string, dither as bool = NO)
FAIL_IF(surf = NULL, "NULL Surface")
FAIL_IF(surf->format <> SF_32bit, "8bit Surface")
FAIL_IF(surf->pitch <> surf->width, "pitch doesn't match width")
dim writer as GifWriter
if GifBegin(@writer, fopen(fname, "wb"), surf->width, surf->height, 0, NO, NULL) = NO then
debug "GifWriter(" & fname & ") failed"
elseif GifWriteFrame(@writer, surf->pColorData, surf->width, surf->height, 0, 8, iif(dither, 1, 0)) = NO then
debug "GifWriteFrame failed"
elseif GifEnd(@writer) = NO then
debug "GifEnd failed"
end if
end sub
' Output a single-frame .gif. Ignores mask.
sub frame_export_gif (fr as Frame Ptr, fname as string, maspal() as RGBcolor, pal as Palette16 ptr = NULL, transparent as bool = NO)
if fr->surf then
surface_export_gif fr->surf, fname
exit sub
end if
BUG_IF(fr->pitch <> fr->w, "pitch doesn't match width")
dim writer as GifWriter
dim gifpal as GifPalette
GifPalette_from_pal gifpal, maspal(), pal
if GifBegin(@writer, fopen(fname, "wb"), fr->w, fr->h, 0, iif(transparent, 1, 0), @gifpal) = NO then
debug "GifWriter(" & fname & ") failed"
elseif GifWriteFrame8(@writer, fr->image, fr->w, fr->h, 0, NULL) = NO then
debug "GifWriteFrame8 failed"
elseif GifEnd(@writer) = NO then
debug "GifEnd failed"
end if
end sub
'==========================================================================================
' GIFRecorder
'==========================================================================================
property GIFRecorder.active() as bool
return writer.f <> NULL
end property
'Returns time delay in hundreds of a second to be used for next frame
'(We have to say how long the frame will be displayed when we write it, rather than
'just telling how long the last frame was on-screen for.)
function GIFRecorder.calc_delay() as integer
' Predict the time that this frame will be shown via the setwait timer.
' But the actual next setvispage might happen after or before that
' (if there are multiple setvispage calls before dowait).
dim as double next_frame_time = waittime
'next_next_frame_time = waittime + 1 / requested_framerate
if gif_max_fps > 0 andalso next_frame_time - last_frame_end_time < 1. / gif_max_fps then
' Wait until some more time has passed
return 0
end if
dim ret as integer
ret = (next_frame_time - last_frame_end_time) * 100
if ret <= 0 then
' In this case there's no point writing the frame, but this should be rare
return 0
end if
' Instead of doing last_frame_end_time = waittime, this accumulates
' the parts less than 0.01s, to avoid rounding error
last_frame_end_time += ret * 0.01
return ret
end function
sub start_recording_gif(secondscreen as string = "")
stop_recording_video()
recordvid = new GIFRecorder(absolute_path(next_unused_screenshot_filename() + ".gif"), secondscreen)
end sub
constructor GIFRecorder(outfile as string, secondscreen as string = "")
dim gifpal as GifPalette
' Use curmasterpal() rather than actual palette (displaypal()), because
' displaypal() is affected by fades. We want the master palette,
' because that's likely to be the palette for most frames.
GifPalette_from_pal gifpal, curmasterpal()
this.fname = outfile
this.secondscreen = secondscreen
dim file as FILE ptr = fopen(this.fname, "wb")
if GifBegin(@this.writer, file, vpages(vpage)->w, vpages(vpage)->h, 6, NO, @gifpal) then
show_overlay_message "Shft/Ctrl-F12 to stop recording", 1.
this.last_frame_end_time = timer
debuginfo "Starting to record to " & outfile
else
show_overlay_message "Can't record, GifBegin failed"
debug "GifBegin failed"
end if
end constructor
sub GIFRecorder.stop()
if not this.active then exit sub
if len(this.secondscreen) then
#if defined(IS_CUSTOM) and not defined(NO_TEST_GAME)
debug "Asking Game to stop writing to " & this.secondscreen
channel_write_line(channel_to_Game, "SCREEN STOP")
#endif
safekill this.secondscreen 'Both Game and Custom will attempt to delete the file
end if
if GifEnd(@this.writer) = NO then
show_overlay_message "Recording failed"
safekill this.fname
exit sub
end if
dim msg as string = "Recorded " & trimpath(this.fname)
#ifndef MINIMAL_OS
' Compress it using gifsicle, if available
dim gifsicle as string = find_helper_app("gifsicle")
if len(gifsicle) then
debuginfo "Compressing " & this.fname & " with gifsicle; size before = " & filelen(this.fname)
dim handle as ProcessHandle
' Without --careful, Discord's broken gif "recompressor" (which actually increases file size and
' worsens quality; some other recompressors are similarly garbage) corrupts the gif if it was
' recorded at 24-bit depth.
' As a bonus, -O3 --careful is much faster than -O3 but better compression than -O2.
' (Also, consider --colors=256, which greatly reduces the size of gifs recorded at 24-bit)
handle = open_process(gifsicle, "--careful -O3 " & escape_filename(this.fname) & " -o " & escape_filename(this.fname), NO, NO)
if handle = 0 then
debug "open_process " & gifsicle & " failed"
else
msg += " (Compressing...)"
end if
cleanup_process(@handle)
end if
#endif
show_overlay_message msg, 1.2
end sub
function recording_gif() as bool
return recordvid andalso recordvid->active andalso *recordvid is GIFRecorder
end function
'Perform the effect of pressing Shift/Ctrl-F12: start or stop recording a gif
sub toggle_recording_gif()
if recordvid andalso recordvid->active then
stop_recording_video
else
start_recording_gif
end if
end sub
local sub _gif_pitch_fail(what as string)
showbug "Can't record gif from " & what & " with extra pitch"
'This will cause the following GifWriteFrame* call to fail
recordvid->stop()
end sub
'Stack two images, one of them loaded from a file; our on top and other underneath
local function combined_screen(our as Frame ptr, our_pal() as RGBcolor, other_path as string) as Frame ptr
'Since the editor and player palettes might be different, or one might be running
'at 32 bitdepth, easiest to always convert to 32bit.
dim other as Surface ptr
if real_isfile(other_path) then 'Avoid errors
other = image_import_as_surface(other_path, YES) 'always_32bit=YES
end if
if other = NULL then
'Maybe the game has quit, or hasn't started yet.
'The bottom of the image will simply be blank while this is the case.
debuginfo "combined_screen: couldn't read file"
return NULL
end if
dim ret as Frame ptr
ret = frame_new(large(our->w, other->width), our->h + other->height, 1, NO, NO, YES)
frame_clear ret, uilook(uiBackground)
frame_draw our, our_pal(), , 0, 0, NO, ret
dim other_fr as Frame ptr = frame_with_surface(other) 'TODO: get rid of this
frame_draw other_fr, , 0, our->h, NO, ret
frame_unload @other_fr
gfx_surfaceDestroy(@other)
return ret
end function
' Called with every frame that should be included in any ongoing gif recording
sub GIFRecorder.record_frame(fr as Frame ptr, pal() as RGBcolor)
if this.active = NO then exit sub
dim delay as integer = this.calc_delay()
if delay <= 0 then exit sub
dim ret as bool
dim bits as integer
dim combined as Frame ptr
if len(this.secondscreen) then
combined = combined_screen(fr, pal(), this.secondscreen)
if combined then fr = combined
end if
dim sf as Surface ptr = fr->surf
if sf andalso sf->format = SF_32bit then
bits = 32
if sf->width <> sf->pitch then _gif_pitch_fail "32-bit Surface"
ret = GifWriteFrame(@this.writer, sf->pColorData, sf->width, sf->height, delay, 8, YES)
else
' 8-bit Surface-backed Frames and regular Frames.
bits = 8
dim gifpal as GifPalette
GifPalette_from_pal gifpal, pal()
if sf andalso sf->format = SF_8bit then
if sf->width <> sf->pitch then _gif_pitch_fail "8-bit Surface"
ret = GifWriteFrame8(@this.writer, sf->pPaletteData, sf->width, sf->height, delay, @gifpal)
else
if fr->w <> fr->pitch then _gif_pitch_fail "Frame"
ret = GifWriteFrame8(@this.writer, fr->image, fr->w, fr->h, delay, @gifpal)
end if
end if
if ret = NO then
' On a write failure, this.active will already be set to false
show_overlay_message "Recording failed (GifWriteFrame " & bits & ")"
debug "GifWriteFrame failed, bits = " & bits
end if
frame_unload @combined
end sub
'==========================================================================================
' Screenshots
'==========================================================================================
'All extensions that might be used for screenshots or recordings (including by gfx_screenshot)
dim shared as zstring*6 screenshot_exts(...) => {".bmp", ".png", ".jpg", ".jpeg", ".dds", ".gif"}
dim shared as string screenshot_dir
local sub load_screenshot_settings()
loaded_screenshot_settings = YES
dim temp as string = "." & lcase(read_config_str("gfx.screenshot_format", "png"))
if temp = ".bmp" orelse temp = ".png" orelse temp = ".gif" orelse temp = ".jpg" orelse temp = ".jpeg" then
screenshot_format = temp
else
debug "Unrecognised/unsupported screenshot_format in config file: " & temp
screenshot_format = ".png"
end if
use_gfx_screenshot = read_config_bool("gfx.gfx_" & gfxbackend & ".backend_screenshot", YES)
screenshot_dir = read_config_str("gfx.screenshot_dir", "")
end sub
'Save a screenshot.
'basename: overrides the path/filename, default to gamename####.ext. Should NOT include the extension,
' since the gfx backend can decide that.
'page: defaults to last setvispage
'message: if true, announces the file was saved.
'Returns the filename it was saved to, with extension
function screenshot (basename as string = "", page as integer = -1, message as bool = YES) as string
if loaded_screenshot_settings = NO then
load_screenshot_settings
end if
dim ret as string
if len(basename) = 0 then
basename = next_unused_screenshot_filename()
end if
'try external first
if page <> -1 orelse use_gfx_screenshot = NO orelse gfx_screenshot(basename) = 0 then
'otherwise save it ourselves
ret = basename & screenshot_format
if page = -1 then page = getvispage()
frame_export_image(vpages(page), ret, displaypal())
else
' gfx_screenshot succeeded:
' The reason for this for loop is that we don't know what extension the gfx backend
' might save the screenshot as; have to search for it.
for i as integer = 0 to ubound(screenshot_exts)
dim tmp as string = basename & screenshot_exts(i)
if isfile(tmp) then
ret = tmp
exit for
end if
next
end if
if message then
show_overlay_message "Saved screenshot " & text_right(ret, 150), 1.5
end if
return ret
end function
sub bmp_screenshot(basename as string)
'This is for when you explicitly want a bmp screenshot, and NOT the preferred
'screenshot type used by the current gfx backend
frame_export_bmp(basename & ".bmp", vpages(getvispage), displaypal())
end sub
' Find an available screenshot name in screenshot_dir, or current directory if that's not set.
' Returns filename without extension, and ensures it doesn't collide regardless of the
' extension selected from screenshot_extns.
local function next_unused_screenshot_filename() as string
static search_start as integer
static search_gamename as string
dim as string ret
dim as string gamename = game_fname
if gamename = "" then
' If we haven't loaded a game yet
gamename = "ohrrpgce"
end if
if len(screenshot_dir) then
gamename = screenshot_dir + SLASH + gamename
end if
' Reset search_start counter if needed
if search_gamename <> gamename then
search_gamename = gamename
search_start = 0
end if
for n as integer = search_start to 99999
ret = gamename + right("0000" & n, 4)
'checking curdir, which is export directory
for i as integer = 0 to ubound(screenshot_exts)
if isfile(ret + screenshot_exts(i)) then continue for, for
next
search_start = n
return ret
next
return ret 'This won't be reached
end function
'Take a single screenshot if F12 is pressed.
'Holding down F12 takes a screenshot each frame, however besides
'the first, they're saved to the temporary directory until key repeat kicks in, and then
'moved, in order to 'debounce' F12 if you only press it for a short while.
'(Hmm, now that we can record gifs directly, it probably makes sense to remove the ability to hold F12)
'NOTE: global variables like tmpdir can change between calls, have to be lenient
local sub snapshot_check(page as integer = -1)
static as string backlog()
' The following are just for the overlay message
static as integer num_screenshots_taken
static as string first_screenshot
dim as integer n, F12bits
dim as string shot
F12bits = real_keyval(scF12)
if F12bits = 0 then
' If key repeat never occurred then delete the backlog.
for n = 0 to ubound(backlog)
'debug "killing " & backlog(n)
safekill backlog(n)
next
erase backlog
' Tell what we did
if num_screenshots_taken = 1 then
show_overlay_message "Saved screenshot " & first_screenshot, 1.5
elseif num_screenshots_taken > 1 then
show_overlay_message "Saved " & first_screenshot & " and " & (num_screenshots_taken - 1) & " more", 1.5
end if
num_screenshots_taken = 0
elseif real_keyval(scCtrl) = 0 andalso real_keyval(scShift) = 0 then 'Not Shift/Ctrl-F12 to record a gif
if F12bits = 1 then
' Take a screenshot, but maybe delete it later
shot = tmpdir & get_process_id() & "_tempscreen" & (ubound(backlog) + 1)
a_append(backlog(), screenshot(shot, page, NO)) 'message=NO
'debug "temp save " & backlog(ubound(backlog))
else
' Key repeat has kicked in, so move our backlog of screenshots to the visible location.
for n = 0 to ubound(backlog)
shot = next_unused_screenshot_filename() & "." & justextension(backlog(n))
'debug "moving " & backlog(n) & " to " & shot
'Might be on a different filesystem, can't use renamefile
os_shell_move backlog(n), shot
num_screenshots_taken += 1
next
erase backlog
' Take the new screenshot
dim temp as string = screenshot( , page, NO) 'message=NO
'debug "saved " & temp
if num_screenshots_taken = 0 then
first_screenshot = text_right(temp, 150)
end if
num_screenshots_taken += 1
end if
'debug "screen " & shot
end if
' This is in case this sub is called more than once before setkeys is called.
' Normally setkeys happens at the beginning of a tick and setvispage at the end,
' so this does no damage.
' Clear 'new keypress' bit, but not key repeat.
real_clearkey(scF12, NO)
end sub
'==========================================================================================
' Screen forwarding
'==========================================================================================
constructor ScreenForwarder(outfile as string)
fname = outfile
end constructor
property ScreenForwarder.active() as bool
return LEN(this.fname) <> 0
end property
sub ScreenForwarder.stop()
if this.active then
safekill this.fname
this.fname = ""
end if
end sub
sub ScreenForwarder.record_frame(fr as Frame ptr, pal() as RGBcolor)
frame_export_image(vpages(getvispage), this.fname, pal())
end sub
sub start_forwarding_screen(outfile as string)
stop_recording_video
recordvid = new ScreenForwarder(outfile)
end sub
'==========================================================================================
' Graphics render clipping
'==========================================================================================
'NOTE: there is only one set of clipping values, shared globally for
'all drawing operations. The cliprect is stored in thread-local storage (TLS)
'so that it's possible for multiple threads to draw to Frames.
'The frame argument to setclip() is used to determine the allowed range of clipping values.
'Guaranteed to always return the same result on the same thread.
'Also ensures that the cliprect is for the given Frame, if given.
function get_cliprect(fr as Frame ptr = NULL) byref as ClipState
dim cliprectp as ClipState ptr
#ifdef NO_TLS
static cliprect as ClipState
cliprectp = @cliprect
#else
cliprectp = cast(ClipState ptr, tls_get(tlsKeyClipRect))
if cliprectp = NULL then
cliprectp = new ClipState
tls_set(tlsKeyClipRect, cliprectp)
end if
#endif
if fr andalso cliprectp->frame <> fr then
cliprectp->frame = fr
cliprectp->l = 0
cliprectp->t = 0
cliprectp->r = fr->w - 1
cliprectp->b = fr->h - 1
end if
return *cliprectp
end function
'Set the bounds used by most Frame drawing functions.
'setclip (or get_cliprect(fr)) must be called to reset the clip bounds whenever the Frame being drawn to
'changes, to ensure clip bounds are valid.
sub setclip(l as integer = 0, t as integer = 0, r as integer = 999999, b as integer = 999999, fr as Frame ptr = 0)
dim byref cliprect as ClipState = get_cliprect()
if fr <> 0 then cliprect.frame = fr
if cliprect.frame = 0 then
showbug "Trying to setclip with no Frame"
exit sub
end if
with *cliprect.frame
cliprect.l = bound(l, 0, .w) '.w valid, prevents any drawing
cliprect.t = bound(t, 0, .h)
cliprect.r = bound(r, 0, .w - 1)
cliprect.b = bound(b, 0, .h - 1)
end with
end sub
'Shrinks clipping area, never grows it
'Returns true if the next cliprect still has nonzero size
function shrinkclip(l as integer = 0, t as integer = 0, r as integer = 999999, b as integer = 999999, fr as Frame ptr = 0) as bool
dim byref cliprect as ClipState = get_cliprect()
if fr andalso cliprect.frame <> fr then
cliprect.frame = fr
cliprect.l = 0
cliprect.t = 0
cliprect.r = fr->w - 1
cliprect.b = fr->h - 1
end if
BUG_IF(cliprect.frame = 0 andalso fr = 0, "Trying to shrinkclip with no Frame", NO)
with *cliprect.frame
cliprect.l = bound(large(cliprect.l, l), 0, .w) '.w valid, prevents any drawing
cliprect.t = bound(large(cliprect.t, t), 0, .h)
cliprect.r = bound(small(cliprect.r, r), 0, .w - 1)
cliprect.b = bound(small(cliprect.b, b), 0, .h - 1)
end with
return cliprect.r >= cliprect.l andalso cliprect.b >= cliprect.t
end function
'Blit a Frame with setclip clipping.
'trans: draw transparently, either using ->mask if available, or otherwise use colour 0 as transparent
'write_mask:
' If the destination has a mask, sets the mask for the destination rectangle
' equal to the mask (or color-key) for the source rectangle. Does not OR them.
local sub draw_clipped(src as Frame ptr, pal as Palette16 ptr = NULL, x as integer, y as integer, trans as bool = YES, dest as Frame ptr, opts as DrawOptions)
dim as integer startx, starty, endx, endy
dim as integer srcoffset
startx = x
endx = x + src->w - 1
starty = y
endy = y + src->h - 1
dim byref cliprect as ClipState = get_cliprect(dest)
if startx < cliprect.l then
srcoffset = (cliprect.l - startx)
startx = cliprect.l
end if
if starty < cliprect.t then
srcoffset += (cliprect.t - starty) * src->pitch
starty = cliprect.t
end if
if endx > cliprect.r then
endx = cliprect.r
end if
if endy > cliprect.b then
endy = cliprect.b
end if
if starty > endy or startx > endx then exit sub
blitohr(src, dest, pal, srcoffset, startx, starty, endx, endy, trans, opts)
end sub
' Blit a Frame with setclip clipping and opts->scale <> 1. opts can not be NULL!
local sub draw_clipped_scaled(src as Frame ptr, pal as Palette16 ptr = NULL, x as integer, y as integer, trans as bool = YES, dest as Frame ptr, opts as DrawOptions)
dim byref cliprect as ClipState = get_cliprect(dest)
dim as integer sxfrom, sxto, syfrom, syto
sxfrom = large(cliprect.l, x)
sxto = small(cliprect.r, x + (src->w * opts.scale) - 1)
syfrom = large(cliprect.t, y)
syto = small(cliprect.b, y + (src->h * opts.scale) - 1)
blitohrscaled (src, dest, pal, x, y, sxfrom, syfrom, sxto, syto, trans, opts)
end sub
' Blit a Surface with setclip clipping.
' Kludge: we pass in the dest as both a Frame ptr and Surface ptr to be able to get the cliprect.
local sub draw_clipped_surf(src as Surface ptr, master_pal as RGBcolor ptr, pal as Palette16 ptr = NULL, x as integer, y as integer, trans as bool, dest as Frame ptr, destsurf as Surface ptr, opts as DrawOptions)
dim byref cliprect as ClipState = get_cliprect(dest)
' It's OK for the src and dest rects to have negative size or be off
' the edge of src/dest, because gfx_surfaceCopy properly clips them.
dim srcRect as SurfaceRect = (0, 0, src->width - 1, src->height - 1)
if x < cliprect.l then
srcRect.left = cliprect.l - x
x = cliprect.l
end if
if y < cliprect.t then
srcRect.top = cliprect.t - y
y = cliprect.t
end if
dim destRect as SurfaceRect = (x, y, cliprect.r, cliprect.b)
opts.color_key0 = trans 'Clobbers def_drawoptions.color_key0
if gfx_surfaceCopy(@srcRect, src, master_pal, pal, @destRect, destsurf, opts) then
debug "gfx_surfaceCopy error"
end if
def_drawoptions.color_key0 = NO
end sub
'==========================================================================================
' Sprite (Frame) cache
'==========================================================================================
'not to be used outside of the sprite functions
declare sub frame_delete_members(f as Frame ptr)
declare sub frame_freemem(f as Frame ptr)
declare sub spriteset_freemem(sprset as SpriteSet ptr)
'Assumes pitch == w
declare sub frame_add_mask(fr as Frame ptr, clr as bool = NO)
declare sub sprite_add_cache(sprtype as SpriteType, record as integer, p as Frame ptr)
'The sprite cache holds Frame ptrs, which may also be Frame arrays and SpriteSets. Since
'each SpriteSet is associated with a unique Frame array, we don't need a separate cache
'for SpriteSets. SpriteSet data can be loaded after and linked to the cached Frame array
'if it was initially not loaded as a SpriteSet.
'The sprite cache, which is a HashTable (sprcache) containing all loaded sprites, is split in
'two: the A cache containing currently in-use sprites (which is not explicitly tracked), and
'the B cache holding those not in use, which is a LRU list 'sprcacheB' which holds a maximum
'of SPRCACHEB_SZ entries.
'The number/size of in-use sprites is not limited, and does not count towards the B cache
'unless COMBINED_SPRCACHE_LIMIT is defined. It should be left undefined when memory usage
'is not actually important.
'I couldn't find any algorithms for inequal cost caching so invented my own: sprite size is
'measured in 'base size' units, and instead of being added to the head of the LRU list,
'sprites are moved a number of places back from the head equal to their size. This is probably
'an unnecessary complication over LRU, but it's fun.
CONST SPRCACHE_BASE_SZ = 4096 'bytes
#IFDEF LOWMEM
'Up to 8MB, including in-use sprites
CONST SPRCACHEB_SZ = 2048 'in SPRITE_BASE_SZ units
#DEFINE COMBINED_SPRCACHE_LIMIT 1
#ELSE
'Max cache size of 32MB, but actual limit will be less due to items smaller than 4KB
CONST SPRCACHEB_SZ = 8192 'in SPRITE_BASE_SZ units
#ENDIF
#if 0
'Enable this to help track down sprite leaks.
'Set TRACE_SPRITE to the particular spriteset you want to trace
#define TRACE_SPRITE SPRITE_CACHE_KEY(sprTypeWalkabout, 1) 'walkabout set 1
#macro TRACE_CACHE(fr, msg)
if fr->cacheentry andalso fr->cacheentry->key = TRACE_SPRITE then
debug msg ", spr " & TRACE_SPRITE & " refc=" & fr->refcount
end if
#endmacro
#else
#define TRACE_CACHE(fr, msg)
#endif
' Remove a spriteset from the cache, delete the SpriteCacheEntry,
' and call frame_unload to remove the cache's reference.
local sub sprite_remove_from_cache(entry as SpriteCacheEntry ptr)
TRACE_CACHE(entry->p, "removing from cache")
dlist_remove(sprcacheB.generic, entry)
sprcache.remove(entry->key)
#ifdef COMBINED_SPRCACHE_LIMIT
sprcacheB_used -= entry->cost
#else
if entry->Bcached then
sprcacheB_used -= entry->cost
end if
#endif
entry->p->cached = NO
entry->p->cacheentry = NULL
'Remove the reference due cache (have to do this after clearing ->cached, or would decrement twice)
frame_unload @entry->p
delete entry
end sub
' Removes the final reference to a sprite from the cache, freeing it (and entry)
local sub sprite_delete_from_cache(entry as SpriteCacheEntry ptr)
if entry->p->refcount <> 1 then
debugc errBug, "sprite cache leak/invalid sprite_delete_from_cache(): " & entry->key & " " & frame_describe(entry->p)
'Leak instead of deleting the Frame, to avoid crashes
end if
sprite_remove_from_cache(entry)
end sub
'Free some sprites from the end of the B cache
'Returns true if enough space was freed
local function sprite_cacheB_shrink(amount as integer) as bool
sprite_cacheB_shrink = (amount <= SPRCACHEB_SZ)
if sprcacheB_used + amount <= SPRCACHEB_SZ then exit function
dim as SpriteCacheEntry ptr pt, prevpt
pt = sprcacheB.last
while pt
prevpt = pt->cacheB.prev
sprite_delete_from_cache(pt)
if sprcacheB_used + amount <= SPRCACHEB_SZ then exit function
pt = prevpt
wend
end function
local sub sprite_empty_cache_range(minkey as integer, maxkey as integer)
dim iterstate as uinteger = 0
dim as SpriteCacheEntry ptr pt, nextpt
nextpt = NULL
pt = sprcache.iter(iterstate, nextpt)
while pt
nextpt = sprcache.iter(iterstate, pt)
if pt->key >= minkey andalso pt->key <= maxkey then
sprite_delete_from_cache(pt)
end if
pt = nextpt
wend
end sub
'Unlike sprite_empty_cache, this reloads (in-use) sprites from file, modifying in-place where possible.
'Any sprite that's not actually in use is removed from the cache as it's unnecessary to reload.
local sub sprite_update_cache_range(minkey as integer, maxkey as integer)
dim iterstate as uinteger = 0
dim as SpriteCacheEntry ptr pt, nextpt
nextpt = NULL
pt = sprcache.iter(iterstate, nextpt)
while pt
nextpt = sprcache.iter(iterstate, pt)
if pt->key < minkey or pt->key > maxkey then
pt = nextpt
continue while
end if
dim oldframes as Frame ptr = pt->p
if oldframes->refcount <= 1 then
'Don't bother if not referenced outside the cache
sprite_delete_from_cache(pt)
else
dim sprtype as integer = pt->key \ SPRITE_CACHE_MULT
dim record as integer = pt->key mod SPRITE_CACHE_MULT
dim newframes as Frame ptr
newframes = frame_load_uncached(sprtype, record)
if newframes = NULL then
'I guess it was deleted.
debuginfo "sprite_update_cache: Couldn't reload " & pt->key
elseif newframes->arraylen = oldframes->arraylen then
'If the number of frames haven't changed then we can modify the
'existing Frame array in-place. There are still a few non-sprite-slice
'uses of Frames in Game which will only reload if the frame count
'doesn't change. Most notably, tilesets.
'This also benefits Custom if multiple editors are open at once.
'Transplant the data from the new Frame array and SpriteSet into the
'old Frames and SpriteSet, so that no pointers need to be
'updated. pt (the SpriteCacheEntry) doesn't need to to be modified
'at all.
dim oldsprset as SpriteSet ptr = oldframes->sprset
'Move over any animations from the new SpriteSet to the old one.
if newframes->sprset <> NULL then
if oldsprset = NULL then
'OK then, just keep the new SpriteSet (but this should never happen)
oldsprset = newframes->sprset
newframes->sprset = NULL
else
if oldsprset->animset then
oldsprset->animset->dereference()
end if
oldsprset->animset = newframes->sprset->animset
newframes->sprset->animset = NULL
end if
end if
dim refcount as integer = oldframes->refcount
dim wantmask as bool = (oldframes->mask <> NULL)
'Remove the host's previous organs
oldframes->sprset = NULL 'Don't delete the SpriteSet
frame_delete_members oldframes
'Insert the new organs
memcpy(oldframes, newframes, sizeof(Frame) * newframes->arraylen)
'Having removed everything from the donor, dispose of it
if newframes->sprset then
delete newframes->sprset
end if
deallocate(newframes)
'Fix the bits we just clobbered
oldframes->cached = 1
oldframes->refcount = refcount
oldframes->cacheentry = pt
oldframes->sprset = oldsprset
'Make sure we don't crash if we were using a mask (might be the wrong mask though)
if wantmask then frame_add_mask oldframes
'Incrementing version number still needed so that 'scaled' Sprite slices reload
oldframes->generation += 1
else
'Let any existing users of oldframes keep using it. We remove it
'from the cache and replace it with the new one, and increment the
'generation so that Sprite slices reload and switch to newframes.
TRACE_CACHE(oldframes, "Removing from cache (frames changed), to be replaced")
'Decrements oldframes->refcount, but doesn't delete it, because we
'already checked there's another reference.
sprite_remove_from_cache(pt)
sprite_add_cache(sprtype, record, newframes)
TRACE_CACHE(newframes, "Caching, replacing previous version")
oldframes->generation += 1
'We could update oldframes->sprset (if it exists) to point to the newframes
'animations, but pretty pointless: you'd need to be using a Sprite slice
'to use them anyway.
end if
end if
pt = nextpt
wend
end sub
'Reload all graphics of certain type
sub sprite_update_cache(sprtype as SpriteType)
sprite_update_cache_range(SPRITE_CACHE_MULT * sprtype, SPRITE_CACHE_MULT * (sprtype + 1) - 1)
if sprtype = sprTypeTileset then
sprite_update_cache sprTypeTilesetStrip
end if
update_spriteset_global_animations_cache sprtype
end sub
'Attempt to completely empty the sprite cache, detecting memory leaks
'By default, remove everything. With an argument: remove specific sprite type,
'or with two: remove a specific spriteset
sub sprite_empty_cache(sprtype as SpriteType = sprTypeInvalid, setnum as integer = -1)
#if defined(IS_GAME) or defined(IS_CUSTOM)
'The clipboard may contain Sprite slices with sl->Animation references to SpriteSets,
'although they have sl->SpriteData->loaded = NO.
'Putting this here is ugly, but better to be sure it's called
slice_editor_delete_clipboard
#endif
if sprtype = sprTypeInvalid then
sprite_empty_cache_range(INT_MIN, INT_MAX)
if sprcacheB_used <> 0 or sprcache.numitems <> 0 then
debug "sprite_empty_cache: corruption: sprcacheB_used=" & sprcacheB_used & " items=" & sprcache.numitems
end if
empty_spriteset_global_animations_cache
elseif setnum < 0 then
sprite_empty_cache_range(SPRITE_CACHE_MULT * sprtype, SPRITE_CACHE_MULT * (sprtype + 1) - 1)
animset_unload @spriteset_global_animations_cache(sprtype)
else
dim which as integer = SPRITE_CACHE_MULT * sprtype + setnum
sprite_empty_cache_range(which, which)
end if
end sub
sub sprite_debug_cache()
debug "==sprcache=="
dim iterstate as integer = 0
dim pt as SpriteCacheEntry ptr = NULL
while sprcache.iter(iterstate, pt)
debug pt->key & " cost=" & pt->cost & " : " & frame_describe(pt->p)
wend
debug "==sprcacheB== (used units = " & sprcacheB_used & "/" & SPRCACHEB_SZ & ")"
pt = sprcacheB.first
while pt
debug pt->key & " cost=" & pt->cost & " : " & frame_describe(pt->p)
pt = pt->cacheB.next
wend
end sub
'a sprite has no references, move it to the B cache
local sub sprite_to_B_cache(entry as SpriteCacheEntry ptr)
dim pt as SpriteCacheEntry ptr
if sprite_cacheB_shrink(entry->cost) = NO then
'fringe case: bigger than the max cache size
sprite_delete_from_cache(entry)
exit sub
end if
'apply size penalty
pt = sprcacheB.first
dim tobepaid as integer = entry->cost
while pt
tobepaid -= pt->cost
if tobepaid <= 0 then exit while
pt = pt->cacheB.next
wend
dlist_insertat(sprcacheB.generic, pt, entry)
entry->Bcached = YES
#ifndef COMBINED_SPRCACHE_LIMIT
sprcacheB_used += entry->cost
#endif
end sub
' move a sprite out of the B cache
local sub sprite_from_B_cache(entry as SpriteCacheEntry ptr)
dlist_remove(sprcacheB.generic, entry)
entry->Bcached = NO
#ifndef COMBINED_SPRCACHE_LIMIT
sprcacheB_used -= entry->cost
#endif
end sub
' search cache, update as required if found
local function sprite_fetch_from_cache(sprtype as SpriteType, record as integer) as Frame ptr
dim entry as SpriteCacheEntry ptr
entry = sprcache.get(SPRITE_CACHE_KEY(sprtype, record))
if entry then
'cachehit += 1
if entry->Bcached then
sprite_from_B_cache(entry)
end if
entry->p->refcount += 1
return entry->p
end if
return NULL
end function
' adds a newly loaded frame to the cache with a given type/record
local sub sprite_add_cache(sprtype as SpriteType, record as integer, p as Frame ptr)
if p = 0 then exit sub
dim entry as SpriteCacheEntry ptr
entry = new SpriteCacheEntry
entry->key = SPRITE_CACHE_KEY(sprtype, record)
entry->p = p
entry->cost = (p->w * p->h * p->arraylen) \ SPRCACHE_BASE_SZ + 1
'leave entry->cacheB unlinked
entry->Bcached = NO
'the cache counts as a reference, but only to the head element of an array!!
p->cached = 1
p->refcount += 1
p->cacheentry = entry
sprcache.add(entry->key, entry)
#ifdef COMBINED_SPRCACHE_LIMIT
sprcacheB_used += entry->cost
#endif
end sub
local sub _cache_sprtype(byref doc as DocPtr, sprtype as SpriteType)
for record as integer = 0 TO sprite_sizes(sprtype).lastrec()
dim fr as Frame ptr
fr = sprite_fetch_from_cache(sprtype, record)
if fr = NULL then
if doc = NULL then
doc = rgfx_open(sprtype, NO, optNoDelay)
if doc = NULL then exit sub
end if
fr = rgfx_load_spriteset(doc, sprtype, record, YES)
if fr then
sprite_add_cache(sprtype, record, fr)
end if
end if
frame_unload @fr
next
end sub
'Equivalent to loading and freeing all graphics of one type, but vastly faster.
'Does nothing if graphics haven't been converted to rgfx.
'sprtype can sprTypeBackdrop too, but not sprTypeTileset
'TODO: we should just hold the .rgfx files open instead and this will become obsolete
sub cache_all_spritesets(sprtype as SpriteType)
BUG_IF(sprtype > sprTypeEnemy, "Must be an rgfx sprite type")
'dim starttime as double = timer
dim doc as DocPtr
'FIXME: the sprite cache doesn't know that each enemy sprite has two sprtypes
if sprtype = sprTypeEnemy then
_cache_sprtype doc, sprTypeSmallEnemy
_cache_sprtype doc, sprTypeMediumEnemy
_cache_sprtype doc, sprTypeLargeEnemy
else
_cache_sprtype doc, sprtype
end if
FreeDocument doc
'debuginfo "sprtype " & sprtype & " cached in " & cint((timer - starttime) * 1e3) & "ms"
end sub
'==========================================================================================
' Frames
'==========================================================================================
'Create a blank Frame or array of Frames. No SpriteSet created!
'By default not initialised; pass clr=YES to initialise to 0
'with_surface32: if true, create a 32-it Surface-backed Frame.
'no_alloc: ignore this; internal use only.
function frame_new(w as integer, h as integer, frames as integer = 1, clr as bool = NO, wantmask as bool = NO, with_surface32 as bool = NO, no_alloc as bool = NO) as Frame ptr
if w < 1 or h < 1 or frames < 1 then
showbug "frame_new: bad size " & XY(w,h).wh & "*" & frames
return 0
end if
if with_surface32 then
if wantmask then
'8-bit surfaces can have masks, but not 32-bit ones (no form
'of transparency is implemented for them yet!)
showbug "frame_new: mask and backing surface mututally exclusive"
end if
end if
dim ret as Frame ptr
'this hack was Mike's idea, not mine!
ret = callocate(sizeof(Frame) * frames)
'no memory? shucks.
if ret = 0 then
showerror "Could not create sprite frames, no memory"
return 0
end if
for i as integer = 0 to frames - 1
with ret[i]
'the caller to frame_new is considered to have a ref to the head; and the head to have a ref to each other elem
'so set each refcount to 1
.refcount = 1
.arraylen = frames
'By default, use contiguous frameids
.frameid = i
if i > 0 then .arrayelem = 1
.defpal = -1
.w = w
.h = h
.pitch = w
.mask = NULL
if no_alloc then
elseif with_surface32 then
if gfx_surfaceCreate(w, h, SF_32bit, SU_Staging, @.surf) then
frame_freemem(ret)
return NULL
end if
if clr then
gfx_surfaceFill(curmasterpal(0).col, NULL, .surf)
end if
else
if clr then
.image = callocate(.pitch * h)
if wantmask then .mask = callocate(.pitch * h)
else
.image = allocate(.pitch * h)
if wantmask then .mask = allocate(.pitch * h)
end if
if .image = 0 or (.mask = 0 and wantmask <> NO) then
showerror "Could not allocate sprite frames/surfaces"
'well, I don't really see the point freeing memory, but who knows...
frame_freemem(ret)
return NULL
end if
end if
end with
next
return ret
end function
'Create a frame which is a view onto part of a larger frame
'Can return a zero-size view. Seems to work, but not yet sure that all operations will work correctly on such a frame.
function frame_new_view(spr as Frame ptr, x as integer, y as integer, w as integer, h as integer) as Frame ptr
dim ret as Frame ptr = callocate(sizeof(Frame))
if ret = 0 then
showerror "Could not create sprite view, no memory"
return 0
end if
if x < 0 then w -= -x: x = 0
if y < 0 then h -= -y: y = 0
with *ret
.w = bound(w, 0, spr->w - x)
.h = bound(h, 0, spr->h - y)
if x >= spr->w or y >= spr->h or .w = 0 or .h = 0 then
'this might help to keep things slightly saner
.w = 0
.h = 0
end if
.pitch = spr->pitch
if spr->surf then
'.surf must be destroyed (refcount decremented) when this Frame is unloaded
if gfx_surfaceCreateView(spr->surf, x, y, .w, .h, @.surf) then
deallocate ret
return NULL
end if
else
'These must not be freed when this Frame is unloaded
.image = spr->image + .pitch * y + x
if spr->mask then
.mask = spr->mask + .pitch * y + x
end if
end if
.refcount = 1
.arraylen = 1 'at the moment not actually used anywhere on sprites with isview = 1
.defpal = -1
.isview = 1
'we point .base at the 'root' frame which really owns these pixel buffer(s)
if spr->isview then
.base = spr->base
else
.base = spr
end if
if .base->refcount <> NOREFC then .base->refcount += 1
end with
return ret
end function
' Returns a Frame which is backed by a Surface.
' Unload/Destroy both the Frame and the Surface: increments refcount for the Surface!
' Note: normally it makes no sense to call this on a Surface that is itself
' a view of a Frame
function frame_with_surface(surf as Surface ptr) as Frame ptr
if surf = NULL then return NULL
dim ret as Frame ptr = frame_new(1, 1, 1, , , , YES) 'no_alloc = YES. Dummy size
init_frame_with_surface ret, surf
return ret
end function
'ret is a Frame without image/mask allocated
local sub init_frame_with_surface(ret as Frame ptr, surf as Surface ptr)
surf = gfx_surfaceReference(surf)
with *ret
.surf = surf
.w = surf->width
.h = surf->height
.pitch = surf->pitch
'image and mask are Null
end with
end sub
' Creates an (independent) 32 bit Surface which is a copy of a Frame.
' This is not the same as gfx_surfaceCreateFrameView, which creates a Surface which
' is just a view of a Frame (and is a temporary hack!)
function frame_to_surface32(fr as Frame ptr, masterpal() as RGBcolor, pal as Palette16 ptr = NULL) as Surface ptr
if fr->surf then
debug "frame_to_surface32 called on a Surface-backed Frame"
if fr->surf->format = SF_8bit then
showbug "Converting Frame w/ 8bit Surface to 32bit Surface unimplemented"
return NULL
end if
return gfx_surfaceReference(fr->surf)
end if
dim surf as Surface ptr
if gfx_surfaceCreate(fr->w, fr->h, SF_32bit, SU_Staging, @surf) then
return NULL
end if
dim wrapper as Frame ptr 'yuck
wrapper = frame_with_surface(surf)
dim trans as bool = NO
dim opts as DrawOptions
if fr->mask then
'32bit Surfaces don't have transparency yet, but if the Frame has
'a mask at least make transparent pixels end up as rgb 0,0,0
trans = YES
opts.write_mask = YES
end if
frame_draw fr, masterpal(), pal, 0, 0, trans, wrapper, opts
frame_unload @wrapper
return surf
end function
' Turn a regular Frame into a 32-bit Surface-backed Frame.
' Content is preserved.
' Warning: this is a dangerous implementation. Any view onto fr will become invalid
sub frame_convert_to_32bit(fr as Frame ptr, masterpal() as RGBcolor, pal as Palette16 ptr = NULL)
BUG_IF(fr->cached, "refusing to clobber cached Frame")
fr->surf = frame_to_surface32(fr, masterpal(), pal)
deallocate(fr->image)
fr->image = NULL
deallocate(fr->mask)
fr->mask = NULL
end sub
' Turn Surface-backed Frame back to a regular Frame. Content IS WIPED if it was a 32-bit Surface!
sub frame_drop_surface(fr as Frame ptr)
if fr->surf then
if fr->image = NULL then 'Should always be true
if fr->surf->format = SF_8bit then
fr->image = allocate(fr->pitch * fr->h)
memcpy(fr->image, fr->surf->pPaletteData, fr->pitch * fr->h)
if fr->surf->pMaskData then
fr->mask = allocate(fr->pitch * fr->h)
memcpy(fr->mask, fr->surf->pMaskData, fr->pitch * fr->h)
end if
else
fr->image = callocate(fr->pitch * fr->h)
end if
end if
gfx_surfaceDestroy(@fr->surf)
end if
end sub
local sub frame_delete_members(f as Frame ptr)
if f->arrayelem then debug "can't free arrayelem!": exit sub
for i as integer = 0 to f->arraylen - 1
deallocate(f[i].image) 'May be NULL
f[i].image = NULL
deallocate(f[i].mask) 'May be NULL
f[i].mask = NULL
if f[i].surf then gfx_surfaceDestroy(@f[i].surf)
f[i].refcount = FREEDREFC 'help to detect double free
next
if f->sprset then
delete f->sprset
f->sprset = NULL
end if
end sub
' unconditionally frees a sprite from memory.
' You should never need to call this: use frame_unload
' Should only be called on the head of an array (and not a view, obv)!
' Warning: not all code calls frame_freemem to free sprites! Grrr!
local sub frame_freemem(f as Frame ptr)
if f = 0 then exit sub
frame_delete_members f
deallocate(f)
end sub
' Duplicates a Frame array to a vector of individual Frame ptrs. Doesn't deref input.
' (TODO: this function is temporary; Frame arrays should be replaced with SpriteSets)
function frame_array_to_vector(frames as Frame ptr) as Frame ptr vector
dim ret as Frame ptr vector
v_new ret
for idx as integer = 0 TO frames->arraylen - 1
'Don't use v_append, to avoid _frame_copyctor
v_expand(ret)[0] = frame_duplicate(@frames[idx])
next
return ret
end function
' Duplicates a vector of Frames, which must all have the same size and mask/no mask,
' as a single Frame array. Doesn't free input.
' (TODO: this function is temporary; Frame arrays should be replaced with SpriteSets)
function frame_vector_to_array(frames as Frame ptr vector) as Frame ptr
if frames = NULL then return NULL
dim ret as Frame ptr
ret = frame_new(frames[0]->w, frames[0]->h, v_len(frames), , frames[0]->mask <> NULL)
for idx as integer = 0 TO v_len(frames) - 1
dim opts as DrawOptions
opts.write_mask = YES
frame_draw frames[idx], , 0, 0, NO, @ret[idx], opts
ret[idx].frameid = frames[idx]->frameid
next
return ret
end function
'================================ Loading & Saving Frames =================================
'Public:
' Loads a 4-bit or 8-bit sprite/backdrop/tileset from the appropriate game lump, *with caching*.
' For 4-bit sprites it will return a pointer to the first frame, and subsequent frames
' will be immediately after it in memory. (This is a hack, and will probably be removed)
' For tilesets, the tileset will already be reordered as needed.
' Note: if no game has been loaded, the lump doesn't exist, or the record is out of range,
' may return either NULL or a blank Frame!
function frame_load(sprtype as SpriteType, record as integer) as Frame ptr
dim ret as Frame ptr = sprite_fetch_from_cache(sprtype, record)
if ret then
TRACE_CACHE(ret, "frame_load from cache")
return ret
end if
ret = frame_load_uncached(sprtype, record)
if ret then
sprite_add_cache(sprtype, record, ret)
TRACE_CACHE(ret, "frame_load from file")
end if
return ret
end function
'If an extension, must exclude the '.'
function graphics_file(lumpname_or_extn as string) as string
dim as bool fullname = instr(lumpname_or_extn, ".") > 0
if len(game) = 0 then
' Haven't loaded a game, fallback to the engine's default graphics
' (Note that this won't exist when running a distributed game.exe)
dim gfxdir as string = finddatadir("defaultgfx", NO) 'error_if_missing=NO
if len(gfxdir) = 0 then
return ""
end if
if fullname then
return gfxdir & SLASH & lumpname_or_extn
else
return gfxdir & SLASH "ohrrpgce." & lumpname_or_extn
end if
end if
if fullname then
return workingdir & SLASH & lumpname_or_extn
else
return game & "." & lumpname_or_extn
end if
end function
' Loads a 4-bit or 8-bit sprite/backdrop/tileset from the appropriate game lump. See frame_load.
function frame_load_uncached(sprtype as SpriteType, record as integer) as Frame ptr
if sprtype < sprTypeFirstLoadable orelse sprtype > sprTypeLastLoadable orelse record < 0 then
debugc errBug, "frame_load: invalid type=" & sprtype & " and rec=" & record
return 0
end if
dim ret as Frame ptr
dim sprset as SpriteSet ptr
var prev_subtimer = main_timer.switch(TimerIDs.FileIO)
if sprtype = sprTypeTileset or sprtype = sprTypeTilesetStrip then
dim mxs as Frame ptr
'Returns a blank Frame on error
mxs = frame_load_mxs(graphics_file("til"), record)
if mxs = NULL then return NULL
if sprtype = sprTypeTilesetStrip then
ret = mxs_frame_to_tileset(mxs)
frame_unload @mxs
else
ret = mxs
end if
else
ret = rgfx_load_spriteset(sprtype, record, NO) 'expect_exists=NO
if ret then
'OK. ret already has a sprset.
elseif sprtype = sprTypeBackdrop then
'Returns a blank Frame on error
ret = frame_load_mxs(graphics_file("mxs"), record)
if ret then
sprset = new SpriteSet(ret) 'Attaches to ret
end if
else
'Not in the .rgfx file, try .pt#, or create a blank spriteset
with sprite_sizes(sprtype)
'debug "loading " & sprtype & " " & record
'cachemiss += 1
ret = frame_load_4bit(graphics_file("pt" & sprtype), record, .frames, .size.w, .size.h)
if ret = NULL then
ret = frame_new(.size.w, .size.h, .frames, YES)
end if
end with
if ret then
initialise_backcompat_pt_frameids ret, sprtype
sprset = new SpriteSet(ret) 'Attaches to ret
DEBUG_ANIM_CACHE(sprset->name = "SpriteSet " & sprtype & "_" & record)
sprset->get_animset->fallback_set = spriteset_load_global_animations(sprtype)
end if
end if
end if
main_timer.switch(prev_subtimer)
return ret
end function
' You can use this to load a .pt?-format 4-bit sprite from some non-standard location.
' No code does this. Does not use a cache.
' It will return a pointer to the first frame (of num frames), and subsequent frames
' will be immediately after it in memory. (This is a hack, and will probably be removed)
function frame_load_4bit(filen as string, rec as integer, numframes as integer, wid as integer, hei as integer) as Frame ptr
dim ret as Frame ptr
dim frsize as integer = wid * hei / 2
dim recsize as integer = frsize * numframes
dim fh as integer
if openfile(filen, for_binary + access_read, fh) then
debugerror "frame_load_4bit: could not open " & filen
return 0
end if
ret = frame_new(wid, hei, numframes)
if ret = 0 then
close #fh
return 0
end if
'find the right sprite (remember, it's base-1)
seek #fh, recsize * rec + 1
dim framenum as integer, x as integer, y as integer, z as ubyte
'pixels stored in columns, 2 pixels/byte
for framenum = 0 to numframes - 1
with ret[framenum]
for x = 0 to wid - 1
for y = 0 to hei - 1
'pull up two pixels
get #fh, , z
'the high nybble is the first pixel
.image[y * wid + x] = (z SHR 4)
y += 1
'and the low nybble is the second one
.image[y * wid + x] = z AND 15
next
next
end with
next
lazyclose fh
return ret
end function
declare sub write_frame_node(fr as Frame ptr, fs_node as Node ptr, bits as integer)
declare sub read_frame_node(fr as Frame ptr, fr_node as Node ptr, bitdepth as integer, byref lastid as integer)
'Appends a new "frameset" child node storing an array of Frames and returns it.
'TODO: Doesn't save metadata about palette or master palette
'TODO: Doesn't save mask, but we don't have any need to serialise masks at the moment
function frameset_to_node(fr as Frame ptr, parent as Node ptr) as Node ptr
if fr->arrayelem then
showbug "frameset_to_node: not first Frame in array"
return NULL
end if
dim as Node ptr fs_node
fs_node = AppendChildNode(parent, "frameset")
AppendChildNode(fs_node, "w", fr->w)
AppendChildNode(fs_node, "h", fr->h)
AppendChildNode(fs_node, "format", 0)
if fr->mask then
debug "WARNING: frameset_to_node can't save masks"
end if
'"bits" gives the format of the "image" node; whether this Frame
'is a 4 or 8 bit sprite is unknown (and would be stored separately)
dim bits as integer = 8
if fr->surf then
if fr->surf->format = SF_32bit then
bits = 32
end if
end if
AppendChildNode(fs_node, "bits", bits)
for idx as integer = 0 to fr->arraylen - 1
write_frame_node(@fr[idx], fs_node, bits)
next
return fs_node
end function
'Write a single Frame in an array as a "frame" node
local sub write_frame_node(fr as Frame ptr, fs_node as Node ptr, bits as integer)
dim as Node ptr frame_node, image_node
frame_node = AppendChildNode(fs_node, "frame")
AppendChildNode(frame_node, "id", fr->frameid)
image_node = AppendChildNode(frame_node, "image")
'Allocate uninitialised memory
SetContent(image_node, NULL, fr->w * fr->h * (bits \ 8))
dim imdata as byte ptr = GetZString(image_node)
if fr->surf then
dim surf as Surface ptr = fr->surf
dim rowbytes as integer = surf->width * bits \ 8
dim pitchbytes as integer = surf->pitch * bits \ 8
for y as integer = 0 TO surf->height - 1
memcpy(imdata + y * rowbytes, cast(byte ptr, surf->pRawData) + y * pitchbytes, rowbytes)
next
else
for y as integer = 0 TO fr->h - 1
memcpy(imdata + y * fr->w, fr->image + y * fr->pitch, fr->w)
next
end if
end sub
'Loads an array of Frames from a "frameset" node
function frameset_from_node(fs_node as Node ptr) as Frame ptr
dim as integer dataformat = GetChildNodeInt(fs_node, "format")
dim as integer bitdepth = GetChildNodeInt(fs_node, "bits", 8)
dim as XYPair size
size.w = GetChildNodeInt(fs_node, "w")
size.h = GetChildNodeInt(fs_node, "h")
dim as integer frames = 0
dim as Node ptr ch = FirstChild(fs_node, "frame")
while ch
frames += 1
ch = NextSibling(ch, "frame")
wend
ERROR_IF(dataformat <> 0, "unsupported data format " & dataformat, NULL)
ERROR_IF(frames = 0, "no frames!", NULL)
ERROR_IF(size.w <= 0 orelse size.h <= 0 orelse size.w > maxFrameSize orelse size.h > maxFrameSize, _
"bad size " & size, NULL)
dim fr as Frame ptr
if bitdepth = 8 then
fr = frame_new(size.w, size.h, frames)
elseif bitdepth = 32 then
fr = frame_new(size.w, size.h, frames, , , , YES) 'no_alloc = YES
else
showerror "frameset_from_node: Unsupported graphics bitdepth " & bitdepth
return NULL
end if
if fr = NULL then return NULL 'Should already have shown an error
dim index as integer = 0
dim lastid as integer = -1
dim fr_node as Node ptr = FirstChild(fs_node, "frame")
while fr_node
read_frame_node(@fr[index], fr_node, bitdepth, lastid)
fr_node = NextSibling(fr_node, "frame")
index += 1
wend
return fr
end function
'Loads a single "frame" node in a frameset
'lastid: frameid for previous Frame
local sub read_frame_node(fr as Frame ptr, fr_node as Node ptr, bitdepth as integer, byref lastid as integer)
fr->frameid = GetChildNodeInt(fr_node, "id", fr->frameid)
ERROR_IF(fr->frameid <= lastid, "corrupt .rgfx file; frameids not in order: " & fr->frameid & " follows " & lastid)
lastid = fr->frameid
dim image_node as NodePtr = GetChildByName(fr_node, "image")
dim imdata as ubyte ptr = GetZString(image_node)
dim imlen as integer = GetZStringSize(image_node)
if imdata = NULL orelse imlen <> fr->w * fr->h * bitdepth \ 8 then
showerror "frame_from_node: Couldn't load image; data missing or bad length (" & imlen & " for " & fr->size & ", bitdepth=" & bitdepth & ")"
exit sub
end if
if bitdepth = 8 then
memcpy(fr->image, imdata, fr->w * fr->h)
elseif bitdepth = 32 then
dim surf as Surface ptr
if gfx_surfaceCreate(fr->w, fr->h, SF_32bit, SU_Staging, @surf) then
exit sub
end if
memcpy(surf->pColorData, imdata, fr->w * fr->h * 4)
init_frame_with_surface(fr, surf)
gfx_surfaceDestroy(@surf)
end if
end sub
'==========================================================================================
'Public:
' Releases a reference to a sprite and nulls the pointer.
' If it is refcounted, decrements the refcount, otherwise it is freed immediately.
' A note on frame arrays: you may pass around pointers to frames in it (call frame_reference
' on them) and then unload them, but no memory will be freed until the head pointer refcount reaches 0.
' The head element will have 1 extra refcount if the frame array is in the cache. Each of the non-head
' elements also have 1 refcount, indicating that they are 'in use' by the head element,
' but this is just for feel-good book keeping
' (cdecl so that it can be used in the Frame ptr vector typetable)
sub frame_unload cdecl(ppfr as Frame ptr ptr)
if ppfr = 0 then exit sub
dim fr as Frame ptr = *ppfr
*ppfr = 0
if fr = 0 then exit sub
with *fr
if .refcount = FREEDREFC then
debug frame_describe(fr) & " already freed!"
exit sub
end if
if .refcount = NOREFC then
exit sub
end if
.refcount -= 1
TRACE_CACHE(fr, "frame_unload")
if .refcount < 0 then debugc errBug, frame_describe(fr) & " has refcount " & .refcount
'if cached, can free two references at once
if (.refcount - .cached) <= 0 then
TRACE_CACHE(fr, "now unused")
dim byref cliprect as ClipState = get_cliprect()
if cliprect.frame = fr then cliprect.frame = 0
if .arrayelem then
'this should not happen, because each arrayelem gets an extra refcount
debug "arrayelem with refcount = " & .refcount
exit sub
end if
if .isview then
if .surf then
'View onto surf, so decrement its refcount
gfx_surfaceDestroy(@.surf)
end if
frame_unload @.base
deallocate(fr)
else
for i as integer = 1 to .arraylen - 1
if fr[i].refcount <> 1 then
debug frame_describe(@fr[i]) & " array elem freed with bad refcount"
end if
next
if .cached then
sprite_to_B_cache(fr->cacheentry)
else
'Frees .surf and .sprset
frame_freemem(fr)
end if
end if
end if
end with
end sub
'Takes a 320x200 Frame and produces a 20x3200 Frame in the format expected of tilesets:
'linear series of 20x20 tiles - better cache behaviour, but I haven't tested whether it
'has a significant performance effect.
function mxs_frame_to_tileset(spr as Frame ptr) as Frame ptr
CHECK_FRAME_8BIT(spr, NULL)
dim tileset as Frame ptr
tileset = frame_new(20, 20 * 160)
dim as ubyte ptr sptr = tileset->image
dim as ubyte ptr srcp
dim tilex as integer
dim tiley as integer
dim px as integer
dim py as integer
for tiley = 0 to 9
for tilex = 0 to 15
srcp = spr->image + tilex * 20 + tiley * 320 * 20
for py = 0 to 19
for px = 0 to 19
*sptr = *srcp
sptr += 1
srcp += 1
next
srcp += 320 - 20
next
next
next
return tileset
end function
function hexptr(p as any ptr) as string
return hex(cast(intptr_t, p))
end function
function frame_describe(p as Frame ptr) as string
if p = 0 then return "'(null)'"
dim temp as string
if p->sprset then temp = p->sprset->describe()
return "'(0x" & hexptr(p) & ") " & p->arraylen & "*" & p->size.wh _
& " offset=" & p->offset & " img=0x" & hexptr(p->image) _
& " msk=0x" & hexptr(p->mask) & " pitch=" & p->pitch & " cached=" & p->cached & " aelem=" _
& p->arrayelem & " view=" & p->isview & " base=0x" & hexptr(p->base) & " refc=" & p->refcount & "' " _
& temp
end function
'this is mostly just a gimmick
function frame_is_valid(p as Frame ptr) as bool
if p = 0 then return NO
dim ret as bool = YES
if p->refcount <> NOREFC and p->refcount <= 0 then ret = NO
'this is an arbitrary test, and in theory, could cause a false-negative, but I can't concieve of 100 thousand references to the same sprite.
if p->refcount > 100000 then ret = NO
if p->w < 0 or p->h < 0 then ret = NO
if p->pitch < p->w then ret = NO
if p->surf then
if p->image <> 0 orelse p->mask <> 0 then ret = NO
else
if p->image = 0 then ret = NO
end if
'Patterns used by Windows and Linux to scrub memory
if cint(p->mask) = &hBAADF00D or cint(p->image) = &hBAADF00D then ret = NO
if cint(p->mask) = &hFEEEFEEE or cint(p->image) = &hFEEEFEEE then ret = NO
if ret = NO then
showbug "Invalid sprite " & frame_describe(p)
'if we get here, we are probably doomed, but this might be a recovery
if p->cacheentry then
sprite_remove_from_cache(p->cacheentry)
end if
end if
return ret
end function
'Add a mask
'clr: is true, blank mask (entirely transparent), otherwise copy image
local sub frame_add_mask(fr as Frame ptr, clr as bool = NO)
CHECK_FRAME_8BIT(fr)
if fr->mask then exit sub
if clr = NO then
fr->mask = allocate(fr->pitch * fr->h)
memcpy(fr->mask, fr->image, fr->pitch * fr->h)
else
fr->mask = callocate(fr->pitch * fr->h)
end if
end sub
'for a copy you intend to modify. Otherwise use frame_reference
'clr: if true, return a new blank Frame with the same size.
'note: does not copy frame arrays (or SpriteSets or animations), only single frames
function frame_duplicate(p as Frame ptr, clr as bool = NO, addmask as bool = NO) as Frame ptr
dim ret as Frame ptr
if p = 0 then return 0
if p->surf then
BUG_IF(clr orelse addmask, "clr/addmask unimplemented for Surfaces", NULL) 'TODO: we don't need it yet
dim surf as Surface ptr = surface_duplicate(p->surf)
ret = frame_with_surface(surf)
ret->offset = p->offset
gfx_surfaceDestroy(@surf) 'Decrement extra reference
return ret
end if
ret = callocate(sizeof(Frame))
if ret = 0 then return 0
ret->w = p->w
ret->h = p->h
ret->pitch = p->w
ret->offset = p->offset
ret->refcount = 1
ret->image = 0
ret->mask = 0
ret->arraylen = 1
ret->frameid = p->frameid
ret->defpal = p->defpal
if p->image then
if clr = 0 then
ret->image = allocate(ret->w * ret->h)
if p->w = p->pitch then
'a little optimisation (we know ret->w == ret->pitch)
memcpy(ret->image, p->image, ret->w * ret->h)
else
for i as integer = 0 to ret->h - 1
memcpy(ret->image + i * ret->pitch, p->image + i * p->pitch, ret->w)
next
end if
else
ret->image = callocate(ret->w * ret->h)
end if
end if
if p->mask then
if clr = 0 then
ret->mask = allocate(ret->w * ret->h)
if p->w = p->pitch then
'a little optimisation (we know ret->w == ret->pitch)
memcpy(ret->mask, p->mask, ret->w * ret->h)
else
for i as integer = 0 to ret->h - 1
memcpy(ret->mask + i * ret->pitch, p->mask + i * p->pitch, ret->w)
next
end if
else
ret->mask = callocate(ret->w * ret->h)
end if
elseif addmask then
frame_add_mask ret, clr
end if
return ret
end function
function frame_reference cdecl(p as Frame ptr) as Frame ptr
if p = 0 then return 0
if p->refcount = NOREFC then
'showbug "tried to reference a non-refcounted sprite!"
else
p->refcount += 1
TRACE_CACHE(p, "frame_reference")
end if
return p
end function
' This is a convenience function to set a Frame ptr variable, CHANGING the
' Frame ptr it contains. Useful because many frame functions are not in-place.
' (Use frame_draw with trans=NO, write_mask=YES to set the contents of one Frame
' equal to another. There is no way to do so while changing the Frame size
' (it could be implemented, but only for Frames with no views onto them).
sub frame_assign cdecl(ptr_to_replace as Frame ptr ptr, new_value as Frame ptr)
frame_unload ptr_to_replace
*ptr_to_replace = new_value
end sub
' See frame_assign.
sub surface_assign cdecl(ptr_to_replace as Surface ptr ptr, new_value as Surface ptr)
if *ptr_to_replace then gfx_surfaceDestroy(ptr_to_replace)
*ptr_to_replace = new_value
end sub
' This is for the Frame ptr vector typetable. Ignore.
local sub _frame_copyctor cdecl(dest as Frame ptr ptr, src as Frame ptr ptr)
*dest = frame_reference(*src)
end sub
constructor DrawOptions(scale as integer = 1)
this.scale = scale
end constructor
'Public:
' Draws a sprite to a page/dest.
' trans: if true, color 0 is transparent. (If the Frame has a mask, mask = 0 is transparent instead)
sub frame_draw(src as Frame ptr, pal as Palette16 ptr = NULL, x as RelPos, y as RelPos, trans as bool = YES, page as integer, opts as DrawOptions = def_drawoptions)
frame_draw src, curmasterpal(), pal, x, y, trans, vpages(page), opts
end sub
sub frame_draw(src as Frame ptr, pal as Palette16 ptr = NULL, x as RelPos, y as RelPos, trans as bool = YES, dest as Frame ptr, opts as DrawOptions = def_drawoptions)
frame_draw src, curmasterpal(), pal, x, y, trans, dest, opts
end sub
' Explicitly specify the master palette to use - it is only used if the src is 8-bit
' and the dest is 32-bit.
sub frame_draw overload (src as Frame ptr, masterpal() as RGBcolor, pal as Palette16 ptr = NULL, x as RelPos, y as RelPos, trans as bool = YES, dest as Frame ptr, opts as DrawOptions = def_drawoptions)
BUG_IF(src = NULL orelse dest = NULL, "trying to draw from/to null frame")
x = relative_pos(x, dest->w, src->w)
y = relative_pos(y, dest->h, src->h)
x += src->offset.x * opts.scale
y += src->offset.y * opts.scale
frame_draw_internal src, masterpal(), pal, x, y, trans, dest, opts
end sub
private function surface_shim(src as Frame ptr, temp_surface as Surface ptr) as Surface ptr
if src->surf then return src->surf
'Correct but slower:
'dim src_surface as Surface ptr
'if gfx_surfaceCreateFrameView(src, @src_surface) then return
'Kludgy but faster, avoid a slow allocation:
if surfaceFrameShim(src, temp_surface) then return NULL
return temp_surface
end function
local sub frame_draw_internal(src as Frame ptr, masterpal() as RGBcolor, pal as Palette16 ptr = NULL, x as integer, y as integer, trans as bool = YES, dest as Frame ptr, opts as DrawOptions = def_drawoptions)
dim subtimer as TimerIDs
if gfx_op_timer.enabled then
'Doesn't matter that it may not actually be blended/transformed (eg. opacity = 0)
if opts.with_blending then
subtimer = TimerIDs.Blend
elseif opts.scale <> 1 then
subtimer = TimerIDs.Rotozoom
end if
subtimer = gfx_op_timer.substart(subtimer)
end if
if (src->surf andalso src->surf->format <> SF_8bit) orelse _
(dest->surf andalso dest->surf->format <> SF_8bit) then
' Have to use gfx_surfaceCopy, so translate everything to Surfaces
BUG_IF(opts.scale <> 1, "scale not supported with 32-bit Frames")
dim as Surface tempsrc_surface = any, tempdest_surface = any
dim src_surface as Surface ptr = surface_shim(src, @tempsrc_surface)
dim dest_surface as Surface ptr = surface_shim(dest, @tempdest_surface)
if src_surface = 0 orelse dest_surface = 0 then return
/'
dim master_pal as RGBPalette ptr
if src_surface->format = SF_8bit then
' From 8 -> 32 bit
' This is slow, performs an allocation and copy!
' (Can use masterpal_to_gfxpal instead)
if gfx_paletteFromRGB(@masterpal(0), @master_pal) then
debug "gfx_paletteFromRGB failed"
goto cleanup
end if
end if
'/
draw_clipped_surf src_surface, @masterpal(0), pal, x, y, trans, dest, dest_surface, opts
/'
cleanup:
if master_pal then
gfx_paletteDestroy(@master_pal)
end if
if src->surf = NULL then
gfx_surfaceDestroy(@src_surface)
end if
'/
else
if opts.scale <> 1 then
BUG_IF(src->surf orelse dest->surf, "32-bit Frames don't support scale<>1")
draw_clipped_scaled src, pal, x, y, trans, dest, opts
else
draw_clipped src, pal, x, y, trans, dest, opts
end if
end if
if subtimer then gfx_op_timer.substop subtimer
end sub
' Draw a Frame with position and transformation specified by an AffineTransform.
' Supports 8 & 32-bit Frames, including alpha channels. (Respects opts.alpha_channel.)
' Supports opts.with_blending, opts.blend_mode, and opts.argbModifier in addition to opts.opacity.
' Does not support masks on 8-bit Frames, or color_key0 on 32-bit Frames.
' Does not support opts.alpha_channel=NO when using opacity/argbModifier.a or vertex alpha.
' Optionally, can pass in an array of 4 colours (clockwise from bottomleft) to interpolate
' colour (and alpha) modulation across the image.
sub frame_draw_transformed(src as Frame ptr, masterpal() as RGBcolor, pal as Palette16 ptr = NULL, transf as AffineTransform, trans as bool = YES, dest as Frame ptr, opts as DrawOptions = def_drawoptions, vertex_cols as RGBcolor ptr = NULL)
dim vertices(3) as VertexPT
'Clockwise from bottom-left
vertices(0).tex.u = 0
vertices(0).tex.v = 1
vertices(1).tex.u = 0
vertices(1).tex.v = 0
vertices(2).tex.u = 1
vertices(2).tex.v = 0
vertices(3).tex.u = 1
vertices(3).tex.v = 1
with transf
'Shift vertices slightly to avoid almost-horizontal or -vertical edges
'cutting through going exactly through a row/column of pixel centers,
'which causes artifacts (not a rasterizer bug, will happen in OpenGL too)
vertices(0).pos = .bottomleft - 0.01
vertices(1).pos = .topleft - 0.01
vertices(2).pos = .topright - 0.01
'vertices(3).pos = .bottomright - 0.01
vertices(3).pos = XYF(.bottomleft.x + (.topright.x - .topleft.x), .bottomleft.y + (.topright.y - .topleft.y))
end with
'Get Surface shims around Frames as needed
dim as Surface tempsrc_surface = any, tempdest_surface = any
dim src_surface as Surface ptr = surface_shim(src, @tempsrc_surface)
dim dest_surface as Surface ptr = surface_shim(dest, @tempdest_surface)
if src_surface = 0 orelse dest_surface = 0 then return
'Convert from pal (which may be NULL) to a 256-color palette
dim gfxpal as RGBPalette ptr = unrollPalette16(pal, @masterpal(0))
dim byref cliprect as ClipState = get_cliprect(dest)
dim destrect as SurfaceRect = (cliprect.l, cliprect.t, cliprect.r, cliprect.b)
opts.color_key0 = trans 'Can clobber def_drawoptions.color_key0, so we reset it after drawing
if opts.with_blending andalso opts.argbModifier.col <> &hffffffff andalso vertex_cols = NULL then
'gfx_renderQuadTexture doesn't support argbModifier
static white(3) as RGBcolor = {(-1), (-1), (-1), (-1)}
vertex_cols = @white(0)
'(Possible optimisation: if only argbModifier.a is set, set opts.opacity instead)
end if
if vertex_cols then
dim ptcvertices(3) as VertexPTC
for i as integer = 0 to 3
ptcvertices(i).tex = vertices(i).tex
ptcvertices(i).pos = vertices(i).pos
ptcvertices(i).col = vertex_cols[i]
next
gfx_renderQuadTextureColor(@ptcvertices(0), src_surface, gfxpal, @destrect, dest_surface, @opts)
else
gfx_renderQuadTexture(@vertices(0), src_surface, gfxpal, @destrect, dest_surface, @opts)
end if
def_drawoptions.color_key0 = NO
end sub
' Draw a paralleogram with a colour gradient between its corners.
' Supports opts.with_blending, opts.blend_mode, and opts.argbModifier in addition to opts.opacity
' opts.alpha_channel ignored.
sub rectangle_transformed(cols() as RGBcolor, transf as AffineTransform, dest as Frame ptr, opts as DrawOptions = def_drawoptions)
BUG_IF(ubound(cols) <> 3, "expect 4 colors")
dim vertices(3) as VertexPC
'Clockwise from bottom-left
with transf
vertices(0).pos = .bottomleft - 0.01
vertices(1).pos = .topleft - 0.01
vertices(2).pos = .topright - 0.01
'vertices(3).pos = .bottomright - 0.01
vertices(3).pos = XYF(.bottomleft.x + (.topright.x - .topleft.x), .bottomleft.y + (.topright.y - .topleft.y))
end with
for i as integer = 0 to 3
vertices(i).col = cols(i)
next
'Get Surface shims around Frames as needed
dim as Surface tempdest_surface = any
dim dest_surface as Surface ptr = surface_shim(dest, @tempdest_surface)
if dest_surface = 0 then return
dim byref cliprect as ClipState = get_cliprect(dest)
dim destrect as SurfaceRect = (cliprect.l, cliprect.t, cliprect.r, cliprect.b)
gfx_renderQuadColor(@vertices(0), @destrect, dest_surface, @opts)
end sub
'Calculate an AffineTransform of a slice of given 'size' by first stretching by 'zoom',
'then rotating `angle` degrees clockwise about `center` (defaults of center of `size`),
'then translating by `pos`. (Does NOT support RelPosXY)
'This can achieve any affine transform.
'(The Float2 args are passed byref but not modified)
sub rotozoom_transform(byref result as AffineTransform, size as XYPair, center as Float2 ptr = NULL, pos as Float2, angle as double, zoom as Float2)
dim _center as Float2 = any
if center = NULL then
_center = XYF(size.x / 2, size.y / 2)
center = @_center
end if
dim vertices(3) as Float2
vec2GenerateCorners @vertices(0), 4, size, *center
dim matrix as Float3x3
matrixLocalTransform @matrix, angle * -M_PI / 180, zoom, pos
'Only first 3 vertices
vec2Transform @result.vertices(0), 3, @vertices(0), 3, matrix
end sub
'Return a copy of a single Frame or a Frame array, each frame clipped or extended.
'Extended portions are filled with bgcol.
'Can also be used to scroll (does not wrap around)
'Turns an 8-bit Surface-backed Frame into a regular Frame, and works on 32-bit Surface-backed ones too.
'Like all functions that return new Frames, the new Frame doesn't have a SpriteSet ptr (see copy_spriteset_data)
function frame_resized(spr as Frame ptr, wide as integer, high as integer, shiftx as integer = 0, shifty as integer = 0, bgcol as integer = 0) as Frame ptr
dim as Frame ptr ret
dim with_surface32 as bool = (spr->surf <> NULL andalso spr->surf->format = SF_32bit)
ret = frame_new(wide, high, spr->arraylen, NO, (spr->mask <> NULL), with_surface32)
dim opts as DrawOptions
opts.write_mask = YES
for fridx as integer = 0 to spr->arraylen - 1
frame_clear @ret[fridx], bgcol
frame_draw @spr[fridx], NULL, shiftx, shifty, NO, @ret[fridx], opts
ret[fridx].frameid = spr[fridx].frameid
next
return ret
end function
'Scale a Frame to given size. Returns a 32-bit Surface-backed Frame.
'masterpal() only used if src is 8-bit. pal can be NULL.
function frame_scaled32(src as Frame ptr, wide as integer, high as integer, masterpal() as RGBcolor, pal as Palette16 ptr = NULL) as Frame ptr
dim as Surface ptr src_surface, temp
if src->surf then
src_surface = src->surf
else
src_surface = frame_to_surface32(src, masterpal(), pal)
end if
temp = surface_scale(src_surface, wide, high)
if src->surf = NULL then
gfx_surfaceDestroy(@src_surface)
end if
dim ret as Frame ptr = frame_with_surface(temp)
gfx_surfaceDestroy(@temp)
return ret
end function
function dissolve_type_caption(n as integer) as string
select case n
case 0: return "Random scatter"
case 1: return "Crossfade"
case 2: return "Diagonal Vanish"
case 3: return "Sink into Ground"
case 4: return "Squash"
case 5: return "Melt"
case 6: return "Vaporize"
case 7: return "Phase out"
case 8: return "Squeeze"
case 9: return "Shrink"
case 10: return "Flicker"
case 11: return "Shrink to Center"
case 12: return "Fade"
case 13: return "Ghostly fade"
case 14: return "Fade to white"
case 15: return "Puff"
case 16: return "Fade up"
case 17: return "Blip"
case else: return n & " Invalid!"
end select
end function
function appear_type_caption(n as integer) as string
'These are names for the inverted dissolve animations.
'They should only differ where the dissolve name doesn't make sense backwards
select case n
case 0: return "Random scatter"
case 1: return "Crossfade"
case 2: return "Diagonal Appear"
case 3: return "Rise from Ground"
case 4: return "Un-Squash"
case 5: return "Un-Melt"
case 6: return "Un-Vaporize"
case 7: return "Phase In"
case 8: return "Un-Squeeze"
case 9: return "Expand"
case 10: return "Flicker"
case 11: return "Expand from Center"
case 12: return "Fade"
case 13: return "Ghostly fade"
case 14: return "Fade from white"
case 15: return "Puff"
case 16: return "Fade down"
case 17: return "Blip"
case else: return n & " Invalid!"
end select
end function
'Public:
' Returns a copy of a sprite in the midst of a given fade or distort effect.
' This only supports a subset of effects; frame_draw_dissolved should normally be used instead.
' Note that the result has a mask, which is very unusual for Frames.
' tlength is the desired length of the transition (in any time units you please),
' t is the number of elasped time units. style is the specific transition.
function frame_dissolved(spr as Frame ptr, tlength as integer, t as integer, style as integer) as Frame ptr
CHECK_FRAME_8BIT(spr, NULL)
'Return a blank sprite of same size
'(Note that Vapourise and Phase Out aren't blank on t==tlength, while others are, unless tlength=0
if t > tlength then return frame_duplicate(spr, YES)
'Return copy. (Actually Melt otherwise has very slight distortion on frame 0.)
if t <= 0 then return frame_duplicate(spr)
'by default, sprites use colourkey transparency instead of masks.
'We could easily not use a mask here, but by using one, this function can be called on 8-bit graphics
'too; just in case you ever want to fade out a backdrop or something?
dim startblank as bool = (style = 8 or style = 9 or style = 11)
dim cpy as Frame ptr
cpy = frame_duplicate(spr, startblank, YES) 'addmask = YES
if cpy = 0 then return 0
dim as integer i, j, sx, sy, tog
select case style
case 0 'scattered pixel dissolve
dim prng_state as unsigned integer = cpy->w * tlength
dim cutoff as unsigned integer = 2 ^ 20 * t / (tlength - 0.5)
for sy = 0 to cpy->h - 1
dim mptr as ubyte ptr = @cpy->mask[sy * cpy->pitch]
for sx = 0 to cpy->w - 1
prng_state = (prng_state * 1103515245 + 12345)
if (prng_state shr 12) < cutoff then
mptr[sx] = 0
end if
next
next
case 1 'crossfade
'interesting idea: could maybe replace all this with calls to generalised fuzzyrect
dim m as integer = cpy->w * cpy->h * t * 2 / tlength
dim mptr as ubyte ptr
dim xoroff as integer = 0
if t > tlength / 2 then
'after halfway mark: checker whole sprite, then checker the remaining (with tog xor'd 1)
for sy = 0 to cpy->h - 1
mptr = cpy->mask + sy * cpy->pitch
tog = sy and 1
for sx = 0 to cpy->w - 1
tog = tog xor 1
if tog then mptr[sx] = 0
next
next
xoroff = 1
m = cpy->w * cpy->h * (t - tlength / 2) * 2 / tlength
end if
'checker the first m pixels of the sprite
for sy = 0 to cpy->h - 1
mptr = cpy->mask + sy * cpy->pitch
tog = (sy and 1) xor xoroff
for sx = 0 to cpy->w - 1
tog = tog xor 1
if tog then mptr[sx] = 0
m -= 1
if m <= 0 then exit for, for
next
next
case 2 'diagonal vanish
i = cpy->w * t * 2 / tlength
j = i
for sy = 0 to i
j = i - sy
if sy >= cpy->h then exit for
for sx = 0 to j
if sx >= cpy->w then exit for
cpy->mask[sy * cpy->pitch + sx] = 0
next
next
case 3 'sink into ground
dim fall as integer = cpy->h * t / tlength
for sy = cpy->h - 1 to 0 step -1
if sy < fall then
memset(cpy->mask + sy * cpy->pitch, 0, cpy->w)
else
memcpy(cpy->image + sy * cpy->pitch, cpy->image + (sy - fall) * cpy->pitch, cpy->w)
memcpy(cpy->mask + sy * cpy->pitch, cpy->mask + (sy - fall) * cpy->pitch, cpy->w)
end if
next
case 4 'squash
for i = cpy->h - 1 to 0 step -1
dim desty as integer = cpy->h * (t / tlength) + i * (1 - t / tlength)
desty = bound(desty, 0, cpy->h - 1)
if desty > i then
memcpy(cpy->image + desty * cpy->pitch, cpy->image + i * cpy->pitch, cpy->w)
memcpy(cpy->mask + desty * cpy->pitch, cpy->mask + i * cpy->pitch, cpy->w)
memset(cpy->mask + i * cpy->pitch, 0, cpy->w)
end if
next
case 5 'melt
'height and meltmap are fixed point, with 8 bit fractional parts
'(an attempt to speed up this dissolve, which is 10x slower than most of the others!)
'the current height of each column above the base of the frame
dim height(-1 to cpy->w) as integer
dim meltmap(cpy->h - 1) as integer
for i = 0 to cpy->h - 1
'Gompertz sigmoid function, exp(-exp(-x))
'this is very close to 1 when k <= -1.5
'and very close to 0 when k >= 1.5
'so decreases down to 0 with increasing i (height) and t
'meltmap(i) = exp(-exp(-7 + 8.5*(t/tlength) + (-cpy->h + i))) * 256
meltmap(i) = exp(-exp(-8 + 10*(t/tlength) + 6*(i/cpy->h))) * 256
next
dim poffset as integer = (cpy->h - 1) * cpy->pitch
dim destoff as integer
for sy = cpy->h - 1 to 0 step -1
for sx = 0 to cpy->w - 1
destoff = (cpy->h - 1 - (height(sx) shr 8)) * cpy->pitch + sx
'if sx = 24 then
'debug sy & " mask=" & cpy->mask[poffset + sx] & " h=" & height(sx)/256 & " dest=" & (destoff\cpy->pitch) & " " & t/tlength
'end if
'potentially destoff = poffset + sx
dim temp as integer = cpy->mask[poffset + sx]
cpy->mask[poffset + sx] = 0
cpy->image[destoff] = cpy->image[poffset + sx]
cpy->mask[destoff] = temp
if temp then
height(sx) += meltmap(height(sx) shr 8)
else
'empty spaces melt quicker, for flop down of hanging swords,etc
'height(sx) += meltmap(height(sx)) * (1 - t/tlength)
'height(sx) += meltmap((height(sx) shr 8) + 16)
height(sx) += meltmap(sy)
end if
next
poffset -= cpy->pitch
'mix together adjacent heights so that hanging pieces don't easily disconnect
height(-1) = height(0)
height(cpy->w) = height(cpy->w - 1)
for sx = (sy mod 3) to cpy->w - 1 step 3
height(sx) = height(sx - 1) \ 4 + height(sx) \ 2 + height(sx + 1) \ 4
next
next
case 6 'vaporize
'vapoury is the bottommost vapourised row
dim vapoury as integer = (cpy->h - 1) * (t / tlength)
dim vspeed as integer = large(cint(cpy->h / tlength), 1)
for sx = 0 to cpy->w - 1
dim chunklength as integer = randint(vspeed + 5)
for i = -2 to 9999
if rando() < 0.3 then exit for
next
dim fragy as integer = large(vapoury - large(i, 0) - (chunklength - 1), 0)
'position to copy fragment from
dim chunkoffset as integer = large(vapoury - (chunklength - 1), 0) * cpy->pitch + sx
dim poffset as integer = sx
for sy = 0 to vapoury
if sy >= fragy and chunklength <> 0 then
cpy->image[poffset] = cpy->image[chunkoffset]
cpy->mask[poffset] = cpy->mask[chunkoffset]
chunkoffset += cpy->pitch
chunklength -= 1
else
cpy->mask[poffset] = 0
end if
poffset += cpy->pitch
next
next
case 7 'phase out
dim fall as integer = 1 + (cpy->h - 2) * (t / tlength) 'range 1 to cpy->h-1
'blank out top of sprite
for sy = 0 to fall - 2
memset(cpy->mask + sy * cpy->pitch, 0, cpy->w)
next
for sx = 0 to cpy->w - 1
dim poffset as integer = sx + fall * cpy->pitch
'we stretch the two pixels at the vapour-front up some factor
dim beamc1 as integer = -1
dim beamc2 as integer = -1
if cpy->mask[poffset] then beamc1 = cpy->image[poffset]
if cpy->mask[poffset - cpy->pitch] then beamc2 = cpy->image[poffset - cpy->pitch]
if beamc1 = -1 then continue for
for sy = fall to large(fall - 10, 0) step -1
cpy->image[poffset] = beamc1
cpy->mask[poffset] = 1
poffset -= cpy->pitch
next
if beamc2 = -1 then continue for
for sy = sy to large(sy - 10, 0) step -1
cpy->image[poffset] = beamc2
cpy->mask[poffset] = 1
poffset -= cpy->pitch
next
next
case 8 'squeeze (horizontal squash)
dim destx(spr->w - 1) as integer
for sx = 0 to spr->w - 1
destx(sx) = sx * (1 - t / tlength) + 0.5 * (spr->w - 1) * (t / tlength)
next
for sy = 0 to spr->h - 1
dim destimage as ubyte ptr = cpy->image + sy * cpy->pitch
dim destmask as ubyte ptr = cpy->mask + sy * cpy->pitch
dim srcmask as ubyte ptr = iif(spr->mask, spr->mask, spr->image)
dim poffset as integer = sy * cpy->pitch
for sx = 0 to spr->w - 1
destimage[destx(sx)] = spr->image[poffset]
destmask[destx(sx)] = srcmask[poffset]
poffset += 1
next
next
case 9 'shrink (horizontal+vertical squash) centered on bottom center
dim destx(spr->w - 1) as integer
for sx = 0 to spr->w - 1
destx(sx) = sx * (1 - t / tlength) + 0.5 * (spr->w - 1) * (t / tlength)
next
for sy = 0 to spr->h - 1
dim desty as integer = sy * (1 - t / tlength) + (spr->h - 1) * (t / tlength)
dim destimage as ubyte ptr = cpy->image + desty * cpy->pitch
dim destmask as ubyte ptr = cpy->mask + desty * cpy->pitch
dim srcmask as ubyte ptr = iif(spr->mask, spr->mask, spr->image)
dim poffset as integer = sy * cpy->pitch
for sx = 0 to spr->w - 1
destimage[destx(sx)] = spr->image[poffset]
destmask[destx(sx)] = srcmask[poffset]
poffset += 1
next
next
case 10 'flicker
dim state as integer = 0
dim ctr as integer 'percent
for i = 0 to t
dim cutoff as integer = 60 * (1 - i / tlength) + 25 * (i / tlength)
dim inc as integer = 60 * i / tlength
ctr += inc
if ctr > cutoff then
i += ctr \ cutoff 'length of gaps increases
if i > t then state = 1
ctr = ctr mod 100
end if
next
if state then frame_clear(cpy)
case 11 'shrink (horizontal+vertical squash) centered
dim destx(spr->w - 1) as integer
for sx = 0 to spr->w - 1
destx(sx) = sx * (1 - t / tlength) + 0.5 * (spr->w - 1) * (t / tlength)
next
for sy = 0 to spr->h - 1
dim desty as integer = sy * (1 - t / tlength) + 0.5 * (spr->h - 1) * (t / tlength)
dim destimage as ubyte ptr = cpy->image + desty * cpy->pitch
dim destmask as ubyte ptr = cpy->mask + desty * cpy->pitch
dim srcmask as ubyte ptr = iif(spr->mask, spr->mask, spr->image)
dim poffset as integer = sy * cpy->pitch
for sx = 0 to spr->w - 1
destimage[destx(sx)] = spr->image[poffset]
destmask[destx(sx)] = srcmask[poffset]
poffset += 1
next
next
case else
debug "frame_dissolved: unsupported effect " & style
end select
return cpy
end function
'Draw a Frame with a dissolve/distort effect.
'This supports all effects, unlike frame_dissolved.
sub frame_draw_dissolved (src as Frame ptr, pal as Palette16 ptr = NULL, x as RelPos, y as RelPos, trans as bool = YES, dest as Frame ptr, opts as DrawOptions = def_drawoptions, tlength as integer, tick as integer, style as integer)
'Trivial cases
if tick > tlength then exit sub
if tick <= 0 then
frame_draw src, pal, x, y, trans, dest, opts
exit sub
end if
dim fadeopts as DrawOptions
fadeopts.with_blending = YES
fadeopts.blend_mode = blendModeNormal
dim max_opacity as double = 1.
if opts.with_blending then
'We respect the baseline opts.opacity and blend_mode
max_opacity = opts.opacity
fadeopts.blend_mode = opts.blend_mode
end if
'Should just pass other drawoptions on, though the combination hasn't necessarily been tested
'(FIXME: when opts.scale <> 1., we need to adjust dissolves that offset the sprite)
fadeopts.scale = opts.scale
fadeopts.write_mask = opts.write_mask
dim tfrac as double = tick / tlength
select case style
case 12 'Fade out
fadeopts.opacity = max_opacity * (1 - tfrac)
frame_draw src, pal, x, y, trans, dest, fadeopts
case 13 'Ghost fade
'Fade out (normal blending) 100% to 0% at half time
dim t_to_halfway as double = 1. - tick / (tlength / 2.) 'Goes from 1 to -1
if t_to_halfway > 0. then
fadeopts.opacity = max_opacity * t_to_halfway
frame_draw src, pal, x, y, trans, dest, fadeopts
end if
'...while also fade in (add blending) from 0% to 100% at half time to 0%
fadeopts.opacity = max_opacity * (1 - abs(t_to_halfway))
fadeopts.blend_mode = blendModeAdd
frame_draw src, pal, x, y, trans, dest, fadeopts
case 14 'Fade to white
FAIL_IF(pal = NULL, "Fade through white needs palette")
dim white as RGBcolor
if fadeopts.blend_mode = blendModeMultiply then
'Special case, fading to white would do nothing, so fade to black
else
white.col = &hffffffff
end if
dim fadepal as Palette16 ptr = palette16_duplicate(pal)
Palette16_mix_n_match fadepal, white, small(1., tfrac * 2), mixBlend
fadeopts.opacity = max_opacity * bound(2. - tfrac * 2, 0., 1.)
frame_draw src, fadepal, x, y, trans, dest, fadeopts
palette16_unload @fadepal
case 15, 16 'Puff, Fade Up
'Zoom out at same time as fading out
dim as double zoomx = 1., zoomy = 1.
if style = 15 then
zoomx = 1. + 0.6 * tfrac ^ 0.5
zoomy = zoomx
else
zoomy = 1. + 1.2 * tfrac ^ 2
end if
dim scaled as Frame ptr = frame_rotozoom(src, pal, 0, zoomx, zoomy)
'Recenter
fadeopts.opacity = 1 - tfrac
if style = 15 then
x += (src->w - scaled->w) / 2
y += 3 * (src->h - scaled->h) / 4
fadeopts.opacity ^= 2
else
y += (src->h - scaled->h)
end if
fadeopts.opacity *= max_opacity
frame_draw scaled, pal, x, y, trans, dest, fadeopts
frame_unload @scaled
case 17 'Blip
dim as double zoomx = 1., zoomy = 1.
zoomx = (1 - tfrac) ^ 2
zoomy = 2. - (1 - tfrac ^ 2)
dim scaled as Frame ptr = frame_rotozoom(src, pal, 0, zoomx, zoomy)
x += (src->w - scaled->w) / 2
y += 5 * (src->h - scaled->h) / 4 'move upwards slightly
frame_draw scaled, pal, x, y, trans, dest, opts
frame_unload @scaled
case else
dim dissolved as Frame ptr
dissolved = frame_dissolved(src, tlength, tick, style)
frame_draw dissolved, pal, x, y, trans, dest, opts
frame_unload @dissolved
end select
end sub
'Warning: this is used ONLY for battle appear/death animations, it is NOT used by
'dissolving slices set to default dissolve length! (They use (w+h)/10)
function default_dissolve_time(style as integer, w as integer, h as integer) as integer
select case style
case 4, 6, 7, 8, 9, 11, 15, 16
'squash, vapourise, phase out, squeeze, shrink, shrink centered, puff, fade up
return w / 5
case 12 'fade
return w / 4
case 13, 14 'ghost fade, fade to white
return w / 3
case 17 'blip
return 9
case else
return w / 2
end select
end function
'Returns a scaled+rotated copy.
'See also rotozoom_transform + frame_draw_transformed.
'Note: Frame masks are not supported, so can't rotate a dissolved sprite
function frame_rotozoom(src as Frame ptr, pal as Palette16 ptr = NULL, angle as double, zoomx as double, zoomy as double, smooth as integer = 0) as Frame ptr
dim as Surface ptr in_surf, out_surf
dim as Surface temp_surf = any
if smooth > 0 andalso vpages_are_32bit then
'Going to perform smoothing
'Can't do any smoothing with an 8-bit input Surface, since the rotozoomer
'doesn't do 8->32 bit like frame_draw can.
in_surf = frame_to_surface32(src, curmasterpal(), pal)
else
'Correct but slower:
'if gfx_surfaceCreateFrameView(src, @in_surf) then return NULL
'Kludgy but faster, avoid a slow allocation:
in_surf = @temp_surf
if surfaceFrameShim(src, in_surf) then return NULL
'We can call gfx_surfaceDestroy on in_surf, it will do nothing.
end if
if smooth = 2 andalso vpages_are_32bit then
'surface_scale does much better smoothing for zoom levels < 100% (neglible
'difference at zoom > 100%), but it's slower and doesn't support rotation.
'Dest size axes must be >= 1
out_surf = surface_scale(in_surf, large(1., src->w * zoomx), large(1., src->h * zoomy))
else
'Bilinear interpolation or no smoothing
'Negate rotation so angle is clockwise
out_surf = rotozoomSurface(in_surf, angle, zoomx, zoomy, smooth)
end if
BUG_IF(out_surf = NULL, "rotozoom returned NULL", NULL)
dim ret as Frame ptr = frame_with_surface(out_surf)
gfx_surfaceDestroy(@in_surf)
gfx_surfaceDestroy(@out_surf)
return ret
end function
'Used by frame_flip_horiz and frame_flip_vert
local sub flip_image(pixels as ubyte ptr, d1len as integer, d1stride as integer, d2len as integer, d2stride as integer)
for x1 as integer = 0 to d1len - 1
dim as ubyte ptr pixelp = pixels + x1 * d1stride
for offset as integer = (d2len - 1) * d2stride to 0 step -2 * d2stride
dim as ubyte temp = pixelp[0]
pixelp[0] = pixelp[offset]
pixelp[offset] = temp
pixelp += d2stride
next
next
end sub
'not-in-place isometric transformation of a pixel buffer
'dimensions/strides of source is taken from src, but srcpixels specifies the actual pixel buffer
'destorigin points to the pixel in the destination buffer where the pixel at the (top left) origin should be put
local sub transform_image(src as Frame ptr, srcpixels as ubyte ptr, destorigin as ubyte ptr, d1stride as integer, d2stride as integer)
for y as integer = 0 to src->h - 1
dim as ubyte ptr sptr = srcpixels + y * src->pitch
dim as ubyte ptr dptr = destorigin + y * d1stride
for x as integer = 0 to src->w - 1
*dptr = sptr[x]
dptr += d2stride
next
next
end sub
'Public:
' flips a sprite horizontally. In place: you are only allowed to do this on sprites with no other references
sub frame_flip_horiz(spr as Frame ptr)
if spr = 0 then exit sub
CHECK_FRAME_8BIT(spr)
BUG_IF(spr->refcount > 1, "illegal when refc>1")
flip_image(spr->image, spr->h, spr->pitch, spr->w, 1)
if spr->mask then
flip_image(spr->mask, spr->h, spr->pitch, spr->w, 1)
end if
end sub
'Public:
' flips a sprite vertically. In place: you are only allowed to do this on sprites with no other references
sub frame_flip_vert(spr as Frame ptr)
if spr = 0 then exit sub
CHECK_FRAME_8BIT(spr)
BUG_IF(spr->refcount > 1, "illegal when refc>1")
flip_image(spr->image, spr->w, 1, spr->h, spr->pitch)
if spr->mask then
flip_image(spr->mask, spr->w, 1, spr->h, spr->pitch)
end if
end sub
'90 degree (anticlockwise) rotation.
'Unlike flipping functions, not inplace!
function frame_rotated_90(spr as Frame ptr) as Frame ptr
if spr = 0 then return NULL
CHECK_FRAME_8BIT(spr, NULL)
dim ret as Frame ptr = frame_new(spr->h, spr->w, 1, (spr->mask <> NULL))
'top left corner transformed to bottom left corner
transform_image(spr, spr->image, ret->image + ret->pitch * (ret->h - 1), 1, -ret->pitch)
if spr->mask <> NULL then
transform_image(spr, spr->mask, ret->mask + ret->pitch * (ret->h - 1), 1, -ret->pitch)
end if
return ret
end function
'270 degree (anticlockwise) rotation, ie 90 degrees clockwise.
'Unlike flipping functions, not inplace!
function frame_rotated_270(spr as Frame ptr) as Frame ptr
if spr = 0 then return NULL
CHECK_FRAME_8BIT(spr, NULL)
dim ret as Frame ptr = frame_new(spr->h, spr->w, 1, (spr->mask <> NULL))
'top left corner transformed to top right corner
transform_image(spr, spr->image, ret->image + (ret->w - 1), -1, ret->pitch)
if spr->mask <> NULL then
transform_image(spr, spr->mask, ret->mask + (ret->w - 1), -1, ret->pitch)
end if
return ret
end function
'Note that we clear masks to transparent! I'm not sure if this is best (not currently used anywhere), but notice that
'frame_duplicate with clr=1 does the same
sub frame_clear(spr as Frame ptr, colour as integer = 0)
if spr->surf then
gfx_surfaceFill(curmasterpal(colour).col, NULL, spr->surf)
exit sub
end if
if spr->image then
if spr->w = spr->pitch then
memset(spr->image, colour, spr->w * spr->h)
else
for i as integer = 0 to spr->h - 1
memset(spr->image + i * spr->pitch, colour, spr->w)
next
end if
end if
if spr->mask then
if spr->w = spr->pitch then
memset(spr->mask, 0, spr->w * spr->h)
else
for i as integer = 0 to spr->h - 1
memset(spr->mask + i * spr->pitch, 0, spr->w)
next
end if
end if
end sub
'Warning: this code is rotting; don't assume ->mask is used, etc. Anyway the whole thing should be replaced with a memmove call or two.
' function frame_scroll(spr as Frame ptr, h as integer = 0, v as integer = 0, wrap as bool = NO, direct as bool = NO) as Frame ptr
' CHECK_FRAME_8BIT(spr, NULL)
'
' dim ret as Frame ptr, x as integer, y as integer
'
' ret = frame_clear(spr, -1)
'
' 'first scroll horizontally
'
' if h <> 0 then
' if h > 0 then
' for y = 0 to spr->h - 1
' for x = spr->w - 1 to h step -1
' ret->image[y * spr->h + x] = spr->image[y * spr->h - h + x]
' ret->mask[y * spr->h + x] = spr->mask[y * spr->h - h + x]
' next
' next
' if wrap then
' for y = 0 to spr->h - 1
' for x = 0 to h - 1
' ret->image[y * spr->h + x] = spr->image[y * spr->h + (x + spr->w - h)]
' ret->mask[y * spr->h + x] = spr->mask[y * spr->h + (x + spr->w - h)]
' next
' next
' end if
' else if h < 0 then
' for y = 0 to spr->h - 1
' for x = 0 to abs(h) - 1
' ret->image[y * spr->h + x] = spr->image[y * spr->h - h + x]
' ret->mask[y * spr->h + x] = spr->mask[y * spr->h - h + x]
' next
' next
' if wrap then
' for y = 0 to spr->h - 1
' for x = abs(h) to spr->w - 1
' ret->image[y * spr->h - h + x] = spr->image[y * spr->h + x]
' ret->mask[y * spr->h - h + x] = spr->mask[y * spr->h + x]
' next
' next
' end if
' end if
' end if
'
' 'then scroll vertically
'
' if v <> 0 then
'
' end if
'
' if direct then
' deallocate(spr->image)
' deallocate(spr->mask)
' spr->image = ret->image
' spr->mask = ret->mask
' ret->image = 0
' ret->mask = 0
' sprite_delete(@ret)
' return spr
' else
' return ret
' end if
' end function
/'
local sub grabrect(page as integer, x as integer, y as integer, w as integer, h as integer, ibuf as ubyte ptr, tbuf as ubyte ptr = 0)
'this isn't used anywhere anymore, was used to grab tiles from the tileset videopage before loadtileset
'maybe some possible future use?
'ibuf should be pre-allocated
dim sptr as ubyte ptr
dim as integer i, j, px, py, l
if ibuf = null then exit sub
CHECK_FRAME_8BIT(vpages(page))
sptr = vpages(page)->image
py = y
for i = 0 to h-1
px = x
for j = 0 to w-1
l = i * w + j
'ignore clip rect, but check screen bounds
if not (px < 0 or px >= vpages(page)->w or py < 0 or py >= vpages(page)->h) then
ibuf[l] = sptr[(py * vpages(page)->pitch) + px]
if tbuf then
if ibuf[l] = 0 then tbuf[l] = &hff else tbuf[l] = 0
end if
else
ibuf[l] = 0
tbuf[l] = 0
end if
px += 1
next
py += 1
next
end sub
'/
'==========================================================================================
' Palette16
'==========================================================================================
'Note that the palette cache works completely differently to the sprite cache:
'we simply load all palettes into memory. Each cache entry will have refcount 1 if it's unused.
redim shared palcache() as Palette16 ptr
local sub Palette16_delete(f as Palette16 ptr ptr)
if f = 0 then exit sub
if *f = 0 then exit sub
(*f)->refcount = FREEDREFC 'help detect double frees
delete *f
*f = 0
end sub
'Completely empty the Palette16 cache
local sub Palette16_empty_cache()
for idx as integer = 0 to ubound(palcache)
'Palettes in the cache but unused have refc=1
if palcache(idx) andalso palcache(idx)->refcount <> 1 then
debugc errBug, "Palette16 leak/bad refc: " & palette16_describe(palcache(idx))
palcache(idx) = NULL
else
Palette16_delete(@palcache(idx))
end if
next
erase palcache
end sub
'Create a new palette which is not connected to any data file
function Palette16_new(numcolors as integer = 16) as Palette16 ptr
dim ret as Palette16 ptr
ret = new Palette16
ret->numcolors = numcolors
ret->refcount = 1
ret->palnum = -1 'Uncached
return ret
end function
function Palette16_new_identity(numcolors as integer = 16) as Palette16 ptr
dim ret as Palette16 ptr = Palette16_new(numcolors)
for cidx as integer = 0 TO numcolors - 1
ret->col(cidx) = cidx
next
return ret
end function
'pal() is an array of master palette indices, to convert into a Palette16
function Palette16_new_from_indices(pal() as integer) as Palette16 ptr
BUG_IF(ubound(pal) > 255, "Palette indices pal() too long!", NULL)
dim ret as Palette16 ptr = Palette16_new(ubound(pal) + 1)
for idx as integer = 0 to ubound(pal)
ret->col(idx) = pal(idx)
next
return ret
end function
'Loads and returns a palette from the current game (resolving -1 to default palette),
'returning a blank palette if it didn't exist.
'(Note that the blank palette isn't put in the cache, so if that palette is later
'added to the game, it won't auto-update.)
'autotype, spr: spriteset type and id, for default palette lookup.
function Palette16_load(num as integer, autotype as SpriteType = sprTypeInvalid, spr as integer = 0, expect_exists as bool = YES) as Palette16 ptr
if num <= -1 then
if autotype = sprTypeInvalid then
return 0
end if
num = getdefaultpal(autotype, spr)
'Returns num = -1 if the defpal file is missing
end if
if num >= 0 andalso num <= ubound(palcache) then
palcache(num)->refcount += 1
return palcache(num)
end if
if num >= 0 andalso expect_exists then
' Only bother to warn if a specific palette failed to load.
' Avoids debug noise when default palette load fails because of a non-existant defpal file
debug "failed to load palette " & num
end if
' Is it a problem that this isn't put in the cache, so you can load
' this palette multiple times and get different ptrs?
return Palette16_new()
end function
'Open a .PAL file and pass back file handle, number of palettes, header size.
'Returns true on success.
local function open_pal_and_read_header(fname as string, byref fh as integer, byref numpalettes as integer, byref headersize as integer) as bool
if openfile(fname, for_binary + access_read + or_error, fh) then return NO
dim mag as short
get #fh, 1, mag
if mag = 4444 then
' File is in new file format
headersize = 16
get #fh, , mag
numpalettes = mag + 1
if LOF(fh) <> 16 + 16 * numpalettes then
debug "Mismatched .pal header (last=" & mag & ") and size " & LOF(fh)
end if
else
' .pal file is still in ancient BSAVE format, with exactly 100
' palettes. This shouldn't happen because upgrade() upgrades it.
' Skip 7-byte BSAVE header.
headersize = 7
numpalettes = 100
end if
return YES
end function
'Load all palettes into the cache that aren't already cached.
'(Using during live-previewing because it leaves in-use entries alone)
local sub palette16_fill_cache()
dim fh as integer
dim numpalettes as integer
dim headersize as integer
'If we haven't loaded a game, and data/defaultgfx isn't available, then there's nothing to load
dim fname as string = graphics_file("pal")
if len(fname) = 0 then exit sub
if open_pal_and_read_header(fname, fh, numpalettes, headersize) = NO then exit sub
seek #fh, 1 + headersize
if numpalettes >= 1 then
redim preserve palcache(large(ubound(palcache), numpalettes - 1))
for idx as integer = 0 to numpalettes - 1
if palcache(idx) = NULL then
seek #fh, 1 + headersize + 16 * idx
palcache(idx) = palette16_load_pal_single(fh)
palcache(idx)->palnum = idx
end if
next
end if
lazyclose fh
end sub
'Load all palettes into the cache, throwing out old cache if any.
sub palette16_reload_cache()
dim starttime as double = timer
palette16_empty_cache
palette16_fill_cache
debug_if_slow(starttime, 0.1, "")
end sub
'Loads and returns a palette from a .pal file. num can not be -1.
'Returns NULL if the palette doesn't exist!
function palette16_load_pal_uncached(fil as string, num as integer) as Palette16 ptr
BUG_IF(num < 0, "negative pal num", NULL)
dim fh as integer
dim numpalettes as integer
dim headersize as integer
if open_pal_and_read_header(fil, fh, numpalettes, headersize) = NO then return NULL
dim ret as Palette16 ptr
if num <= numpalettes - 1 then
seek #fh, 1 + headersize + 16 * num
ret = palette16_load_pal_single(fh)
end if
lazyclose fh
return ret
end function
local function palette16_load_pal_single(fh as integer) as Palette16 ptr
dim ret as Palette16 ptr = Palette16_new(16)
for idx as integer = 0 to 15
dim byt as ubyte
get #fh, , byt
ret->col(idx) = byt
next
return ret
end function
sub Palette16_unload(palptr as Palette16 ptr ptr)
if palptr = 0 then exit sub
dim pal as Palette16 ptr = *palptr
if pal = 0 then exit sub
if pal->refcount > 0 then
pal->refcount -= 1
end if
if pal->refcount <= 0 then
if pal->refcount < 0 orelse pal->palnum >= 0 then
'Cached palettes should never reach refc=0
showbug "Too many frees of " & palette16_describe(pal)
end if
if pal->palnum < 0 then
'Uncached palettes should be deleted when they are unloaded
Palette16_delete(palptr)
end if
end if
*palptr = 0
end sub
function Palette16_reference(pal as Palette16 ptr) as Palette16 ptr
if pal = NULL then return NULL
BUG_IF(pal->refcount <= 0, "Bad refc " & pal->refcount, NULL)
pal->refcount += 1
return pal
end function
function Palette16_duplicate(pal as Palette16 ptr) as Palette16 ptr
dim ret as Palette16 ptr = palette16_new(pal->numcolors)
for i as integer = 0 to ubound(pal->col)
ret->col(i) = pal->col(i)
next
'Result is uncached.
return ret
end function
'Update a palette in the cache (or add to the cache if missing) even while possibly in use.
'(Won't update localpal in a cached PrintStrState... but PrintStrState caching isn't implemented yet)
sub Palette16_update_cache(record as integer)
dim as Palette16 ptr oldpal, newpal
if record > ubound(palcache) then
palette16_fill_cache
else
oldpal = palcache(record)
newpal = palette16_load_pal_uncached(graphics_file("pal"), record)
'copy to old palette structure
dim as integer oldrefcount = oldpal->refcount
memcpy(oldpal, newpal, sizeof(Palette16))
oldpal->refcount = oldrefcount
oldpal->palnum = record
Palette16_delete(@newpal)
end if
end sub
function Palette16_describe(pal as Palette16 ptr) as string
if pal = 0 then return "'(null)'"
dim temp as string
temp = strprintf("<Palette16 num=%d numcolors=%d refc=%d ", pal->palnum, pal->numcolors, pal->refcount)
for idx as integer = 0 to pal->numcolors - 1
if idx then temp &= ","
temp &= hex(pal->col(idx))
next
return temp & ">"
end function
'Modifies a palette in-place, changing each color according to method, e.g. greyscale.
'Calculated using the master palette ignoring screen fades.
sub Palette16_transform_n_match(pal as Palette16 ptr, method as ColorOperator)
for idx as integer = 0 to pal->numcolors - 1
dim as integer r, g, b, temp
with curmasterpal(pal->col(idx))
if method = copLuminance then
'Best choice for converting to grey
r = .r * 0.3 + .g * 0.59 + .b * 0.11
g = r
b = r
elseif method = copValue then
'Just the value component of HSV, converted to grey
r = iif(.r > .g, .r, .g)
r = iif(r > .b, r, .b)
g = r
b = r
elseif method = copTintValue then
'Like copValue, but a produces a grey better suited for
'being tinted using Palette16_mix_n_match:
'only return 255 for pure white for better distrinctions,
'and don't return 0 to allow tinting black.
temp = iif(.r > .g, .r, .g)
temp = iif(temp > .b, temp, .b)
temp = (temp * 4 + .r + .g + .b + 255) \ 8
r = temp
g = temp
b = temp
end if
end with
pal->col(idx) = nearcolor_fast(r, g, b) 'Never 0
next
end sub
'Modifies a palette in-place, tinting it with a color
'Calculated using the master palette ignoring screen fades.
sub Palette16_mix_n_match(pal as Palette16 ptr, byval col as RGBcolor, colfrac as double, method as ColorMixMethod, scale as double = 1.0)
for idx as integer = 0 to pal->numcolors - 1
dim as integer mixr, mixg, mixb
with curmasterpal(pal->col(idx))
if method = mixBlend then
mixr = scale * .r * (1 - colfrac) + col.r * colfrac
mixg = scale * .g * (1 - colfrac) + col.g * colfrac
mixb = scale * .b * (1 - colfrac) + col.b * colfrac
elseif method = mixMult then
dim nonmult as double = 255 * (1 - colfrac)
mixr = scale * .r * (nonmult + col.r * colfrac) / 255
mixg = scale * .g * (nonmult + col.g * colfrac) / 255
mixb = scale * .b * (nonmult + col.b * colfrac) / 255
end if
end with
pal->col(idx) = nearcolor_fast(mixr, mixg, mixb) 'Never 0
next
end sub
'This is a faster alternative to gfx_paletteFromRGB. The result doesn't need to
'be deallocated with gfx_paletteDestroy (it's a noop).
'Very similar to surfaceFrameShim
'This exists mostly as a stub, in future we might just swap the whole engine to
'RGBPalette instead of RGBcolor FB arrays to avoid conversions.
function masterpal_to_gfxpal(pal() as RGBcolor) as RGBPalette ptr
BUG_IF(UBOUND(pal) < 256, "pal() should be length 257", NULL)
dim ret as RGBPalette ptr = cast(RGBPalette ptr, @pal(0))
ret->from_backend = NO
return ret
end function
'==========================================================================================
' SpriteSet
'==========================================================================================
'Find a frame in a frameset, returning frame index or -1.
'If the frame doesn't exist:
' exact = YES: return -1
' exact = NO: return the nearest match: the last frame in the same frame group, or -1 if an empty group
'frameset must be the first Frame in the frameset
function frameid_to_frame(frameset as Frame ptr, frameid as integer, exact as bool = NO) as integer
dim as integer lastid = -1, lastidx = -1
' Can assume arraylen > 0
for idx as integer = 0 to frameset->arraylen - 1
dim thisid as integer = frameset[idx].frameid
if thisid = frameid then
return idx
end if
' Frames are always in increasing order of ID
if thisid > frameid then exit for
lastid = thisid
lastidx = idx
next
if exact = NO then
if lastid \ 100 = frameid \ 100 then
return lastidx
end if
end if
return -1
end function
function num_frames_in_group(frameset as Frame ptr, group as integer) as integer
dim ret as integer = 0
for idx as integer = 0 to frameset->arraylen - 1
dim thisid as integer = frameset[idx].frameid
if thisid >= 100 * (group + 1) then
exit for
end if
if thisid >= 100 * group then
ret += 1
end if
next
return ret
end function
sub FrameGroupInfo.set(frameid as integer, name as string, default_num as integer)
this.frameid = frameid
this.name = name
this.default_num = default_num
end sub
' This should only be called from within allmodex
constructor SpriteSet(frameset as Frame ptr)
BUG_IF(frameset = NULL orelse frameset->arrayelem, "need first Frame in array")
BUG_IF(frameset->sprset, "Overwriting Frame->sprset ptr")
frames = frameset
frameset->sprset = @this
'No need to create animset until needed
end constructor
' This destructor isn't responsible for deleting this.frames (see how it's called in sprite_update_cache_range)
destructor SpriteSet()
animset_unload @animset
end destructor
function SpriteSet.num_frames() as integer
return frames->arraylen
end function
'Note that frame groups can be empty
function SpriteSet.last_frame_group() as integer
return frames[frames->arraylen - 1].frameid \ 100
end function
function SpriteSet.frame_starts_group(frameidx as integer) as bool
BUG_IF(frameidx >= frames->arraylen, "bad frameidx", NO)
return (frames[frameidx].frameid MOD 100) = 0
end function
function SpriteSet.get_animset() as AnimationSet ptr
if animset = NULL then
animset = new AnimationSet
animset->reference()
end if
return animset
end function
'Create a SpriteSet for a Frame array if it doesn't have one.
function spriteset_for_frame(fr as Frame ptr) as SpriteSet ptr
if fr->sprset then return fr->sprset
var ret = new SpriteSet(fr)
DEBUG_ANIM_CACHE(ret->name = "spriteset_for_frame")
return ret
end function
'Copy over (actually, share) animations.
'When modifying a Frame array that has a SpriteSet, most functions,
'e.g. frame_resized, don't copy the SpriteSet and you need this so the new
'sprite can be animated or saved to .rgfx.
'If from_sprite has animset=NULL, to_sprite's animset is not deleted.
sub copy_spriteset_data(to_sprite as Frame ptr, from_sprite as Frame ptr)
dim from_ss as SpriteSet ptr = from_sprite->sprset
if from_ss andalso from_ss->animset then
dim to_ss as SpriteSet ptr = spriteset_for_frame(to_sprite)
animset_unload @to_ss->animset
to_ss->animset = from_ss->animset->reference()
end if
end sub
sub copy_spriteset_frameids(to_sprite as Frame ptr, from_sprite as Frame ptr)
BUG_IF(to_sprite->arraylen <> from_sprite->arraylen, "mismatched Frame arrays")
for idx as integer = 0 to to_sprite->arraylen - 1
to_sprite[idx].frameid = from_sprite[idx].frameid
next
end sub
' Load the global animations for a sprtype from rgfx, or defaults if they don't exist.
' If loadinto=NULL, creates a new AnimationSet with .refcount=1, otherwise returns loadinto with its animations replaced.
local function spriteset_load_global_animations_uncached(sprtype as SpriteType, rgfxdoc as Doc ptr = NULL, loadinto as AnimationSet ptr = NULL) as AnimationSet ptr
dim ret as AnimationSet ptr
if rgfxdoc then
' Will create new if loadinto=NULL, unless animations missing
ret = rgfx_load_global_animations(rgfxdoc, loadinto)
else
rgfxdoc = rgfx_open(sprtype, NO)
if rgfxdoc then
ret = rgfx_load_global_animations(rgfxdoc, loadinto)
FreeDocument rgfxdoc
end if
end if
if ret = NULL then
if loadinto then
ret = loadinto
else
ret = new AnimationSet
' Result goes in the cache
ret->reference()
end if
spriteset_default_global_animations(*ret, sprtype)
end if
ret->name = sprite_sizes(sprtype).name & " global animations"
return ret
end function
' Load (with caching) the global animations (or defaults if they don't exist) for a sprtype.
' Increments the refcount. Use animset_unload to deref/free the result.
' If rgfxdoc is already open you can optionally pass it to avoid reloading.
function spriteset_load_global_animations(sprtype as SpriteType, rgfxdoc as Doc ptr = NULL) as AnimationSet ptr
dim ret as AnimationSet ptr
ret = spriteset_global_animations_cache(sprtype)
if ret then return ret->reference()
ret = spriteset_load_global_animations_uncached(sprtype, rgfxdoc)
DEBUG_ANIM_CACHE(? strprintf("load global_animations_cache(%d)", sprtype))
' ret has .refcount = 1
spriteset_global_animations_cache(sprtype) = ret
return ret->reference()
end function
' Called when updating the sprite cache. Updates the AnimationSet of global animations in-place
local sub update_spriteset_global_animations_cache(sprtype as SpriteType)
dim byref cached as AnimationSet ptr = spriteset_global_animations_cache(sprtype)
' If cached=NULL, creates a new AnimationSet with refc=1, otherwise returns cached with its animations replaced.
' If the animations don't exist, loads the defaults.
cached = spriteset_load_global_animations_uncached(sprtype, NULL, cached)
DEBUG_ANIM_CACHE(if cached then ? strprintf("update global_animations_cache(%d) refc=%d", sprtype, cached->refcount))
end sub
sub empty_spriteset_global_animations_cache()
for sprtype as SpriteType = lbound(spriteset_global_animations_cache) to ubound(spriteset_global_animations_cache)
var byref cached = spriteset_global_animations_cache(sprtype)
if cached andalso cached->refcount > 1 then
debugc errBug, strprintf("global_animations_cache(%d) leak with refc=%d", sprtype, cached->refcount)
end if
DEBUG_ANIM_CACHE(if cached then ? strprintf("empty_global_animations_cache(%d)", sprtype))
animset_unload @cached
next
end sub
' Load a spriteset from file, or return a reference if already cached.
' WARNING: Holding onto a SpriteSet ptr in Game while live previewing would currently crash if it's reloaded!
' This increments the refcount, use spriteset_unload to decrement it, NOT 'DELETE'.
function spriteset_load(ptno as SpriteType, record as integer) as SpriteSet ptr
' frame_load will load a Frame array with a corresponding SpriteSet
dim frameset as Frame ptr
frameset = frame_load(ptno, record)
if frameset = NULL then return NULL
return frameset->sprset
end function
' Decrement refcount and delete on zero.
sub spriteset_unload(pp as SpriteSet ptr ptr)
if *pp then
(*pp)->dereference()
*pp = NULL
end if
end sub
' Increment refcount.
function SpriteSet.reference() as SpriteSet ptr
if frames then
frame_reference frames
else
showbug "SpriteSet.reference(): no frames!"
end if
DEBUG_ANIM_CACHE(? "SpriteSet.reference(" & name & "): frames.refc=" & frames->refcount)
return @this
end function
' Recommended to call the spriteset_unload() wrapper instead.
' Exactly one of spriteset_unload/dereference or frame_unload should be called,
' since the two share the same refcount and lifetime.
sub SpriteSet.dereference()
' A SpriteSet and its Frame array are never unloaded separately;
' frame_unload is responsible for all refcounting and unloading
dim temp as Frame ptr = frames
DEBUG_ANIM_CACHE(? "SpriteSet.dereference(" & name & "): new frames.refc=" & frames->refcount - 1)
frame_unload @temp
end sub
function SpriteSet.describe() as string
return "spriteset:<" & num_frames & " frames: 0x" & hexptr(frames) _
& ", " & iif(animset, v_len(animset->animations), 0) & " animations>"
end function
'==========================================================================================
' Platform specific wrapper functions
'==========================================================================================
sub show_virtual_keyboard()
'Does nothing on platforms that have real keyboards
debuginfo "show_virtual_keyboard"
io_show_virtual_keyboard()
end sub
sub hide_virtual_keyboard()
'Does nothing on platforms that have real keyboards
debuginfo "hide_virtual_keyboard"
io_hide_virtual_keyboard()
end sub
sub show_virtual_gamepad()
'Does nothing on platforms that have real keyboards
io_show_virtual_gamepad()
end sub
sub hide_virtual_gamepad()
'Does nothing on platforms that have real keyboards
io_hide_virtual_gamepad()
end sub
sub remap_android_gamepad(player as integer, gp as GamePadMap)
'Does nothing on non-android non-ouya platforms
'debuginfo "remap_android_gamepad " & gp.Ud & " " & gp.Rd & " " & gp.Dd & " " & gp.Ld & " " & gp.A & " " & gp.B & " " & gp.X & " " & gp.Y & " " & gp.L1 & " " & gp.R1 & " " & gp.L2 & " " & gp.R2
io_remap_android_gamepad(player, gp)
end sub
sub remap_touchscreen_button (button_id as integer, ohr_scancode as integer)
'Does nothing on platforms without touch screens
'debuginfo "remap_android_gamepad " & button_id & " " & ohr_scancode
io_remap_touchscreen_button(button_id, ohr_scancode)
end sub
'Get data from platform (currently just Blackbox) environment, overridable with a config key for testing.
'Does NOT read environmental variables, use FB's environ() for that.
'The key is case-insensitive.
function read_environment_key(key as string) as string
dim ret as string
ret = read_config_str("env." & lcase(key), @CHR(1))
if ret = CHR(1) then
#ifdef __FB_BLACKBOX__
ret = *blackbox_get_environment(ucase(key))
#else
ret = ""
#endif
end if
return ret
end function
function running_on_console() as bool
'Currently supports OUYA, GameStick, Fire-TV
#IFDEF __FB_ANDROID__
static cached as bool = NO
static cached_result as bool
if not cached then
cached_result = io_running_on_console()
cached = YES
end if
return cached_result
#ELSEIF DEFINED(__FB_BLACKBOX__)
return YES
#ELSE
return NO
#ENDIF
end function
function running_on_ouya() as bool
'Only use this for things that strictly require OUYA, like the OUYA store
#IFDEF __FB_ANDROID__
static cached as bool = NO
static cached_result as bool
if not cached then
cached_result = io_running_on_ouya()
cached = YES
end if
return cached_result
#ELSE
return NO
#ENDIF
end function
function running_on_mobile() as bool
'TODO: what if running web port on a phone?
#IFDEF __FB_ANDROID__
'--return true for all Android except OUYA
static cached as bool = NO
static cached_result as bool
if not cached then
cached_result = NOT io_running_on_console()
cached = YES
end if
return cached_result
#ELSE
return NO
#ENDIF
end function
function running_on_web() as bool
#if defined(__FB_JS__)
return YES
#else
return NO
#endif
end function
function get_safe_zone_margin () as integer
'--returns and integer from 0 to 10 representing the percentage
' of the screen edges reserved for TV safe zones. Only returns non-zero
' values on backends that support this feature.
dim margin as integer = int(gfx_get_safe_zone_margin() * 100)
return large(0, small(10, margin))
end function
sub set_safe_zone_margin (margin as integer)
'the margin argument is an integer from 0 to 10 representing
' the percentage of the screen edges reserved for TV safe zones.
' this has no effect on backends that don't support this feature.
margin = bound(margin, 0, 10)
gfx_set_safe_zone_margin(margin / 100)
end sub
function supports_safe_zone_margin () as bool
'Returns YES if the current backend supports safe zone margins
return gfx_supports_safe_zone_margin()
end function
sub ouya_purchase_request (dev_id as string, identifier as string, key_der as string)
'Only works on OUYA. Should do nothing on other platforms
debug "ouya_purchase_request for product " & identifier
gfx_ouya_purchase_request(dev_id, identifier, key_der)
end sub
function ouya_purchase_is_ready () as bool
'Wait until the OUYA store has replied. Always return YES on other platforms
return gfx_ouya_purchase_is_ready()
end function
function ouya_purchase_succeeded () as bool
'Returns YES if the OUYA purchase was completed successfully.
'Always returns NO on other platforms
return gfx_ouya_purchase_succeeded()
end function
sub ouya_receipts_request (dev_id as string, key_der as string)
'Start a request for reciepts. They may take some time.
'Does nothing if the platform is not OUYA
gfx_ouya_receipts_request(dev_id, key_der)
end sub
function ouya_receipts_are_ready () as bool
'Wait until the OUYA store has replied. Always return YES on other platforms
return gfx_ouya_receipts_are_ready ()
end function
function ouya_receipts_result () as string
'Returns a newline delimited list of OUYA product identifiers that
'have already been purchased.
'Always returns "" on other platforms
return gfx_ouya_receipts_result()
end function
sub email_files(address as string, subject as string, message as string, file1 as zstring ptr = NULL, file2 as zstring ptr = NULL, file3 as zstring ptr = NULL)
debuginfo "Emailing " & *file1 & " " & *file2 & " " & *file3 & " to " & address
debuginfo " subject: '" & subject & "' body: '" & message & "'"
#ifdef __FB_ANDROID__
' Omitted files should be NULL, not "".
if len(*file1) = 0 then file1 = NULL
if len(*file2) = 0 then file2 = NULL
if len(*file3) = 0 then file3 = NULL
SDL_ANDROID_EmailFiles(address, subject, message, file1, file2, file3)
#else
debug "email_files only supported on Android"
#endif
end sub