-- FILE:     MACHINE2.E
-- PURPOSE:  Utility/Bitwise/Machine routines for Euphoria 3.1.1.
-- AUTHOR:   Shian Lee
-- VERSION:  1.12, October/20/2019
-- LANGUAGE: Euphoria version 3.1.1 (http://www.RapidEuphoria.com)
-- PLATFORM: Any
-- LICENCE:  Free. Use at your own risk.
-- NOTE:     * The code is optimized for Euphoria 3.1.1, using DOS32 platform.
--           * See the attached reference manual MACHINE2.DOC for details.
--           * Created using QE 2.3.9 & edu 2.33 (RapidEuphoria311.com archive).
-- HISTORY:  v1.00 - initial version
--           v1.01 - string() type is optimized and faster. Tip added to DOC.
--           v1.05 - new: get_xkey, wait_xkey, clear_keyboard, flat, crash, iif.
--           v1.06 - unpack_bits() now using floor() and it's much faster.
--           v1.08 - new: bsearch, hash, checksum.
--           v1.09 - new: byte_string, sencode, encode
--           v1.10 - encode() is now faster!
--           v1.11 - bug fix: sencode() return *only* byte_string type
--           v1.12 - range_per_bits() supports larger range: 0 to 52.
-----------------------------------------------------------------------------



--bookmark: Local Constants;

constant
    SHx32   = #100000000,                   -- power(2, 32), shift 32-bits
    SHx16   = #10000,                       -- power(2, 16), shift 16-bits
    SHx8    = #100,                         -- power(2, 8),  shift 8-bits
    MIN_S32 = -2147483648,                  -- min signed 32-bit (-2147483648)
    MAX_U32 = #FFFFFFFF,                    -- max unsigned 32-bit
    MASK16  = #FFFF,                        -- max unsigned 16-bit
    MAX_S16 = #7FFF                         -- max signed 16-bit



-- PURPOSE: constants to speedup routines while keeping the code clear.
--          masks also serve as fast type-checking ("subscript out of bounds")
constant
    -- sequence of 32 bit-set-masks for bin(), #80000000..#1,
    -- calculated using power(2, 31 to 0 by -1):
    MASKS = {#80000000,#40000000,#20000000,#10000000,
	     #8000000,#4000000,#2000000,#1000000,
	     #800000,#400000,#200000,#100000,
	     #80000,#40000,#20000,#10000,
	     #8000,#4000,#2000,#1000,
	     #800,#400,#200,#100,
	     #80,#40,#20,#10,
	     #8,#4,#2,#1}

constant
    -- sequences of 33 masks for bit-manipulation routines
    M_LOW = #FFFFFFFF & (MASKS - 1),        -- #FFFFFFFF..#0
    M_SHL = #0 & MASKS,                     -- #0 & #80000000..#1
    M_SHR = #100000000 & MASKS              -- #100000000..#1



constant
    -- max 8/16/32 bits prime numbers, used for hash and encoding routines
    PRIME_MAX8BIT  = 251,
    PRIME_MAX16BIT = 65521,
    PRIME_MAX32BIT = 4294967291,
    -- magic number for DJB hash algorithm (5381)
    DJB_MAGIC_NUMBER = 5381



constant
    -- machine_func()/machine_proc() arguments
    M_WAIT_KEY = 26,                        -- wait_key(), get.e
    M_CRASH_MESSAGE = 37                    -- crash_message(), machine.e



--bookmark: Local Types;

-- PURPOSE: test if significand-field x is accurate for 32-bit Euphoria.
-- NOTE:    the significand-field is the largest integer size of floating-point.
type fp_significand_field(object x)
    return equal(x >= 0 and x <= 52, x or 1) -- 64-bit C Double (up to 52-bit)
end type



--bookmark: Global Constants;

global constant
    FALSE = 0,                              -- the boolean value 0
    TRUE  = not FALSE,                      -- the boolean value 1
    EMPTY = {}                              -- an empty sequence ({})



--bookmark: Predefined Types;

-- PURPOSE: test if an object is a boolean integer
-- RETURN:  boolean;
-- EXAMPLE: i = boolean(0)  --> i is TRUE
global type boolean(object x)
    return equal(x, FALSE) or equal(x, TRUE)
end type



-- PURPOSE: test if an object is a DWORD (32-bit) atom or sequence
-- NOTE:    bitwise operations are limited to 32-bit numbers
-- RETURN:  boolean;
-- EXAMPLE: i = dwords({3,{100.5, {-9}, 0}})  --> i is TRUE
global type dwords(object x)
    return equal(x, (x >= MIN_S32 and x <= MAX_U32) * x)
end type



-- PURPOSE: test if an object is a string (a flat sequence)
-- RETURN:  boolean;
-- EXAMPLE: i = string({1, 2.5, 3, {}})  --> i is FALSE
--          i = string({1, 2.5, 3, 4})   --> i is TRUE
global type string(object x)
    if atom(x) then
	return FALSE
    else -- [nested] sequence(x)
	return equal(x and 0, repeat(0, length(x)))
    end if
end type



-- PURPOSE: test if an object is an unsigned byte-string
-- RETURN:  boolean;
-- EXAMPLE: i = byte_string({1, 2.5, 3, {}})    --> i is FALSE
--          i = byte_string({0, 2.5, 3, 255})   --> i is TRUE
global type byte_string(object x)
    if atom(x) then
	return FALSE
    else -- [nested] sequence(x)
	return equal(x >= 0 and x <= 255, repeat(1, length(x)))
    end if
end type



--bookmark: crash;

-- PURPOSE: specify a message to be printed and crash your program
-- DETAILS: if 'message' is empty, "", then crash_message() will be used
-- EXAMPLE: crash("Bad argument in function get_version().\n")
global procedure crash(string message)
    if length(message) then
	machine_proc(M_CRASH_MESSAGE, message)
    end if

    ? 1 / 0     -- crash and save stack call in ex.err file
end procedure



--bookmark: Sequence Manipulation;

-- PURPOSE: calculate the sum of a sequence
-- DETAILS: s is sequence
-- RETURN:  atom;
-- EXAMPLE: a = sum({{1},2,{{3,4,{5,6}}}})  --> a is 21 (1+2+3+4+5+6)
global function sum(sequence s)
    atom a

    a = 0
    for i = 1 to length(s) do
	if atom(s[i]) then
	    a += s[i]
	else
	    a += sum(s[i])
	end if
    end for
    return a
end function



-- PURPOSE: flatten a sequence, don't add an end-of-string marker
-- NOTE:    flat() is faster and more efficient then flatten()
-- RETURN:  sequence;
-- EXAMPLE: s = flat({0,{1},2,{{3,4,{5.5,6}}, {{"789"}-'0'}}, 10,11,{12}})
--            --> s is {0,1,2,3,4,5.5,6,7,8,9,10,11,12}
global function flat(sequence s)
    integer i

    i = 1
    while i <= length(s) do
	if atom(s[i]) then
	    i += 1
	else
	    s = s[1..i - 1] & s[i] & s[i + 1..$]
	end if
    end while

    return s
end function



-- PURPOSE: flatten a sequence
-- DETAILS: s is sequence. eos is character or string for end-of-string marker
-- RETURN:  sequence;
-- EXAMPLE:
--   s = flatten({0,{1},2,{{3,4,{5.5,6}}, {{"789"}-'0'}}, 10,11,{12}}, "")
--                                 --> s is {0,1,2,3,4,5.5,6,7,8,9,10,11,12}
integer
    stIdx, enIdx                        -- local vars speedup a bit more
global function flatten(sequence s, object eos)
    sequence f

    f = EMPTY                           -- f is the new flat sequence

    stIdx = 0                           -- 0 = start new string/atom
    for i = 1 to length(s) do
	if atom(s[i]) then
	    if stIdx then               -- update end of string
		enIdx += 1
	    else -- stIdx = 0           -- start new string?
		stIdx = i               -- start of string/atom
		enIdx = i               -- end of string/atom
	    end if
	    if i = length(s) then       -- append entire "string" fast
		f &= s[stIdx..enIdx] & eos
		stIdx = 0               -- 0 = start new string/atom
	    end if
	else -- nested sequence(s)
	    if stIdx then               -- there are atoms to append:
		if stIdx = enIdx then   -- append single 'atom'
		    f &= s[stIdx] & eos
		else                    -- append "few-atoms" fast
		    f &= s[stIdx..enIdx] & eos
		end if
	     -- stIdx = 0               --> (we don't need it with local vars)
	    end if
	    f &= flatten(s[i], eos)     -- append nested sequence(s)
	end if
    end for

    return f
end function



-- PURPOSE: encode or decode a string sequence
-- AUTHOR:  Shian Lee (using DJB hash algorithm by Daniel J. Bernstein).
-- DETAILS: st must be an unsigned byte-string (8-bit string sequence).
--          key is a string sequence made of any integer type numbers.
-- RETURN:  sequence; unsigned byte-string sequence.
-- EXAMPLE: s = sencode({0,0,0,0,0,0,1,1,1}, "EU3!")
--           -- s is {185,166,7,13,247,204,7,230,163}
global function sencode(byte_string st, string key)
    integer len_s, len_key, n, count
    sequence s

    s = st -- ignore type check (faster)
    len_s = length(s)
    len_key = length(key)
    n = DJB_MAGIC_NUMBER
    count = 1 -- start at first byte of s

    if len_key and len_s then
	while TRUE do
	    for p = 1 to len_key do
		n = remainder(n * 33 + key[p], PRIME_MAX8BIT)
		s[count] = xor_bits(s[count], and_bits(n, #FF))
		if count = len_s then
		    return s
		end if
		count += 1
	    end for
	end while
    end if

    return s
end function



--bookmark: Searching and Sorting;

-- PURPOSE: find an object in a sorted sequence
-- CREDIT:  Euphoria 3.1.1, include/database.e
-- DETAILS: find object x in sequence s
-- NOTE:    * using fast binary search algorithm
--          * x must be sorted in ascending order
-- RETURN:  integer; match location, or insert location (negative) if not found
-- EXAMPLE: i = bsearch("b", {"a", "b", "c"}) -- i is 2
global function bsearch(object x, sequence s)
    integer low, high, middle, c

    low = 1
    high = length(s)
    middle = 1
    c = 0
    while low <= high do
	middle = floor((low + high) / 2)
	c = compare(x, s[middle])
	if c < 0 then
	    high = middle - 1
	elsif c > 0 then
	    low = middle + 1
	else
	    return middle
	end if
    end while
    -- return the position it would have, if inserted now
    if c > 0 then
	middle += 1
    end if
    return -middle
end function



-- PURPOSE: calculate the hash value of an object
-- CREDIT:  djb2 -- http://www.cse.yorku.ca/~oz/hash.html
-- RETURN:  atom; (integer) in the range 1 to abs(limit)
-- NOTE:    low limit (16-bit integer) is calculated much faster
-- EXAMPLE: i = hash("hello world!", 1000) -- i is 627
global function hash(object x, atom limit)
    atom n
    sequence s

    n = DJB_MAGIC_NUMBER

    if atom(x) then
	n = remainder(n * 33 + x, limit)
    else
	s = x
	for i = 1 to length(s) do
	    if atom(s[i]) then
		n = remainder(n * 33 + s[i], limit)
	    else -- [nested] sequence(s[i])
		n = remainder(n * 33 + hash(s[i], limit), limit)
	    end if
	end for
    end if
    if n < 0 then
	n = -n
    end if
    return floor(n) + 1
end function



--bookmark: Math;

-- PURPOSE: return the absolute value of a number
-- DETAILS: x is atom/sequence
-- RETURN:  object;
-- EXAMPLE: x = abs({-15, 15})  --> x is {15,15}
global function abs(object x)
    return x * ((x > 0) - (x < 0))          -- x * sign(x)
end function



-- PURPOSE: truncate the fractional part of a number
-- DETAILS: x is atom/sequence
-- RETURN:  object;
-- EXAMPLE: x = fix({-15.5, 15.5})  --> x is {-15, 15}
global function fix(object x)
    return x - remainder(x, 1)
end function



-- PURPOSE: return a value indicating the sign of a number, 0 is 0
-- DETAILS: x is atom/sequence
-- RETURN:  object; (0 if 0, 1 if positive, -1 if negative)
global function sign(object x)
    return (x > 0) - (x < 0)
end function



-- PURPOSE: return a value indicating the sign of a number, 0 is 1
-- DETAILS: x is atom/sequence
-- RETURN:  object; (1 if 0, 1 if positive, -1 if negative)
global function psign(object x)
    return (x >= 0) - (x < 0)
end function



-- PURPOSE: return a value indicating the sign of a number, 0 is -1
-- DETAILS: x is atom/sequence
-- RETURN:  object; (-1 if 0, 1 if positive, -1 if negative)
global function nsign(object x)
    return (x > 0) - (x <= 0)
end function



-- PURPOSE: return a value indicating the sign of a number, 0 is TRUE
-- DETAILS: x is atom/sequence
-- RETURN:  object; (1 if 0, 0 if positive, 0 if negative)
global function zsign(object x)
    return x = 0
end function



--bookmark: Bitwise Operations;

-- PURPOSE: perform logical EQV on corresponding bits
--          Truth table:  x1  x2  EQV (Equivalence)
--                        --  --  ---
--                        1   1   1
--                        1   0   0
--                        0   1   0
--                        0   0   1
--                        -----------
-- DETAILS: x1,x2 are 32-bit atom/sequence
-- RETURN:  object;
-- EXAMPLE: a = eqv_bits(#F, #71)  --> a is #FFFFFF81
global function eqv_bits(object x1, object x2)
    return xor_bits(x1, not_bits(x2))
end function



-- PURPOSE: perform logical IMP on corresponding bits
--          Truth table:  x1  x2  IMP (Implication)
--                        --  --  ---
--                        1   1   1
--                        1   0   0
--                        0   1   1
--                        0   0   1
--                        -----------
-- DETAILS: x1,x2 are 32-bit atom/sequence
-- RETURN:  object;
-- EXAMPLE: a = imp_bits(#F, #71)  --> a is #FFFFFFF1
global function imp_bits(object x1, object x2)
    return or_bits(xor_bits(x1, not_bits(x2)), not_bits(x1))
end function



-- PURPOSE: return the result of shifting bits left
-- NOTE:    or_bits() is here to return *signed* value (standard)
-- DETAILS: x is 32-bit atom/sequence
--          n is number of bits to shift: 0 to 32
-- RETURN:  object;
global function shl_bits(object x, integer n)
    return or_bits(and_bits(x, M_LOW[n + 1]) * M_SHL[33 - n], #0)
end function



-- PURPOSE: return the result of shifting bits right
-- NOTE:    here we must unsigned(x) before shifting right 32-bits
-- DETAILS: x is 32-bit atom/sequence
--          n is number of bits to shift: 0 to 32
-- RETURN:  object;
global function shr_bits(object x, integer n)
    return or_bits((x + (x < 0) * SHx32) / M_SHR[33 - n], #0)
end function



-- PURPOSE: return the result of rotating bits left
-- DETAILS: x is 32-bit atom/sequence
--          n is number of bits to rotate: 0 to 32
-- RETURN:  object;
global function rol_bits(object x, integer n)
    return or_bits(
	and_bits(x, M_LOW[n + 1]) * M_SHL[33 - n],  -- shl_bits
	(x + (x < 0) * SHx32) / M_SHR[n + 1]        -- shr_bits (unsigned)
    )
end function



-- PURPOSE: return the result of rotating bits right
-- DETAILS: x is 32-bit atom/sequence
--          n is number of bits to rotate: 0 to 32
-- RETURN:  object;
global function ror_bits(object x, integer n)
    return or_bits(
	and_bits(x, M_LOW[33 - n]) * M_SHL[n + 1],  -- shl_bits
	(x + (x < 0) * SHx32) / M_SHR[33 - n]       -- shr_bits (unsigned)
    )
end function



-- PURPOSE: return the result of getting a bit value
-- DETAILS: x is 32-bit atom/sequence
--          p is bit position to get: 1 to 33
-- RETURN:  object; (bit value: 0 is false, non-zero is true)
-- EXAMPLE: a = get_bit(#5, #3)  --> a is #4 (0b100)
global function get_bit(object x, integer p)
    return and_bits(x, M_SHL[34 - p])
end function



-- PURPOSE: return the result of setting a bit value
-- DETAILS: x is 32-bit atom/sequence
--          p is bit position to set: 1 to 33
--          n is bit value: 0 is false, non-zero is true
-- RETURN:  object;
global function set_bit(object x, integer p, integer n)
    if n then                               -- set bit to 1 (n != 0)
	return or_bits(x, M_SHL[34 - p])
    else -- n = 0                           -- reset bit to 0
	return and_bits(x, not_bits(M_SHL[34 - p]))
    end if
end function



-- NOTE: pack/unpack bits are used to pack small integers into 32-bit atom,
--       e.g. to pack date() sequence into a single integer.


-- PURPOSE: convert a sequence of numbers to an integer
-- DETAILS: v is sequence of values (small integers)
--          n is sequence of bits per value, range: 0 to 32 (or 0 to -32)
-- NOTE:    v and n are paralleled. n must be accurate to get correct result.
-- RETURN:  atom; (32-bit signed atom)
-- EXAMPLE:
--  a = pack_bits({#FA3, #8, #12}, {12,4,8})  -- a is 16398354 (#FA3812)
--  s = unpack_bits(#FA3812, {12,4,8})  -- s is {4003,8,18}; {#FA3,#8,#12}
--
--  a = pack_bits({#40000000, 1}, {31,1})  -- a is -2147483647 (#80000001)
--  s = unpack_bits(-2147483647, {31,1}) -- s is {1073741824,1}; {#40000000,#1}
global function pack_bits(sequence v, sequence n)
    atom a

    -- abs(n) -- for compatibility with unpack_bits() of signed numbers
    n *= ((n > 0) - (n < 0))

    a = 0
    for i = 1 to length(n) do
	-- shl_bits, mask low bits (for negative numbers), and pack value
	a = or_bits(a * M_SHL[33 - n[i]], and_bits(v[i], M_LOW[33 - n[i]]))
    end for
    return a                                -- return 32-bit signed atom
end function



-- PURPOSE: convert an integer to a sequence of numbers
-- DETAILS: a is 32-bit atom to unpack
--          n is sequence of bits per value, range: 0 to 32
--           - if n value is negative (0 to -32) it unpacks signed number
-- NOTE:    n must be accurate to get correct result.
-- RETURN:  sequence;
-- EXAMPLE: See pack_bits() example
global function unpack_bits(atom a, sequence n)
    sequence r

    if a < 0 then a += SHx32 end if         -- unsigned(a) for shift-right

    r = repeat(0, length(n))
    for i = length(n) to 1 by -1 do
	if n[i] >= 0 then                   -- unpack unsigned number
	    r[i] = and_bits(a, M_LOW[33 - n[i]])
	    a = floor(a / M_SHR[33 - n[i]]) -- shr_bits (unsigned)

	else -- n[i] < 0                    -- unpack signed number
	    r[i] = and_bits(a, M_LOW[33 + n[i]])
	    a = floor(a / M_SHR[33 + n[i]]) -- shr_bits (unsigned)

	    -- if r[i] > maximum-signed then convert to negative number
	    if r[i] > floor(M_LOW[33 + n[i]] / 2) then
		r[i] -= M_SHR[33 + n[i]]    -- signed(r[i])
	    end if
	end if
    end for
    return r
end function



--bookmark: File and Device I/O;

-- PURPOSE: output an object to a file or device
-- NOTICE:  putx() is not as fast and efficient as puts()
-- DETAILS: fn is file or device. x is object.
--          eos is character or string for end-of-string marker, e.g. '\n'
-- EXAMPLE:
-- putx(1, {{"http",':','/','/'},"www",'.',{{"RapidEuphoria"},'.',"com"}}, 32)
-- --> outputs "http :// www . RapidEuphoria . com "
global procedure putx(integer fn, object x, object eos)
    if atom(x) then
	puts(fn, x & eos)
    else -- [nested] sequence(x)
	puts(fn, flatten(x, eos))
    end if
end procedure



-- PURPOSE: check for key pressed by the user, don't wait, return an object
-- NOTE:    this function is useful for many terminals (Linux xterm, etc)
-- RETURN:  object; key (integer or string of integers)
-- EXAMPLE: x = get_xkey() -- see also demo: xkey.ex
global function get_xkey()
    object key

    key = get_key()
    if key = -1 then
	return -1
    else
	key = {key}
	while key[$] != -1 do
	    key = append(key, get_key())
	end while

	if length(key) = 2 then             -- key is integer (ASCII, etc)
	    return key[1]
	else                                -- key is sequence of integers
	    return key[1..$ - 1]            -- (Escape-sequence, UTF-32, etc)
	end if
    end if
end function



-- PURPOSE: wait for user to press a key, return an object
-- NOTE:    this function is useful for many terminals (Linux xterm, etc)
-- RETURN:  object; key (integer or string of integers)
-- EXAMPLE: x = wait_xkey() -- x is {27,91,72} for 'Home' in Linux xterm terminal
global function wait_xkey()
    sequence key

    key = {machine_func(M_WAIT_KEY, 0)}     -- wait until user press a key
    while key[$] != -1 do
	key = append(key, get_key())
    end while

    if length(key) = 2 then                 -- key is integer (ASCII, etc)
	return key[1]
    else                                    -- key is sequence of integers
	return key[1..$ - 1]                -- (Escape-sequence, UTF-32, etc)
    end if
end function



-- PURPOSE: suspend execution until user press a key
-- EXAMPLE: puts(1, "start... ")  pause()  puts(1, " ...end")
global procedure pause()
    while get_key() != -1 do                -- empty the keyboard buffer
    end while

    if machine_func(M_WAIT_KEY, 0) then     -- wait until user press a key
    end if
end procedure



-- PURPOSE: clear the keyboard buffer
-- NOTE:    useful before waiting for a new input from the user
-- EXAMPLE: clear_keyboard()    ok = (wait_key() = 'y')
global procedure clear_keyboard()
    while get_key() != -1 do
    end while
end procedure



-- PURPOSE: calculate the checksum value of data
-- CREDIT:  djb2 -- http://www.cse.yorku.ca/~oz/hash.html
-- DETAILS: fn = open(file_or_device, "rb").
--          bits is 0|1 (calculate 16|32-bit checksum)
-- NOTE:    16-bit checksum is calculated much faster
-- RETURN:  atom; in the range 1 to 16|32-bit number
constant
    CS_16_32 = {PRIME_MAX16BIT, PRIME_MAX32BIT}
global function checksum(integer fn, boolean bits)
    atom limit, n
    integer c

    limit = CS_16_32[bits + 1]
    n = DJB_MAGIC_NUMBER
    while TRUE do
	c = getc(fn)
	if c = -1 then
	    return n + 1
	end if
	n = remainder(n * 33 + c, limit)
    end while
end function



-- PURPOSE: encode or decode data
-- AUTHOR:  Shian Lee (using DJB hash algorithm by Daniel J. Bernstein).
-- DETAILS: file1 is source filename to encode (open for read).
--          file2 is the new encoded filename (open for write).
--          key is a string sequence made of any integer type numbers.
-- NOTE:    using 16-bit algorithm is much faster then 32-bit.
-- RETURN:  integer; 0/1/2/3 (success/file1-error/file2-error/empty-key).
-- EXAMPLE: i = encode("machine2.e", "@achine2.e", "@!New sunny DAY!@" & -349)
global function encode(byte_string file1, byte_string file2, string key)
    integer fn1, fn2, len_key, n, c

    len_key = length(key)
    if len_key = 0 then
	return 3 -- empty key
    else
	fn1 = open(file1, "rb") -- "rb" - open binary file for reading
	if fn1 = -1 then
	    return 1 -- can't open file 1
	else
	    fn2 = open(file2, "wb") -- "wb" - create binary file for writing
	    if fn2 = -1 then
		close(fn1)
		return 2 -- can't open file 2
	    end if
	end if
    end if

    n = DJB_MAGIC_NUMBER

    while TRUE do
	for p = 1 to len_key do
	    c = getc(fn1)
	    if c = -1 then
		close(fn1)
		close(fn2)
		return 0 -- success
	    else
		n = remainder(n * 33 + key[p], PRIME_MAX16BIT)
		puts(fn2, xor_bits(c, n))
	    end if
	end for
    end while
end function



--bookmark: Operating System;

-- PURPOSE: return a value indicating the sign of time()
-- NOTE:    on some machines, time() can return a negative number
-- RETURN:  integer; -1 if negative, 1 if positive
function time_sign()
    while 1 do                              -- time() might return 0
	if time() > 0 then
	    return 1
	elsif time() < 0 then
	    return -1
	end if
    end while
end function

global constant
    TIME_SIGN = time_sign()                 -- sign of time() is a constant



-- PURPOSE: suspend execution for a period of time
-- NOTE:    * sleep() is in seconds; delay() uses 0.01 second resolution
--          * on DOS you can set the time() resolution with tick_rate(100);
--            on other platforms the resolution is about 100 ticks/second
-- EXAMPLE: tick_rate(100)   delay(50)   --> delay for 0.5 second
constant
    DELAY_UNIT = 0.01                       -- 0.01 second
global procedure delay(atom n)
    atom d, t

    t = time() * TIME_SIGN
    d = t + DELAY_UNIT
    while n > 0 do
	if (d <= t) or                      -- one delay unit is over?
	    (d > (t + DELAY_UNIT))          -- on DOS32 time() may reset to 0
	then
	    d = t + DELAY_UNIT
	    n -= 1
	end if
	t = time() * TIME_SIGN
    end while
end procedure



--bookmark: Machine Level Interface;

-- PURPOSE: read 2-byte signed values from memory
-- NOTE:    *local* variables (p, r, v) will speedup peek2s/peek2u a bit more
-- DETAILS: see peek4s() description, but peek2s() is for 2-byte (16-bit) value
-- RETURN:  object;
global function peek2s(object a)
    sequence p, r                           -- peek, return
    integer  v                              -- value

    if atom(a) then
	v = or_bits(peek(a), peek(a + 1) * SHx8)
	if v <= MAX_S16 then
	    return v
	else -- v is 16-bit negative number
	    return v - SHx16
	end if
    else -- sequence(a)
	p = peek4u({a[1], floor(a[2] / 2)}) -- peek 4 bytes fast
	r = repeat(0, a[2])
	for i = 1 to length(p) do
	    r[i * 2 - 1] = and_bits(p[i], MASK16)
	    r[i * 2] = floor(p[i] / SHx16)
	end for

	if remainder(a[2], 2) then          -- peek the last 2 bytes
	    a[1] += (a[2] * 2 - 2)
	    r[a[2]] = or_bits(peek(a[1]), peek(a[1] + 1) * SHx8)
	end if

	return r - (r > MAX_S16) * SHx16    -- return 16-bit signed values
    end if
end function



-- PURPOSE: read 2-byte unsigned values from memory
-- DETAILS: see peek4u() description, but peek2u() is for 2-byte (16-bit) value
-- RETURN:  object;
global function peek2u(object a)
    sequence p, r                           -- peek, return

    if atom(a) then
	return or_bits(peek(a), peek(a + 1) * SHx8)
    else -- sequence(a)
	p = peek4u({a[1], floor(a[2] / 2)}) -- peek 4 bytes fast
	r = repeat(0, a[2])
	for i = 1 to length(p) do
	    r[i * 2 - 1] = and_bits(p[i], MASK16)
	    r[i * 2] = floor(p[i] / SHx16)
	end for

	if remainder(a[2], 2) then          -- peek the last 2 bytes
	    a[1] += (a[2] * 2 - 2)
	    r[a[2]] = or_bits(peek(a[1]), peek(a[1] + 1) * SHx8)
	end if

	return r                            -- return 16-bit unsigned values
    end if
end function



-- PURPOSE: write 2-byte values into memory
-- DETAILS: see poke4() description, but poke2() is for 2-byte (16-bit) value
global procedure poke2(atom a, object x)
    if atom(x) then
	poke(a, {x, floor(x / SHx8)})
    else -- sequence(x)
	for i = 1 to length(x) - 1 by 2 do  -- poke 4 bytes fast (lower 16-bit)
	    poke4(a - 2 + i * 2, or_bits(
		and_bits(x[i], MASK16), and_bits(x[i + 1], MASK16) * SHx16)
	    )
	end for

	if remainder(length(x), 2) then     -- poke the last 2 bytes
	    poke(a - 2 + length(x) * 2, {x[$], floor(x[$] / SHx8)})
	end if
    end if
end procedure



-- PURPOSE: standard prefix string for each base (decimal has no prefix)
constant
    BIN_PREFIX2 = "0b",                     -- binary prefix 2-chars
    OCT_PREFIX2 = "0o",                     -- octal prefix 2-chars
    HEX_PREFIX1 = "#",                      -- hexa prefix 1-char
    HEX_PREFIX2 = "0x"                      -- hexa prefix 2-chars



-- PURPOSE: convert an atom or sequence to binary string
-- DETAILS: x is 32-bit atom/sequence
-- RETURN:  sequence;
-- EXAMPLE: s = bin(10)  --> s is "0b1010" in base-2
global function bin(object x)
    if atom(x) then                         -- return 32-bit unsigned(fix(x))
	x = and_bits(x, MASKS) and 1        -- x to sequence of 0's and 1's
	return BIN_PREFIX2 & x[find(1, x) + 32 * not find(1, x)..32] + '0'
    else -- [nested] sequence(x)
	for i = 1 to length(x) do
	    x[i] = bin(x[i])
	end for
	return x
    end if
end function



-- PURPOSE: convert an atom or sequence to octal string
-- DETAILS: x is 32-bit atom/sequence
-- RETURN:  sequence;
-- EXAMPLE: s = oct(10)  --> s is "0o12" in base-8
constant
    OCT_FORMAT = OCT_PREFIX2 & "%o"
global function oct(object x)
    if atom(x) then                         -- return 32-bit unsigned(fix(x))
	return sprintf(OCT_FORMAT, or_bits(x, #0))
    else -- [nested] sequence(x)
	for i = 1 to length(x) do
	    x[i] = oct(x[i])
	end for
	return x
    end if
end function



-- PURPOSE: convert an atom or sequence to unsigned decimal string
-- DETAILS: x is 32-bit atom/sequence
-- RETURN:  sequence;
-- EXAMPLE: s = dec(-10.7)  --> s is "4294967286" in base-10
constant
    DEC_FORMAT = "%d"                       -- here %d behaves like %o and %x
global function dec(object x)
    if atom(x) then
	if or_bits(x, #0) >= 0 then         -- return 32-bit unsigned(fix(x))
	    return sprintf(DEC_FORMAT, or_bits(x, #0))
	else -- or_bits(x, #0) < 0
	    return sprintf(DEC_FORMAT, or_bits(x, #0) + SHx32)
	end if
    else -- [nested] sequence(x)
	for i = 1 to length(x) do
	    x[i] = dec(x[i])
	end for
	return x
    end if
end function



-- PURPOSE: convert an atom or sequence to hexadecimal string
-- DETAILS: x is 32-bit atom/sequence
-- RETURN:  sequence;
-- EXAMPLE: s = hex(10)  --> s is "#A" in base-16
constant
    HEX_FORMAT = HEX_PREFIX1 & "%x"
global function hex(object x)
    if atom(x) then                         -- return 32-bit unsigned(fix(x))
	return sprintf(HEX_FORMAT, or_bits(x, #0))
    else -- [nested] sequence(x)
	for i = 1 to length(x) do
	    x[i] = hex(x[i])
	end for
	return x
    end if
end function



-- PURPOSE: convert a string or sequence to unsigned atom
-- DETAILS: s is string/sequence which represents unsigned atom in base
--          2/8/10/16 (can be larger then 32-bits); see example below.
-- RETURN:  object;
-- EXAMPLE:                           base          prefix  digits
--  x = int("0b1010")  --> = 10     (  2 (binary)   "0b"    "0..1"        )
--  x = int("0o12")    --> = 10     (  8 (octal)    "0o"    "0..7"        )
--  x = int("#A")      --> = 10     ( 16 (hexa)     "#"     "0..9","A..F" )
--  x = int("0xA")     --> = 10     ( 16 (hexa)     "0x"    "0..9","A..F" )
--  x = int("10")      --> = 10     ( 10 (decimal)          "0..9"        )
--
--  x = int({{"#000A"}, "0b1010", {"0o12", "10"}})  --> = {{10},10,{10,10}}
constant
    BASE_CHARS  = "0123456789ABCDEF"
global function int(sequence s)
    integer  base, pos
    sequence values
    atom n

    if length(s) and atom(s[1]) then        -- s is "string"
	   if match(BIN_PREFIX2, s) then base = 2   pos = 3
	elsif match(HEX_PREFIX1, s) then base = 16  pos = 2
	elsif match(HEX_PREFIX2, s) then base = 16  pos = 3
	elsif match(OCT_PREFIX2, s) then base = 8   pos = 3
	else  base = 10  pos = 1            -- base 10 starts with 0-9
	end if
					    -- characters to values
	if base <= 10 then                  -- 0-9 digits (faster)
	    values = s - '0'
	else                                -- 0-9, A-Z digits (slower)
	    values = s - '0' - ((s >= 'A') * 7)
	end if

	n = 0
	for i = pos to length(s) do         -- sum values
	    if find(s[i], BASE_CHARS[1..base]) then
		n += values[i] * power(base, length(s) - i)
	    else
		return 0                    -- illegal char, cannot convert
	    end if
	end for
	return n                            -- return unsigned atom

    else -- [nested] sequence(s)
	for i = 1 to length(s) do
	    s[i] = int(s[i])
	end for
	return s
    end if
end function



-- PURPOSE: convert an atom or sequence to signed number
-- DETAILS: x is 32-bit atom/sequence
--          n is bits size: 0 to 32
-- RETURN:  object;
-- EXAMPLE: x = signed({#FFFFFFFF, #FF}, 32)  --> x is {-1, 255}
--          x = signed({#FFFFFFFF, #FF},  8)  --> x is {-1,  -1}
global function signed(object x, integer n)
    if n = 32 then                          -- return signed(fix(x))
	return or_bits(x, #0)
    else -- n = 0..31
	x = and_bits(x, M_LOW[33 - n])      -- mask n lower bits (unsigned)

	-- if x > maximum-signed then convert to negative value (signed)
	return x - (x > floor(M_LOW[33 - n] / 2)) * M_SHR[33 - n]
    end if
end function



-- PURPOSE: convert an atom or sequence to unsigned number
-- DETAILS: x is 32-bit atom/sequence
--          n is bits size: 0 to 32
-- RETURN:  object;
-- EXAMPLE: x = unsigned(-1, 32)  --> x is 4294967295 (#FFFFFFFF)
--          x = unsigned(-1, 8)   --> x is 255 (#FF)
global function unsigned(object x, integer n)
    if n = 32 then                          -- return 32-bit unsigned(fix(x))
	return or_bits(x, #0) + (or_bits(x, #0) < 0) * SHx32
    else -- n = 0..31
	return and_bits(x, M_LOW[33 - n])   -- mask n lower bits (unsigned)
    end if
end function



-- PURPOSE: return range of numbers per bits
-- DETAILS: x is bits size (integer/sequence of integers): 0 to 52
-- RETURN:  sequence; {minimum_signed, maximum_signed, maximum_unsigned}
--            * (minimum_unsigned range is always 0)
-- EXAMPLE: s = range_per_bits(8)  --> s is {-128, 127, 255}
constant
    RANGE_FACTORS = {-2, 2, 1}              -- {min_s, max_s, max_u}
global function range_per_bits(fp_significand_field x)
    sequence r

    if atom(x) then
	return floor((power(2, x) - 1) / RANGE_FACTORS)
    else -- [nested] sequence(x)
	r = x
	for i = 1 to length(r) do
	    r[i] = range_per_bits(r[i])
	end for
	return r
    end if
end function



--bookmark: Misc;

-- PURPOSE: return a value according to specified condition
-- RETURN:  object;
-- EXAMPLE: constant SLASH = iif(platform() = LINUX, '/', '\\')
global function iif(atom condition, object if_true, object if_false)
    if condition then
	return if_true
    else
	return if_false
    end if
end function



-- End of file.
