'OHRRPGCE - General FreeBASIC utility code
'(C) Copyright 1997-2020 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 file contains utility subs and functions which would be useful for
' any FreeBasic program. Nothing in here can depend on Allmodex, nor on any
' gfx or music backend, nor on any other part of the OHR

#include "config.bi"
#include "datetime.bi" 'FB header
#include "string.bi"  'FB header
#include "util.bi"
#include "miscc.bi"
#include "unicode.bi"
#include "fb/fb.bi"
#include "lib/sha1.bi"
#include "os.bi"
#include "common_base.bi"
#include "lumpfile.bi"
#ifdef __FB_MAIN__
#include "testing.bi"
#endif


Type FBSTRING as string
'Resize a FB string
Declare Function fb_hStrRealloc Alias "fb_hStrRealloc" (byval s as FBSTRING ptr, byval size as ssize_t, byval preserve as long) as FBSTRING ptr
'Resize a FB string or allocate a new one, and mark it temporary (equals SPEED)
Declare Function fb_hStrAllocTemp Alias "fb_hStrAllocTemp" (byval s as FBSTRING ptr, byval size as ssize_t) as FBSTRING ptr
'Although unused, documenting this here: free a temporary FBstring which is returned (Normally would destroy it with fb_StrAssign)
'(returns error code)
'Declare Function fb_hStrDelTemp Alias "fb_hStrDelTemp" (s as FBSTRING ptr) as long

DECLARE FUNCTION integerptr_compare CDECL (byval a as integer ptr ptr, byval b as integer ptr ptr) as long
DECLARE FUNCTION stringptr_compare CDECL (byval a as string ptr ptr, byval b as string ptr ptr) as long


'It is very important for this to be populated _before_ any calls to CHDIR
DIM orig_dir as string

DIM tmpdir as string

DIM exename as string

DIM program_start_timer as double

'Dummy value used to indicate the default value of a byref arg
DIM default_arg as integer

#ifdef timer_variables
DIM timer_variables
#endif

'---------------- Initialization -----------------


DIM SHARED filetype_names(fileTypeError) as string
filetype_names(fileTypeNonexistent) = "nonexistent"
filetype_names(fileTypeFile)        = "a file"
filetype_names(fileTypeDirectory)   = "a directory"
filetype_names(fileTypeOther)       = "a special file"
filetype_names(fileTypeError)       = "unreadable"


'Set up an error handler for the errors FB throws when compiled with -exx. The
'default handler prints a message which is lost on Windows.
'Note also that this installs signal handlers, but some of those signal handlers
'are overridden on Unix by setup_exception_handler()
SUB setup_fb_error_handler()

 'Emscripten port doesn't seem to support GOTO label
 #IFNDEF __FB_JS__

  'There seems to be a gengcc bug at play: passing the address of a label to a
  'function doesn't work (gcc docs say it's undefined behaviour) and the address
  'of this function gets passed instead. So we see this function reentering if
  'an error occurs, rather than starting at QB_error_handler!
  STATIC as bool already_setup
  IF already_setup THEN GOTO QB_error_handler
  already_setup = YES

  'What's this wacky QB stuff doing in a FB codebase!
  ON ERROR GOTO QB_error_handler
  EXIT SUB

 QB_error_handler:
  STATIC as integer reentered
  IF reentered <> 0 THEN SYSTEM 99 'fatal_error_shutdown
  reentered += 1

  'Warning: any code using anonymous temporary string variables here seems to crash,
  'unless compiling with -gen gcc, because the function prologue hasn't occurred!
  DIM as integer err_num = ERR, err_line = ERL
  DIM as zstring ptr func_name = ERFN, mod_name = ERMN
  DIM as zstring ptr message = ANY
  message = format_FB_error_message(err_num, err_line, mod_name, func_name)
  DIM terminate_signal as bool = (err_num = fberrSIGINT) OR (err_num = fberrSIGTERM)
  DIM interrupt_signal as bool = (err_num = fberrSIGQUIT)
  fb_error_hook message, terminate_signal, interrupt_signal
 #ENDIF
END SUB

SUB remove_fb_error_handler()
  ON ERROR GOTO 0
END SUB

'Called if FB catches a fatal error, signal, or exception, such as (if compiled
'with -exx) array out-of-bounds read, bad REDIM call, SIGSEGV. (Unless
'CrashRpt/etc is installed, then it catches signals.)  This hook is installed in
'one of two different ways by calling hook_fb_End or setup_fb_error_handler (not
'both!) Called on ASSERT failure only if fb_End hooked.
EXTERN "C"
SUB fb_error_hook(message as const zstring ptr, terminate_signal as boolint, interrupt_signal as boolint)
  IF terminate_signal THEN
   'SIGINT, SIGTERM: Try to quit cleanly
   print *message
   debuginfo *message
   post_terminate_signal
  ELSEIF interrupt_signal THEN
   'SIGQUIT: Print stack and exit quickly (still does some cleanup)
   print *message
   debug *message
   fatal_error_shutdown
  ELSE
   'Tries to show a graphical error and invoke crash reporter
   fatalbug message
  END IF
END SUB
END EXTERN

LOCAL SUB lowlevel_error (msg as zstring ptr)
#IFDEF __FB_WIN32__
 'We can't print to the console because that won't work in programs compiled for
 'the Windows 'gui' subsystem (and util.bas gets linked into both kinds of exe;
 'could use is_console_program() to detect)
 error_message_box(msg)
#ELSE
 PRINT *msg
#ENDIF
END SUB

'Gets called at the top of the main module for each executable just by including util.bi.
'This is the place to put initialisation code common to everything.
SUB lowlevel_init()
  'Note: if compiled with -e, FB will insert a call to fb_InitSignals()
  'at the top of main(), installing signals handlers for SIGSEGV, etc.
  'and will also, on x86 only, call fb_CpuDetect and print an error and quit if
  'the CPU isn't 686+ (Pentium Pro+) or (if compiled with -fpu sse) doesn't
  'support SSE & SSE2. We duplicate that since we don't always compile with -e

  program_start_timer = TIMER

  'Android only
  external_log "main() started..."

  init_crt   'setlocale

  os_init
  #IF defined(__FB_X86__) AND NOT defined(__FB_64BIT__) AND NOT defined(NO_SSE)
   'Check for SSE and SSE2 support
   IF (fb_CpuDetect() AND &h6000000) <> &h6000000 THEN
    #IFDEF __FB_WIN32__
     'Unfortunately if you're using a default (gfx_sdl2) build you won't see this
     'message due to dll errors unless you're running WinXP+ on an ancient machine.
     lowlevel_error "Your CPU doesn't support SSE2 instructions (Pentium 4+). Go to https://ohrrpgce.com and download a 'Win95' build of the OHRRPGCE for older computers"
    #ELSE
     lowlevel_error "Your CPU doesn't support SSE2 instructions (Pentium 4+)?! Recompile the OHRRPGCE for older CPUs."
    #ENDIF
    SYSTEM 1
   END IF
  #ENDIF

  'Install FB error handler, either by hooking fb_End (which is a kludge)
  'or using ON ERROR GOTO (which is so yuck it's also a kludge).
  'Hooking fb_End is preferred (but only works in FB 1.02+) because how ON ERROR
  'GOTO works as of FB 1.07, the topmost frame gets clobbered by a computed
  'goto, bad for debugging: though we would still be able to read the line
  'number from g/c_debug.txt in that case, we can't inspect locals.
  'It also catches fb_Assert().
  'If nothing if hooked then the program would terminate without an exception
  'when the rtlib throws an error, and CrashRpt would not be invoked!
  'We could almost just use atexit() instead, because fb's rtlib cleanup happens
  '(afterwards?) in a global destructor function, except not under emscripten,
  'and libfbgfx destroys the window before then.
  IF hook_fb_End() = NO THEN
   setup_fb_error_handler
   'Note: if --rawexx cmdline arg given, we later call remove_fb_error_handler.
  END IF

  exename = trimextension(trimpath(COMMAND(0)))

  'Requires exename on Windows.
  setup_exception_handler

  init_intern_string

  disable_extended_precision

  reseed_prng TIMER * 1e9
END SUB

'------------- Basic datatypes -------------

DEFINE_VECTOR_OF_POD_TYPE(XYPair, XYPair)

#MACRO XYPAIR_OPERATOR_AND_XY(OP)
  OPERATOR OP (lhs as XYPair, rhs as XYPair) as bool
    RETURN lhs.x OP rhs.x ANDALSO lhs.y OP rhs.y
  END OPERATOR
#ENDMACRO

#MACRO XYPAIR_OPERATOR_AND_INT(OP)
  OPERATOR OP (lhs as XYPair, rhs as integer) as bool
    RETURN lhs.x OP rhs ANDALSO lhs.y OP rhs
  END OPERATOR
#ENDMACRO

'The commented out operator='s, and all the other missing ones, have been moved to util.bi
'so they can be inlined by the compiler.

'XYPAIR_OPERATOR_AND_XY (=)
'XYPAIR_OPERATOR_AND_INT(=)
XYPAIR_OPERATOR_AND_XY(<)
XYPAIR_OPERATOR_AND_INT(<)
XYPAIR_OPERATOR_AND_XY(<=)
XYPAIR_OPERATOR_AND_INT(<=)
XYPAIR_OPERATOR_AND_XY(>)
XYPAIR_OPERATOR_AND_INT(>)
XYPAIR_OPERATOR_AND_XY(>=)
XYPAIR_OPERATOR_AND_INT(>=)

OPERATOR XYPair.CAST () as string
  RETURN x & "," & y
END OPERATOR

OPERATOR WHSimple.CAST () as string
  RETURN w & "*" & h
END OPERATOR

OPERATOR ABS (lhs as XYPair) as XYPair
  RETURN TYPE(ABS(lhs.x), ABS(lhs.y))
END OPERATOR

OPERATOR MOD (lhs as XYPair, rhs as XYPair) as XYPair
  RETURN TYPE(lhs.x MOD rhs.x, lhs.y MOD rhs.y)
END OPERATOR

OPERATOR MOD (lhs as XYPair, rhs as integer) as XYPair
  RETURN TYPE(lhs.x MOD rhs, lhs.y MOD rhs)
END OPERATOR


OPERATOR Float2.CAST () as string
  RETURN x & "," & y
END OPERATOR

OPERATOR Float2.+= (rhs as Float2)
  x += rhs.x
  y += rhs.y
END OPERATOR

OPERATOR = (lhs as Float2, rhs as Float2) as bool
  RETURN lhs.x = rhs.x andalso lhs.y = rhs.y
END OPERATOR

OPERATOR <> (lhs as Float2, rhs as Float2) as bool
  RETURN lhs.x <> rhs.x orelse lhs.y <> rhs.y
END OPERATOR

'In util.bi
' OPERATOR + (lhs as Float2, rhs as Float2) as Float2
'   RETURN TYPE(lhs.x + rhs.x, lhs.y + rhs.y)
' END OPERATOR

OPERATOR + (lhs as Float2, rhs as double) as Float2
  RETURN TYPE(lhs.x + rhs, lhs.y + rhs)
END OPERATOR

' OPERATOR - (lhs as Float2, rhs as Float2) as Float2
'   RETURN TYPE(lhs.x - rhs.x, lhs.y - rhs.y)
' END OPERATOR

OPERATOR - (lhs as Float2, rhs as double) as Float2
  RETURN TYPE(lhs.x - rhs, lhs.y - rhs)
END OPERATOR

OPERATOR * (lhs as Float2, rhs as Float2) as Float2
  RETURN TYPE(lhs.x * rhs.x, lhs.y * rhs.y)
END OPERATOR

OPERATOR * (lhs as Float2, rhs as double) as Float2
  RETURN TYPE(lhs.x * rhs, lhs.y * rhs)
END OPERATOR

OPERATOR / (lhs as Float2, rhs as Float2) as Float2
  RETURN TYPE(lhs.x / rhs.x, lhs.y / rhs.y)
END OPERATOR

OPERATOR / (lhs as Float2, rhs as double) as Float2
  RETURN TYPE(lhs.x / rhs, lhs.y / rhs)
END OPERATOR


OPERATOR = (lhs as RectType, rhs as RectType) as bool
  RETURN memcmp(@lhs, @rhs, sizeof(RectType)) = 0
END OPERATOR

OPERATOR <> (lhs as RectType, rhs as RectType) as bool
  RETURN memcmp(@lhs, @rhs, sizeof(RectType)) <> 0
END OPERATOR

OPERATOR + (lhs as RectType, rhs as RectType) as RectType
  RETURN XYWH(lhs.x + rhs.x, lhs.y + rhs.y, lhs.wide + rhs.wide, lhs.high + rhs.high)
END OPERATOR

OPERATOR * (lhs as RectType, rhs as integer) as RectType
  RETURN XYWH(lhs.x * rhs, lhs.y * rhs, lhs.wide * rhs, lhs.high * rhs)
END OPERATOR

OPERATOR RectType.CAST () as string
  RETURN x & "," & y & ",w" & wide & ",h" & high
END OPERATOR

FUNCTION xypair_direction (v as XYPair, byval axis as integer, byval default as DirNum = dirNone) as DirNum
 IF axis = 0 THEN
  IF v.x < 0 THEN RETURN dirLeft
  IF v.x > 0 THEN RETURN dirRight
 ELSEIF axis = 1 THEN
  IF v.y < 0 THEN RETURN dirUp
  IF v.y > 0 THEN RETURN dirDown
 END IF
 RETURN default
END FUNCTION

FUNCTION xypair_to_direction (v as XYPair) as DirNum
 IF v.x = 0 AND v.y = 0 THEN RETURN dirNone
 IF ABS(v.x) > ABS(v.y) THEN
  IF v.x < 0 THEN RETURN dirLeft
  IF v.x > 0 THEN RETURN dirRight
 ELSE
  IF v.y < 0 THEN RETURN dirUp
  IF v.y > 0 THEN RETURN dirDown
 END IF
END FUNCTION

SUB xypair_move (v as XYPair, byval direction as integer, byval amount as integer = 1)
 SELECT CASE direction
  CASE 0: v.y -= amount
  CASE 1: v.x += amount
  CASE 2: v.y += amount
  CASE 3: v.x -= amount
  CASE ELSE
   showbug "xypair_move: invalid direction " & direction
 END SELECT
END SUB

FUNCTION xypair_manhattan_distance(v1 as XYPair, v2 as XYPair) as integer
 DIM diff as XYPair = v2 - v1
 RETURN ABS(diff.x) + ABS(diff.y)
END FUNCTION

FUNCTION xypair_distance_squared(v1 as XYPair, v2 as XYPair) as integer
 DIM diff as XYPair = v2 - v1
 RETURN diff.x * diff.x + diff.y * diff.y
END FUNCTION

#IFDEF __FB_MAIN__
startTest(XYPairOperators)
  DIM as XYPair A = (1,2), B = (3,4)

  IF A <> A THEN fail
  IF A <> TYPE<XYPair>(1,2) THEN fail
  IF XY(101,-34) <> TYPE<XYPair>(101,-34) THEN fail
  IF (A = XY(1,2)) <> YES THEN fail

  IF A < 2 THEN fail
  IF NOT A < 3 THEN fail
  IF NOT A > 0 THEN fail
  IF NOT A >= 1 THEN fail
  IF A >= 2 THEN fail

  A += B
  IF A <> XY(4,6) THEN fail
  IF -A <> XY(-4,-6) THEN fail
  IF A + 4 <> XY(8,10) THEN fail
  IF A - A <> XY(0,0) THEN fail
  IF A * 10 <> XY(40,60) THEN fail
  IF A * B <> XY(12,24) THEN fail
  IF A \ 3 <> XY(1,2) THEN fail
  IF A \ XY(2,-1) <> XY(2,-6) THEN fail
  IF A * 5 \ 5 <> A THEN fail
  IF A / 3 <> XY(1,2) THEN fail
  IF A / 4 <> XY(1,2) THEN fail
  IF A / 1.5 <> XY(3,4) THEN fail
  IF A / XY(-1,4) <> XY(-4,2) THEN fail
  IF STR(A) <> "4,6" THEN fail
  IF STR(A.wh) <> "4*6" THEN fail
  IF ABS(XY(-4,-5)) <> XY(4,5) THEN fail
  IF A MOD 3 <> XY(1,0) THEN fail
  IF A MOD XY(3,5) <> XY(1,1) THEN fail
endTest

startTest(RectTypeOperators)
  DIM as RectType A = (1,2,1,1), B = (1,2,1,0)

  IF A <> A THEN fail
  IF A = B THEN fail
endTest
#ENDIF

FUNCTION dirX(dirn as DirNum, dist as integer = 1) as integer
 IF dirn = dirLeft THEN RETURN -dist
 IF dirn = dirRight THEN RETURN -dist
END FUNCTION

FUNCTION dirY(dirn as DirNum, dist as integer = 1) as integer
 IF dirn = dirUp THEN RETURN -dist
 IF dirn = dirDown THEN RETURN -dist
END FUNCTION

'------------- Math operations -------------

FUNCTION bitcount (byval v as unsigned integer) as integer
  'From the "Software Optimization Guide for AMD Athlon 64 and Opteron Processors". Thanks, AMD!
  v = v - ((v SHR 1) AND &h55555555)
  v = (v AND &h33333333) + ((v SHR 2) AND &h33333333)
  RETURN ((v + (v SHR 4) AND &hF0F0F0F) * &h1010101) SHR 24
END FUNCTION

FUNCTION ceiling (byval n as integer) as integer
 RETURN INT(n * -1) * -1
END FUNCTION

'Clamp a value to within a range with warning
SUB clamp_value (byref value as integer, byval min as integer, byval max as integer, argname as string)
 DIM oldval as integer = value
 IF value < min THEN value = min
 IF value > max THEN value = max
 IF value <> oldval THEN debug "Clamped invalid " + argname + " value " & oldval & " to " & value
END SUB

SUB loopvar (byref value as integer, min as integer, max as integer, inc as integer = 1)
 value = POSMOD((value + inc) - min, (max - min) + 1) + min
END SUB

SUB loopvar (byref value as longint, min as longint, max as longint, inc as longint = 1)
 value = POSMOD((value + inc) - min, (max - min) + 1) + min
END SUB

' Split a RelPos into offset, alignment, and anchor.
SUB RelPos_decode(pos as RelPos, byref offset as integer, byref align as AlignType, byref anchor as AlignType, byref show as AlignType)
 DIM as integer highpart, lowpart
 lowpart = ((pos + _rMargin) MOD _rFactor) - _rMargin
 highpart = (pos + _rMargin) \ _rFactor
 IF highpart >= 0 AND highpart < 27 AND ABS(lowpart) <= _rMargin THEN
  offset = lowpart
  align = (highpart MOD 9) \ 3
  anchor = highpart MOD 3
  IF highpart >= 18 THEN
   show = alignRight
  ELSEIF highpart >= 9 THEN
   show = alignLeft
  ELSE
   show = alignCenter
  END IF
 ELSE
  offset = pos
  align = alignLeft
  anchor = alignLeft
  show = alignCenter  'None
 END IF
END SUB

' Converts a RelPos value like "rCenter + 30" to "width\2 + 30", and so forth,
' for combinations of at most one of
'   rTop, rLeft, rRight, rCenter, rBottom, rWidth, rHeight,
'   (which edge of the screen this position is relative to)
' and at most one of
'   ancTop, ancLeft, ancRight, ancCenter, ancBottom,
'   (which edge of this object the position describes)
' (although in some contexts, like when specifying width of a rect,
' anchor constants don't make sense and do nothing).
' Finally, showLeft, showRight can be added to clip the position so that either
' the left-most or right-most part of the object is on-screen
FUNCTION relative_pos(pos as RelPos, pagewidth as integer, objwidth as integer = 0) as integer
 DIM offset as integer
 DIM as AlignType align, anchor, show
 RelPos_decode pos, offset, align, anchor, show
 IF align  = alignCenter THEN offset += pagewidth \ 2
 IF align  = alignRight  THEN offset += pagewidth
 IF anchor = alignCenter THEN offset -= objwidth \ 2
 IF anchor = alignRight  THEN offset -= objwidth
 ' show = alignCenter means no clipping
 IF show = alignRight   THEN offset = large(offset, 0)    'Don't go over left screen edge
 IF show <> alignCenter THEN offset = small(offset, pagewidth - objwidth) 'Don't go over right screen edge
 IF show = alignLeft    THEN offset = large(offset, 0)    'Don't go over left screen edge
 RETURN offset
END FUNCTION

FUNCTION relative_pos(pos as RelPosXY, pagesize as XYPair, objsize as XYPair = XY(0,0)) as XYPair
 DIM ret as XYPair = pos
 ret.x = relative_pos(pos.x, pagesize.x, objsize.x)
 ret.y = relative_pos(pos.y, pagesize.y, objsize.y)
 RETURN ret
END FUNCTION

#IFDEF __FB_MAIN__
startTest(RelPos)
  DIM offset as integer
  DIM as AlignType align, anchor, show
  RelPos_decode rCenter + ancRight - 12359 + showLeft, offset, align, anchor, show
  testEqual(offset, -12359)
  testEqual(align, alignCenter)
  testEqual(anchor, alignRight)
  testEqual(show, alignLeft)

  'Test that these values close to a power of 10 aren't treated as containing flags, as documented
  DIM testvals(...) as integer = {INT_MAX, 99999, 999999, 9999999, 999999999, 1050000, -1, -50000, -60050000}
  FOR i as integer = 0 TO UBOUND(testvals)
    RelPos_decode testvals(i), offset, align, anchor, show
    testEqual(offset, testvals(i))
    testEqual(align, alignLeft)
    testEqual(anchor, alignLeft)
    testEqual(show, alignCenter)
  NEXT

  testEqual(rCenter + rCenter, rRight)
  testEqual(rRight - rLeft, rRight)
  testEqual((rRight + 100) \ 2, rCenter + 50)
   
  testEqual(relative_pos(0, 0, 0), 0)
  testEqual(relative_pos(-3499, 1000), -3499)
  testEqual(relative_pos(rLeft + 1312334, 1000), 1312334)
  testEqual(relative_pos(rCenter + 50000, 20000), 60000)
  testEqual(relative_pos(rCenter - 1000, 20000), 9000)
  testEqual(relative_pos(rRight - 50000, 200042), 150042)
  testEqual(relative_pos(rRight - 20000, 20000), 0)
  testEqual(relative_pos(ancCenter - 90, 20000, 0), -90)
  testEqual(relative_pos(ancCenter - 90, 20000, 100), -140)
  testEqual(relative_pos(ancRight  - 90, 20000, 100), -190)
  testEqual(relative_pos(rCenter + ancCenter + 9, 20100, 100), 10009)
  testEqual(relative_pos(rCenter + ancRight + 9, 20200, 100), 10009)
  testEqual(relative_pos(rRight + ancRight + 9, 20200, 100), 20109)
  testEqual(relative_pos(rRight + ancCenter + 9, 20200, 100), 20159)

  testEqual(relative_pos(67 + showLeft, 100, 10), 67)
  testEqual(relative_pos(67 + showRight, 100, 10), 67)
  testEqual(relative_pos(showRight, 100, 110), -10)
  testEqual(relative_pos(rRight + showLeft, 100, 10), 90)
  testEqual(relative_pos(rRight + showRight, 100, 10), 90)
  testEqual(relative_pos(rRight + showRight, 100, 1000), -900)
  testEqual(relative_pos(rRight + showLeft - 50, 100, 10), 50)
  testEqual(relative_pos(rRight + showRight - 50, 100, 10), 50)
  testEqual(relative_pos(rCenter + showLeft, 100, 1000), 0)
  testEqual(relative_pos(rCenter + showRight, 100, 1000), -900)
  testEqual(relative_pos(rRight + ancRight - 120 + showLeft, 100, 1000), 0)
  testEqual(relative_pos(rRight + ancRight - 120 + showRight, 100, 1000), -900)

  'Test RelPosXY overload
  testEqual(relative_pos(XY(rLeft + 1312334, rCenter + 50000), XY(1000, 20000)), XY(1312334, 60000))
endtest
#ENDIF

'Find dimensions of a rect, given opposite corners 
SUB corners_to_rect (p1 as XYPair, p2 as XYPair, result as RectType)
 IF p1.x < p2.x THEN result.x = p1.x ELSE result.x = p2.x
 result.wide = ABS(p1.x - p2.x)
 IF p1.y < p2.y THEN result.y = p1.y ELSE result.y = p2.y
 result.high = ABS(p1.y - p2.y)
END SUB

'As above, but include the corner positions inside the rect (for use when coordinates measure on a discrete grid)
SUB corners_to_rect_inclusive (p1 as XYPair, p2 as XYPair, result as RectType)
 corners_to_rect p1, p2, result
 result.wide += 1
 result.high += 1
END SUB

FUNCTION rect_collide_point (r as RectType, p as XYPair) as bool
 RETURN p.x >= r.x ANDALSO p.y >= r.y ANDALSO p.x < r.x + r.wide ANDALSO p.y < r.y + r.high
END FUNCTION

FUNCTION rect_collide_rect (r1 as RectType, r2 as RectType) as bool
 IF r1.w + r2.w <= ABS(2 * r1.x + r1.w - 2 * r2.x - r2.w) THEN RETURN NO
 IF r1.h + r2.h <= ABS(2 * r1.y + r1.h - 2 * r2.y - r2.h) THEN RETURN NO
 RETURN YES
END FUNCTION

FUNCTION rect_collide_point_vertical_chunk (r as RectType, p as XYPair, chunk_spacing as integer) as integer
 'Divide a rect into vertical chunks (like a menu) and return the
 'index of the one the point collides with. Returns -1 if none collide
 IF chunk_spacing = 0 THEN debug "divide by 0: chunk_spacing=0" : RETURN -1
 IF rect_collide_point(r, p) THEN
  RETURN (p.y - r.y) \ chunk_spacing
 END IF
 RETURN -1
END FUNCTION

FUNCTION rando () as double
 'STATIC count as integer = 0
 'This is a simple wrapper for RND to facilitate debugging
 DIM n as double = RND
 'debug count & " RND=" & n
 'count += 1
 RETURN n
END FUNCTION

FUNCTION randint (byval limit as integer) as integer
 'Returns a random integer >=0 and < limit
 RETURN INT(rando() * limit)
END FUNCTION

'Simple low quality psuedo random number generator with exposed state. Same speed as RND.
'Initialise prng_state to a seed before first call.
'Returns a float in the range [0.0, 1.0) but no where near a full double of precision.
FUNCTION simple_rand (byref prng_state as uinteger) as double
 prng_state = (prng_state * 1103515245 + 12345)
 RETURN CAST(double, prng_state) * (1.0 / &hffffffffU)
END FUNCTION

'Simple low quality psuedo random number generator. Initialise prng_state to a seed before first call.
'Returns an integer in the range 0 to limit - 1. limit should be <= 2^20
FUNCTION simple_randint (byref prng_state as uinteger, byval limit as integer) as uinteger
 prng_state = (prng_state * 1103515245 + 12345)
 RETURN CINT((CAST(longint, prng_state) * limit) SHR 32)
END FUNCTION

'simple_rand simple test: create a bmp
/'
 DIM timestart as double = TIMER
 DIM tframe as frame ptr = frame_new(256, 256)
 DIM pstate as unsigned integer = 0
 FOR yy as integer = 0 to 255
  FOR xx as integer = 0 to 255
   putpixel tframe, xx, yy, simple_randint(pstate, 16) * 15
   'putpixel tframe, xx, yy, CINT(simple_rand(pstate) * 16) * 15
  NEXT
 NEXT
 frame_export_bmp8 "randtest.bmp", tframe, master()
 debug "testframe in " & (TIMER - timestart) * 1000 & "ms"
 frame_unload @tframe
'/

SUB reseed_prng (seed as double)
 'Note: the fractional part of seed is ignored!
 RANDOMIZE seed, 3
END SUB

' Returns number +/- up to percent%
' Note that the average value returned is number - 0.5! Don't change this
' without adjusting attack damage calculation
FUNCTION range (number as integer, percent as integer) as integer
 DIM a as longint
 a = (number / 100) * percent
 ' number - a <= RETURN < number + a
 a = number + INT((rando() * a) * 2) - a
 RETURN bound(a, -2147483648LL, 2147483647LL)
END FUNCTION

FUNCTION isnan (byval value as double) as integer
 RETURN value <> value
END FUNCTION

FUNCTION isnan (byval value as single) as integer
 RETURN value <> value
END FUNCTION

FUNCTION isfinite (byval value as double) as integer
 RETURN DBL_MAX >= value AND value >= -DBL_MAX
END FUNCTION

FUNCTION isfinite (byval value as single) as integer
 RETURN FLT_MAX >= value AND value >= -FLT_MAX
END FUNCTION

'A fuzzy equivalent to 'iif(value >= low+high/2, 1.0, 0.0)'
'Swap low,high to reverse the comparison
FUNCTION fuzzythreshold (byval value as double, byval low as double, byval high as double) as double
 IF low > high THEN
  low = -low
  high = -high
  value = -value
 END IF
 IF value <= low THEN
  RETURN 0.0
 ELSEIF value >= high THEN
  RETURN 1.0
 ELSE
  RETURN (value - low) / (high - low)
 END IF
END FUNCTION


'---------------- String operations --------------


'strprintf is actually defined in miscc.c, but test it here
#IFDEF __FB_MAIN__
startTest(strprintf)
 IF strprintf("") <> "" THEN fail
 IF strprintf(" ") <> " " THEN fail
 IF strprintf(" %d ", 23) <> " 23 " THEN fail
 IF strprintf(" %s ", @"42") <> " 42 " THEN fail
 IF strprintf(" %d %d%d", 1, 2, -3) <> " 1 2-3" THEN fail
 IF strprintf("%04dd %.2f %s %%", -1, 2.4, @",") <> "-001d 2.40 , %" THEN fail
 IF strprintf("%-4d", -23) <> "-23 " THEN fail
 IF strprintf("%-04d", -23) <> "-23 " THEN fail
 IF strprintf("%0-4d", -23) <> "-23 " THEN fail
endTest
#ENDIF

'FB will convert an empty string which has never been explicitly set to "" to a
'NULL zstring ptr, which is not acceptable to many C functions such as strcmp.
FUNCTION cstring (s as string) as zstring ptr
 DIM ret as zstring ptr = strptr(s)
 IF ret = NULL THEN RETURN strptr("")
 RETURN ret
END FUNCTION

'Allocate a copy of a null-terminated zstring. In case you don't want to use FB strings for some reason.
FUNCTION copy_zstring (str_ptr as zstring ptr) as zstring ptr
 DIM ret as zstring ptr = allocate(strlen(str_ptr) + 1)
 strcpy(ret, str_ptr)
 RETURN ret
END FUNCTION

'FB's string assignment will always do a strlen on zstring arguments, (even if you call fb_StrAssign
'manually with the right length!) so if the source is a binary blob containing null bytes then
'this function should be used instead.
FUNCTION blob_to_string (byval str_ptr as zstring ptr, byval str_len as integer) as string
 DIM ret as string
 'Consider this a testcase for "Can you trust TMC to implement a FreeBASIC compiler?"
 'OK, OK, you could just do ret = SPACE(str_len), but this is faster
 fb_hStrAllocTemp(@ret, str_len)
 memcpy(@ret[0], str_ptr, str_len)
 ret[str_len] = 0
 RETURN ret
END FUNCTION

'Add padding to the right of a string to reach 'size' length, and possibly clip it to 'size'
FUNCTION rpad (s as string, pad_char as zstring ptr = @" ", size as integer, clip as clipDir = clipNone) as string
 IF clip = clipNone AND LEN(s) >= size THEN RETURN s
 DIM temp as string
 temp = IIF(clip = clipRight, LEFT(s, size), RIGHT(s, size))
 RETURN temp & STRING(size - LEN(temp), *pad_char)
END FUNCTION

'Add padding to the left of a string to reach 'size' length, and possibly clip it to 'size'
FUNCTION lpad (s as string, pad_char as zstring ptr = @" ", size as integer, clip as clipDir = clipNone) as string
 IF clip = clipNone AND LEN(s) >= size THEN RETURN s
 DIM temp as string
 temp = IIF(clip = clipRight, LEFT(s, size), RIGHT(s, size))
 RETURN STRING(size - LEN(temp), *pad_char) & temp
END FUNCTION

' First pad right, then pad left
FUNCTION rlpad (s as string, pad_char as zstring ptr = @" ", pad_right as integer, pad_left as integer, clip as clipDir = clipNone) as string
 RETURN lpad(rpad(s, pad_char, pad_right, NO), pad_char, pad_left, clip)
END FUNCTION

'Like INSTR, but return the n-th match
'Returns 0 if not found
FUNCTION Instr_nth (byval start as integer, s as string, substring as string, byval nth as integer = 1) as integer
 DIM temp as integer = start - 1
 IF nth < 1 THEN RETURN 0
 FOR n as integer = 1 TO nth
  temp = INSTR(temp + 1, s, substring)
  IF temp = 0 THEN RETURN 0
 NEXT
 RETURN temp
END FUNCTION

'Like INSTR without start point, but return the n-th match
'Returns 0 if not found
FUNCTION Instr_nth (s as string, substring as string, byval nth as integer = 1) as integer
 RETURN Instr_nth(1, s, substring, nth)
END FUNCTION

'Returns the number of characters at the start of two strings that are equal
FUNCTION length_matching(s1 as string, s2 as string) as integer
 DIM as byte ptr p1 = @s1[0], p2 = @s2[0]
 IF p1 = NULL ORELSE p2 = NULL THEN RETURN 0
 DIM as integer ret = 0
 WHILE *p1 AND *p2
  IF *p1 <> *p2 THEN RETURN ret
  p1 += 1
  p2 += 1
  ret += 1
 WEND
 RETURN ret
END FUNCTION

'Advance 'idx' (1-based) over copies of tok. Returns number of copies skipped over.
'If tok is more than one character long, only skips over whole matches.
FUNCTION skip_over(text as string, byref idx as integer, tok as zstring ptr, maxskips as integer = -1) as integer
  IF LEN(text) = 0 THEN RETURN 0  'Protect against zero-length strings with null pointers
  DIM ret as integer = 0
  DIM toklen as integer = strlen(tok)
  WHILE strncmp(@text[idx - 1], tok, toklen) = 0
    idx += toklen
    ret += 1
    IF ret = maxskips THEN EXIT WHILE
  WEND
  RETURN ret
END FUNCTION

'Try to parse a string into an int, returning true on success and optionally
'putting the results in *ret (*ret is unmodified on failure).
'This is stricter than VALINT: the string must be composed only of digits and
'possible leading - and leading space.  If strict=YES, then leading spaces and
'leading zeroes (but not -0) are also rejected.
FUNCTION parse_int (stri as zstring ptr, ret as integer ptr=NULL, strict as bool=NO) as bool
 IF stri = NULL THEN RETURN NO  'Empty string
 DIM s as unsigned byte ptr = stri

 IF strict = NO THEN
  's = LTRIM(s)
  WHILE isspace(s[0]): s += 1 : WEND
 END IF
 IF s[0] = 0 THEN RETURN NO  'length 0

 DIM sign as integer = 1
 IF s[0] = ASC("-") THEN
  sign = -1
  s += 1  's = MID(s, 2)
  IF s[0] = 0 THEN RETURN NO  'length 0
 END IF

 'Reject leading zeroes (check length is >= 2)
 IF strict ANDALSO s[0] = ASC("0") ANDALSO s[1] THEN RETURN NO

 DIM n as integer = 0
 WHILE s[0]
  DIM c as integer = s[0] - 48
  s += 1
  IF c >= 0 AND c <= 9 THEN
   n = n * 10 + (c * sign)
  ELSE
   RETURN NO
  END IF
 WEND

 IF ret THEN *ret = n
 RETURN YES
END FUNCTION

'Use this in contrast to FB's VALINT.
'It is stricter, and returns a default on failure: the string
'must be composed only of digits and possible leading - and leading space.
'If strict=YES, then leading spaces and leading zeroes (but not -0) are rejected.
FUNCTION str2int (stri as zstring ptr, default as integer=0, strict as bool=NO) as integer
 DIM ret as integer
 IF parse_int(stri, @ret, strict) THEN RETURN ret
 RETURN default
END FUNCTION

'Split a string composed of alphabetic text and an integer concatenated without
'whitespace, like "H32" or "Font-1" into action ("Font") and arg (-1).
'Returns false if isn't strictly formatted like that (eg whitespace anywhere, or eg "H00")
FUNCTION split_str_int(z as zstring ptr, byref action as string, byref arg as integer) as bool
 'Written to avoid temporary strings, for speed
 IF z = NULL THEN RETURN NO
 DIM chidx as integer
 FOR chidx = 0 TO LEN(z) - 1
  IF isalpha(CAST(ubyte ptr, z)[chidx]) = 0 THEN EXIT FOR
 NEXT
 IF chidx = 0 THEN RETURN NO
 action = LEFT(*z, chidx)
 RETURN parse_int(z + chidx, @arg, YES)  'strict=YES
END FUNCTION

#IFDEF __FB_MAIN__
startTest(parse_int)
 DIM n as integer
 IF parse_int(NULL) THEN fail
 IF parse_int("") THEN fail
 IF parse_int(" ") THEN fail
 IF parse_int("-") THEN fail
 IF parse_int("2 ", @n) THEN fail
 IF parse_int(" - 2", @n) THEN fail
 IF parse_int("1 2", @n) THEN fail
 IF parse_int("1") = NO THEN fail
 IF parse_int("00", @n) = NO ORELSE n <> 0 THEN fail
 IF parse_int("-001234", @n) = NO ORELSE n <> -1234 THEN fail
 IF parse_int("2147483647", @n) = NO ORELSE n <> 2147483647 THEN fail
 IF parse_int("-2147483648", @n) = NO ORELSE n <> -2147483648 THEN fail
 IF parse_int("0", @n) = NO ORELSE n <> 0 THEN fail
 IF parse_int("-0", @n) = NO ORELSE n <> 0 THEN fail
 IF parse_int(" -2", @n) = NO ORELSE n <> -2 THEN fail

 'Test strictness
 IF parse_int("00", , YES) THEN fail
 IF parse_int("01", , YES) THEN fail
 IF parse_int("-001234", , YES) THEN fail
 IF parse_int(" 2", , YES) THEN fail
 IF parse_int(" -2", , YES) THEN fail
 IF parse_int("0", @n, YES) = NO ORELSE n <> 0 THEN fail
 IF parse_int("-0", @n, YES) = NO ORELSE n <> 0 THEN fail
endTest
#ENDIF

'Lenient, accepts any number or the strings yes, no, true, false, on, off.
'Otherwise returns default.
FUNCTION str2bool(q as string, default as integer = NO) as integer
 DIM v as string = TRIM(LCASE(q))
 IF LEN(v) = 0 THEN RETURN default
 IF v = "yes" ORELSE v = "true" ORELSE v = "on" THEN RETURN YES
 IF v = "no" ORELSE v = "false" ORELSE v = "off" THEN RETURN NO
 DIM value as integer
 IF parse_int(v, @value) THEN RETURN value <> 0
 RETURN default
END FUNCTION

'Ancient password encryption/decryption function
FUNCTION rotascii (s as string, o as integer) as string
 DIM as string temp = ""
 FOR i as integer = 1 TO LEN(s)
  temp &= CHR(POSMOD(ASC(MID(s, i, 1)) + o, 256))
 NEXT i
 RETURN temp
END FUNCTION

'Capitalise first letter, lower-case the rest. Assumes one word.
FUNCTION titlecase(word as string) as string
 RETURN UCASE(LEFT(word, 1)) & LCASE(MID(word, 2))
END FUNCTION

FUNCTION untitlecase(word as string) as string
 RETURN LCASE(LEFT(word, 1)) & MID(word, 2)
END FUNCTION

FUNCTION escape_string(s as string, chars as string) as string
 DIM i as integer
 DIM c as string
 DIM result as string
 result = ""
 FOR i = 1 to LEN(s)
  c = MID(s, i, 1)
  IF INSTR(chars, c) THEN
   result = result & "\"
  END IF
  result = result & c
 NEXT i
 RETURN result
END FUNCTION

'Replace occurrences of a substring with the result of replacefun. Modifies 'buffer'!
'Returns the number of replacements done. Inserted text is not eligible for further replacements.
'Optionally limit the number of times to do the replacement by passing maxtimes; no limit if < 0
FUNCTION replacestr (byref buffer as string, replacewhat as string, replacefunc as FnReplacement, arg as any ptr, maxtimes as integer = -1, caseinsensitive as bool = NO) as integer
 DIM pt as integer
 DIM count as integer
 DIM start as integer = 1

 WHILE maxtimes < 0 OR count < maxtimes
  IF caseinsensitive THEN
   pt = INSTR(start, LCASE(buffer), LCASE(replacewhat))  'inefficient
  ELSE
   pt = INSTR(start, buffer, replacewhat)
  END IF
  IF pt = 0 THEN RETURN count
  DIM withwhat as string = replacefunc(MID(buffer, pt, LEN(replacewhat)), arg)
  buffer = MID(buffer, 1, pt - 1) + withwhat + MID(buffer, pt + LEN(replacewhat))
  start = pt + LEN(withwhat)
  count += 1
 WEND
 RETURN count
END FUNCTION

LOCAL FUNCTION _get_replacement(original as string, arg as any ptr) as string
 RETURN *CAST(string ptr, arg)
END FUNCTION

'Replace occurrences of a substring with the result of replacefun. Modifies 'buffer'!
'Returns the number of replacements done. Inserted text is not eligible for further replacements.
'Optionally limit the number of times to do with replacement by passing maxtimes; no limit if < 0
FUNCTION replacestr (byref buffer as string, replacewhat as string, withwhat as string, maxtimes as integer = -1, caseinsensitive as bool = NO) as integer
 RETURN replacestr(buffer, replacewhat, @_get_replacement, @withwhat, maxtimes, caseinsensitive)
END FUNCTION

' Change the type of newline in a string, which might contain mixed win/unix line endings
' (but doesn't current support Mac style \r line endings)
' newline is usually either !"\n" or !"\r\n", but could be anything. eg. " ".
FUNCTION normalize_newlines (buffer as string, newline as string = LINE_END) as string
 DIM ret as string = buffer
 IF newline = !"\n" THEN
  replacestr(ret, !"\r\n", newline)
 ELSE
  replacestr(ret, !"\r\n", !"\n")
  replacestr(ret, !"\n", newline)
 END IF
 RETURN ret
END FUNCTION

#IFDEF __FB_MAIN__
startTest(normalize_newlines)
 IF normalize_newlines(!"a\n b\r\n", !"\n") <> !"a\n b\n" THEN fail
 IF normalize_newlines(!"a\n b\r\n", !"\r\n") <> !"a\r\n b\r\n" THEN fail
 IF normalize_newlines(!"a\n b\r\n", " ") <> !"a  b " THEN fail
endTest
#ENDIF

FUNCTION exclude (s as string, x as string) as string
 DIM ret as string = ""
 FOR i as integer = 1 TO LEN(s)
  DIM tmp as string = MID(s, i, 1)
  IF INSTR(x, tmp) = 0 THEN
   ret &= tmp
  END IF
 NEXT i
 RETURN ret
END FUNCTION

FUNCTION exclusive (s as string, x as string) as string
 DIM ret as string = ""
 FOR i as integer = 1 TO LEN(s)
  DIM tmp as string = MID(s, i, 1)
  IF INSTR(x, tmp) THEN
   ret &= tmp
  END IF
 NEXT i
 RETURN ret
END FUNCTION

'------------- Stack -------------

SUB createstack (st as Stack)
  WITH st
    .size = 1000
    .bottom = allocate(.size * sizeof(integer))
    IF .bottom = 0 THEN
      'oh dear
      'debug "Not enough memory for stack"
      EXIT SUB
    END IF
    .pos = .bottom
  END WITH
END SUB

SUB destroystack (st as Stack)
  IF st.bottom <> 0 THEN
    deallocate st.bottom
    st.size = -1
  END IF
END SUB

'Ensure can push at least 'amount' integers without overflow.
SUB checkoverflow (st as Stack, byval amount as integer = 1)
  WITH st
    IF .pos - .bottom + amount >= .size THEN
      .size += .size \ 2 + amount
      'debug "new stack size = " & .size & " * 4  pos = " & (.pos - .bottom) & " amount = " & amount

      DIM newptr as integer ptr
      newptr = reallocate(.bottom, .size * sizeof(integer))
      IF newptr = 0 THEN
        'debug "stack: out of memory"
        EXIT SUB
      END IF
      .pos += newptr - .bottom
      .bottom = newptr
    END IF
  END WITH
END SUB

SUB setstackposition (st as Stack, byval position as integer)
  BUG_IF(position < 0 ORELSE position > stackposition(st), "invalid, " & position)
  st.pos = st.bottom + position
END SUB

'------------- Old allmodex stack  -------------

dim shared stackbottom as integer ptr
dim shared stackptr as integer ptr    'Where to put the next pushed dword
dim shared stacksize as integer = -1  'In dwords

SUB setupstack ()
	stacksize = 8192
	stackbottom = callocate(sizeof(integer) * stacksize)
	if stackbottom = 0 then
		'oh dear
		debug "Not enough memory for stack"
                stacksize = -1
		exit sub
	end if
	stackptr = stackbottom
end SUB

SUB pushdw (byval dword as integer)
	if stackptr - stackbottom >= stacksize then
		dim newptr as integer ptr
		stacksize += 8192
		newptr = reallocate(stackbottom, sizeof(integer) * stacksize)
		if newptr = 0 then
			debug "stack: out of memory"
			exit sub
		end if
		stackptr += newptr - stackbottom
		stackbottom = newptr
	end if
	*stackptr = dword
	stackptr += 1
end SUB

FUNCTION popdw () as integer
	dim pdw as integer

	if (stackptr >= stackbottom + 1) then
		stackptr -= 1
		pdw = *stackptr
	else
		pdw = 0
		showbug "Stack underflow"
	end if

	popdw = pdw
end FUNCTION

SUB releasestack ()
	if stacksize > 0 then
		deallocate stackbottom
		stacksize = -1
	end if
end SUB

'Number of dwords that have been pushed to the stack
FUNCTION stackpos () as integer
	stackpos = stackptr - stackbottom
end FUNCTION

'read an int from the stack relative to current position (eg -1 is last word pushed - off should be negative)
FUNCTION readstackdw (byval off as integer) as integer
	if stackptr + off >= stackbottom then
		return *(stackptr + off)
	end if
END FUNCTION

'------------- End allmodex stack -------------

FUNCTION sign_string(n as integer, neg_str as string, zero_str as string, pos_str as string) as string
 IF n < 0 THEN RETURN neg_str
 IF n > 0 THEN RETURN pos_str
 RETURN zero_str
END FUNCTION

'See also defaultint
FUNCTION zero_default(n as integer, default_caption as string="default") as string
 IF n = 0 THEN RETURN default_caption
 RETURN STR(n)
END FUNCTION

'See also zero_default
FUNCTION defaultint (n as integer, default_caption as string="default", default_value as integer=-1) as string
 IF n = default_value THEN RETURN default_caption
 RETURN STR(n)
END FUNCTION

FUNCTION blank_default(s as string, blankcaption as string="[default]") as string
 IF s = "" THEN RETURN blankcaption
 RETURN s
END FUNCTION

FUNCTION caption_or_int (captions() as string, n as integer) as string
 IF n >= LBOUND(captions) AND n <= UBOUND(captions) THEN RETURN captions(n)
 RETURN STR(n)
END FUNCTION

FUNCTION safe_caption(caption_array() as string, index as integer, description as string = "value") as string
 IF index >= LBOUND(caption_array) AND index <= UBOUND(caption_array) THEN
  RETURN caption_array(index)
 ELSE
  RETURN "Invalid " & description & " " & index
 END IF
END FUNCTION

'Overload for storing captions in a zstring ptr array, useful because unlike string arrays,
'those can be initialised (with  = {...}) at file scope..
'Because of https://sourceforge.net/p/fbc/bugs/666/ (fixed in FB 1.09) it's not possible to define an overload for
'safe_caption which takes a zstring ptr array, hence the different name.
FUNCTION safe_captionz(caption_array() as zstring ptr, index as integer, description as string = "value") as string
 IF index >= LBOUND(caption_array) AND index <= UBOUND(caption_array) THEN
  RETURN *caption_array(index)
 ELSE
  RETURN "Invalid " & description & " " & index
 END IF
END FUNCTION

'Returns a copy of the string with separators inserted, replacing spaces, so that there's at most 'wid'
'characters between separators; use together with split()
Function wordwrap(z as string, byval wid as integer, sep as string = chr(10)) as string
 dim as string ret, in
 in = z
 if len(in) <= wid then return in
 
 dim as integer i, j
 do
  'Need to add a separator? See if there's one already. Look up to one character past end of line
  for i = 1 to small(wid + 1, len(in))
   if mid(in, i, 1) = sep then
    ret &= left(in, i - 1) & sep
    in = mid(in, i + 1)
    continue do
   end if
  next
  
  if len(in) <= wid then
   'We reached the end of input, and it will fit on a line
   ret &= in
   in = ""
   exit do
  end if

  'Look for the last space in the second half of the line (ugly to wrap near the beginning of the line)
  for j = i - 1 to wid \ 2 step -1
   if mid(in, j, 1) = " " then
    'bingo! (separator overwrites the space)
    ret &= left(in, j - 1) & sep
    in = mid(in, j + 1)
    continue do
   end if
  next

  'No space found; the last word's too long, we need to cut it off
  ret &= left(in, wid) & sep
  in = mid(in, wid + 1)
 loop while in <> ""

 return ret
end function

'After calling wordwrap() and split(), this calculates the start position of each line
'in the lines array produced by split(), and puts the result in line_starts() after REDIM'ing it.
'Offsets are 0-based
sub split_line_positions(original_text as string, lines() as string, line_starts() as integer, sep as string = chr(10))
 dim offset as integer = 0
 redim line_starts(ubound(lines))
 dim idx as integer
 for idx = 0 TO ubound(lines)
  line_starts(idx) = offset
  offset += len(lines(idx))
  if offset >= len(original_text) then exit for
  if original_text[offset] = asc(" ") or original_text[offset] = asc(sep) then
   'This character was transformed to/is a seperator, and excluded by split()
   offset += 1
  end if
 next
 'Always exits early on last iteration
 if idx <> ubound(lines) or offset <> len(original_text) then
  showbug "split_line_positions buggy or called with bad args"
 end if
end sub

'Splits text at the separators; use together with wordwrap() to do wrapping
'sep must be length 1. ret() must be resizeable. If in == "", then ret() is redimmed to length 1.
sub split(in as string, ret() as string, sep as string = chr(10))
 redim ret(0)
 dim as integer i = 0, i2 = 1, j = 0
 i = instr(i2, in, sep)
 if i = 0 then
  ret(0) = in
  exit sub
 end if
 do
  redim preserve ret(j)
  if i = 0 then
   ret(j) = mid(in, i2)
   exit do
  else
   ret(j) = mid(in, i2, i - i2)
  end if
  i2 = i + 1
  i = instr(i2, in, sep)
  j+=1
 loop
end sub

function split_chunk(in as string, index as integer, sep as string = chr(10), default as string="") as string
 ' Split a string by a separater, return one chunk.
 ' 0 is the first chunk.
 ' negative index counts from the end of the list, python-style
 dim chunks() as string
 split(in, chunks(), sep)
 if index < 0 then
  ' convert negative index
  index = ubound(chunks) + 1 + index
 end if
 if index < lbound(chunks) or index > ubound(chunks) then return default
 return chunks(index)
end function

'Like INSTR (opposite arg order!), but only returns the offset of the first match starting at a word
'boundary where 'excludeword' doesn't also match, unless query actually starts with excludeword.
'This is intended to be used with select_by_typing on menus where you don't necessarily
'want to start typing from the beginning.
'For example needle="e" excludeword="edit" matches "edit enemy data" but not "edit items"
'Returns 0 on no match.
FUNCTION find_on_word_boundary_excluding(haystack as string, needle as string, excludeword as string) as integer
 DIM excluding as bool = YES
 IF LEN(excludeword) = 0 ORELSE starts_with(needle, excludeword) THEN
  excluding = NO
 END IF
 DIM wordboundary as bool = YES
 FOR index as integer = 1 TO LEN(haystack)
  DIM alnum as integer = isalnum(haystack[index - 1])
  IF alnum AND wordboundary THEN
   IF MID(haystack, index, LEN(needle)) = needle ANDALSO _
      (excluding = NO ORELSE MID(haystack, index, LEN(excludeword)) <> excludeword) THEN
    RETURN index
   END IF
  END IF
  wordboundary = (alnum = 0)
 NEXT
 RETURN 0
END FUNCTION

FUNCTION find_on_word_boundary(haystack as string, needle as string) as integer
 RETURN find_on_word_boundary_excluding(haystack, needle, "")
END FUNCTION

FUNCTION extract_string_chunk(haystack as string, start_needle as string, end_needle as string, byref success as bool = NO, byref foundat as integer=0) as string
 'Extract and return a chunk of a larger string. (return chunk found between two substrings)
 'Matches after the first instance of start_needle up to before the first instance of end_needle that follows start_needle
 'Also returns the position where the returned substring was found in foundat (1 is the first char of the string)
 success = NO
 foundat = 0
 DIM startpos as integer = INSTR(haystack, start_needle)
 IF startpos = 0 THEN RETURN ""
 startpos += LEN(start_needle)
 DIM aftertext as string = MID(haystack, startpos)
 DIM endpos as integer = INSTR(aftertext, end_needle)
 IF endpos = 0 THEN RETURN ""
 DIM chunk as string = MID(aftertext, 1, endpos - 1)
 success = YES
 foundat = startpos
 RETURN chunk
END FUNCTION

#IFDEF __FB_MAIN__
startTest(extract_string_chunk)
 DIM teststr as string = !"foo <b>bar</b> baz"
 DIM wasok as bool
 DIM foundat as integer
 IF extract_string_chunk(teststr, "<b>", "</b>", wasok, foundat) <> "bar" THEN fail
 IF wasok = NO THEN fail
 IF foundat <> 8 THEN fail
 IF extract_string_chunk(teststr, "<nope>", "</never>", wasok, foundat) <> "" THEN fail
 IF wasok = YES THEN fail
endTest
#ENDIF

FUNCTION replace_string_chunk(haystack as string, start_needle as string, end_needle as string, new_chunk as string, byref success as bool = NO) as string
 'Looking to replace a simple substring? use replacestr instead. This function replaces the chunk between two substrings
 'On success, Returns the full string with the chunk replaced and set success arg to true
 'On failure, return the string unmodified, and set success arg to false
 success = NO
 DIM beforetext as string
 DIM aftertext as string
 
 DIM startpos as integer = INSTR(haystack, start_needle)
 IF startpos = 0 THEN RETURN haystack
 startpos += LEN(start_needle)
 beforetext = MID(haystack, 1, startpos - 1)
 aftertext = MID(haystack, startpos)
 DIM endpos as integer = INSTR(aftertext, end_needle)
 IF endpos = 0 THEN RETURN haystack
 aftertext = MID(aftertext, endpos)
 
 success = YES
 RETURN beforetext & new_chunk & aftertext
END FUNCTION

#IFDEF __FB_MAIN__
startTest(replace_string_chunk)
 DIM teststr as string = !"foo <b>bar</b> baz"
 DIM wasok as bool
 IF replace_string_chunk(teststr, "<b>", "</b>", "MOONBEAMS", wasok) <> "foo <b>MOONBEAMS</b> baz" THEN fail
 IF wasok = NO THEN fail
 IF replace_string_chunk(teststr, "<no>", "</no>", "MOONBEAMS", wasok) <> "foo <b>bar</b> baz" THEN fail
 IF wasok = YES THEN fail
endTest
#ENDIF

FUNCTION days_since_datestr (datestr as string) as integer
 'Returns the number of days since a date given as a string in the format YYYY-MM-DD
 IF LEN(datestr) <> 10 THEN
  debug "days_since_datestr: bad datestr " & datestr
  RETURN 0
 END IF
 DIM y as integer = str2int(MID(datestr, 1, 4))
 DIM m as integer = str2int(MID(datestr, 6, 2))
 DIM d as integer = str2int(MID(datestr, 9, 2))
 RETURN NOW - DateSerial(y, m, d)
END FUNCTION

'Format a duration as a string with given precision, like '2m23.1s' or '0.4s'.
'decimal_places = 1 means 0.1s precision, = 0 means 1s precision, etc
'minutes_always: include minutes when < 60s
'See also seconds2str for actual format strings.
FUNCTION format_duration(total_seconds as double, decimal_places as integer = 1, minutes_always as bool = NO) as string
 DIM subseconds as string
 IF decimal_places > 0 THEN subseconds = "." & STRING(decimal_places, "0")

 DIM seconds as double = fmod(total_seconds, 60)
 DIM minutes as integer = INT(total_seconds) \ 60
 IF seconds > 60 - 0.5 * 0.1 ^ decimal_places THEN
  'Avoid e.g. printing 1m60.0s for total_seconds 119.99
  seconds = 0.
  minutes += 1
 END IF

 DIM msg as string
 IF minutes_always ORELSE minutes >= 1 THEN
  IF minutes >= 60 THEN
   msg = (minutes \ 60) & "h"
   minutes = minutes MOD 60
  END IF
  msg &= minutes & "m"
  msg &= FORMAT(seconds, "00" & subseconds) & "s"
 ELSE
  msg = FORMAT(seconds, "0" & subseconds) & "s"
 END IF
 RETURN msg
END FUNCTION

' Argument is a timeserial (measured in days, e.g. NOW, FILEDATETIME)
FUNCTION format_date(timeser as double) as string
 IF timeser = 0 THEN RETURN "0"
 RETURN FORMAT(timeser, "yyyy mmm dd hh:mm:ss")
END FUNCTION

' Format seconds according to a format string containing %s/%S, %m/%M, %h/%H.
' The largest time interval should be lower-case, others uppercase,
' e.g. "%h:%M:%S" or "%m:%S".
' Use format_duration instead for less rigid formatting.
FUNCTION seconds2str(sec as integer, f as string = " %m: %S") as string
  DIM ret as string
  DIM as integer s, m, h
  s = sec mod 60
  m = (sec \ 60) mod 60
  h = (sec \ 3600)

  DIM as integer i
  FOR i as integer = 0 TO len(f) - 1
    IF f[i] = asc("%") THEN
      i += 1
      SELECT CASE as CONST f[i]
        CASE asc("s")
          ret = ret & sec
        CASE asc("S")
          IF s < 10 THEN ret = ret & "0"
          ret = ret & s
        CASE asc("m")
          ret = ret & (sec \ 60)
        CASE asc("M")
          IF m < 10 THEN ret = ret & "0"
          ret = ret & m
        CASE asc("h")
          ret = ret & h
        CASE asc("H")
          IF h < 10 THEN ret = ret & "0"
          ret = ret & h
        CASE asc("%")
          ret = ret & "%"
      END SELECT
    ELSE
      ret = ret & chr(f[i])
    END IF
  NEXT

  RETURN ret
END FUNCTION


SUB flusharray (array() as integer, byval size as integer=-1, byval value as integer=0)
 'If size is -1, then flush the entire array
 IF size = -1 THEN size = UBOUND(array)
 FOR i as integer = LBOUND(array) TO size
  array(i) = value
 NEXT i
END SUB

#MACRO MAKE_ARRAY_APPEND(Typename)
 'Insert a new element into an array at position 'pos'.
 SUB a_append (array() as Typename, value as Typename)
  REDIM PRESERVE array(LBOUND(array) TO UBOUND(array) + 1)
  array(UBOUND(array)) = value
 END SUB
#ENDMACRO

'MAKE_ARRAY_APPEND(string)
MAKE_ARRAY_APPEND(integer)

SUB a_append (array() as string, value as zstring ptr)
 REDIM PRESERVE array(LBOUND(array) TO UBOUND(array) + 1)
 array(UBOUND(array)) = *value
END SUB

SUB a_append (array() as IntStrPair, byval k as integer, s as zstring ptr)
 REDIM PRESERVE array(LBOUND(array) TO UBOUND(array) + 1)
 array(UBOUND(array)).i = k
 array(UBOUND(array)).s = *s
END SUB

#MACRO MAKE_ARRAY_INSERT(Typename)
 'Insert a new element into an array at position 'pos'.
 SUB a_insert(array() as Typename, pos as integer, value as Typename)
  BUG_IF(pos < LBOUND(array) ORELSE pos > UBOUND(array) + 1, "out of bounds: " & pos)
  REDIM PRESERVE array(LBOUND(array) TO UBOUND(array) + 1)
  array(UBOUND(array)) = value
  FOR idx as integer = UBOUND(array) - 1 TO pos STEP -1
   SWAP array(idx), array(idx + 1)
  NEXT
 END SUB
#ENDMACRO

MAKE_ARRAY_INSERT(string)
MAKE_ARRAY_INSERT(integer)

#MACRO MAKE_ARRAY_POP(Typename)
 ' Remove array(which) (default last), shuffling everything else down
 SUB a_pop (array() as Typename, which as integer = -&h7FFFFFFF)
  IF which = -&h7FFFFFFF THEN which = UBOUND(array)
  IF which >= LBOUND(array) ANDALSO which <= UBOUND(array) THEN
   a_shuffle_to_end array(), which
   IF LBOUND(array) < UBOUND(array) THEN
    REDIM PRESERVE array(LBOUND(array) TO UBOUND(array) - 1)
   ELSE
    ERASE array
   END IF
  END IF
 END SUB
#ENDMACRO

MAKE_ARRAY_POP(string)
MAKE_ARRAY_POP(integer)

#MACRO MAKE_ARRAY_FIND(Subname, ArrayTypename, ValTypename, EqualCheck)
 ' Return index of first item in array equal to 'value', or 'notfound'.
 FUNCTION Subname (array() as ArrayTypename, value as ValTypename, notfound as integer = -1) as integer
  FOR i as integer = LBOUND(array) TO UBOUND(array)
   IF EqualCheck THEN RETURN i
  NEXT
  RETURN notfound
 END FUNCTION
#ENDMACRO

MAKE_ARRAY_FIND(a_find,      string,     string,  array(i) = value)
MAKE_ARRAY_FIND(a_findcasei, string,     string,  LCASE(array(i)) = LCASE(value))
MAKE_ARRAY_FIND(a_find,      integer,    integer, array(i) = value)
MAKE_ARRAY_FIND(a_find,      IntStrPair, integer, array(i).i = value)
MAKE_ARRAY_FIND(a_find,      IntStrPair, string,  array(i).s = value)

#MACRO MAKE_ARRAY_SHUFFLE_TO_END(Typename)
 'Preserves order of everything except element at position 'which'. OK to give invalid 'which'
 SUB a_shuffle_to_end(array() as Typename, which as integer)
  IF which < LBOUND(array) THEN EXIT SUB
  FOR idx as integer = which TO UBOUND(array) - 1
   SWAP array(idx), array(idx + 1)
  NEXT
 END SUB
#ENDMACRO

MAKE_ARRAY_SHUFFLE_TO_END(string)
MAKE_ARRAY_SHUFFLE_TO_END(integer)

#MACRO MAKE_ARRAY_REMOVE(Typename)
 'Remove the first instance of value, resizing the dynamic array.
 'No error or warning if it isn't found.
 'Returns the index of the item if it was found, or -1 if not
 FUNCTION a_remove (array() as TypeName, value as TypeName) as integer
  DIM idx as integer
  idx = a_find(array(), value, -&h7FFFFFFF)
  IF idx = -&h7FFFFFFF THEN RETURN -1
  a_pop array(), idx
  RETURN idx
 END FUNCTION
#ENDMACRO

MAKE_ARRAY_REMOVE(string)
MAKE_ARRAY_REMOVE(integer)

SUB a_copy (fromarray() as integer, toarray() as integer)
 DIM as integer low = LBOUND(fromarray), high = UBOUND(fromarray)
 REDIM toarray(low TO high)
 memcpy @toarray(low), @fromarray(low), sizeof(integer) * (high - low + 1)
END SUB

SUB a_copy (fromarray() as string, toarray() as string)
 DIM as integer low = LBOUND(fromarray), high = UBOUND(fromarray)
 REDIM toarray(low TO high)
 FOR i as integer = low TO high
  toarray(i) = fromarray(i)
 NEXT
END SUB

'Only have tests for some of the above functions here...
#IFDEF __FB_MAIN__
startTest(array_operators)
 REDIM arr() as integer
 IF UBOUND(arr) <> -1 THEN fail
 a_append arr(), 100
 IF UBOUND(arr) <> 0 THEN fail
 IF arr(0) <> 100 THEN fail
 a_insert arr(), 0, 101
 a_append arr(), 103
 a_insert arr(), 3, 102 'Insert 1 past end
 IF UBOUND(arr) <> 3 THEN fail
 IF arr(0) <> 101 THEN fail
 IF arr(1) <> 100 THEN fail
 IF arr(2) <> 103 THEN fail
 IF arr(3) <> 102 THEN fail
 a_pop arr(), 1         'Remove 100
 IF UBOUND(arr) <> 2 THEN fail
 IF a_remove(arr(), 100) <> -1 THEN fail  'Does nothing
 IF arr(1) <> 103 THEN fail
 a_pop arr()            'Remove arr(2)=102
 IF UBOUND(arr) <> 1 THEN fail
 IF arr(1) <> 103 THEN fail
 IF a_remove(arr(), 101) <> 0 THEN fail  'Remove arr(0)
 IF UBOUND(arr) <> 0 THEN fail
 IF arr(0) <> 103 THEN fail  'arr = {103}
 a_pop arr()
 IF LBOUND(arr) <> 0 THEN fail
 IF UBOUND(arr) <> -1 THEN fail
 a_pop arr()  'noop, already empty
 IF UBOUND(arr) <> -1 THEN fail
endTest

'Test how static dynamic behave in FB, especially before they are first REDIMed.
'This behaviour was different in older versions (0.90?)

#MACRO STATIC_TEST_FUNC(Typename)
FUNCTION test_static_##Typename##_array (push as Typename, expectubound as integer) as Typename
  STATIC array() as Typename
  DIM ret as Typename
  IF LBOUND(array) <> 0 THEN RETURN push            'This will cause a fail
  IF UBOUND(array) <> expectubound THEN RETURN push 'ditto
  IF a_find(array(), push) <> -1 THEN RETURN push   'ditto
  IF UBOUND(array) >= 0 THEN ret = array(UBOUND(array))
  a_append array(), push
  'After 3 pushes, reset
  IF UBOUND(array) = 2 THEN ERASE array
  RETURN ret
END FUNCTION
#ENDMACRO

STATIC_TEST_FUNC(integer)
STATIC_TEST_FUNC(string)

startTest(staticDynamicArray)
 IF test_static_integer_array(30, -1) <> 0 THEN fail
 IF test_static_integer_array(31, 0) <> 30 THEN fail
 IF test_static_integer_array(32, 1) <> 31 THEN fail  'Erases the array
 IF test_static_integer_array(33, -1) <> 0 THEN fail
 IF test_static_integer_array(34, 0) <> 33 THEN fail
 IF test_static_string_array("a", -1) <> "" THEN fail
 IF test_static_string_array("ab", 0) <> "a" THEN fail
endTest
#ENDIF


'Stable (insert) sort of integers. Running time is O(n^2), but much faster on nearly-sorted lists.
'Use qsort_integers_indices instead when speed is needed.
'Returns, in indices() (assumed to already have been dimmed large enough), indices for
'visiting the data (an array of some kind of struct containing an integer) in ascending order.
'start points to the integer in the first element, stride is the size of an array element, in integers
SUB sort_integers_indices(indices() as integer, byval start as integer ptr, byval number as integer, byval stride as integer)
 IF number = 0 THEN number = UBOUND(indices) + 1
 DIM keys(number - 1) as integer
 DIM as integer i, temp
 FOR i = 0 TO number - 1
  keys(i) = *start
  start = CAST(integer ptr, CAST(byte ptr, start) + stride) 'yuck
 NEXT

 indices(0) = 0
 FOR j as integer = 1 TO number - 1
  temp = keys(j)
  FOR i = j - 1 TO 0 STEP -1
   IF keys(i) <= temp THEN EXIT FOR
   keys(i + 1) = keys(i)
   indices(i + 1) = indices(i)
  NEXT
  keys(i + 1) = temp
  indices(i + 1) = j
 NEXT
END SUB

'CRT Quicksort. Running time is *usually* O(n*log(n)). NOT STABLE
'See sort_integer_indices.
'
'A comparison (dependent on your libc) of sort_integers_indices and qsort_integers_indices speed:
'For random integers, the quicksort is faster
'for arrays over length about 80. For arrays which are 90% sorted appended with 10% random data,
'the cut off is about 600 (insertion sort did ~5x better on nearly-sort data at the 600 mark)
SUB qsort_indices(indices() as integer, byval start as any ptr, byval number as integer = 0, byval stride as integer, byval compare_fn as FnCompare)
 IF number = 0 THEN number = UBOUND(indices) + 1

 DIM keys(number - 1) as any ptr
 DIM i as integer
 FOR i = 0 TO number - 1
  keys(i) = start + stride * i
 NEXT

 qsort(@keys(0), number, sizeof(any ptr), compare_fn)

 FOR i = 0 TO number - 1
  indices(i) = CAST(integer, keys(i) - start) \ stride
 NEXT
END SUB

SUB qsort_integers_indices(indices() as integer, byval start as integer ptr, byval number as integer, byval stride as integer)
 qsort_indices indices(), start, number, stride, CAST(FnCompare, @integerptr_compare)
END SUB

SUB qsort_strings_indices(indices() as integer, byval start as string ptr, byval number as integer, byval stride as integer)
 qsort_indices indices(), start, number, stride, CAST(FnCompare, @stringptr_compare)
END SUB


FUNCTION ptr_compare CDECL (byval a as any ptr ptr, byval b as any ptr ptr) as long
 IF *a < *b THEN RETURN -1
 IF *a > *b THEN RETURN 1
 'implicitly RETURN 0 (it's faster to omit the RETURN :-)
END FUNCTION

FUNCTION integer_compare CDECL (byval a as integer ptr, byval b as integer ptr) as long
 IF *a < *b THEN RETURN -1
 IF *a > *b THEN RETURN 1
 'implicitly RETURN 0 (it's faster to omit the RETURN :-)
END FUNCTION

FUNCTION integerptr_compare CDECL (byval a as integer ptr ptr, byval b as integer ptr ptr) as long
 IF **a < **b THEN RETURN -1
 IF **a > **b THEN RETURN 1
 'implicitly RETURN 0
END FUNCTION

'a string ptr is a pointer to a FB string descriptor
FUNCTION string_compare CDECL (a as string, b as string) as integer
 'This is equivalent, but the code below can be adapted for case insensitive compare (and is faster (what, how?!))
 'Yep, still twice as fast as of 2019.
 'RETURN fb_StrCompare(a, -1, b, -1)

 DIM ret as integer = 0
 DIM somenull as bool = NO
 'Zero-length strings in FB may have either a NULL data pointer or a pointer to a '\0', deal with that.
 IF @a[0] = 0 THEN ret -= 1: somenull = YES
 IF @b[0] = 0 THEN ret += 1: somenull = YES
 IF somenull THEN RETURN ret

 DIM k as integer = 0
 DIM chara as ubyte
 DIM charb as ubyte
 DO
  chara = a[k]
  charb = b[k]
  IF chara < charb THEN
   RETURN -1
  ELSEIF chara > charb THEN
   RETURN 1
  END IF
  k += 1
 LOOP WHILE chara OR charb
 RETURN 0
END FUNCTION

FUNCTION stringptr_compare CDECL (byval a as string ptr ptr, byval b as string ptr ptr) as long
 RETURN string_compare(**a, **b)
END FUNCTION

FUNCTION numeric_string_compare CDECL (a as string, b as string, case_insen as bool = NO) as integer
 DIM ptra as zstring ptr = @a[0]
 DIM ptrb as zstring ptr = @b[0]
 DO
  DIM as ubyte chara, charb
  IF ptra THEN chara = *ptra  'On the first iteration one of the strings might be NULL
  IF ptrb THEN charb = *ptrb
  IF case_insen THEN
   chara = tolower(chara)
   charb = tolower(charb)
  END IF

  IF chara = 0 ANDALSO charb = 0 THEN
   RETURN 0
  ELSEIF chara <> ASC("0") ANDALSO isdigit(chara) ANDALSO charb <> ASC("0") ANDALSO isdigit(charb) THEN
   'Two numbers which both don't start with a leading zero.
   'If either number has a leading zero, then the one with the most leading zeroes
   'is first, eg "09" before "1". Avoids having to check length if the values are equal.
   DIM as longint numa, numb
   DIM as zstring ptr aftera, afterb
   'strtol is quite similar to VALINT
   numa = strtoll(ptra, @aftera, 10)
   numb = strtoll(ptrb, @afterb, 10)
   IF numa < numb THEN
    RETURN -1
   ELSEIF numa > numb THEN
    RETURN 1
   ELSEIF numa = LLONG_MAX THEN
    'If overflowed, don't compare by value, but by digits.
    '(Can't allow numa/numb to overflow, because we ignore negative signs)
   ELSE
    'Skip over the number
    ptra = aftera
    ptrb = afterb
    CONTINUE DO
   END IF
  END IF
  IF chara < charb THEN
   RETURN -1
  ELSEIF chara > charb THEN
   RETURN 1
  END IF
  ptra += 1
  ptrb += 1
 LOOP
END FUNCTION

#IFDEF __FB_MAIN__
startTest(numeric_string_compare)
 DIM nul as string, notnul as string = "x"
 notnul[0] = 0
 IF numeric_string_compare(notnul, nul) <> 0 THEN fail
 IF numeric_string_compare("a", "0") <> 1 THEN fail
 IF numeric_string_compare("0", "0") <> 0 THEN fail
 IF numeric_string_compare("abc", "aBc", YES) <> 0 THEN fail
 IF numeric_string_compare("abc", "aBc", NO) <> 1 THEN fail
 IF numeric_string_compare("ab5c", "ab0d") <> 1 THEN fail
 IF numeric_string_compare("ab5c", "ab5d") <> -1 THEN fail
 IF numeric_string_compare("12345678900", "12345678900") <> 0 THEN fail  '32-bit int
 IF numeric_string_compare("1234567890000", "1234567890000") <> 0 THEN fail  '64-bit int
 IF numeric_string_compare("1234567890000", "10000000000000") <> -1 THEN fail  '64-bit int
 'Note: huge integers aren't compared by value
 IF numeric_string_compare("9223372036854775809", "9223372036854775808") <> 1 THEN fail  '>64-bit int
 IF numeric_string_compare("09", "1") <> -1 THEN fail
endTest
#ENDIF

'Invert a (possibly partial) permutation such as that returned by sort_integers_indices;
'indices() should normally contain the integers 0 to UBOUND(inverse),
'result stored in inverse().
'If an integer x between 0 and UBOUND(inverse) is missing from indices(),
'then inverse(x) contains garbage. You may want to clear inverse() first.
SUB invert_permutation(indices() as integer, inverse() as integer)
 FOR i as integer = 0 TO UBOUND(indices)
  DIM index as integer = indices(i)
  IF index >= 0 AND index <= UBOUND(inverse) THEN
   inverse(index) = i
  END IF
 NEXT
END SUB

SUB invert_permutation(indices() as integer)
 DIM inverse(UBOUND(indices)) as integer
 invert_permutation indices(), inverse()
 'Copy back
 memcpy(@indices(0), @inverse(0), sizeof(integer) * (UBOUND(indices) + 1))
END SUB

'These cache functions store a 'resetter' string, which causes search_string_cache
'to automatically empty the cache when its value changes (eg, different game).
'Normally you would just use the game_unique_id global for this.
'Note that you can resize the cache arrays (in either direction!) as you want at any time.
FUNCTION search_string_cache (cache() as IntStrPair, byval key as integer, resetter as string) as string
 IF cache(0).s <> resetter THEN
  cache(0).s = resetter
  cache(0).i = 0  'used to loop through the indices when writing
  
  FOR i as integer = 1 TO UBOUND(cache)
   cache(i).i = -1099999876
   cache(i).s = ""
  NEXT
 END IF

 FOR i as integer = 1 TO UBOUND(cache)
  IF cache(i).i = key THEN RETURN cache(i).s
 NEXT
END FUNCTION

SUB add_string_cache (cache() as IntStrPair, byval key as integer, value as string)
 DIM i as integer
 FOR i = 1 TO UBOUND(cache)
  IF cache(i).i = -1099999876 THEN
   cache(i).i = key
   cache(i).s = value
   EXIT SUB
  END IF
 NEXT
 'overwrite an existing entry, in a loop
 i = 1 + (cache(0).i MOD UBOUND(cache))
 cache(i).i = key
 cache(i).s = value
 cache(0).i = i
END SUB

SUB remove_string_cache (cache() as IntStrPair, byval key as integer)
 FOR i as integer = 1 TO UBOUND(cache)
  IF cache(i).i = key THEN
   cache(i).i = -1099999876
   cache(i).s = ""
   EXIT SUB
  END IF
 NEXT
END SUB


'---------------- Hash Functions --------------

'Return the SHA1 hash of a file.
SUB file_hash_SHA1(filename as string, result_out as SHA160 ptr)
  DIM fh as integer
  IF OPENFILE(filename, FOR_BINARY + ACCESS_READ, fh) THEN
    debug "file_hash: couldn't open " & filename
    memset result_out, 0, 20
    EXIT SUB
  END IF
  file_hash_SHA1(fh, result_out)
  CLOSE #fh
END SUB

'Read a whole file (clobbering file position) and return its SHA1 hash.
SUB file_hash_SHA1(fh as integer, result_out as SHA160 ptr)
  DIM size as integer = LOF(fh)
  SEEK fh, 1
  DIM buf(4095) as ubyte
  DIM ctx as SHA1_CTX
  SHA1Init(@ctx)
  WHILE size > 0
    DIM readamnt as size_t
    fgetiob fh, , @buf(0), 4096, @readamnt
    IF readamnt <= 0 THEN
      debug "file_hash: fgetiob failed!"
      memset result_out, 0, 20
      EXIT SUB
    END IF
    SHA1Update(@ctx, cptr(zstring ptr, @buf(0)), readamnt)
    size -= readamnt
  WEND
  SHA1Final(result_out, @ctx)
END SUB

'Return a 64 bit hash (first 64 bits of SHA1) of a file
'(The bytes are reversed so that HEX() prints the first 8 bytes of the hash)
FUNCTION file_hash64(filename as string) as ulongint
  DIM hash as SHA160
  file_hash_SHA1 filename, @hash
  RETURN int64_to_bigendian(*CAST(ulongint ptr, @hash))
END FUNCTION

'Return a 64 bit hash (first 64 bits of SHA1) of a file (clobbers file position)
'(The bytes are reversed so that HEX() prints the first 8 bytes of the hash)
FUNCTION file_hash64(fh as integer) as ulongint
  DIM hash as SHA160
  file_hash_SHA1 fh, @hash
  RETURN int64_to_bigendian(*CAST(ulongint ptr, @hash))
END FUNCTION

'Format a SHA1 hash to a hex string (length 40)
FUNCTION SHA1_to_string(hash as SHA160) as string
  DIM ret as string
  FOR idx as integer = 0 TO 19
   ret &= LCASE(HEX(hash[idx], 2))
  NEXT
  RETURN ret
END FUNCTION

'A fast hash function suitable for hashmaps
FUNCTION strhash(hstr as string) as unsigned integer
  RETURN stringhash(cptr(zstring ptr, strptr(hstr)), len(hstr))
END FUNCTION

#IFDEF __FB_MAIN__
startTest(stringhash)
  if strhash("") <> &h99829982 then fail
  if strhash("a") <> &h21F521F4 then fail
  if strhash("ab") <> &h0D150D14 then fail
  if strhash("abc") <> &h79E579E5 then fail
  if strhash("abcd") <> &hA860A85F then fail
  if strhash("abcde") <> &hC158C158 then fail
  if strhash("abcdef") <> &hA737A737 then fail
  'Test misaligned strings
  if stringhash(strptr("_abcdef") + 1, 6) <> &hA737A737 then fail
  if stringhash(strptr("__abcdef") + 2, 6) <> &hA737A737 then fail
  if stringhash(strptr("___abcdef") + 3, 6) <> &hA737A737 then fail
endTest
#ENDIF

'---------- Path and File functions -----------

' Same as os.path.join in Python.
' path1 is a directory (possibly empty) and
FUNCTION join_path(path1 as string, path2 as string) as string
 IF is_absolute_path(path2) THEN RETURN path2
 IF LEN(path1) = 0 THEN RETURN path2
 RETURN trim_trailing_slashes(path1) & SLASH & path2
END FUNCTION

'Change / to \ in paths on Windows
FUNCTION normalize_path(filename as string) as string
  DIM ret as string = filename
#IFDEF __FB_WIN32__
  FOR i as integer = 0 TO LEN(ret) - 1 
    IF ispathsep(ret[i]) THEN ret[i] = ASC(SLASH)
  NEXT
#ENDIF
  RETURN ret
END FUNCTION

FUNCTION path_with_only_forward_slashes(filename as string) as string
  DIM ret as string = filename
  FOR i as integer = 0 TO LEN(ret) - 1 
    IF ret[i] = ASC("\") THEN ret[i] = ASC("/")
  NEXT
  RETURN ret
END FUNCTION

#IFDEF __FB_MAIN__

#DEFINE testjoin(path1, path2, expected) testEqual(join_path(path1, path2), expected)

startTest(join_path)
  testjoin("",         "foo.bar", "foo.bar")
  testjoin("",         "",        "")
  #IFDEF __FB_WIN32__
    testjoin("foo/bar/", "qux",   "foo/bar\qux")
    testjoin("foo.bar",  "",      "foo.bar\")
    testjoin("foo\bar",  "qux\",  "foo\bar\qux\")
    testjoin("c:\foo",   "bar",   "c:\foo\bar")
    testjoin("foo",      "c:\bar","c:\bar")
  #ELSE
    testjoin("foo/bar/", "qux",   "foo/bar/qux")
    testjoin("foo.bar",  "",      "foo.bar/")
    testjoin("foo\bar",  "qux\",  "foo\bar/qux\")
    testjoin("/foo",     "bar",   "/foo/bar")
    testjoin("foo",      "/bar",  "/bar")
  #ENDIF
endTest

#DEFINE testnorm(path, expected) testEqual(normalize_path(path), expected)

startTest(normalize_path)
  #IFDEF __FB_WIN32__
    testnorm("a/b/cat//",  "a\b\cat\\")
    testnorm("/cat/",      "\cat\")
    testnorm("\cat\",      "\cat\")
    testnorm("c:/",        "c:\")
  #ELSE
    testnorm("a/b/cat//",  "a/b/cat//")
    testnorm("/cat/",      "/cat/")
    testnorm("\cat\",      "\cat\")
    testnorm("c:/",        "c:/")
  #ENDIF
  testnorm("",          "")
endTest
#ENDIF

FUNCTION add_trailing_slash (dirname as string) as string
  IF LEN(dirname) = 0 THEN RETURN dirname  'For safety
  #IFDEF __FB_WIN32__
    'Also valid on Windows
    IF RIGHT(dirname, 1) = "/" THEN RETURN dirname
  #ENDIF
  IF RIGHT(dirname, 1) = SLASH THEN RETURN dirname
  RETURN dirname + SLASH
END FUNCTION

'On Windows both slashes are trimmed, on Unix only /
'This will NOT trim a trailing slash if it's part of the root,
'"/" on Unix; "X:\" or "X:/" on Windows.
FUNCTION trim_trailing_slashes(filename as string) as string
  DIM root_length as integer = LEN(get_path_root(filename))
  DIM retend as integer = LEN(filename)
  WHILE retend > root_length
    DIM ch as byte = filename[retend - 1]
    IF ispathsep(ch) THEN
      retend -= 1
    ELSE
      EXIT WHILE
    END IF
  WEND
  RETURN LEFT(filename, retend)
END FUNCTION

FUNCTION trimpath(filename as string) as string
  'Return the file/directory name without path, and without trailing (or any) slashes.
  'See testcases below
  DIM temp as string = trim_trailing_slashes(filename)
  FOR i as integer = LEN(temp) TO 1 STEP -1
    IF ispathsep(temp[i - 1]) THEN
      RETURN MID(temp, i + 1, LEN(temp) - (i + 1) + 1)
    END IF
  NEXT
  RETURN temp
END FUNCTION

#IFDEF __FB_MAIN__

#DEFINE testtrims(path, expected) testEqual(trim_trailing_slashes(path), expected)

startTest(trim_trailing_slashes)
  testtrims("a/b/cat//", "a/b/cat")
  testtrims("a/b/cat/",  "a/b/cat")
  testtrims("a/b/cat",   "a/b/cat")
  testtrims("cat/",      "cat")
  testtrims("/cat/",     "/cat")
  testtrims("/c",        "/c")
  #IFDEF __FB_WIN32__
    testtrims("c:\",      "c:\")
    testtrims("c:\/",     "c:\")
    testtrims("c:\foo",   "c:\foo")
    testtrims("c:\f\",    "c:\f")
    testtrims("c:\foo/",  "c:\foo")
  #ELSE
    testtrims("/",        "/")
    testtrims("//",       "/")
  #ENDIF
  testtrims("",          "")
endTest

#DEFINE testtrimp(path, expected) testEqual(trimpath(path), expected)

startTest(trimpath)
  testtrimp("a/b/cat//", "cat")
  testtrimp("a/b/cat/",  "cat")
  testtrimp("a/b/cat",   "cat")
  testtrimp("a/b//cat",  "cat")
  testtrimp("cat/",      "cat")
  testtrimp("/cat/",     "cat")
  #IFDEF __FB_WIN32__
    testtrimp("c:\",      "")
    testtrimp("c:\foo",   "foo")
    testtrimp("c:\foo\",  "foo")
    testtrimp("c:\foo/",  "foo")
  #ELSE
    testtrimp("/",        "")
  #ENDIF
  testtrimp("",          "")
endTest
#ENDIF

'FIXME: this function is terribly misnamed; rename it or change semantics
FUNCTION trimfilename (filename as string) as string
  'Trim the last component of a path (which may be a directory rather than file!)
  'Return path without trailing slash (unless need to return root dir). See testcases.
  'This is the complement to trimpath
  'Quite similar to parentdir().
  DIM ret as string = trim_trailing_slashes(normalize_path(filename))
  ret = MID(ret, 1, large(0, INSTRREV(ret, SLASH) - 1))
  IF is_absolute_path(filename) AND is_absolute_path(ret) = NO THEN
    'Whoops, we deleted the / or \ corresponding to the root, put it back
    RETURN normalize_path(get_path_root(filename))
  END IF
  return ret
END FUNCTION

#IFDEF __FB_MAIN__
#DEFINE testtrimf(path, expected) testEqual(trimfilename(path), normalize_path(expected))

startTest(trimfilename)
  testtrimf("a/b/cat//", "a/b")
  testtrimf("a/b/cat/",  "a/b")
  testtrimf("a/b/cat",   "a/b")
  testtrimf("cat/",      "")
  testtrimf("/cat/",     "/")
  testtrimf("/",         "/")
  #IFDEF __FB_WIN32__
    testtrimf("c:/vak",          "c:\")
    testtrimf("c:\vak/",         "c:\")
    testtrimf("c:\",             "c:\")
  #ENDIF
  testtrimf("",          "")
endTest
#ENDIF

FUNCTION trimextension (filename as string) as string
  'Return the filename (including path) without extension
  'Periods at the beginning of file/folder names are not counted as beginning an extension
  DIM at as integer = INSTRREV(filename, ".")
  DIM at2 as integer = INSTRREV(filename, "/")
#IFDEF __FB_WIN32__
  at2 = large(at2, INSTRREV(filename, "\"))
#ENDIF
  IF at >= at2 + 2 THEN
    RETURN MID(filename, 1, at - 1)
  ELSE
    RETURN filename
  END IF
END FUNCTION

FUNCTION justextension (filename as string) as string
  'Return only the extension (everything after the *last* period)
  'Periods at the beginning of file/folder names are not counted as beginning an extension
  DIM at as integer = INSTRREV(filename, ".")
  DIM at2 as integer = INSTRREV(filename, "/")
#IFDEF __FB_WIN32__
  at2 = large(at2, INSTRREV(filename, "\"))
#ENDIF
  IF at >= at2 + 2 THEN
    RETURN MID(filename, at + 1)
  ELSE
    RETURN ""
  END IF
END FUNCTION

#IFDEF __FB_MAIN__
#DEFINE testTrimExt(path, expected) testEqual(trimextension(path), normalize_path(expected))
#DEFINE testJustExt(path, expected) testEqual(justextension(path), normalize_path(expected))

startTest(TrimExtension)
  testTrimExt("", "")
  testTrimExt("File", "File")
  testTrimExt("file.e", "file")
  testTrimExt("file.tar.gz", "file.tar")
  testTrimExt("dir/game.rpgdir", "dir/game")
  testTrimExt("dir/game.rpgdir/", "dir/game.rpgdir/")
  testTrimExt(".config", ".config")
  testTrimExt(".config.TxT", ".config")
  testTrimExt("bad filename. no?", "bad filename")

  testJustExt("", "")
  testJustExt("File", "")
  testJustExt("file.e", "e")
  testJustExt("file.tar.gz", "gz")
  testJustExt("dir/game.rpgdir", "rpgdir")
  testJustExt("dir/game.rpgdir/", "")
  testJustExt(".config", "")
  testJustExt(".config.TxT", "TxT")
  testJustExt("bad filename. no?", " no?")
endTest
#ENDIF

'Return the root of a Windows path, regardless of the current OS: X:/ or X:\ or / or \
'Otherwise return ""
'FIXME: should handle network paths on Windows too
FUNCTION get_windows_path_root (pathname as string) as string
  DIM first as string = LCASE(LEFT(pathname, 1))
  DIM temp as string = MID(pathname, 2, 2)
  IF first >= "a" ANDALSO first <= "z" ANDALSO (temp = ":\" OR temp = ":/") THEN
    RETURN MID(pathname, 1, 3)
  END IF
END FUNCTION

'If a path is absolute return the root directory: / on Unix, X:/ or X:\ or / or \ on Windows
'Otherwise return ""
'FIXME: should handle network paths on Windows too
FUNCTION get_path_root (pathname as string) as string
#IFDEF __FB_WIN32__
  DIM root as string = get_windows_path_root(pathname)
  IF LEN(root) THEN RETURN root
#ENDIF
  IF LEN(pathname) ANDALSO ispathsep(pathname[0]) THEN RETURN MID(pathname, 1, 1)
  RETURN ""
END FUNCTION

'Strip / or X:\ from path, if any
FUNCTION trim_path_root (pathname as string) as string
  DIM root as string = get_path_root(pathname)
  IF LEN(root) THEN
    RETURN MID(pathname, LEN(root) + 1)
  ELSE
    RETURN pathname
  END IF
END FUNCTION

FUNCTION is_absolute_path (sDir as string) as bool
  RETURN LEN(get_path_root(sDir)) <> 0
END FUNCTION

'Return whether a path is absolute on this or any other OS
FUNCTION is_possibly_absolute_path (pathname as string) as bool
  IF LEN(pathname) THEN
    IF pathname[0] = ASC("/") OR pathname[0] = ASC("\") THEN RETURN YES
  END IF
  IF LEN(get_windows_path_root(pathname)) THEN RETURN YES
  RETURN NO
END FUNCTION

'Make a path absolute. See also absolute_with_orig_path
FUNCTION absolute_path(pathname as string) as string
  IF NOT is_absolute_path(pathname) THEN RETURN CURDIR & SLASH & pathname
  RETURN pathname
END FUNCTION


FUNCTION absolute_with_orig_path(file_or_dir as string, byval add_slash as bool = NO) as string
  DIM d as string = file_or_dir
  IF NOT is_absolute_path(d) THEN d = orig_dir & SLASH & d
  IF add_slash THEN d = add_trailing_slash(d)
  RETURN d
END FUNCTION

'Remove redundant ../, ./, // in a path. Handles both relative and absolute paths
'Result has normalised slashes and no trailing slash (unless it's the root /).
'See testcases below
FUNCTION simplify_path(sDir as string) as string
  DIM piecesarray() as string
  DIM pieces as string vector
  DIM pathname as string = normalize_path(sDir)
  DIM isabsolute as integer = is_absolute_path(pathname)
  'remove drive letter
  DIM ret as string = get_path_root(pathname)
  'Trim everything except the final slash of the root
  IF LEN(ret) THEN
   pathname = MID(pathname, LEN(ret))
  END IF

  split pathname, piecesarray(), SLASH
  array_to_vector pieces, piecesarray()
  DIM i as integer = 0
  DIM leading_updots as integer = 0  'The number of "../"s at the start
  WHILE i < v_len(pieces)
    IF pieces[i] = "" OR pieces[i] = "." THEN
      v_delete_slice pieces, i, i+1
    ELSEIF pieces[i] = ".." THEN
      IF i = 0 ANDALSO isabsolute THEN
        'Can't go up in the root directory
        v_delete_slice pieces, i, i+1
      ELSEIF i > leading_updots THEN
        v_delete_slice pieces, i-1, i+1
        i -= 1
      ELSE
        leading_updots += 1
        i += 1
      END IF
    ELSE
      i += 1
    END IF
  WEND
  FOR i = 0 TO v_len(pieces) - 1
    IF i <> 0 THEN ret += SLASH
    ret += pieces[i]
  NEXT
  v_free pieces
  IF ret = "" THEN ret = "."   'so that appending a slash is safe
  RETURN ret
END FUNCTION

#IFDEF __FB_MAIN__
#DEFINE testsimplify(path, expected) testEqual(simplify_path(path), normalize_path(expected))

startTest(simplify_path)
  testsimplify("testcases",         "testcases")
  testsimplify(".././../foo/",      "../../foo")
  testsimplify(".././a/../../foo/", "../../foo")
  testsimplify("/..",   "/")
  testsimplify("",      ".")
  testsimplify(".",     ".")
  testsimplify("/../.", "/")
  testsimplify("./../../../../a",   "../../../../a")
  testsimplify("//.//../a/../c/b/../d", "/c/d")
endTest
#ENDIF

'If one path is absolute and the other isn't, returns false!
'It doesn't make a difference if one has a trailing slash and not the other.
FUNCTION paths_equal(path1 as string, path2 as string) as bool
  #IFDEF __FB_WIN32__
    RETURN simplify_path(LCASE(path1)) = simplify_path(LCASE(path2))
  #ELSE
    RETURN simplify_path(path1) = simplify_path(path2)
  #ENDIF
END FUNCTION

'Run pathname through simplify_path, and also make it relative if it's below
''fromwhere' (which ought to be a dir, not a file, and defaults to CURDIR).
'Returns "." if both are equal.
'It would be possible to also possibly return something starting with some ../'s, but it's more trouble
'Warning, either both paths should be absolute, or both relative, otherwise
'no parts of the path can be removed.
FUNCTION simplify_path_further(pathname as string, fromwhere as string = "") as string
  DIM path as string = simplify_path(pathname)
  DIM source as string = fromwhere
  IF source = "" THEN source = CURDIR
  source = simplify_path(source)
  'source and path now have no trailing slash (unless they're the root dir)
  #IFDEF __FB_WIN32__
    DIM matchlen as integer = length_matching(LCASE(source), LCASE(path))
  #ELSE
    DIM matchlen as integer = length_matching(source, path)
  #ENDIF
  IF matchlen = LEN(source) THEN
    IF matchlen = LEN(path) THEN
      'They are equal
      RETURN "."
    ELSEIF ispathsep(path[matchlen]) THEN
      'Need a slash following the part matching source, so we don't match foo and foo.rpgdir
      'Strip the slash.
      RETURN MID(path, matchlen + 2)
    ELSEIF ispathsep(path[matchlen - 1]) THEN
      'Special case: if the last character of source is / or \ that means it's the root dir
      RETURN MID(path, matchlen + 1)
    END IF
  END IF
  RETURN path
END FUNCTION

#IFDEF __FB_MAIN__
#DEFINE testsimplify2(path, fromwhere, expected) testEqual(simplify_path_further(path, fromwhere), normalize_path(expected))

startTest(simplify_path_further)
  testsimplify2("testcases",    "",          "testcases")
  testsimplify2("testcases/",   "",          "testcases")
  testsimplify2("testcases",    "testcases", ".")
  testsimplify2("testcases",    "test",      "testcases")
  testsimplify2("/foo/bar",     "foo",       "/foo/bar")
  testsimplify2("/foo/bar/",    "foo/",      "/foo/bar")
  testsimplify2("/foo/bar",     "/foo",      "bar")
  testsimplify2("/foo/bar/",    "/foo/",     "bar")
  testsimplify2("/foo",         "/",         "foo")
  testsimplify2("/foo/",        "/",         "foo")
  testsimplify2("../bar",       "..",        "bar")
  testsimplify2(".././../foo/", "",          "../../foo")
  testsimplify2(".././../foo/", "..",        "../foo")
  testsimplify2(".././../foo/", "..",        "../foo")
  testsimplify2(".././a/../../foo/", "",     "../../foo")
  testsimplify2("/..",           "/foo",     "/")
  testsimplify2("/../.",         "/foo",     "/")
  testsimplify2("",              "",         ".")
  testsimplify2(".",             ".",        ".")
  testsimplify2("//.//../a/../c/b/../d",  "/c",  "d")
  testsimplify2(CURDIR & SLASH & "bar",   "",    "bar")
endTest
#ENDIF

'Go up a number of directories. Simplifies and normalises.
'path is interpreted as a directory even if missing the final slash!
FUNCTION parentdir (path as string, byval upamount as integer = 1) as string
  DIM pathname as string = path + SLASH
  FOR i as integer = 0 TO upamount - 1
   pathname += ".." + SLASH
  NEXT
  RETURN add_trailing_slash(simplify_path(pathname))
END FUNCTION

#IFDEF __FB_MAIN__
startTest(parentdir)
  testEqual(parentdir("foo/bar/qux/", 1), "foo" SLASH "bar" SLASH)
  testEqual(parentdir("foo/bar/qux", 1), "foo" SLASH "bar" SLASH)
  testEqual(parentdir("foo/bar/qux", 2), "foo" SLASH)
  testEqual(parentdir("foo/bar/qux", 3), "." SLASH)
  testEqual(parentdir("qux/", 0), "qux" SLASH)
  testEqual(parentdir("qux", 0), "qux" SLASH)
  testEqual(parentdir("qux", 1), "." SLASH)
  testEqual(parentdir(SLASH, 1), SLASH)
  #IFDEF __FB_WIN32__
    testEqual(parentdir("C:\", 1), "C:\")
  #ENDIF
endTest
#ENDIF

' Given a relative path to a file or dir by a user clueless about Unix/Windows
' differences, try to find that file, returning either a simplified/normalised
' path or an error message. Use isfile() or isdir() to test for success.
' 'path' is not modified.
' In particular:
' - \ is treated as a path separator even on Unix
' - The path is treated as case insensitive, and we search for a file matching that pattern
' - If there are multiple files matching case insensitively, return an error
' - If the path would be absolute on any platform, give up, this can't be made portable
' FIXME: Need to disallow non-portable characters such as :
'
' NOTE: while on UNIX and Mac we return the path with the actual capitalisation, on Windows we don't bother
' to do so, and return the original path (normalised and simplified).
' Note that on Mac the filesystem may or may not be case sensitive, but we use the Unix/case sensitive
' codepath to handle both cases.
FUNCTION find_file_portably (path as string) as string
  IF is_possibly_absolute_path(path) THEN RETURN "Absolute path not allowed: " + path

  CONST findhidden = YES

  DIM _path as string = path
  #IFDEF __FB_UNIX__
    replacestr _path, "\", "/"
    _path = simplify_path(_path)

    DIM ret as string
    DIM filenames as string vector

    ' Walk the path
    REDIM components() as string
    split _path, components(), SLASH

    FOR idx as integer = 0 TO UBOUND(components)
      DIM namemask as string = anycase(components(idx))
      IF idx > 0 THEN ret += SLASH

      IF components(idx) = ".." THEN
        ret += components(idx)
        CONTINUE FOR
      END IF

      IF idx = UBOUND(components) THEN
        ' We don't know whether we're looking for a file or directory, allow either
        v_move filenames, list_files_or_subdirs(ret, namemask, findhidden, -1)
      ELSE
        v_move filenames, list_subdirs(ret, namemask, findhidden)
      END IF

      IF v_len(filenames) = 0 THEN
        ' Failure
        v_free filenames
        RETURN "Can't find " + ret + components(idx)
      ELSEIF v_len(filenames) > 1 THEN
        ' Return an error
        DIM errmsg as string = "Found multiple paths"
        IF LEN(ret) THEN errmsg += " (in " + ret + ")"
        ' Sort just so the error message is deterministic, for testcases
        v_sort filenames
        errmsg += " with same case-insensitive name: " + v_str(filenames)
        v_free filenames
        RETURN errmsg
      END IF
      ret += filenames[0]
    NEXT

    v_free filenames
    RETURN ret

  #ELSE
    ' On Windows, no searching needed
    _path = simplify_path(path)
    IF isfile(_path) ORELSE isdir(_path) THEN RETURN _path
    RETURN "Can't find " + _path
  #ENDIF
END FUNCTION

'If the given file or directory with possibly changed case already exists then
'return its filename, otherwise returns 'path' unchanged.
'Also, path can contain ? or * wildcards in the final component.
'(Only does case-insensitive matching of the final component. Try find_file_portably for the whole path)
FUNCTION find_file_anycase(path as string, file_type as FileTypeEnum = fileTypeFile) as string
 #IFDEF __FB_WIN32__
  'If the path contains a wildcard, then we have to run it through findfiles to get rid of it,
  'otherwise there's no need to do a search
  IF INSTR(path, "*") = 0 ANDALSO INSTR(path, "?") = 0 THEN RETURN path
 #ENDIF
 DIM filelist() as string
 DIM dirname as string = trimfilename(path)
 IF LEN(dirname) = 0 THEN dirname = CURDIR
 'findfiles is always case-insensitive
 findfiles dirname, trimpath(path), file_type, YES, filelist()
 IF UBOUND(filelist) < 0 THEN RETURN path
 IF UBOUND(filelist) > 0 THEN
  debug "find_path_anycase: multiple files case-insensitively match " & path
 END IF
 RETURN dirname & SLASH & filelist(0)
END FUNCTION

#IFDEF __FB_MAIN__
' Have to allow find_file_portably to not resolve the true capitalisation on Windows
#IFDEF __FB_UNIX__
  #DEFINE testfindfile(path, expected_unix, expected_windows) testEqual(find_file_portably(path), expected_unix)
  #DEFINE testanycase( path, expected_unix, expected_windows) testEqual(find_file_anycase (path), expected_unix)
#ELSE
  #DEFINE testfindfile(path, expected_unix, expected_windows) testEqual(find_file_portably(path), expected_windows)
  #DEFINE testanycase( path, expected_unix, expected_windows) testEqual(find_file_anycase (path), expected_windows)
#ENDIF
#DEFINE testfilemissing(path, expected) testEqual(find_file_portably(path), "Can't find " + normalize_path(expected))
#DEFINE testfileabsolute(path) testEqual(find_file_portably(path), "Absolute path not allowed: " + path)

'This also indirectly tests findfiles a bit (Unix only)
startTest(find_file_portably_and_anycase)
  CONST tempdir = "_Testdir.tmp"
  CONST tempdir2 = tempdir + SLASH + "subDir"
  IF makedir(tempdir) <> 0 THEN fail
  IF makedir(tempdir2) <> 0 THEN fail
  touchfile(tempdir + "/Foo.Tmp")
  touchfile(tempdir2 + "/bar.TMP")
  #IFDEF __FB_UNIX__
    touchfile(tempdir + "/file1.TMP")
    touchfile(tempdir + "/FILE1.tmp")
    IF makedir(tempdir + "/Subdir1") <> 0 THEN fail
    #IFNDEF __FB_DARWIN__
      IF makedir(tempdir + "/SUBDIR1") <> 0 THEN fail
    #ENDIF
  #ENDIF

  ' Test finding files
  testfindfile(tempdir + "/foo.tmp",          tempdir + "/Foo.Tmp",  tempdir + "\foo.tmp")
  testfindfile(tempdir + "\Foo.tmp",          tempdir + "/Foo.Tmp",  tempdir + "\Foo.tmp")
  testfindfile(UCASE(tempdir) + "\foo.TMP",   tempdir + "/Foo.Tmp",  UCASE(tempdir) + "\foo.TMP")
  testfindfile(tempdir2 + "/..\foo.tmp",      tempdir + "/Foo.Tmp",  tempdir + "\foo.tmp")
  testfindfile(tempdir2 + "\../foo.tmp",      tempdir + "/Foo.Tmp",  tempdir + "\foo.tmp")
  testfindfile(tempdir2 + "/Bar.tmp",         tempdir2 + "/bar.TMP", tempdir2 + "\Bar.tmp")
  testfindfile(UCASE(tempdir2) + "\bar.tmp",  tempdir2 + "/bar.TMP", UCASE(tempdir2) + "\bar.tmp")
  ' Test finding directories
  testfindfile(tempdir,                       tempdir,  tempdir)
  testfindfile(tempdir2,                      tempdir2, tempdir2)
  testfindfile(UCASE(tempdir2),               tempdir2, UCASE(tempdir2))
  testfindfile(tempdir2 + "/",                tempdir2, tempdir2)
  testfindfile(tempdir2 + "\",                tempdir2, tempdir2)
  testfindfile(tempdir2 + "//.",              tempdir2, tempdir2)
  testfindfile(tempdir2 + "\\.",              tempdir2, tempdir2)
  testfindfile(tempdir2 + "/..",              tempdir,  tempdir)
  testfindfile(tempdir2 + "\..",              tempdir,  tempdir)
  ' Test files that don't exist
  testfilemissing(tempdir + "\Not.A.Directory\",        tempdir + SLASH + "Not.A.Directory")
  testfilemissing(tempdir + "/Not here",                tempdir + SLASH + "Not here")
  testfilemissing(tempdir2 + "\nor THERE",              tempdir2 + SLASH + "nor THERE")
  testfilemissing(tempdir + "/FLOOP\..\not anywhere!",  tempdir + SLASH + "not anywhere!")  ' Should simplify
  ' Test parent directories
  CHDIR tempdir2
  testfindfile("bar.tmp",                     "bar.TMP",    "bar.tmp")
  testfindfile("..\foo.tmp",                  "../Foo.Tmp", "..\foo.tmp")
  testfindfile("..\subdir",                   "../subDir",  "..\subdir")
  testfindfile("..",                          "..",         "..")
  CHDIR "../.."

  ' Test disallowed paths
  testfileabsolute("c:/Invalid")
  testfileabsolute("c:\Invalid")
  testfileabsolute("/Invalid")
  ' Test multiple files with same case-collapsed path (can't happen on Windows)
  ' Also skip this test on Mac because there the filesystem is usually case-insensitive, so this can't happen
  #IF defined(__FB_UNIX__) and not defined(__FB_DARWIN__)
    DIM normed as string = normalize_path(tempdir + "/")
    testEqual(find_file_portably(tempdir + "/file1.tmp"), _
              "Found multiple paths (in " + normed + ") with same case-insensitive name: [""FILE1.tmp"", ""file1.TMP""]")
    testEqual(find_file_portably(tempdir + "/subdir1/file"), _
              "Found multiple paths (in " + normed + ") with same case-insensitive name: [""SUBDIR1"", ""Subdir1""]")
  #ENDIF

  ' Test find_file_anycase
  testanycase(tempdir + "/foo.tmp",          tempdir + "/Foo.Tmp",  tempdir + "/foo.tmp")
  testanycase(tempdir + "/Foo.tmp",          tempdir + "/Foo.Tmp",  tempdir + "/Foo.tmp")
  CHDIR tempdir2
  testanycase("bar.tmp",                     CURDIR + "/bar.TMP",   "bar.tmp")
  testanycase(".." SLASH "foo.tmp",          ".." SLASH "Foo.Tmp", ".." SLASH "foo.tmp")
  '(Looking for a file, not a subdir)
  testanycase("../subdir",                   "../subdir",  "../subdir")
  testanycase("..",                          "..",         "..")
  ' Test wildcard support
  testanycase("*.tmp",                       CURDIR + "/bar.TMP",   CURDIR + "\bar.TMP")
  testanycase("bar.?mp",                     CURDIR + "/bar.TMP",   CURDIR + "\bar.TMP")
  testanycase("doesn't exist *",             "doesn't exist *",     "doesn't exist *")
  CHDIR "../.."

  killdir(tempdir, YES)  'recursively

  IF isdir(tempdir) THEN fail
endTest
#ENDIF


FUNCTION anycase (filename as string) as string
  'create a case-insensitive regex from a filename
#IFDEF __FB_WIN32__
  'Windows filenames are always case-insenstitive
  RETURN filename
#ELSE
  DIM ascii as integer
  DIM as string result = ""
  FOR i as integer = 1 TO LEN(filename)
    ascii = ASC(MID(filename, i, 1))
    IF ascii >= 65 AND ascii <= 90 THEN
      result = result + "[" + CHR(ascii) + CHR(ascii + 32) + "]"
    ELSEIF ascii >= 97 AND ascii <= 122 THEN
      result = result + "[" + CHR(ascii - 32) + CHR(ascii) + "]"
    ELSE
      result = result + CHR(ascii)
    END IF
  NEXT i
  RETURN result
#ENDIF
END FUNCTION

FUNCTION escape_filename (filename as string) as string
  'This is intended for escaping filenames for use in shells
#IFDEF __FB_UNIX__
  'Don't escape '
  RETURN """" & escape_string(filename, """`\$") & """"
#ELSE
  'Note " is not allowed in filenames
  IF RIGHT(filename, 1) = "\" ANDALSO RIGHT(filename, 2) <> "\\" THEN
   'If the filename ends in \ then the \ would escape the ", escape it
   RETURN """" & filename & "\"""
  ELSE
   RETURN """" & filename & """"
  END IF
#ENDIF
END FUNCTION

FUNCTION escape_filenamec CDECL (byval filename as zstring ptr) as zstring ptr
  DIM ret as string = escape_filename(*filename)
  DIM retz as zstring ptr = ALLOCATE(LEN(ret) + 1)
  strcpy retz, cstring(ret)
  RETURN retz
END FUNCTION

'Exclude chars disallowed in filenames (on any platform), and also
'wildcards that will be a problem if passed to findfiles. Printable ASCII only.
'Does NOT disallow characters that need escaping.
FUNCTION fixfilename (filename as string) as string
  '/\: should definitely be excluded.
  'For findfiles also exclude *?, and also [] (supported by fnmatch/findfiles only on Unix)
  'and <> (undocumented wildcards supported by Windows DIR command:
  ' https://ss64.com/nt/syntax-wildcards.html
  'Probably not supported by FB's DIR, but to be safe...)
  DIM temp as string = exclude(filename, "/\:*?[]<>")
  DIM result as string
  FOR i as integer = 0 TO LEN(temp) - 1
    SELECT CASE temp[i]
      CASE 32 TO 127 : result &= CHR(temp[i])
    END SELECT
  NEXT
  RETURN result
END FUNCTION

'This is called to check whether the name of lump file is valid. fixfilename is
'too restrictive for that, because script source files lumped into source.lumped
'are unrestricted.
FUNCTION lump_filename_valid (filename as string) as bool
  IF INSTR(filename, ANY "/\") THEN RETURN NO
  FOR i as integer = 0 TO LEN(filename) - 1
    IF filename[i] < 32 THEN RETURN NO
  NEXT
  RETURN YES
END FUNCTION

'The hostname part of a URL, eg HamsterRepublic.com
FUNCTION url_hostname (url as string) as string
  DIM ret as string = url
  DIM idx as integer
  idx = INSTR(ret, "://")
  IF idx THEN ret = MID(ret, idx + 3)
  idx = INSTR(ret, "/")
  IF idx THEN ret = LEFT(ret, idx - 1)
  RETURN ret
END FUNCTION

'This is a replacement for SHELL, meaning it invokes a command interpreter like
'cmd.exe instead of just running a program, and the standard search paths are searched,
'don't need to get a full path.
'Unlike SHELL on Windows, it doesn't pop up a terminal window.
'Also it needs to be used on Windows if the executable was escaped (so contains quotes).
'Returns the exit code, or -1 if it couldn't be run, or -2 if it timed out
'NOTE: use instead run_and_get_output and check stderr if you want better ability to catch errors
FUNCTION safe_shell (cmd as string, timeout as double = 5., log_it as bool = YES) as integer
#IFDEF MINIMAL_OS
  debuginfo "shell unsupported: " & cmd
  RETURN -1
#ELSEIF DEFINED(__FB_WIN32__)
  IF log_it THEN debuginfo cmd
  'SHELL wraps system() which calls cmd.exe (or command.com on non-NT Windows)
  DIM handle as ProcessHandle
  IF is_windows_9x() THEN
   handle = open_process("command.com", "/C " & cmd, YES, NO)
  ELSE
   'cmd.exe will remove the first and last quotes from the string and leave the rest.
   'Therefore, there need to be two quotes at the beginning of the string!
   handle = open_process("cmd.exe", "/C """ & cmd & """", YES, NO)
  END IF
  RETURN wait_for_process(@handle, timeout * 1000)
#ELSE  'Unix
  IF log_it THEN debuginfo cmd
  ' Replacement for SHELL which checks the return code in more detail
  ' Doesn't timeout. Only implemented on Unix.
  RETURN checked_system(STRPTR(cmd))
#ENDIF
END FUNCTION

'Like safe_shell, but passes back the output in the 'stdout' string, and optionally 'stderr' in a string too.
'By default stderr also gets debuginfo logged, and cmd too when log_it is true.
'If stderr = "<ignore>" then stderr isn't captured, and writes to stderr pass through to our stderr stream.
'
'The return value is generally -1 on an error invoking the shell, -2 on timeout,
'-4444/-4445 on an error running or capturing the output,
'and otherwise the shell exit code, generally equal to the program exitcode and 0 on success.
'
'(There is a second implementation of this as run_process_and_get_output in os_unix.c
' which does't support stderr, but doesn't use temporary files or run the shell)
'(If you want to SEE the program's output in a terminal emulator, use spawn_and_wait instead)
FUNCTION run_and_get_output(cmd as string, byref stdout_s as string, byref stderr_s as string = "", log_it as bool = YES) as integer
  DIM ret as integer
  DIM as string stdout_file, stderr_file, cmdline
  DIM as bool grab_stderr
  grab_stderr = (stderr_s <> "<ignore>")
  IF is_windows_9x() THEN
   grab_stderr = NO
   stderr_s = "(Can't grab errors on Windows 9x/ME)"
  END IF

  stdout_file = tmpdir & "temp_stdout." & randint(1000000) & ".tmp"
  cmdline = cmd & " > " & escape_filename(stdout_file)
  IF grab_stderr THEN
    stderr_file = tmpdir & "temp_stderr." & randint(1000000) & ".tmp"
    ' This redirection works on Windows too with cmd.exe, but not command.com
    cmdline &= " 2> " & escape_filename(stderr_file)
  END IF
  ret = safe_shell(cmdline, , log_it)

  IF grab_stderr THEN
    IF isfile(stderr_file) THEN
      stderr_s = string_from_file(stderr_file)
      killfile stderr_file
    ELSE
      stderr_s = "(redirection failed)"
      ret = -4445
    END IF
  END IF

  IF isfile(stdout_file) THEN
    stdout_s = string_from_file(stdout_file)
    killfile stdout_file
  ELSE
    stdout_s = ""
    ret -= -4000
  END IF

  IF ret ORELSE (grab_stderr AND LEN(stderr_s)) THEN
   debuginfo "safe_shell(" & IIF(log_it, "", cmd) & ")=" & ret & " stderr:" & stderr_s
  END IF

  RETURN ret
END FUNCTION

'Create if it doesn't exist. Does NOT update its timestamp!
SUB touchfile (filename as string)
  DIM as integer fh
  IF OPENFILE(filename, FOR_BINARY + ACCESS_READ_WRITE, fh) THEN
    debug "touchfile(): could not open " + filename
    EXIT SUB
  END IF
  CLOSE #fh
END SUB

'Increases (never decreases) the length of a file by appending NUL bytes as required.
'Writing off the end of a file writes garbage between the new data and the end of the old file.
'Use this function to extend the file first.
SUB extendfile (byval fh as integer, byval length as integer)
 DIM curlen as integer = LOF(fh)
 IF curlen < length THEN
  DIM oldpos as integer = SEEK(fh)
  DIM buf(length - curlen - 1) as ubyte
  PUT #fh, curlen + 1, buf()
  SEEK #fh, oldpos
 END IF
END SUB

' Convert a UTF8 string to Latin-1. Any codepoints not in Latin-1 (ie above 255) get converted to '?'
' NOTE: you should normally use utf8_to_OHR instead!
FUNCTION utf8_to_latin1(utf8string as ustring) as string
  IF LEN(utf8string) = 0 THEN RETURN ""

  'Avoid FB's builtin conversion to wstring because it's locale-dependent
  DIM length as integer = utf8_length(strptr(utf8string))
  IF length < 0 THEN
    debug "utf8_length(" & utf8string & ") failed"
    'Maybe this garbage string is actually already latin-1? E.g. if some application
    'put a string in the clipboard without encoding it in UTF8
    RETURN utf8string ' "[CORRUPTED]"
  END IF

  DIM widestr as wstring ptr
  widestr = utf8_decode(strptr(utf8string), @length)
  IF widestr = NULL THEN RETURN "[CORRUPTED]"  'Shouldn't ever happen

  DIM ret as string = SPACE(length)
  length = wstring_to_latin1(widestr, strptr(ret), length + 1)
  ' The result might be shorter
  ret = LEFT(ret, length)
  DEALLOCATE widestr
  RETURN ret
END FUNCTION

' Just leaves all the icon characters alone
FUNCTION latin1_to_utf8(s as string) as ustring
  DIM buf as ustring = SPACE(LEN(s) * 2)  'At most a 2x blowup

  DIM outchar as ubyte ptr = @buf[0]
  FOR idx as integer = 0 TO LEN(s) - 1
    outchar += utf8_encode_char(outchar, s[idx])
  NEXT
  RETURN LEFT(buf, outchar - @buf[0])
END FUNCTION

' Translates from utf8 to the OS native multibyte string encoding (that is, to
' the OS codepage (for non-unicode programs) on Windows and to the LC_CTYPE
' encoding on Unix), which is used for printing to console.
' Returns original u8str on failure
FUNCTION utf8_to_mbs(u8str as ustring) as string
  'First convert from utf8 to wstring so we can call wcstombs
  DIM wcstr as wstring ptr = utf8_decode(strptr(u8str))
  IF wcstr = NULL THEN debug "utf8_decode failed" : RETURN u8str
  DIM length as integer = wcstombs(NULL, wcstr, 0)
  IF length < 0 THEN RETURN u8str
  DIM mbstr as zstring ptr = calloc(length + 1, 1)
  IF wcstombs(mbstr, wcstr, length) = cast(size_t, -1) THEN RETURN u8str
  RETURN *mbstr
END FUNCTION

' This translates a filename, e.g. returned from browse() or findfiles() to
' Latin-1 so it can be displayed normally.
' FIXME: check the font type instead of assuming Latin-1.
' FIXME: check the Windows ANSI codepage instead of assuming 1252 (extension of Latin-1).
'
' Filenames may be in various encodings depending on OS, filesystem, and locale.
' In practice, on Unix the encoding might be anything, and is determined by
' the LANG and LC_CTYPE envvars.
' On Windows, there are ANSI (8-bit) and UTF-16 filenames for each file, depending
' on which variant of winapi functions get called; FB uses the ANSI ones
' meaning filenames are encoded in the system codepage, often Windows-1252
' (an extension of Latin1).
' FIXME: filenames stored as 8-bit (ANSI) strings on Windows can't be used to open
' filenames that can't be encoded in the ANSI codepage; FindNextFileA does lossy conversion.
'
' The engine recieves filenames in the unknown encoding, treats them as byte
' strings (aside from dependable ASCII characters like / \ .) and then hands
' them back to the OS, and must never attempt to muck with the encoding
' along the way. This function must ONLY be used for display, as it is lossy!
FUNCTION decode_filename(filename as string) as string
  IF LEN(filename) = 0 THEN RETURN filename
#ifdef __FB_UNIX__
  DIM length as integer
  DIM unicode as wstring ptr

#ifdef __FB_ANDROID__
  'Android NDK doesn't support mbstowcs or non-C locales (only exposed to Java apps),
  'and is always UTF8
  length = utf8_length(strptr(filename))
  IF length < 0 THEN
    debuginfo "decode_filename(" & filename & ") failed, " & length
    RETURN filename
  END IF
  unicode = utf8_decode(strptr(filename), @length)
  IF unicode = NULL THEN RETURN filename  'Shouldn't happen

#else
/' This is just equivalent to assigning a string to a wstring!
  length = mbstowcs(NULL, STRPTR(filename), 0)
  IF length = -1 THEN
    debuginfo "decode_filename(" & filename & ") failed"
    RETURN filename   'not valid UTF-8 (Note: we continue on valid ASCII)
  END IF
  unicode = allocate(SIZEOF(wstring) * (length + 1))
  mbstowcs(unicode, STRPTR(filename), length + 1)
'/
  length = LEN(filename)
  unicode = allocate(SIZEOF(wstring) * (length + 1))
  *unicode = filename
#endif

  DIM ret as string = SPACE(length)
  length = wstring_to_latin1(unicode, strptr(ret), length + 1)
  ' The result might be shorter
  ret = LEFT(ret, length)
  deallocate unicode

#elseif defined(__FB_WIN32__)

  'Internally FB uses legacy ANSI file IO functions, so all filenames are in
  'the system ANSI codepage, if possible (they might contain ?'s and be impossible to open!)
  'FIXME: we assume the system codepage is Windows-1252, which is extremely wrong!
  'Convert Windows-1252 to Latin-1 by removing the extra characters
  '(There's little point doing this)
  DIM ret as string = filename
  FOR i as integer = 0 TO LEN(ret) - 1
    IF ret[i] >= 127 AND ret[i] <= 160 THEN
      ret[i] = ASC("?")
    END IF
  NEXT

#endif

  'debug "decode_filename(" & filename & ") = " & ret
  RETURN ret
END FUNCTION

'Finds files in a directory, writing them into an array without their path
'(If you want to find a single file, use find_file_portably())
'filelist() must be resizeable; it'll be resized so that LBOUND = -1, with files, if any, in filelist(0) up
'By default, find all files in directory, otherwise namemask is a case-insensitive filename mask
'filetype is one of fileTypeFile, fileTypeDirectory, fileTypeFileOrDir
SUB findfiles (directory as string, namemask as string = "", filetype as FileTypeEnum = fileTypeFile, findhidden as bool = NO, filelist() as string)
  REDIM filelist(-1 TO -1)
  IF directory = "" THEN
   ' For safety and bug catching: for example deletetemps() calls findfiles
   ' and then deletes everything.
   showbug "findfiles called with empty directory"
   EXIT SUB
  END IF
  IF filetype <> fileTypeDirectory and filetype <> fileTypeFile and filetype <> fileTypeFileOrDir THEN
   showbug "findfiles: bad filetype"
   EXIT SUB
  END IF
  DIM as string searchdir = add_trailing_slash(directory)
  DIM as string nmask = anycase(namemask)
  IF LEN(nmask) = 0 THEN nmask = ALLFILES
#ifdef DEBUG_FILE_IO
  DIM filetypestr as string = "fileTypeFile"
  IF filetype = fileTypeDirectory THEN filetypestr = "fileTypeDirectory"
  IF filetype = fileTypeFileOrDir THEN filetypestr = "fileTypeFileOrDir"
  debuginfo "findfiles(directory = " & directory & ", namemask = " & namemask & ", " _
            & filetypestr & ", findhidden = " & findhidden & ")"
#endif

#ifdef __FB_UNIX__
  DIM filenames as string vector

  IF filetype = fileTypeDirectory THEN
    v_move filenames, list_subdirs(searchdir, nmask, findhidden)
  ELSEIF filetype = fileTypeFile THEN
    v_move filenames, list_files(searchdir, nmask, findhidden)
  ELSE
    v_move filenames, list_files_or_subdirs(searchdir, nmask, findhidden, -1)
  END IF
        
  FOR i as integer = 0 TO v_len(filenames) - 1
    IF filetype = fileTypeDirectory THEN
     'Filter out some Linux dirs that we should not be browsing around in.
     IF filenames[i] = "dev" ORELSE filenames[i] = "proc" ORELSE filenames[i] = "sys" THEN CONTINUE FOR
     'Maybe we should filter out some other dirs on Mac and on Android?
    END IF
    a_append filelist(), filenames[i]
  NEXT

  v_free filenames

#else
  'FIXME: On Windows, non-unicode-enabled programs automatically get their filenames downconverted to the current
  '"ANSI" codepage. If any character in the filename isn't in that codepage, then opening the file is impossible,
  'and DIR will return a useless filename containing ?'s. (If we're searching for directories, the
  'extra DIR call to test the filetype will then filter it out).
  'If the filename does fit in the codepage we can open it, but we use Latin-1 internally (a subset
  'of Windows-1252), and if the filename has characters not in Latin-1 then they'll display wrong, as something
  'else. Ee want to support more than just Latin-1 filenames, we will have to rewrite
  'this properly, using winapi calls, because FB's DIR has no support. Or fix FB itself.

  DIM foundfile as string
  DIM attrib as integer
  /'---Windows directory attributes
  CONST attribReadOnly = 1
  CONST attribHidden = 2
  CONST attribSystem = 4
  ' 8 is not used
  CONST attribDirectory = 16
  CONST attribArchive = 32
  CONST attribDevice = 64
  CONST attribNormal = 128  '"A file that does not have other attributes set." (Not a real attribute?)
  CONST attribReserved = 64+128
  CONST attribAlmostAll = 255-16-2 ' All except directory and hidden
  '/
  ' Recall that DIR returns all things in a directory except those
  ' with a bit that we didn't specify
  IF filetype = fileTypeDirectory THEN
    attrib = 32+16+4+1
  ELSEIF filetype = fileTypeFile THEN
    attrib = 255 XOR (16+2)
  ELSE
    attrib = 255 XOR 2
  END IF
  IF findhidden THEN attrib += 2
  foundfile = DIR(searchdir + nmask, attrib)
  IF foundfile = "" THEN EXIT SUB
  REDIM tempfilelist(-1 TO -1) as string
  DO UNTIL foundfile = ""
    a_append tempfilelist(), foundfile
    foundfile = DIR '("", attrib)
  LOOP
  FOR i as integer = 0 TO UBOUND(tempfilelist)
    foundfile = tempfilelist(i)
    IF foundfile = "." ORELSE foundfile = ".." THEN CONTINUE FOR
    IF filetype = fileTypeDirectory THEN
      'alright, we want directories, but DIR is too broken to give them to us
      'files with attribute 0 appear in the list, so single those out
      IF DIR(searchdir + foundfile, 32+16+4+2+1) = "" OR DIR(searchdir + foundfile, 32+4+2+1) <> "" THEN CONTINUE FOR
    END IF
    a_append filelist(), foundfile
  NEXT

  'If DIR is not called until it returns "" then internally it holds a HANDLE for the search,
  'which makes the directory on which it was last run undeletable. So reset it by
  'doing another search (C:\ is actually invalid, the search string can't end in \)
  DIR("C:\")

#endif
END SUB 'filelist

'Recursively build alist of files including subdirectories.
'This is similar to findfiles.
'It fulls filelists with full paths including the base directory, subdirectories, and the filename at the end.
' (in contrast to findfiles which only finds filenames, no path)
'Don't pass anything for the cur_depth argument. That is only for recursion.
SUB recursefiles (directory as string, namemask as string = "", findhidden as bool = NO, filelist() as string, cur_depth as integer = 0)
 IF cur_depth = 0 THEN
  REDIM filelist(-1 TO -1) as string
 END IF
 REDIM finder(-1 TO -1) as string
 DIM longname as string
 findfiles directory, namemask, fileTypeFile, findhidden, finder()
 FOR i as integer = 0 to UBOUND(finder)
  longname = join_path(directory, finder(i))
  a_append filelist(), longname
 NEXT i
 findfiles directory, ALLFILES, fileTypeDirectory, findhidden, finder()
 FOR i as integer = 0 to UBOUND(finder)
  recursefiles join_path(directory, finder(i)), namemask, findhidden, filelist(), cur_depth + 1
 NEXT i
END SUB

'Returns true on success
FUNCTION writeablecopyfile(src as string, dest as string) as bool
 IF copyfile(src, dest) = NO THEN RETURN NO
 #IFDEF __FB_WIN32__
  IF setwriteable(dest, YES) = NO THEN RETURN NO
 #ENDIF
 RETURN YES
END FUNCTION

'Copy files in one directory to another (ignores directories)
SUB copyfiles(src as string, dest as string, copyhidden as bool = NO, lowercase as bool = NO)
 DIM filelist() as string
 findfiles src, ALLFILES, fileTypeFile, copyhidden, filelist()
 FOR i as integer = 0 TO UBOUND(filelist)
  DIM destname as string = IIF(lowercase, LCASE(filelist(i)), filelist(i))
  writeablecopyfile src + SLASH + filelist(i), dest + SLASH + destname
 NEXT
END SUB

FUNCTION copydirectory (src as string, dest as string, byval copyhidden as bool = YES) as string
 'Recursively copy directory src to directory dest. Dest should not already exist
 'returns "" on success, or an error string on failure. Failure might leave behind a partial copy.
 IF isdir(dest) THEN RETURN "copydirectory: Destination """ & dest & """ must not already exist"
 
 '--create the dest directory
 IF makedir(dest) <> 0 THEN RETURN "copydirectory: Couldn't create """ & dest & """"

 '--copy all the files
 DIM filelist() as string
 findfiles src, ALLFILES, fileTypeFile, copyhidden, filelist()
 FOR i as integer = 0 TO UBOUND(filelist)
  writeablecopyfile src & SLASH & filelist(i), dest & SLASH & filelist(i)
  IF NOT isfile(dest & SLASH & filelist(i)) THEN
   RETURN "copydirectory: Couldn't copy file """ & dest & SLASH & filelist(i) & """"
  END IF
 NEXT i

 '--recursively copy all the subdirectories
 DIM result as string = ""
 DIM dirlist() as string
 findfiles src, ALLFILES, fileTypeDirectory, copyhidden, dirlist()
 FOR i as integer = 0 TO UBOUND(dirlist)
  IF dirlist(i) = "." ORELSE dirlist(i) = ".." THEN CONTINUE FOR
  result = copydirectory(src & SLASH & dirlist(i), dest & SLASH & dirlist(i), copyhidden)
  IF result <> "" THEN RETURN result
 NEXT i
 
 RETURN ""
 
END FUNCTION

FUNCTION confirmed_copy (srcfile as string, destfile as string) as bool
 'Copy a file, check to make sure it really was copied, and show an error message if not.
 'The copy will not be read-only (this acts like writeablecopyfile()).
 '(FIXME: The real error message is printed to debug by copy_file_replacing())
 ' Returns true if the copy was okay, false if it failed
 IF NOT isfile(srcfile) THEN
  visible_debug "ERROR: file " & destfile & " was missing"
  RETURN NO
 END IF
 ' I really hope that checking isfile is redundant, but who knows.
 IF NOT copyfile(srcfile, destfile) THEN
  visible_debug "ERROR: couldn't copy file to " & destfile
  RETURN NO
 END IF
 IF NOT isfile(destfile) THEN
  showbug "Couldn't copy file to " & destfile & ", although copyfile() succeeded"
  RETURN NO
 END IF
 #IFDEF __FB_WIN32__
  'On Windows copyfile() preserves file attributes, but we usually don't want the copy to be read-only
  setwriteable destfile, YES
 #ENDIF
 RETURN YES
END FUNCTION

FUNCTION confirmed_copydirectory(src as string, dest as string) as bool
 'Copy a directory, but if it fails, clean up any partial copy and show a visible warning
 'Returns YES for success and NO for failure
 DIM result as string
 result = copydirectory(src, dest, YES)
 IF result <> "" THEN
  visible_debug result
  IF isdir(dest) THEN
   killdir dest, YES
  END IF
  RETURN NO
 END IF
 RETURN YES
END FUNCTION

FUNCTION os_shell_move(src as string, dest as string) as bool
 'When used to move a directory on unixes, this should preserve bits and symlinks.
 'When used to move a directory on Windows this should just be a dang ol' move... except it doesn't work at all :(
 'Returns YES for success or NO for failure
 'Warning: doesn't send lump modification messages! So don't use to move lumps!
 'Use renamefile() instead (if renaming, not moving) to send those message, and for more robust error reporting.

 IF isfile(dest) THEN
  safekill dest
 ELSEIF isdir(dest) THEN
  killdir dest, YES
 END IF
 DIM src_is_file as bool = isfile(src)
 IF NOT src_is_file ANDALSO NOT isdir(src) THEN
  debug "os_shell_move: src file " & src & " does not exist"
  RETURN NO
 END IF
 
 DIM stderr_s as string
 DIM mv as string
 DIM args as string
 #IFDEF __FB_UNIX__
  mv = "mv"
  args = " -f"  ' Overwrite without confirmation
 #ENDIF
 #IFDEF __FB_WIN32__
  mv = "move"
  args = " /Y"  ' Overwrite without confirmation
 #ENDIF
 args &= " " & escape_filename(src) & " " & escape_filename(dest)

 'SHELL mv & args
 IF run_and_get_output(mv & args, "", stderr_s) THEN
  visible_debug "os_shell_move: move failed: " & stderr_s : RETURN NO
 END IF

 DIM success as bool = NO
 IF src_is_file THEN success = isfile(dest) ELSE success = isdir(dest)
 IF NOT success THEN debug "os_shell_move: dest file not created: " & dest
 RETURN success
END FUNCTION

SUB killdir(directory as string, recurse as bool = NO)
#ifdef DEBUG_FILE_IO
  debuginfo "killdir(" & directory & ", recurse = " & recurse & ")"
#endif
  close_lazy_files
  DIM filetype as FileTypeEnum = get_file_type(directory)
  IF filetype <> fileTypeDirectory THEN
    DIM msg as string
    msg = "killdir: '" & directory & "' is not a directory, it is " & safe_caption(filetype_names(), filetype, "filetype") & ". Skipping."
    IF filetype <> fileTypeNonexistent THEN visible_debug msg ELSE debuginfo msg
    EXIT SUB
  END IF
  ' For safety. (You ought to pass absolute paths.) Check
  ' writability so we don't recurse if started from e.g. /home until
  ' we hit something deletable (this happened to me)!
  IF LEN(directory) < 5 ORELSE diriswriteable(directory) = NO THEN
   showbug "killdir: refusing suspicious attempt to delete directory '" & directory & "'"
   EXIT SUB
  END IF
  DIM filelist() as string
  findfiles directory, ALLFILES, fileTypeFile, YES, filelist()
  FOR i as integer = 0 TO UBOUND(filelist)
    killfile directory + SLASH + filelist(i)
  NEXT
  IF recurse THEN
   DIM dirlist() as string
   findfiles directory, ALLFILES, fileTypeDirectory, YES, dirlist()
   FOR i as integer = 0 TO UBOUND(dirlist)
    IF dirlist(i) = "." ORELSE dirlist(i) = ".." THEN CONTINUE FOR
    'debuginfo "recurse to " & directory & SLASH & dirlist(i)
    killdir directory & SLASH & dirlist(i), YES
   NEXT i
  END IF
  IF RMDIR(directory) THEN
    'errno would get overwritten while building the error message
    DIM err_string as string = *get_sys_err_string()
    debug "Could not rmdir(" & directory & "): " & err_string
  END IF
'  IF isdir(directory) THEN
'    debug "Failed to delete directory " & directory
'  END IF
END SUB

'Returns zero on success (including if already exists)
FUNCTION makedir (directory as string) as integer
  IF isdir(directory) THEN
    debuginfo "makedir: " & directory & " already exists"
    RETURN 0
  END IF
#ifdef DEBUG_FILE_IO
  debuginfo "makedir(" & directory & ")"
#endif
  IF MKDIR(directory) THEN
    'errno would get overwritten while building the error message
    DIM err_string as string = *get_sys_err_string()
    'The heck? On Windows at least, MKDIR throws this false error
#ifdef __FB_WIN32__
    IF err_string = "File exists" THEN RETURN 0
#endif
    debug "Could not mkdir(" & directory & "): " & err_string
    RETURN 1
  END IF
#if defined(__FB_UNIX__) and not defined(MINIMAL_OS) ' I don't know on which OSes this is necessary
  ' work around broken file permissions in dirs created by linux version
  ' MKDIR creates with mode 644, should create with mode 755
  safe_shell "chmod +x " + escape_filename(directory), , NO
#endif
  RETURN 0
END FUNCTION

'Returns 0 on success, including already existing
'Also creates parent directories if needed
FUNCTION makedir_recurse (directory as string) as integer
 DIM parent as string = trimfilename(trim_trailing_slashes(directory))
 IF NOT isdir(parent) THEN
  IF parent = "" orelse parent = "/" THEN
   'don't go any further
  ELSE
   IF makedir_recurse(parent) THEN RETURN 1 'failed to create parent
  END IF
 END IF
 RETURN makedir(directory)
END FUNCTION

'True on successful deletion, false if couldn't or didn't exist
FUNCTION killfile (filename as string) as bool
  'KILL is a thin wrapper around C's remove(), however by calling it directly we can get a textual error message
#ifdef DEBUG_FILE_IO
  debuginfo "killfile(" & filename & ")"
#endif
  close_lazy_files
  IF remove(strptr(filename)) THEN
    DIM err_string as string = *get_sys_err_string()
    debug "Could not remove(" & filename & "): " & err_string

    'NOTE: on Windows, even if deletion doesn't happen because the file is open, the file will be marked
    'to be deleted once everyone closes it. Also, it will no longer be possible to open it.
    'However if someone opened the file without FILE_SHARE_DELETE access, it can't be deleted.
    'Note that FB's OPEN and OPENFILE don't open with FILE_SHARE_DELETE!
    'On Unix, you can unlink a file even when someone else has it open.
    RETURN NO
  END IF
  ' FIXME: send a message to Game if live-previewing, or else special case all
  ' places where it matters ie. music/sfx (like we do for RELOAD's use of renamefile)
  RETURN YES
END FUNCTION

'True on success or didn't exist, false if couldn't delete.
'Call this instead of killfile if you're not sure the file exists, it avoid error messages if it doesn't.
FUNCTION safekill (filename as string) as bool
  DIM exists as bool = real_isfile(filename)
  IF exists THEN RETURN killfile(filename)
#ifdef DEBUG_FILE_IO
  debuginfo "safekill(" & filename & ") exists = NO"
#endif
  RETURN YES
END FUNCTION

SUB safekill_pattern (dirname as string, filepattern as string)
 'Is this "safe"? That is "debatable"
 DIM filelist() as string
 IF LEN(dirname) = 0 THEN
  debuginfo "safekill_pattern: empty dirname, do nothing."
  EXIT SUB
 END IF
 IF NOT isdir(dirname) THEN
  debuginfo "safekill_pattern: """ & dirname & """ directory does not exist, do nothing."
  EXIT SUB
 END IF
 'findfiles is always case-insensitive
 findfiles dirname, filepattern, fileTypeFile, YES, filelist()
 FOR i as integer = 0 TO UBOUND(filelist)
  safekill dirname & SLASH & filelist(i)
 NEXT i
END SUB

'Looking for local_file_move? Now called renamefile, in filelayer.cpp

FUNCTION fileisreadable(filename as string) as bool
  if len(filename) = 0 then debug "fileisreadable: no filename" : return NO
  dim ret as bool = NO
  dim fh as integer, err_code as integer

  ' Check this first, to exclude directories on Linux (you can open a directory read-only)
  if get_file_type(filename) = fileTypeFile then
    err_code = openfile(filename, for_binary + access_read, fh)
    if err_code <> fberrOK then
      'if err_code fberrNOTFOUND, it doesn't exist. Shouldn't happen unless there's a race condition
      debuginfo "fileisreadable: Error " & err_code & " reading " & filename
    else
      close #fh
      ret = YES
    end if
  end if
#ifdef DEBUG_FILE_IO
  debuginfo "fileisreadable(" & filename & ") = " & ret
#endif
  return ret
END FUNCTION

' Whether an existing file can be opened for writing, or else if a new file can be written.
FUNCTION fileiswriteable(filename as string) as bool
  if len(filename) = 0 then debug "fileiswriteable: no filename" : return NO
  dim ret as bool = NO
  dim fh as integer
  dim exists as bool = (get_file_type(filename) <> fileTypeNonexistent)
  ' Attempting to open read-write means that opening directories fails on Linux, unlike read-only
  if openfile(filename, for_binary + access_read_write, fh) = fberrOK then
    close #fh
    ' Delete the file we just created
    if exists = NO then killfile(filename)
    ret = YES
  end if
#ifdef DEBUG_FILE_IO
  debuginfo "fileiswriteable(" & filename & ") = " & ret & " exists=" & exists
#endif
  return ret
END FUNCTION

FUNCTION diriswriteable(filename as string) as bool
  dim ret as bool = NO
  dim testfile as string
  dim testdir as string = filename
  if filename = "" then testdir = curdir

  ' Kludge to detect an rpgdir full of unwriteable files: on Windows you don't seem
  ' able to mark a folder read-only, instead it makes the contents read-only.
  ' (If testdir isn't a directory, these checks will print debug messages,
  ' which I think is a good thing.)
  testfile = testdir + SLASH + "archinym.lmp"
  if real_isfile(testfile) = NO then
    ' If archinym.lmp doesn't exist, then ohrrpgce.gen does
    testfile = testdir + SLASH + "ohrrpgce.gen"
    if real_isfile(testfile) = NO then testfile = ""
  end if
  ' In the case of an .rpgdir, we test both an existing file and a new one for writability.
  if len(testfile) andalso fileiswriteable(testfile) = NO then
    ret = NO
  else
    testfile = testdir & SLASH & "__testwrite_" & randint(100000) & ".tmp"
    if fileiswriteable(testfile) then
      ret = YES
    end if
  end if
  #ifdef DEBUG_FILE_IO
    debuginfo "diriswriteable(" & filename & ") = " & ret
  #endif
  return ret
END FUNCTION

' This is a simple wrapper for fileisreadable, and there's now a lot of code
' that might depend on that. If you want to *really* test if something is a file, use real_isfile
FUNCTION isfile (filename as string) as bool
  return fileisreadable(filename)
END FUNCTION

FUNCTION real_isfile(filename as string) as bool
  if len(filename) = 0 then debug "real_isfile: no filename" : return NO
  dim filetype as FileTypeEnum = get_file_type(filename)
  dim ret as bool = (filetype = fileTypeFile)
  #ifdef DEBUG_FILE_IO
    debuginfo "real_isfile(" & filename & ") = " & ret
    IF ret = NO ANDALSO filetype <> fileTypeNonexistent THEN debuginfo " filetype=" & filetype
  #endif
  return ret
END FUNCTION

'Check whether a filename doesn't refer to a file/dir/etc
FUNCTION is_not_file (filename as string) as bool
  dim filetype as FileTypeEnum = get_file_type(filename)
  dim ret as bool = (filetype = fileTypeNonexistent)
  #ifdef DEBUG_FILE_IO
    debuginfo "is_not_file(" & filename & ") = " & ret & " filetype=" & filetype
  #endif
  return ret
END FUNCTION

' Is a directory. Return true for "" (the current directory)
FUNCTION isdir (filename as string) as bool
  dim ret as bool = (get_file_type(filename) = fileTypeDirectory)
  #ifdef DEBUG_FILE_IO
    debuginfo "isdir(" & filename & ") = " & ret
  #endif
  return ret
END FUNCTION


'--------- File read/write helpers ---------

function ReadShort(byval fh as integer, byval p as long=-1) as short
  dim ret as short
  if p = -1 then
    get #fh, , ret
  elseif p >= 0 then
    get #fh, p, ret
  end if
  return ret
end function

function ReadShort(filename as string, byval p as integer) as short
  dim ret as short
  dim fh as integer
  openfile(filename, for_binary + access_read, fh)
  get #fh, p, ret
  close #fh
  return ret
end function

function ReadByte(byval fh as integer, byval p as long=-1) as ubyte
  dim ret as ubyte
  if p = -1 then
    get #fh, , ret
  elseif p >= 0 then
    get #fh, p, ret
  end if
  return ret
end function

sub WriteShort(byval fh as integer, byval p as long, byval v as integer)
  WriteShort(fh,p,cshort(v))
end sub

sub WriteShort(byval fh as integer, byval p as long, byval v as short)
  if p = -1 then
    put #fh, , v
  elseif p >= 0 then
    put #fh, p, v
  end if
end sub

sub WriteShort(filename as string, byval p as integer, byval v as integer)
  dim fh as integer
  openfile(filename, FOR_BINARY, fh)
  dim dat as short = v
  put #fh, p, dat
  close #fh
end sub

sub WriteByte(byval fh as integer, byval v as ubyte, byval p as long=-1)
  if p = -1 then
    put #fh, , v
  elseif p >= 0 then
    put #fh, p, v
  end if
end sub

function ReadVStr(byval fh as integer, byval maxlen as integer) as string
  dim length as short, ret as string, c as short, i as integer
  length = readshort(fh)

  for i = 0 to maxlen - 1
    c = readshort(fh)
    if i < length then ret &= chr(c and 255)
  next

  return ret
end function

sub WriteVStr(byval fh as integer, byval maxlen as integer, s as string)
  dim i as integer
  writeshort(fh, -1, small(maxlen, len(s)))

  for i = 0 to maxlen - 1
    if i < len(s) then writeshort(fh, -1, cint(s[i])) else writeshort(fh, -1, 0)
  next
end sub

function ReadByteStr(byval fh as integer, byval maxlen as integer) as string
  dim length as short, ret as string, c as ubyte, i as integer
  length = readshort(fh)

  for i = 0 to maxlen - 1
    c = readbyte(fh)
    if i < length then ret = ret & chr(c)
  next

  return ret
end function

sub WriteByteStr(byval fh as integer, byval maxlen as integer, s as string)
  dim i as integer
  writeshort(fh, -1, small(maxlen, len(s)))

  for i = 0 to maxlen - 1
    if i < len(s) then writebyte(fh, cubyte(s[i])) else writebyte(fh, 0)
  next
end sub


'--------- Doubly Linked List ---------

#define DLFOLLOW(someptr)  cast(DListItem(Any) ptr, cast(byte ptr, someptr) + this.memberoffset)

SUB dlist_construct (byref this as DoubleList(Any), byval itemoffset as integer)
  this.numitems = 0
  this.first = NULL
  this.last = NULL
  this.memberoffset = itemoffset
END SUB

'NULL as beforeitem inserts at end
SUB dlist_insertat (byref this as DoubleList(Any), byval beforeitem as any ptr, byval newitem as any ptr)
  dim litem as DListItem(Any) ptr = DLFOLLOW(newitem)

  litem->next = beforeitem

  if beforeitem = NULL then
    litem->prev = this.last
    this.last = newitem
  else
    dim bitem as DListItem(Any) ptr = DLFOLLOW(beforeitem)
    litem->prev = bitem->prev
    bitem->prev = newitem
  end if

  if litem->prev then
    DLFOLLOW(litem->prev)->next = newitem
  else
    this.first = newitem
  end if

  this.numitems += 1
END SUB

SUB dlist_remove (byref this as DoubleList(Any), byval item as any ptr)
  dim litem as DListItem(Any) ptr = DLFOLLOW(item)

  'check whether item isn't the member of a list
  if litem->next = NULL andalso item <> this.last then exit sub

  if litem->prev then
    DLFOLLOW(litem->prev)->next = litem->next
  else
    this.first = litem->next
  end if
  if litem->next then
    DLFOLLOW(litem->next)->prev = litem->prev
  else
    this.last = litem->prev
  end if
  litem->next = NULL
  litem->prev = NULL

  this.numitems -= 1
END SUB

SUB dlist_swap (byref this as DoubleList(Any), byval item1 as any ptr, byref that as DoubleList(Any), byval item2 as any ptr)
  'dlist_insertat can't move items from one list to another
  if item1 = item2 then exit sub
  dim dest2 as any ptr = DLFOLLOW(item1)->next
  dlist_remove(this, item1)
  if dest2 = item2 then
    'items are arranged like  -> item1 -> item2 ->
    dlist_insertat(that, DLFOLLOW(item2)->next, item1)
  else
    dlist_insertat(that, item2, item1)
    dlist_remove(that, item2)
    dlist_insertat(this, dest2, item2)
  end if
END SUB

FUNCTION dlist_find (byref this as DoubleList(Any), byval item as any ptr) as integer
  dim n as integer = 0
  dim lit as any ptr = this.first
  while lit
    if lit = item then return n
    n += 1
    lit = DLFOLLOW(lit)->next
  wend
  return -1
END FUNCTION

FUNCTION dlist_walk (byref this as DoubleList(Any), byval item as any ptr, byval n as integer) as any ptr
  if item = NULL then item = this.first
  while n > 0 andalso item
    item = DLFOLLOW(item)->next
    n -= 1
  wend
  while n < 0 andalso item
    item = DLFOLLOW(item)->prev
    n += 1
  wend
  return item
END FUNCTION

/'
SUB dlist_print (byref this as DoubleList(Any))
  dim ptt as any ptr = this.first
  debug "numitems=" & this.numitems & " first=" & hex(ptt) & " last=" & hex(this.last) & " items:"
  while ptt
    debug " 0x" & hex(ptt) & " n:0x" & hex(DLFOLLOW(ptt)->next) & " p:0x" & hex(DLFOLLOW(ptt)->prev) '& " " & get_menu_item_caption(*ptt, menudata)
    ptt = DLFOLLOW(ptt)->next
  wend
END SUB
'/

'------------- Hash Table -------------
'See util.bi for documentation.

DEFINE_VECTOR_OF_POD_TYPE(HashBucketItem, HashBucketItem)

sub HashTable.construct(tablesize as integer = 31)
  this.destruct()
  this.numitems = 0
  if tablesize > 4096 then tablesize = 4096  'Prevent overflow of iter() 'state'
  this.tablesize = tablesize
  this.table = callocate(sizeof(any ptr) * this.tablesize)
  this.key_compare = NULL
  this.key_hash = NULL
  this.key_length = 0
  this.key_copy = NULL
  this.key_delete = NULL
  this.key_is_integer = YES
  this.value_copy = NULL
  this.value_delete = NULL
  this.value_is_string = NO
  this.value_is_zstring = NO
end sub

sub HashTable.construct(tablesize as integer = 31, key_type as TypeTable, copy_and_delete_keys as bool, value_type as TypeTable, copy_and_delete_values as bool)
  this.construct(tablesize)
  if @key_type <> @type_table(integer) then
    this.key_compare = key_type.comp
    this.key_hash = key_type.hash
    this.key_length = key_type.element_len
    if copy_and_delete_keys then
      this.key_copy = key_type.copy
      this.key_delete = key_type._delete
    end if
    this.key_is_integer = NO
  end if
  if @value_type <> @type_table(integer) then
    if copy_and_delete_values then
      this.value_copy = value_type.copy
      this.value_delete = value_type._delete
    end if
  end if
  this.value_is_string = (@value_type = @type_table(string))
  this.value_is_zstring = (@value_type = @type_table(zstring))
end sub

sub HashTable.destruct()
  this.clear()
  deallocate(this.table)
  this.table = NULL
  this.tablesize = 0
end sub

destructor HashTable()
  this.destruct()
end destructor

function HashTable.constructed() as bool
  return this.tablesize > 0
end function

'Look for a key in a bucket vector, return NULL on failure
local function hash_search_bucket(this as HashTable, bucket as HashBucketItem vector, hash as integer, key as const any ptr = NULL) as HashBucketItem ptr
  for bucketidx as integer = 0 to v_len(bucket) - 1
    dim it as HashBucketItem ptr = @bucket[bucketidx]
    if it->hash = hash then
      if it->key = key then
        return it
      elseif this.key_compare then
        'One or both keys may be NULL
        if this.key_compare(it->key, key) = 0 then
          return it
        end if
      else
        'showbug "HashTable: need a key compare function"
        'Shallow comparison of key pointers: take as inequal
      end if
    end if
  next
  return NULL
end function

function HashTable.hash_key(key as const any ptr) as integer
  if this.key_is_opaque_ptr then
    return cintptr32(key)
  elseif this.key_hash then
    return this.key_hash(key)
  elseif key then
    if this.key_length = 0 then showbug "HashTable: can't hash unknown key type; use TypeTable constructor or set key_is_opaque_ptr"
    return stringhash(key, this.key_length)
  end if
  return 0
end function

sub HashTable.add(hash as integer, value as any ptr, _key as const any ptr = NULL)
  BUG_IF(this.table = NULL, "construct() not called")
  dim byref bucket as HashBucketItem vector = this.table[cuint(hash) mod this.tablesize]
  dim item as HashBucketItem ptr = any
  if bucket = NULL then
    v_new bucket, 1
    item = @bucket[0]
  else
    item = v_expand(bucket)
  end if
  item->hash = hash
  item->key = iif(this.key_copy, this.key_copy(_key), _key)
  item->value = iif(this.value_copy, this.value_copy(value), value)
  this.numitems += 1
end sub

sub HashTable.add(hash as integer, value as integer)
  this.add(hash, canyptr(value), NULL)
end sub

sub HashTable.add(key as const any ptr, value as any ptr)
  this.add(this.hash_key(key), value, key)
end sub

sub HashTable.add(key as const any ptr, value as integer)
  this.add(this.hash_key(key), canyptr(value), key)
end sub

sub HashTable.set(hash as integer, value as any ptr, _key as const any ptr = NULL)
  BUG_IF(this.table = NULL, "construct() not called")
  dim bucket as HashBucketItem vector = this.table[cuint(hash) mod this.tablesize]
  dim it as HashBucketItem ptr = hash_search_bucket(this, bucket, hash, _key)
  if it then
    if this.value_delete andalso it->value then this.value_delete(it->value)
    it->value = iif(this.value_copy, this.value_copy(value), value)
  else
    this.add(hash, value, _key)
  end if
end sub

sub HashTable.set(hash as integer, value as integer)
  this.set(hash, canyptr(value), NULL)
end sub

sub HashTable.set(key as const any ptr, value as any ptr)
  this.set(this.hash_key(key), value, key)
end sub

sub HashTable.set(key as const any ptr, value as integer)
  this.set(this.hash_key(key), canyptr(value), key)
end sub

function HashTable.get(hash as integer, default as any ptr = NULL, _key as const any ptr = NULL) as any ptr
  BUG_IF(this.table = NULL, "construct() not called", NULL)
  dim bucket as HashBucketItem vector = this.table[cuint(hash) mod this.tablesize]
  dim it as HashBucketItem ptr = hash_search_bucket(this, bucket, hash, _key)
  if it = NULL then return default
  return it->value
end function

function HashTable.get(key as const any ptr, default as any ptr = 0) as any ptr
  return this.get(this.hash_key(key), default, key)
end function

function HashTable.get_int(hash as integer, default as integer = 0) as integer
  return cintptr32(this.get(hash, canyptr(default), NULL))
end function

function HashTable.get_int(key as const any ptr, default as integer = 0) as integer
  return cintptr32(this.get(this.hash_key(key), canyptr(default), key))
end function

function HashTable.get_str(hash as integer, default as zstring ptr = @"", _key as const any ptr = NULL) as string
  'return *cast(string ptr, this.get(hash, @default, _key))
  'Avoiding initialising a new string from default if not needed, but want to still allow NULL as a value
  dim ret as any ptr = this.get(hash, canyptr(-1234), _key)
  if ret = canyptr(-1234) then return *default
  if this.value_is_string then
    return *cast(string ptr, ret)
  elseif this.value_is_zstring then
    return *cast(zstring ptr, ret)
  else
    showbug "HashTable.get_str shouldn't be called!"
  end if
end function

function HashTable.get_str(key as const any ptr, default as zstring ptr = @"") as string
  return this.get_str(this.hash_key(key), default, key)
  'if ret = canyptr(-1) then return *default else return *ret
end function

function HashTable.remove(hash as integer, _key as const any ptr = NULL) as bool
  dim byref bucket as HashBucketItem vector = this.table[cuint(hash) mod this.tablesize]
  dim it as HashBucketItem ptr = hash_search_bucket(this, bucket, hash, _key)
  if it = NULL then return NO
  if this.key_delete andalso it->key then this.key_delete(it->key)
  if this.value_delete andalso it->value then this.value_delete(it->value)
  dim idx as integer = it - @bucket[0]
  v_delete_slice bucket, idx, idx + 1
  this.numitems -= 1
  return YES
end function

function HashTable.remove(key as const any ptr) as bool
  return this.remove(this.hash_key(key), key)
end function

sub HashTable.clear()
  for bucketnum as integer = 0 to this.tablesize - 1
    dim byref bucket as HashBucketItem vector = this.table[bucketnum]
    for bucketidx as integer = 0 to v_len(bucket) - 1
      with bucket[bucketidx]
        if this.key_delete andalso .key then this.key_delete(.key)
        if this.value_delete andalso .value then this.value_delete(.value)
      end with
    next
    v_free bucket
  next
  this.numitems = 0
end sub

function HashTable.iter(byref state as uinteger, prev_value as any ptr, byref key as const any ptr = NULL) as any ptr
  if state = &hFFFFFFFF then
    key = NULL
    return NULL
  end if

  'If the length of a bucket exceeds &hfffff = 1048575, then we are in trouble!
  'However, even then iteration will still work if you delete each item you iterate over.
  dim as integer bucketnum = state shr 20, bucketidx = state and &hfffff

  if state <> 0 then
    'Check whether something got deleted from the hash table since last .iter(), upsetting the iteration,
    'and if so search backwards in this bucket to find the correct bucketidx.
    'NOTE: this assumes values are unique!!
    '(If new items got added to the hash table they get added to the end of a bucket, which is no problem.
    'They may or may get included in the iteration.)

    dim bucket as HashBucketItem vector = this.table[bucketnum]
    'bucketidx was incremented on the last iter() call, so we expect to see prev_value at bucketidx-1
    bucketidx -= 1
    bucketidx = small(bucketidx, v_len(bucket) - 1)  'The bucket might have shrunk
    while bucketidx >= 0
      if bucket[bucketidx].value = prev_value then exit while
      bucketidx -= 1
    wend
    if bucketidx < 0 then
      showbug "HashTable.iter: item has been deleted from the table"
      state = &hFFFFFFFF
      return NULL
    end if
    'Increment past prev_value
    bucketidx += 1
  end if

  'Advance to next non-empty bucket if we've reached the end of this one
  while bucketidx >= v_len(this.table[bucketnum])
    bucketnum += 1
    bucketidx = 0
    if bucketnum >= this.tablesize then
      key = NULL
      state = &hFFFFFFFF
      return NULL
    end if
  wend

  state = (bucketnum shl 20) or (bucketidx + 1)  '+1 to advance to next item on next call
  with this.table[bucketnum][bucketidx]
    key = .key
    return .value
  end with
end function

function HashTable.keys() as any ptr vector
  dim ret as any ptr vector
  'v_new ret, 0, this.numitems
  ' dim typetbl as TypeType ptr
  ' if typetbl = NULL then typetbl = @type_table(any_ptr)
  array_new ret, this.numitems, 0, iif(this.key_is_integer, @type_table(integer), @type_table(any_ptr))

  for bucketnum as integer = 0 to this.tablesize - 1
    dim byref bucket as HashBucketItem vector = this.table[bucketnum]
    for bucketidx as integer = 0 to v_len(bucket) - 1
      if this.key_is_integer then
        v_append ret, @bucket[bucketidx].hash
      else
        v_append ret, @bucket[bucketidx].key
      end if
    next
  next
  return ret
end function

/' This seems unnecessary, so commenting out to reduce bloat. (Testcase below is commented out too)
function HashTable.hashes() as integer vector
  dim ret as integer vector
  dim idx as integer
  v_new ret, this.numitems, 0
  for bucketnum as integer = 0 to this.tablesize - 1
    dim byref bucket as HashBucketItem vector = this.table[bucketnum]
    for bucketidx as integer = 0 to v_len(bucket) - 1
      ret[idx] = bucket[bucketidx].hash
      idx += 1
    next
  next
  return ret
end function
'/

function HashTable.items() as HashBucketItem vector
  dim ret as HashBucketItem vector
  v_new ret, 0, this.numitems
  for idx as integer = 0 to this.tablesize - 1
    v_extend(ret, this.table[idx])
  next
  return ret
end function

dim shared HashTable_key_compare as FnCompare

local function HashBucketItem_compare cdecl (a as HashBucketItem ptr, b as HashBucketItem ptr) as long
  if HashTable_key_compare then return HashTable_key_compare(a->key, b->key)
  if a->hash < b->hash then return -1
  if a->hash > b->hash then return 1
end function

function HashTable.items_sorted() as HashBucketItem vector
  dim ret as HashBucketItem vector = this.items()
  HashTable_key_compare = this.key_compare
  qsort(@ret[0], this.numitems, sizeof(HashBucketItem), cast(FnCompare, @HashBucketItem_compare))
  return ret
end function

#IFDEF __FB_MAIN__
startTest(HashTableIntToInt)
  dim as HashTable tbl
  tbl.construct(64)
  'tbl.construct(64, type_table(integer), NO, type_table(any_ptr), NO)  'Equivalent to above

  tbl.add(65, 11)  ' |
  tbl.add(1, 10)   ' |
  tbl.add(129, 9)  ' v
  tbl.add(-255, 8)  'All in same bucket
  tbl.add(20, 7)
  tbl.add(20, -6)  'Duplicates
  if tbl.numitems <> 6 then fail

  if tbl.get(1) <> 10 then fail  'Interestingly FB allows comparing a ptr to an int without warning
  if tbl.get(65) <> 11 then fail
  if tbl.get(129) <> 9 then fail
  if tbl.get(-255) <> 8 then fail
  if tbl.get(20) <> 7 then fail
  dim tmp as integer = tbl.get_int(20)  'But here you do need get_int()
  if tmp <> 7 then fail
  if tbl.get_int(-255, -1) <> 8 then fail  'And also when providing a default value
  if tbl.get_int(0, -1) <> -1 then fail

  tbl.set(20, 0)
  if tbl.remove(-255) <> YES then fail
  if tbl.remove(84) <> NO then fail

  if tbl.get_int(20, -1) <> 0 then fail

  dim items as HashBucketItem vector = tbl.items_sorted()

  if v_len(items) <> 5 then fail
  if items[0].hash <> 1 then fail
  if items[1].hash <> 20 then fail
  if items[2].hash <> 20 then fail
  if items[3].hash <> 65 then fail
  if items[4].hash <> 129 then fail
  if items[0].value_int <> 10 then fail
  'The order of these two values (0, -6) may be random or depend on the CRT implementation
  if items[1].value_int + items[2].value_int <> -6 then fail
  if items[3].value_int <> 11 then fail
  if items[4].value_int <> 9 then fail

  v_free items

  /'
  dim hashes as uinteger vector = tbl.hashes()
  v_sort hashes
  if v_str(hashes) <> "[1, 20, 20, 65, 129]" then fail
  v_free hashes
  '/

  tbl.destruct()
  if tbl.numitems <> 0 then fail
endTest

startTest(HashTableStrings)
  dim tbl as HashTable
  tbl.construct( , type_table(string), YES, type_table(integer), NO)

  dim as string a = "A", b = "B", c = "C", d, e, f
  tbl.add @a, 100
  tbl.add @b, 200
  tbl.set @c, 300

  c = "foo"
  d = "C"
  'Note: you can NOT write 'tbl.get(@"C")', that's a zstring ptr not a string ptr
  if tbl.get(@c) <> 0 then fail
  if tbl.get(@d) <> 300 then fail

  tbl.destruct()
  if a <> "A" then fail  'Shouldn't have touched the originals

  'Try out reinitialising a table with different types.
  'This time, don't copy the strings (note, this is really dangerous, will
  'crash if the strings on the stack go out of scope, so don't do this!)
  tbl.construct(1 , type_table(string), NO, type_table(string), NO)

  c = "C"
  tbl.add @a, @d
  tbl.add @b, @e
  tbl.set @c, @f
  if tbl.numitems <> 3 then fail

  a = "not A"
  if tbl.get(@a) <> NULL then fail
  c = "B"
  tbl.set @c, @d  'Overwrites "B" key, since we are comparing by value, not pointer
  if tbl.numitems <> 3 then fail
  if tbl.get(@b) <> @d then fail
  if tbl.get(@c) <> @d then fail  'Since b and c are equal, the @c->@f item is shadowed
  c = "C"
  if tbl.get(@c) <> @f then fail  'But is still there

  if tbl.get_str(@e) <> "" then fail  '@e = "", which is not in the table
  if tbl.get_str(@e, "none") <> "none" then fail
  if tbl.get_str(@a) <> "" then fail  '@e = "", not in the table either
  if tbl.get_str(@a, "none") <> "none" then fail

  if tbl.get_str(@c) <> "" then fail  'In the table; value is ""
  if tbl.get_str(@c, "none") <> "" then fail
  if tbl.get_str(@b, "none") <> "C" then fail

  tbl.destruct()
endTest

startTest(HashTableZstring)
  dim tbl as HashTable
  tbl.construct(1 , type_table(zstring), YES, type_table(zstring), NO)

  dim as zstring ptr a = @"A", b = @"B", c = @"C"
  tbl.add a, a
  tbl.add b, b
  tbl.set c, c
  if tbl.get(b) <> b then fail
  if tbl.get_str(b) <> "B" then fail
  if tbl.get_int(@"D", 42) <> 42 then fail

  dim items as HashBucketItem vector = tbl.items()
  'Check the key is a deep copy, value is shallow
  if items[0].key = a then fail
  if *cast(zstring ptr, items[0].key) <> *a then fail
  if items[0].value <> a then fail
  v_free items

  if tbl.get(b) <> b then fail

  dim as string a2 = "A"
  if strptr(a2) = a then fail
  if tbl.get(strptr(a2)) <> a then fail

  tbl.destruct()
endTest

#ENDIF


'----------------- StrHashTable -----------------

sub StrHashTable.construct(tablesize as integer = 31, value_type as TypeTable = type_table(any_ptr), copy_and_delete_values as bool)
  base.construct(tablesize, type_table(string), YES, value_type, copy_and_delete_values)
end sub

sub StrHashTable.add(key as string, value as any ptr)
  'Could just cast to string ptr and pass to base.add, but calling stringhash
  'directly avoids a couple extra function calls
  base.add(stringhash(strptr(key), len(key)), value, @key)
end sub

sub StrHashTable.add(key as string, value as integer)
  base.add(stringhash(strptr(key), len(key)), canyptr(value), @key)
end sub

sub StrHashTable.add(key as string, value as string)
  base.add(stringhash(strptr(key), len(key)), canyptr(@value), @key)
end sub

sub StrHashTable.set(key as string, value as any ptr)
  base.set(stringhash(strptr(key), len(key)), value, @key)
end sub

sub StrHashTable.set(key as string, value as integer)
  base.set(stringhash(strptr(key), len(key)), canyptr(value), @key)
end sub

sub StrHashTable.set(key as string, value as string)
  base.set(stringhash(strptr(key), len(key)), canyptr(@value), @key)
end sub

function StrHashTable.get(key as string, default as any ptr = NULL) as any ptr
  return base.get(stringhash(strptr(key), len(key)), default, @key)
end function

function StrHashTable.get_int(key as string, default as integer = 0) as integer
  return cintptr32(base.get(stringhash(strptr(key), len(key)), canyptr(default), @key))
end function

function StrHashTable.get_str(key as string, default as zstring ptr = @"") as string
  'return base.get_str(stringhash(strptr(key), len(key)), default, @key)
  'Avoiding initialising a new string from default if not needed, but want to still allow NULL as a value
  dim ret as string ptr = base.get(stringhash(strptr(key), len(key)), canyptr(-1234), @key)
  if ret = canyptr(-1234) then return *default else return *ret
end function

function StrHashTable.remove(key as string) as bool
  return base.remove(stringhash(strptr(key), len(key)), @key)
end function

#ifdef __FB_MAIN__

startTest(StrStrHashTable)
  dim tbl as StrHashTable
  tbl.construct(32, type_table(string), YES)

  dim as string a = "A", q = "q"
  tbl.add a, "42"
  if tbl.get_str("A") <> "42" then fail
  if tbl.get_str("A", "default") <> "42" then fail
  if tbl.get_str("B") <> "" then fail
  a = "B"
  if tbl.get_str(a) <> "" then fail
  tbl.set "A", q
  if tbl.get_str("A") <> "q" then fail
  q = "not q"
  if tbl.get_str("A") <> "q" then fail
  if tbl.get_str("B", "default") <> "default" then fail
  tbl.set "Q", " "
  if tbl.numitems <> 2 then fail
  tbl.remove "A"
  if tbl.numitems <> 1 then fail
endTest

dim shared testdata_init_cnt as integer
dim shared testdata_failed as bool

type TestDataType
  name as string
  dat as integer
  declare constructor(d as integer)
  declare destructor()
end type

constructor TestDataType(d as integer)
  dat = d
  name = "data" & dat
  testdata_init_cnt += 1
end constructor

destructor TestDataType()
  if name <> "data" & dat then testdata_failed = YES
  name = "blank"
  testdata_init_cnt -= 1
end destructor

DECLARE_VECTOR_OF_TYPE(TestDataType, TestDataType)
DEFINE_VECTOR_OF_CLASS(TestDataType, TestDataType)

' Test mapping to a datatype ptr, which is owned (deleted but not copied in).
' Also tests dupicate keys a bit.
startTest(StrHashTable_NoCopydata)
  dim tbl as StrHashTable
  tbl.construct(32, type_table(TestDataType), YES)
  tbl.value_copy = NULL   'Delete but don't copy

  'Add items
  for idx as integer = 1 to 100
   tbl.add("key" & idx, new TestDataType(idx))
   'Duplicate data
   tbl.add("key" & idx, new TestDataType(1000 + idx))
   if testdata_init_cnt <> 2*idx then fail
  next

  'Check and delete items
  for idx as integer = 100 to 50 step -1
   'var vptr = cptr(TestDataType ptr, tbl.get("key" & idx))
   dim vptr as TestDataType ptr

   vptr = tbl.get("key" & idx)
   if vptr = null then fail
   if vptr->name <> "data" & idx then fail
   'Delete first copy of the key, then lookup the second
   if tbl.remove("key" & idx) = NO then fail

   vptr = tbl.get("key" & idx)
   if vptr = null then fail
   if vptr->name <> "data" & (1000 + idx) then fail

   if testdata_init_cnt <> 100 + idx - 1 then fail
  next

  tbl.clear()
  if testdata_init_cnt <> 0 then fail
  if testdata_failed then fail
endTest

#endif

'----------------------------------------------------------------------
'                         Interned strings

' A HashTable that maps strings to themselves. Keys/values are zstring ptrs to allocated memory.
dim shared interned_strings as HashTable
' Identical keys/values as interned_strings, but the zstring ptrs are compared by value rather than content. No copying/freeing of memory
dim shared interned_fast_lookup as HashTable

sub init_intern_string()
  if interned_strings.constructed then exit sub

  interned_strings.construct(509, type_table(zstring), YES, type_table(zstring), NO)
  ' Prevent the table from calling zstring_copy on insertion because we want to call it ourselves.
  ' (But we still want the table to clear
  interned_strings.key_copy = NULL

  ' Maybe safer to not delete the strings even at program exit. But then they appear as leaks.
  ' Switch to the above construct() if using valgrind.
  'interned_strings.construct(509, type_table(zstring), NO, type_table(zstring), NO)

  interned_fast_lookup.construct(509)
  interned_fast_lookup.key_is_opaque_ptr = YES
end sub

' Intern a string, that is, convert it to a unique zstring ptr with the
' same content: returns the same zstring ptr if called twice.
' Interned strings live forever in the global hash tables.
' Calling intern_string on an already interned string is very fast (it does no
' string comparisons or hashing).
function intern_string(s as zstring ptr) as zstring ptr
  if s = NULL then return intern_string("")

  dim gotfast as zstring ptr = interned_fast_lookup.get(s, NULL)
  if gotfast then
    assert(gotfast = s)
    return s
  end if

  ' Then see whether there is an interned string with the same content.
  dim ret as zstring ptr = interned_strings.get(s)
  if ret then return ret

  ret = zstring_copy(s)
  interned_strings.set(ret, ret)
  interned_fast_lookup.set(ret, ret)

  assert(interned_strings.get(s) = ret)
  assert(interned_fast_lookup.get(ret, 0) = ret)
  'print "intern " & *s & " -> " & hex(ret)
  return ret
end function

#ifdef __FB_MAIN__
startTest(str_intern)
  dim x as integer = 0
  dim as zstring ptr a, a2, b, c
  a = intern_string("a" & x)
  b = intern_string("B....")
  c = intern_string(@"c")
  a2 = intern_string(@"a0")
  if *a <> "a0" then fail
  if *b <> "B...." then fail
  if *c <> "c" then fail
  if a <> a2 then fail
  if a <> intern_string(a) then fail
  if b <> intern_string(b) then fail
  if c <> intern_string(c) then fail
  if a = b then fail
  if b = c then fail
  if a = c then fail
  if interned_fast_lookup.get(c, 0) <> c then fail
  if interned_fast_lookup.get(@"c", 0) <> NULL then fail
  if interned_strings.numitems <> 3 then fail
  if interned_fast_lookup.numitems <> 3 then fail
endTest

' Check that intern_string is faster than StrHashTable lookups as intended, only
' (on already interned strings, it's actually only about 3x faster on x86_64, 5x on x86)
startTest(str_intern_speed)
  dim strings(999) as string
  dim zstrings(999) as zstring ptr
  for i as integer = 0 to 999
    strings(i) = str(i) & "token"
    zstrings(i) = strptr(strings(i))
  next
  ?""

  dim strtable as StrHashTable
  strtable.construct(509, type_table(integer), NO)

  dim runtime as double

  runtime = timer
  for j as integer = 0 to 99
    for i as integer = 0 to 999
      dim found as integer = strtable.get_int(strings(i))
      if found = 0 then
        strtable.set(strings(i), 1 + i)
      end if
    next
  next
  runtime = timer - runtime
  ?"StrHashTable in " & CINT(1e6 * runtime) & "us"

  dim initkeys as integer = interned_strings.numitems
  runtime = timer
  dim numfound as integer = 0
  for j as integer = 0 to 99
    for i as integer = 0 to 999
      dim found as zstring ptr = intern_string(zstrings(i))
    next
  next
  runtime = timer - runtime
  ?"intern_string uninterned in " & CINT(1e6 * runtime) & "us"
  if interned_fast_lookup.numitems <> initkeys + 1000 then fail
  if interned_strings.numitems <> initkeys + 1000 then fail

  runtime = timer
  for j as integer = 0 to 99
    for i as integer = 0 to 999
      dim found as zstring ptr = intern_string(zstrings(i))
      zstrings(i) = found
    next
  next
  runtime = timer - runtime
  ?"intern_string intern in " & CINT(1e6 * runtime) & "us"

  for i as integer = 0 to 999
    if *zstrings(i) <> strings(i) then fail
  next
endTest
#endif


'------------- Old allmodex stuff -------------

SUB array2str (arr() as integer, byval o as integer, dest as string)
'String dest is already filled out with spaces to the requisite size
'o is the offset in bytes from the start of the buffer
'the buffer will be packed 2 bytes to an int, for compatibility, even
'though FB ints are 4 bytes long.
'TODO: this sub is redundant to readbinstring
	dim i as integer
	dim bi as integer
	dim bp as integer ptr
	dim toggle as integer
	dim size as integer = len(dest)

	bp = @arr(0)
	bi = o \ 2 'offset is in bytes
	toggle = o mod 2

	if bi < lbound(arr) orelse o + len(dest) > (ubound(arr) + 1) * 2 then
		showbug "array2str: input array too small: " & ubound(arr)
		size = (ubound(arr) + 1) * 2 - o
	end if

	for i = 0 to size - 1
		if toggle = 0 then
			dest[i] = bp[bi] and &hff
			toggle = 1
		else
			dest[i] = (bp[bi] and &hff00) shr 8
			toggle = 0
			bi = bi + 1
		end if
	next

END SUB

SUB str2array (src as string, arr() as integer, byval o as integer)
'strangely enough, this does the opposite of the above
	dim i as integer
	dim bi as integer
	dim bp as integer ptr
	dim toggle as integer
	dim size as integer = len(src)

	bp = @arr(0)
	bi = o \ 2 'offset is in bytes
	toggle = o mod 2

	if bi < lbound(arr) orelse o + len(src) > (ubound(arr) + 1) * 2 then
		showbug "str2array: input array too small: " & ubound(arr)
		size = (ubound(arr) + 1) * 2 - o
	end if

	'debug "String is " + str(len(src)) + " chars"
	for i = 0 to size - 1
		if toggle = 0 then
			bp[bi] = src[i] and &hff
			toggle = 1
		else
			bp[bi] = (bp[bi] and &hff) or (src[i] shl 8)
			'check sign
			if (bp[bi] and &h8000) > 0 then
				bp[bi] = bp[bi] or &hffff0000 'make -ve
			end if
			toggle = 0
			bi = bi + 1
		end if
	next
end SUB

SUB xbload (filename as string, array() as integer, errmsg as string)
	IF isfile(filename) THEN
		dim ff as integer, byt as ubyte, seg as short, offset as short, length as short
		dim ilength as integer
		dim i as integer
		
		IF OPENFILE(filename, FOR_BINARY + ACCESS_READ, ff) THEN
			fatalerror errmsg
		END IF
		GET #ff,, byt 'Magic number, always 253
		IF byt <> 253 THEN
			CLOSE #ff
			fatalerror errmsg & " (bad header)"  'file may also be zero length
		END IF
		GET #ff,, seg 'Segment, no use anymore
		GET #ff,, offset 'Offset into the array, not used now
		GET #ff,, length 'Length
		'length is in bytes, so divide by 2, and subtract 1 because 0-based
		ilength = (length / 2) - 1

		dim buf(ilength) as short

		GET #ff,, buf()
		CLOSE #ff

		for i = 0 to small(ilength, ubound(array))
			array(i) = buf(i)
		next i

	ELSE
		fatalerror errmsg
	END IF
END SUB

SUB xbsave (filename as string, array() as integer, bsize as integer)
	dim ff as integer, byt as UByte, seg as uShort, offset as Short, length as Short
	dim ilength as integer
	dim i as integer
	dim needbyte as integer
	
	seg = &h9999
	offset = 0
	'Because we're working with a short array, but the data is in bytes
	'we need to check if there's an odd size, and therefore a spare byte
	'we'll need to add at the end.
	ilength = (bsize \ 2) - 1	'will lose an odd byte in the division
	needbyte = bsize mod 2		'write an extra byte at the end?
	length = bsize	'bsize is in bytes
	byt = 253

	'copy array to shorts
	DIM buf(ilength) as short
	for i = 0 to small(ilength, ubound(array))
		buf(i) = array(i)
	next

	OPENFILE(filename, FOR_BINARY + ACCESS_WRITE, ff)  'Truncate
	PUT #ff, , byt				'Magic number
	PUT #ff, , seg				'segment - obsolete
	PUT #ff, , offset			'offset - obsolete
	PUT #ff, , length			'size in bytes

	PUT #ff,, buf()
	if needbyte = 1 then
		i = small(ilength + 1, ubound(array)) 'don't overflow
		byt = array(i) and &hff
		put #ff, , byt
	end if
	CLOSE #ff
END SUB

'Set a bit in an integer if 'value', given a bitmask instead of a bit number
SUB setbitmask (byref bitsets as integer, bitmask as integer, value as bool)
	bitsets and= not bitmask
	if value then bitsets or= bitmask
END SUB

'Turn a bit in an array of 16bit words on or off.
'bitwords(): bit array, 16 bits per integer (rest ignored)
'wordnum:    index in bitwords() to start at (index where bits 0-15 are)
'bitnum:     bit number (counting from bitwords(wordnum))
'value:      whether to set the bit on
SUB setbit (bitwords() as integer, wordnum as integer, bitnum as integer, value as bool)
	dim wordoff as integer
	dim wordbit as integer

	wordoff = wordnum + (bitnum \ 16)
	wordbit = bitnum mod 16

	if wordoff < lbound(bitwords) orelse wordoff > ubound(bitwords) then
		showbug strprintf("setbit overflow: ub %d, wordnum %d, bitnum %d, v %d", _
                                  ubound(bitwords), wordnum, bitnum, value)
		exit sub
	end if

	setbitmask bitwords(wordoff), 1 shl wordbit, value
end SUB

'Returns 0 or 1. Use xreadbit if you want NO or YES instead.
'See setbit for full documentation
FUNCTION readbit (bitwords() as integer, wordnum as integer = 0, bitnum as integer) as integer
	dim wordoff as integer
	dim wordbit as integer

	wordoff = wordnum + (bitnum \ 16)
	wordbit = bitnum mod 16

	if wordoff < lbound(bitwords) orelse wordoff > ubound(bitwords) then
		showbug strprintf("readbit overflow: ub %d, wordnum %d, bitnum %d", _
                                  ubound(bitwords), wordnum, bitnum)
		return 0
	end if

	if bitwords(wordoff) and (1 shl wordbit) then
		readbit = 1
	else
		readbit = 0
	end if
end FUNCTION

'This is a wrapper for readbit that returns YES/NO
FUNCTION xreadbit (bitwords() as integer, bitnum as integer, wordoffset as integer = 0) as bool
	RETURN readbit(bitwords(), wordoffset, bitnum) <> 0
END FUNCTION

'Returns what a scancode is if Shift isn't pressed.
'longname: if false, a one-character string for the character that the key
'  inserts is returned if available, e.g. "[" instead of "Left Bracket", with
'  exception of "Space" and "Enter" and numpad keys like "Numpad Minus" which
'  always returned as long names.
'Perhaps doesn't belong here because scancodes are OHR-specific. However, OHR
'scancodes are 95% the same as FB scancodes
FUNCTION scancodename (k as KBScancode, longname as bool = NO) as string
 'static scancodenames(...) as zstring * 19 = { ... }
 'static joybuttonnames(...) as zstring * 22  = { ... }
 #INCLUDE "scancodenames.bi"

 DIM scname as string
 IF k >= LBOUND(scancodenames) ANDALSO k <= UBOUND(scancodenames) THEN
  scname = scancodenames(k)
 ELSEIF k >= scJoyButton1 ANDALSO k <= scJoyLAST THEN
  IF k >= LBOUND(joybuttonnames) ANDALSO k <= UBOUND(joybuttonnames) THEN
   scname = joybuttonnames(k)
  END IF
  IF LEN(scname) = 0 THEN
   scname = "Gamepad Button " & (k - scJoyButton1 + 1)
  END IF
 END IF
 IF LEN(scname) THEN
  'scname is either "" or formatted like "Long Name" or "X Long Name"
  IF LEN(scname) THEN
   IF LEN(scname) >= 3 ANDALSO scname[1] = ASC(" ") THEN
    IF longname THEN scname = MID(scname, 3) ELSE scname = LEFT(scname, 1)
   END IF
   RETURN scname
  END IF
 END IF
 RETURN "Scancode " & k
END FUNCTION

FUNCTION special_char_sanitize(s as string) as string
 'This is a datalossy function.
 'Remove special characters from an OHR string to make it 7-bit ASCII safe.
 'Also translates the old OHR and the new Latin-1 copyright chars to (C)
 DIM result as string = ""
 FOR i as integer = 0 TO LEN(s) - 1
  SELECT CASE s[i]
   CASE 32 TO 126:
    result &= CHR(s[i])
   CASE 134, 169:
    result &= "(C)"
  END SELECT
 NEXT i
 RETURN result
END FUNCTION

FUNCTION starts_with(s as string, prefix as string) as bool
 'Return YES if the string begins with a specific prefix
 RETURN LEFT(s, LEN(prefix)) = prefix
END FUNCTION

FUNCTION ends_with(s as string, suffix as string) as bool
 'Return YES if the string ends with a specific suffix
 RETURN RIGHT(s, LEN(suffix)) = suffix
END FUNCTION


FUNCTION filesize (file as string) as string
 'returns size of a file in formatted string
 IF isfile(file) THEN
  RETURN format_filesize(FILELEN(file))
 ELSE
  RETURN "N/A"
 END IF
END FUNCTION

FUNCTION format_filesize (size as integer) as string
 DIM as bool fractional = (size > 1024)
 DIM as string fsize, units
 units = " B"
 IF size > 1024 THEN units = " KB"
 IF size > 1048576 THEN size = size / 1024 : units = " MB"
 fsize = STR(size)
 IF fractional THEN
  size = size / 102.4
  fsize = STR(size \ 10)
  IF size < 1000 THEN fsize = fsize + "." + STR(size MOD 10)
 END IF
 RETURN fsize + units
END FUNCTION

FUNCTION count_directory_size(directory as string, byref file_count as integer = 0, limit as integer = 999999) as integer
 '--Count the bytes in all the files in a directory and all subdirectories.
 '--This doesn't consider the space taken by the directories themselves,
 '--nor does it consider blocksize or any other filesystem details.
 'file_count: returns total number of files/directories
 'limit: number of files to consider before stopping early. <= 0 for no limit.
 DIM bytes as integer = 0
 DIM filelist() as string

 '--First count files
 findfiles directory, ALLFILES, fileTypeFile, YES, filelist()
 FOR i as integer = 0 TO UBOUND(filelist)
  bytes += filelen(directory & SLASH & filelist(i))
  file_count += 1
  IF file_count >= limit THEN RETURN bytes
 NEXT

 '--Then count subdirectories
 findfiles directory, ALLFILES, fileTypeDirectory, YES, filelist()
 FOR i as integer = 0 TO UBOUND(filelist)
  bytes += count_directory_size(directory & SLASH & filelist(i), file_count, limit)
  file_count += 1
  IF file_count >= limit THEN RETURN bytes
 NEXT

 RETURN bytes
END FUNCTION

'Return contents of a binary file as a string
'For text files use string_from_file instead.
FUNCTION read_file (filename as string, expect_exists as bool = YES, byref success as bool = NO) as string
 success = NO
 DIM fh as integer
 IF OPENFILE(filename, FOR_BINARY + ACCESS_READ + IIF(expect_exists, OR_ERROR, 0), fh) THEN RETURN ""
 DIM buflen as integer = LOF(fh)  'race condition!
 DIM buf as string = STRING(buflen, 0)
 IF buflen > 0 THEN  'Otherwise FB throws an illegal function call error
  GET #fh, , buf
 END IF
 CLOSE #fh
 success = YES
 RETURN buf
END FUNCTION

'Write binary data (as a string) to a file
'For text files use string_to_file instead.
SUB write_file (filename as string, outdata as string)
 DIM fh as integer
 IF OPENFILE(filename, FOR_BINARY + ACCESS_WRITE, fh) = fberrOK then  'truncate to 0 length
  PUT #fh, , outdata
  CLOSE #fh
 END IF
END SUB

FUNCTION string_from_first_line_of_file (filename as string) as string
 'Read the first line of a text file and return it as a string.
 'ignore/removes any line-ending chars
 DIM fh as integer
 DIM result as string
 OPENFILE(filename, for_input, fh)
 LINE INPUT #fh, result
 CLOSE #fh
 RETURN result
END FUNCTION

FUNCTION string_from_file (filename as string, expect_exists as bool = YES, byref success as bool = NO) as string
 'Read an entire text file as a string and
 'convert the line endings to LF only
 RETURN normalize_newlines(read_file(filename, expect_exists, success), !"\n")
END FUNCTION

SUB string_to_file (string_to_write as string, filename as string)
 'Write a string to a text file using native line endings
 write_file filename, normalize_newlines(string_to_write, LINE_END)
END SUB

'Read each line of a file into a string array. Return true on success
'See also string_from_first_line_of_file() if you only want the first.
FUNCTION lines_from_file(strarray() as string, filename as string, expect_exists as bool = YES) as bool
 REDIM strarray(-1 TO -1)
 DIM as integer fh, openerr
 openerr = OPENFILE(filename, FOR_INPUT, fh)
 IF openerr = fberrNOTFOUND THEN
  IF expect_exists THEN showerror "Missing file: " & filename
  RETURN NO
 ELSEIF openerr <> fberrOK THEN
  showerror "lines_from_file: Couldn't open " & filename
  RETURN NO
 END IF
 DO UNTIL EOF(fh)
  DIM text as string
  LINE INPUT #fh, text
  a_append strarray(), text
 LOOP
 CLOSE #fh
 RETURN YES
END FUNCTION

'Write an array of strings to a file, one-per-line.
'The specified line endings will automatically be added (you can pass "" if not needed)
FUNCTION lines_to_file(strarray() as string, filename as string, lineending as string = !"\n") as bool
 DIM fh as integer
 IF OPENFILE(filename, FOR_BINARY + ACCESS_WRITE, fh) THEN  'truncate to 0 length
  showerror "lines_to_file: Couldn't open " & filename
  RETURN NO
 END IF
 FOR i as integer = 0 TO UBOUND(strarray)
  PUT #fh, , strarray(i) & lineending
 NEXT i
 CLOSE #fh
 RETURN YES
END FUNCTION

'Note: Custom doesn't use this function
FUNCTION get_tmpdir () as string
 DIM tmp as string
 #IFDEF __FB_WIN32__
  'Windows only behavior
  tmp = environ("TEMP")
  IF NOT diriswriteable(tmp) THEN tmp = environ("TMP")
  IF NOT diriswriteable(tmp) THEN tmp = EXEPATH
  IF NOT diriswriteable(tmp) THEN tmp = CURDIR
  IF NOT diriswriteable(tmp) THEN fatalerror "Unable to find any writable temp dir"
 #ELSEIF DEFINED(__FB_ANDROID__)
  'SDL sets initial directory to .../com.hamsterrepublic.ohrrpgce.game/files
  tmp = orig_dir
 #ELSEIF DEFINED(__FB_DARWIN__)
  'This matches fallback behaviour of get_settings_dir. See comments there.
  '(TODO: We only care about using .ohrrpgce if is already exists so that we can delete
  'crashed playing.tmp dirs)
  'We use Caches instead of Application Support; looks like it only matters on iOS
  '(where the OS is free to delete Caches).
  tmp = ENVIRON("HOME") & "/.ohrrpgce"
  IF isdir(tmp) = NO THEN
   tmp = ENVIRON("HOME") & "/Library/Caches/OHRRPGCE"
  END IF
 #ELSEIF DEFINED(__FB_UNIX__)
  tmp = environ("HOME") + SLASH + ".ohrrpgce"
 #ELSE
  #ERROR "Unknown OS"
 #ENDIF
 IF NOT isdir(tmp) THEN
  IF makedir(tmp) <> 0 THEN fatalerror "Temp directory " & tmp & " missing and unable to create it"
 END IF
 tmp = add_trailing_slash(tmp)
 DIM as string d = DATE, t = TIME
 tmp += "ohrrpgce" & MID(d,7,4) & MID(d,1,2) & MID(d,4,2) & MID(t,1,2) & MID(t,4,2) & MID(t,7,2) & "." & randint(1000) & ".tmp" & SLASH
 IF NOT isdir(tmp) THEN
  IF makedir(tmp) <> 0 THEN fatalerror "Unable to create temp directory " & tmp
 END IF
 RETURN tmp
END FUNCTION


'----------------------------------------------------------------------
'                       Commandline processing


'Returns true if opt is a flag (prefixed with -,--,/) and removes the prefix
function commandline_flag(opt as string) as bool
	dim temp as string
	temp = left(opt, 1)
	'/ should not be a flag under unix
#ifdef __FB_UNIX__
	if temp = "-" then
#else
	if temp = "-" or temp = "/" then
#endif
		temp = mid(opt, 2, 1)
		if temp = "-" then  '--
			opt = mid(opt, 3)
		else
			opt = mid(opt, 2)
		end if
		return YES
	end if
	return NO
end function

'Read commandline arguments from actual commandline and from args_file
local sub get_commandline_args(cmdargs() as string, args_file as string = "")
	if len(args_file) andalso isfile(args_file) then
		debuginfo "Reading additional commandline arguments from " & args_file 
		lines_from_file cmdargs(), args_file
	end if

	dim i as integer = 1
	while command(i) <> ""
		a_append(cmdargs(), command(i))
		i += 1
	wend
end sub

' Processes all commandline switches by calling opt_handler function,
' and put any arguments that aren't recognised in nonoption_args() (must be a dynamic array).
' args_file optionally provides additional arguments.
sub processcommandline(nonoption_args() as string, opt_handler as FnSetOption, args_file as string = "")
	dim cnt as integer = 0
	dim opt as string
	dim arg as string
	redim cmdargs(-1 to -1) as string
	redim nonoption_args(-1 to -1) as string

	get_commandline_args cmdargs(), args_file

	while cnt <= ubound(cmdargs)
		dim argsused as integer = 0

		opt = cmdargs(cnt)
		if commandline_flag(opt) then
			#ifdef __FB_DARWIN__
				'Passed when started from Finder. Ignore. (Fix for bug #1171)
                                'This is currently only necessary when using gfx_sdl2 because it doesn't link
                                'mac/SDLMain.m; if using gfx_sdl then this argument is stripped in SDLMain.m.
				if starts_with(opt, "psn_") then
					cnt += 1
					continue while
				end if
			#endif

			if cnt + 1 <= ubound(cmdargs) then
				arg = cmdargs(cnt + 1)
				if commandline_flag(arg) then arg = ""
			else
				arg = ""
			end if

			argsused = opt_handler(opt, arg)

			'debuginfo "commandline option = '" & opt & "' arg = '" & arg & "' used = " & argsused
		end if

		if argsused = 0 then
			'Everything else falls through and is stored for the program to catch
			'(we could prehaps move their handling into functions as well)
			a_append(nonoption_args(), cmdargs(cnt))
			argsused = 1
			'debuginfo "commandline arg " & (ubound(nonoption_args) - 1) & ": stored " & cmdargs(cnt)
		end if
		cnt += argsused
	wend
end sub

'----------------------------------------------------------------------
'                        ini file read/write


SUB write_ini_value (ini_filename as string, key as string, value as string)
 REDIM ini(-1 TO -1) as string
 IF isfile(ini_filename) THEN
  lines_from_file ini(), ini_filename
 END IF
 write_ini_value ini(), key, value
 lines_to_file ini(), ini_filename, LINE_END
END SUB

SUB write_ini_value (ini_filename as string, key as string, value as integer)
 write_ini_value ini_filename, key, STR(value)
END SUB

SUB write_ini_value (ini_filename as string, key as string, value as double)
 write_ini_value ini_filename, key, STR(value)
END SUB

SUB write_ini_value (ini() as string, key as string, value as string)
 'Key is case insensitive but case preservative
 'If the key is matched more than once, all copies of it will be changed
 BUG_IF(LEN(key) = 0, "Can't write empty key to ini file")
 DIM found as bool = NO
 FOR i as integer = 0 TO UBOUND(ini)
  IF ini_key_match(ini(i), key) THEN
   ini(i) = key & " = " & value
   found = YES
  END IF
 NEXT i
 IF NOT found THEN
  a_append ini(), key & " = " & value
 END IF
END SUB

FUNCTION read_ini_str (ini_filename as string, key as string, default as string="", byref linenum as integer = 0) as string
 REDIM ini(-1 TO -1) as string
 IF isfile(ini_filename) THEN
  lines_from_file ini(), ini_filename
 END IF
 RETURN read_ini_str(ini(), key, default, linenum)
END FUNCTION

'Given the content of an .ini as an array of lines, return the value of the
'first line of form "key = value".
'Optionally returns the line number (0-indexed) on which the match was found in linenum, or else -1.
FUNCTION read_ini_str (ini() as string, key as string, default as string="", byref linenum as integer = 0) as string
 linenum = -1
 BUG_IF(LEN(key) = 0, "Can't read empty key from ini file", default)
 DIM value as string
 FOR i as integer = 0 TO UBOUND(ini)
  IF ini_key_match(ini(i), key, value) THEN
   linenum = i
   RETURN value
  END IF
 NEXT i
 RETURN default
END FUNCTION

FUNCTION read_ini_int (ini_filename as string, key as string, default as integer=0) as integer
 RETURN str2int(read_ini_str(ini_filename, key), default)
END FUNCTION

'This is not strict. A non-numerical value will return 0., not default!
FUNCTION read_ini_double (ini_filename as string, key as string, default as double=0.) as double
 DIM value as string = read_ini_str(ini_filename, key)
 IF LEN(value) THEN RETURN VAL(value)
 RETURN default
END FUNCTION

'A case insensitive match for regex "^key *= *value *". Returns true and sets "value" on a match
FUNCTION ini_key_match(text as string, key as string, byref value as string = "") as bool
 DIM eqpos as integer
 IF LCASE(LEFT(text, LEN(key))) <> LCASE(key) THEN RETURN NO
 eqpos = LEN(key) + 1
 WHILE MID(text, eqpos, 1) = " "
  eqpos += 1
 WEND
 IF MID(text, eqpos, 1) <> "=" THEN RETURN NO
 value = TRIM(MID(text, eqpos + 1))
 RETURN YES
END FUNCTION

'----------------------------------------------------------------------

'Measure how long a TIMER call takes
FUNCTION measure_timer_overhead() as double
 DIM as double besttime = 1e99, thistime, timestamp
 'Time 5 times and take the lowest, because OS interruptions cause large spikes on Linux
 FOR attempt as integer = 1 TO 5
  'Don't count initial TIMER, we're timing the interval between two TIMER calls.
  DIM counter as integer = 0
  READ_TIMER(timestamp)
  thistime = -timestamp
  FOR i as integer = 0 TO 1999
   READ_TIMER(timestamp)
   counter += 1
   'Stop early after 1ms
   IF (i AND 255) = 0 ANDALSO thistime + timestamp > 1e-3 THEN EXIT FOR
  NEXT
  thistime += timestamp
  thistime /= counter
  IF thistime < besttime THEN besttime = thistime
 NEXT
 RETURN besttime
END FUNCTION

'----------------------------------------------------------------------

destructor SmoothedTimer()
  v_free times
end destructor

Sub SmoothedTimer.start()
  timing = 0.0
  TIMER_START(timing)  'timing = -TIMER
end sub

'Returns true if smoothed value was updated
function SmoothedTimer.stop() as bool
  TIMER_STOP(timing)
  return add_time(timing)
end function

'Add time and update
function SmoothedTimer.add_time(time as double) as bool
  ran = YES
  if times = NULL then v_new times
  v_append times, time
  if v_len(times) = 9 then
    'Update with median buffer value
    v_sort times
    if smoothtime > times[4] * 4/3 orelse smoothtime < times[4] * 3/4 then
      smoothtime = times[4]   'Reset
    else
      smoothtime = smoothtime * 0.6 + 0.4 * times[4]
    end if
    v_new times  'Clear buffer
    smooth_updated = YES
    return YES
  end if
  smooth_updated = NO
end function

function SmoothedTimer.tell() as string
  return "done in " & cint(1e6 * timing) & !"us;\tsmoothed: " & cint(1e6 * smoothtime) & "us"
end function

sub SmoothedTimer.stop_and_print()
  if stop() then ? tell()
end sub

'----------------------------------------------------------------------

'Begin a new time step and start()
sub ExpSmoothedTimer.begin_timestep()
  cur_time = -timer
end sub

'Stop if not already, and finish a time step by updating smooth_time with decay
function ExpSmoothedTimer.finish_timestep(halflife as double, update_display as bool = YES) as double
  'if cur_time < 0 then cur_time += timer  '.stop(). Breaks timers using negative add_time
  dim decay as double = exp2(-1 / halflife)
  smooth_time = decay * smooth_time + (1 - decay) * cur_time
  if update_display then display_time = smooth_time
  return smooth_time
end function

'Resume adding time to this timer
sub ExpSmoothedTimer.start()
  cur_time -= timer
end sub

'Stop adding time
sub ExpSmoothedTimer.stop()
  cur_time += timer
end sub

operator ExpSmoothedTimer.+=(rhs as ExpSmoothedTimer)
  this.cur_time += rhs.cur_time
  this.smooth_time += rhs.smooth_time
  this.display_time += rhs.display_time
end operator


'----------------------------------------------------------------------

'Reset state and start the Default timer
sub MultiTimer.begin_timestep()
  for idx as integer = lbound(timers) to ubound(timers)
    timers(idx).cur_time = 0.
  next
  timers(TimerIDs.Total).start()
  'num_timer_calls = 1
  subtimer = TimerIDs.Default
  enabled = YES
end sub

'Stop all timers and apply smoothing
sub MultiTimer.finish_timestep(halflife as double, update_display as bool = YES)
  if enabled = NO then exit sub
  if subtimer > TimerIDs.Default then timers(subtimer).stop()  'Shouldn't happen
  timers(TimerIDs.Total).stop()
  'num_timer_calls += 1

  'Calculate Total & Default.
  'For efficiency we don't stop/start Default timer all the time.
  timers(TimerIDs.Total).cur_time -= timers(TimerIDs.Pause).cur_time
  timers(TimerIDs.Default).cur_time = timers(TimerIDs.Total).cur_time
  for idx as integer = TimerIDs.FIRST to ubound(timers)
    timers(TimerIDs.Default).cur_time -= timers(idx).cur_time
  next

  for idx as integer = lbound(timers) to ubound(timers)
    timers(idx).finish_timestep(halflife, update_display)
  next
  enabled = NO
  subtimer = TimerIDs.None
end sub

'If enabled=NO or a subtimer (not Default) is already running, does nothing and
'returns 0 (Default).
'Can use substart(TimerIDs.Pause) to pause.
'The return value can optionally be used to more efficiently skip the matching substop().
function MultiTimer.substart(new_subtimer as TimerIDs) as TimerIDs
  if subtimer <> TimerIDs.Default then return TimerIDs.Default
  subtimer = new_subtimer
  timers(subtimer).cur_time -= timer  '.start()
  'num_timer_calls += 1
  return subtimer
end function

'Pass in the ID of the subtimer to end, so can ignore nested substart/substop pairs; does nothing
'when passed 0 (Default) or subtimer other than the active one.
sub MultiTimer.substop(cur_subtimer as TimerIDs)
  if cur_subtimer <> subtimer then exit sub
  if subtimer = TimerIDs.Default then exit sub
  timers(subtimer).cur_time += timer  '.stop()
  'num_timer_calls += 1
  subtimer = TimerIDs.Default
end sub

'Override the current subtimer, including switching to Default or Pause.
'Returns previous subtimer ID, which can be passed back to switch to resume it:
'you must do so to use this for nesting subtimers.
'Returns TimerIDs.None if not running.
function MultiTimer.switch(new_subtimer as TimerIDs) as TimerIDs
  if subtimer = TimerIDs.None or new_subtimer = TimerIDs.None then return TimerIDs.None
  dim time as double = timer
  'num_timer_calls += 1
  if subtimer <> TimerIDs.Default then timers(subtimer).cur_time += time  '.stop()
  function = subtimer
  subtimer = new_subtimer
  if subtimer <> TimerIDs.Default then timers(subtimer).cur_time -= time  '.start()
end function

sub MultiTimer.add_time(to_subtimer as TimerIDs, amount as double)
  timers(TimerIDs.Total).cur_time += amount
  timers(to_subtimer).cur_time += amount
end sub


'----------------------------------------------------------------------
'                       other misc functions

' For commandline utilities. Wait for a keypress and return it.
FUNCTION readkey () as string
  DO
    DIM w as string = INKEY
    IF w <> "" THEN RETURN w
  LOOP
END FUNCTION

'----------------------------------------------------------------------

#IFDEF __FB_MAIN__
 print "All passed."
#ENDIF
