Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.


Topics - luke

Pages: [1] 2
1
QB64 Discussion / Cheerio, it's been fun
« on: April 16, 2022, 07:48:13 am »
I'll still be at github.com/flukiluke, or you can email me at qb64[at]alephc.xyz

@odin apparently I don't have admin login any more, delete this account please - I shan't be needing it.

2
Programs / Linux video player
« on: January 24, 2022, 12:11:50 am »
Spriggsy has a video player that works on Windows (https://qb64forum.alephc.xyz/index.php?topic=4593.0) so naturally I had to have one that works on Linux. Internally this relies on the decoder from VLC, so you must do "sudo apt-get install libvlc-dev" or similar before trying to compile it. Also make sure to extract the files to your QB64 directory otherwise you might get errors about missing files.

Source code: 

 
Screenshot_20220124_172338.png

3
Programs / Stringless Math
« on: June 05, 2021, 11:21:04 am »
Supports integer operations of practically unlimited size. Addition, subtraction multiplication and division of positive and negative numbers are available, as is an efficient exponentiation. Lightly tested, as always.

Full list of commands and their usage:
Code: [Select]
Dim As bn_int a, b, q, r
Dim As String s
Dim As _Unsigned Long n
+----------------+------------+----------------------------+---------------------------------+-------------------------------------------------+
|   Function     | Arguments  |          Full Name         |            Operation            |                        Notes                    |
+----------------+------------+----------------------------+---------------------------------+-------------------------------------------------+
| bni_new        | a          | New                        | Initialise memory               | Must be called before use                       |
| bni_del        | a          | Delete                     | Free memory                     | Must be called when finished                    |
| bni_fromstr    | a, s       | From String                | a = Val(s)                      | Accepts optional sign                           |
| bni_tostr$     | a          | To String                  | Return Str$(a)                  | Always adds sign unless 0                       |
| bni_fromnative | a, n       | From Native                | a = n                           |                                                 |
| bni_add        | a, b, r    | Add                        | r = a + b                       |                                                 |
| bni_addu       | a, b, r    | Add Unsigned               | r = a + b, treat a & b unsigned |                                                 |
| bni_sub        | a, b, r    | Subtract                   | r = a - b                       |                                                 |
| bni_subu       | a, b, r    | Subtract Unsigned          | r = a - b, treat a & b unsigned | If a < b, r is the base complement and negative |
| bni_neg        | a          | Negate                     | a = -a                          |                                                 |
| bni_mul        | a, b, r    | Multiply                   | r = a * b                       | a, b, r must not be aliased                     |
| bni_mulp       | a, b       | Multiply in-place          | a = a * b                       |                                                 |
| bni_shl        | a, n       | Shift Left                 | a = a * 2^n                     | Requires n <= FOOT_SIZE * 8                     |
| bni_shr        | a, n       | Shift Right                | a = a / 2^n                     | Requires n <= FOOT_SIZE * 8                     |
| bni_basemul    | a, n       | Multiply by Base           | a = a * FOOT_BASE ^ n           |                                                 |
| bni_div        | a, b, q, r | Divide                     | q = a / b, remainder r          | a, b, q, r must not be aliased. r >= 0          |
| bni_divp       | a, b, r    | Divide in-place            | a = a / b, remainder r          | r >= 0                                          |
| bni_pow        | a, n, r    | Power                      | r = a^n                         | a, r must not be aliased                        |
| bni_powp       | a, n       | Power in-place             | a = a^n                         |                                                 |
| bni_tz         | a          | Test Zero                  | a = 0?                          |                                                 |
| bni_tn         | a          | Test Negative              | a < 0?                          |                                                 |
| bni_tp         | a          | Test Positive              | a > 0?                          |                                                 |
| bni_teq        | a, b       | Test Equal                 | a = b?                          |                                                 |
| bni_tlt        | a, b       | Test Less Than             | a < b?                          |                                                 |
| bni_tltu       | a, b       | Test Less Than Unsigned    | Abs(a) < Abs(b)?                |                                                 |
| bni_tgt        | a, b       | Test Greater Than          | a > b?                          |                                                 |
| bni_tgtu       | a, b       | Test Greater Than Unsigned | Abs(a) > Abs(b)?                |                                                 |
+----------------+------------+----------------------------+---------------------------------+-------------------------------------------------+

Functions and demo program:
Code: [Select]
Option _Explicit
_Define A-Z As _UNSIGNED LONG

Const FOOT_SIZE = 4
Const FOOT_MAX = 2 ^ 32 - 1
Const FOOT_BASE = 2 ^ 32

Type bn_int
    length As Long
    feet As _MEM
    sign As Integer '-1 = negative, 1 = positive, 0 = zero
End Type

Dim As bn_int a, b, c, d
bni_new a
bni_new b
bni_new c
bni_new d
bni_fromnative a, 10
bni_powp a, 2784
bni_fromstr b, "999999999999999999999998999999999999999999999999"
Dim t#
t# = Timer(0.001)
bni_div a, b, c, d
'The 115th Fibonacci number
Print Mid$(bni_tostr$(c), 2715)
Print "Time: "; Timer(0.001) - t#


'Initialise a new biginteger with value 0
Sub bni_new (a As bn_int)
    a.feet = _MemNew(FOOT_SIZE * 4) 'Start with 4 feet, somewhat arbitrarily
    If a.feet.SIZE <> FOOT_SIZE * 4 Then Error 257
    a.length = 1
    set_foot a, 0, 0
End Sub

'Delete a biginteger
Sub bni_del (a As bn_int)
    _MemFree a.feet
End Sub

'Parse string of digits into biginteger
Sub bni_fromstr (a As bn_int, original_in$)
    'We will read 7 digits at a time, because that is guaranteed to be at most a 32-bit value
    Const DIGITS_PER_ROUND = 7
    Dim i, sign, multiplier As bn_int, temp As bn_int, s$, in$
    bni_new temp
    bni_new multiplier
    bni_fromnative a, 0
    bni_fromnative multiplier, 10 ^ DIGITS_PER_ROUND
    'Remove any sign prefix if present
    If Left$(original_in$, 1) = "-" Then
        sign = -1
        in$ = Mid$(original_in$, 2)
    ElseIf Left$(original_in$, 1) = "+" Then
        sign = 1
        in$ = Mid$(original_in$, 2)
    Else
        in$ = original_in$
    End If
    For i = 1 To Len(in$) Step DIGITS_PER_ROUND
        s$ = Mid$(in$, i, DIGITS_PER_ROUND)
        bni_fromnative temp, Val(s$)
        If Len(s$) < DIGITS_PER_ROUND Then
            'This only occurs on the final loop if the number of digits is not a multiple of DIGITS_PER_ROUND
            bni_fromnative multiplier, 10 ^ Len(s$)
        End If
        bni_mulp a, multiplier
        bni_add a, temp, a
    Next i
    If bni_tz(a) Then
        a.sign = 0
    ElseIf sign = -1 Then
        a.sign = -1
    Else
        a.sign = 1
    End If
    bni_del temp
    bni_del multiplier
End Sub

'b = a
Sub bni_copy (a As bn_int, b As bn_int)
    If a.feet.OFFSET = b.feet.OFFSET Then Exit Sub
    If b.length Then bni_del b
    b.length = a.length
    b.sign = a.sign
    b.feet = _MemNew(a.feet.SIZE)
    _MemCopy a.feet, a.feet.OFFSET, a.length * FOOT_SIZE To b.feet, b.feet.OFFSET
End Sub

'Store an _unsigned long in a biginteger
Sub bni_fromnative (a As bn_int, b)
    'No need to grow because all bn_int are at least 4 feet
    a.length = 1
    a.sign = Sgn(b) 'Note: b is _unsigned so this is a zero test
    set_foot a, 0, b
End Sub

'Store an _unsigned _integer64 in a biginteger
Sub bni_fromnative_long (a As bn_int, b)
    'No need to grow because all bn_int are at least 4 feet
    set_foot a, 0, b And FOOT_MAX
    Dim t
    t = _SHR(b, FOOT_SIZE * 8)
    If t Then
        set_foot a, 1, t
        a.length = 2
    Else
        a.length = 1
    End If
    a.sign = Sgn(b)
End Sub

Function bni_tostr$ (a As bn_int)
    Dim human_base As bn_int, q As bn_int, r As bn_int, s$, d$
    bni_new human_base
    'Limited by the size of an _unsigned long
    bni_fromnative human_base, 10000000
    bni_new q
    bni_new r
    bni_copy a, q
    Do
        bni_divp q, human_base, r
        d$ = LTrim$(Str$(get_foot(r, 0)))
        If Not bni_tz(q) Then d$ = String$(7 - Len(d$), "0") + d$
        s$ = d$ + s$
    Loop While Not bni_tz(q)
    If a.sign = -1 Then
        s$ = "-" + s$
    ElseIf a.sign = 1 Then
        s$ = "+" + s$
    Else
        s$ = " " + s$
    End If
    bni_del r
    bni_del q
    bni_del human_base
    bni_tostr$ = s$
End Function

Sub bni_add (a As bn_int, b As bn_int, r As bn_int)
    If a.sign = 0 Then
        'quick return on 0
        bni_copy b, r
    ElseIf b.sign = 0 Then
        bni_copy a, r
    ElseIf a.sign = b.sign Then
        'pos + pos = pos; neg - neg = -(pos + pos)
        bni_addu a, b, r
        r.sign = a.sign
    ElseIf a.sign = -1 Then
        'neg + pos = pos - pos
        If bni_tgtu(a, b) Then
            bni_subu a, b, r
            bni_neg r
        Else
            bni_subu b, a, r
        End If
    ElseIf b.sign = -1 Then
        'pos + neg = pos - pos
        If bni_tgtu(b, a) Then
            bni_subu b, a, r
            bni_neg r
        Else
            bni_subu a, b, r
        End If
    End If
End Sub

'r = a + b for bigintegers
Sub bni_addu (a As bn_int, b As bn_int, r As bn_int)
    Dim i, carry, a_foot, b_foot, r_foot
    'The final result can be up to one foot longer than the longest addend.
    bni_grow r, max(a.length, b.length) + 1
    For i = 0 To max(a.length, b.length) - 1
        If i < a.length Then
            a_foot = get_foot(a, i)
        Else
            a_foot = 0
        End If
        If i < b.length Then
            b_foot = get_foot(b, i)
        Else
            b_foot = 0
        End If
        If carry Then
            r_foot = a_foot + b_foot + 1
            If r_foot <= a_foot Then carry = 1 Else carry = 0
        Else
            r_foot = a_foot + b_foot
            If r_foot < a_foot Then carry = 1 Else carry = 0
        End If
        set_foot r, i, r_foot
    Next i
    set_foot r, i, carry
    r.length = max(a.length, b.length) + carry
    r.sign = 1
End Sub

'r = a - b for bigintegers
Sub bni_sub (a As bn_int, b As bn_int, r As bn_int)
    If bni_tz(a) Then
        '0 - b = -b
        bni_copy b, r
        bni_neg r
    ElseIf bni_tz(b) Then
        'a - 0 = a
        bni_copy a, r
    ElseIf bni_tn(a) And bni_tn(b) Then
        'neg(a) - neg(b) = neg(a) + pos(b) = pos(b) - pos(a)
        If bni_tlt(a, b) Then
            bni_subu a, b, r
            bni_neg r
        Else
            bni_subu b, a, r
        End If
    ElseIf bni_tn(a) Then
        'neg(a) - pos(b) = -(pos(a) + pos(b))
        bni_addu a, b, r
        bni_neg r
    ElseIf bni_tn(b) Then
        'pos(a) - neg(b) = pos(a) + pos(b)
        bni_addu a, b, r
    ElseIf bni_tlt(a, b) Then
        'a - b < 0, so a - b = -(b - a)
        bni_subu b, a, r
        bni_neg r
    Else
        bni_subu a, b, r
    End If
End Sub

'r = a - b
'In general assumes a >= b. If a < b then r is negative and
'its value is the base complement of the real answer.
Sub bni_subu (a As bn_int, b As bn_int, r As bn_int)
    Dim i, borrow, a_foot, b_foot, r_foot, r_len
    bni_grow r, max(a.length, b.length)
    r_len = 1 'Don't write directly to r.length in case a = r or b = r
    For i = 0 To max(a.length, b.length) - 1
        If i < a.length Then
            a_foot = get_foot(a, i)
        Else
            a_foot = 0
        End If
        If i < b.length Then
            b_foot = get_foot(b, i)
        Else
            b_foot = 0
        End If
        r_foot = a_foot - b_foot + borrow
        If borrow Then
            r_foot = a_foot - b_foot - 1
            borrow = r_foot >= a_foot
        Else
            r_foot = a_foot - b_foot
            borrow = r_foot > a_foot
        End If
        set_foot r, i, r_foot
        If r_foot <> 0 Then r_len = i + 1
    Next i
    If r_len = 1 And get_foot(r, 0) = 0 Then r.sign = 0 Else r.sign = 1
    r.length = r_len
    If borrow Then r.sign = -1 'Turns out a < b
End Sub

'a = -a
Sub bni_neg (a As bn_int)
    a.sign = -Sgn(a.sign)
End Sub

'r = a * b for bigintegers
'Requires r <> b, see bni_mulp for alternative
'Based on Knuth 4.3.1 Algorithm M
Sub bni_mul (a As bn_int, b As bn_int, r As bn_int)
    Dim i, j, r_foot, carry
    'a_foot and b_foot are an int64 so a 64-bit multiplication is performed.
    'Otherwise a 32-bit multiplication would drop the higher bits.
    Dim a_foot As _Unsigned _Integer64, b_foot As _Unsigned _Integer64
    Dim temp As _Unsigned _Integer64
    'The final result can be up to the sum of the length of the multiplicands
    bni_grow r, a.length + b.length
    'Clear the destination; if you don't, you get a multiply & add instead.
    bni_zero r
    For i = 0 To a.length - 1
        carry = 0
        a_foot = get_foot(a, i)
        For j = 0 To b.length - 1
            b_foot = get_foot(b, j)
            r_foot = get_foot(r, i + j)
            temp = a_foot * b_foot + r_foot + carry
            set_foot r, i + j, temp And FOOT_MAX
            carry = _SHR(temp, FOOT_SIZE * 8)
        Next j
        set_foot r, i + j, carry
    Next i
    r.length = a.length + b.length
    If carry = 0 Then r.length = r.length - 1
    r.sign = a.sign * b.sign
End Sub

'a = a * b for bigintegers
Sub bni_mulp (a As bn_int, b As bn_int)
    Dim result As bn_int
    bni_new result
    bni_mul a, b, result
    bni_del a
    a = result
End Sub

'a = a * 2^b, b <= FOOT_SIZE * 8
Sub bni_shl (a As bn_int, b)
    Dim i, foot, mask, mask_shift, carry, carry2
    If b > FOOT_SIZE * 8 Then Error 5
    bni_grow a, a.length + 1
    'bitmask for bits that will be carried between feet
    mask_shift = FOOT_SIZE * 8 - b
    mask = _SHL(2 ^ b - 1, mask_shift)
    For i = 0 To a.length - 1
        foot = get_foot(a, i)
        carry = foot And mask
        foot = _SHL(foot, b) + carry2
        carry2 = _SHR(carry, mask_shift)
        set_foot a, i, foot
    Next i
    If carry2 Then
        'add a new foot
        a.length = a.length + 1
        set_foot a, a.length - 1, carry2
    End If
End Sub

'a = a / 2^b, b <= FOOT_SIZE * 8
Sub bni_shr (a As bn_int, b)
    Dim i, foot, mask, mask_shift, carry, carry2
    If b > FOOT_SIZE * 8 Then Error 5
    'bitmask for bits that will be carried between feet
    mask_shift = FOOT_SIZE * 8 - b
    mask = 2 ^ b - 1
    For i = a.length - 1 To 0 Step -1
        foot = get_foot(a, i)
        carry = foot And mask
        foot = _SHR(foot, b) + carry2
        carry2 = _SHL(carry, mask_shift)
        set_foot a, i, foot
    Next i
End Sub

'a = a * b^n
'Assumes n >= 0
Sub bni_basemul (a As bn_int, n)
    bni_grow a, a.length + n
    _MemCopy a.feet, a.feet.OFFSET, a.length * FOOT_SIZE To a.feet, a.feet.OFFSET + n * FOOT_SIZE
    _MemFill a.feet, a.feet.OFFSET, n * FOOT_SIZE, 0 As _UNSIGNED LONG
    a.length = a.length + n
End Sub

Sub bni_div (a As bn_int, b As bn_int, q As bn_int, r As bn_int)
    If bni_tz(b) Then
        Error 5
    ElseIf bni_tlt(a, b) Then
        bni_fromnative q, 0
        bni_copy a, r
    ElseIf b.length = 1 Then
        bni_div_short a, b, q, r
    Else
        bni_div_big a, b, q, r
    End If
End Sub

'a = a / b, remainder r for bigintegers
Sub bni_divp (a As bn_int, b As bn_int, r As bn_int)
    Dim result As bn_int
    bni_new result
    bni_div a, b, result, r
    bni_del a
    a = result
End Sub

'q = a / b, remainder r
'Requires b <= FOOT_MAX, gives r >= 0
Sub bni_div_short (a As bn_int, b As bn_int, q As bn_int, r As bn_int)
    Dim i, a_foot, b_foot, d
    Dim temp As _Unsigned _Integer64
    If b.length > 1 Then Error 5 'Use bni_bigdiv for bigger divisors
    bni_grow q, a.length 'This might be one foot too large, we'll deal with it at the end
    'remainder may be as big as the divisor
    bni_grow r, b.length
    bni_fromnative r, 0
    b_foot = get_foot(b, 0)
    For i = a.length - 1 To 0 Step -1
        a_foot = get_foot(a, i)
        temp = (temp * FOOT_BASE + a_foot)
        d = temp \ b_foot
        set_foot q, i, d
        temp = temp Mod b_foot
    Next i
    q.length = a.length
    'Trim leading 0
    If get_foot(q, q.length - 1) = 0 And q.length > 1 Then q.length = q.length - 1
    set_foot r, 0, temp
    r.length = 1
    If temp Then r.sign = 1 Else r.sign = 0
    If q.length = 1 And get_foot(q, 0) = 0 Then q.sign = 0 Else q.sign = a.sign * b.sign
End Sub

'q = a / b, remainder r
'Requires a >= b, b > FOOT_MAX
'Based on Knuth 4.3.1 Algorithm D
Sub bni_div_big (a As bn_int, b As bn_int, q As bn_int, r As bn_int)
    Dim d, j, n, m
    Dim As bn_int u, v, temp
    Dim As _Unsigned _Integer64 temp2, qhat, rhat
    bni_new temp
    bni_new u
    bni_new v
    bni_copy a, u
    bni_copy b, v
    n = v.length
    m = u.length - v.length
    bni_grow q, m + 1 'TODO: Shrink if too big
    d = bni_div_big_normalise(u, v)
    For j = m To 0 Step -1
        'Do not combine these next few lines, it is separate to force 64-bit calculations
        temp2 = get_foot(u, j + n)
        temp2 = temp2 * FOOT_BASE
        temp2 = temp2 + get_foot(u, j + n - 1)
        qhat = temp2 \ get_foot(v, n - 1)
        rhat = temp2 Mod get_foot(v, n - 1)
        'If qhat < foot_base then qhat * v_{n-2} will not overflow
        While qhat >= FOOT_BASE Or qhat * get_foot(v, n - 2) > FOOT_BASE * rhat + get_foot(u, j + n - 2)
            qhat = qhat - 1
            rhat = rhat + get_foot(v, n - 1)
            If rhat >= FOOT_BASE Then Exit While
        Wend
        bni_fromnative_long temp, qhat
        bni_mulp temp, v
        bni_basemul temp, j
        bni_subu u, temp, u
        If bni_tn(u) Then
            'qhat was too big, add back one divisor
            qhat = qhat - 1
            bni_copy v, temp
            bni_basemul temp, j
            bni_addu u, temp, u
            'This will cause a carry into the next digit that we don't care about
            u.length = u.length - 1
        End If
        set_foot q, j, qhat
    Next j
    q.length = m + 1
    If get_foot(q, 0) = 0 Then q.length = q.length - 1
    q.sign = a.sign * b.sign
    bni_shr u, d
    bni_copy u, r
End Sub

'Normalise a & b for division and return the normalisation constant.
Function bni_div_big_normalise (a As bn_int, b As bn_int)
    'Need high foot of b to be >= FOOT_BASE/2, which can be done by
    'bitshifting until the high bit is 1.
    Dim foot, mask, d, old_length
    foot = get_foot(b, b.length - 1)
    mask = FOOT_BASE / 2
    'Find highest 1 bit
    Do While (foot And mask) = 0
        d = d + 1
        mask = _SHR(mask, 1)
    Loop
    old_length = a.length
    bni_shl a, d
    If a.length = old_length Then
        'Algorithm requires a have a leading foot, even if it's zero
        bni_grow a, a.length + 1
        a.length = a.length + 1
        set_foot a, a.length - 1, 0
    End If
    bni_shl b, d
    bni_div_big_normalise = d
End Function

'r = a^b
'Based on Knuth 4.6.3 Algorithm A
Sub bni_pow (a As bn_int, b, r As bn_int)
    Dim n, parity
    Dim As bn_int z, t
    n = b
    bni_new t
    bni_new z
    bni_fromnative r, 1
    bni_copy a, z
    Do
        parity = n And 1
        n = n \ 2
        If parity Then
            bni_mulp r, z
            If n = 0 Then Exit Sub
        End If
        bni_mulp z, z
    Loop
End Sub

'a = a^b
Sub bni_powp (a As bn_int, b)
    Dim result As bn_int
    bni_new result
    bni_pow a, b, result
    bni_copy result, a
    bni_del result
End Sub

'a = 0?
Function bni_tz (a As bn_int)
    bni_tz = a.sign = 0
End Function

'a < 0?
Function bni_tn (a As bn_int)
    bni_tn = a.sign = -1
End Function

'a > 0?
Function bni_tp (a As bn_int)
    bni_tp = a.sign = 1
End Function

'a = b?
Function bni_teq (a As bn_int, b As bn_int)
    If a.length <> b.length Or a.sign <> b.sign Then Exit Function
    Dim i
    For i = 0 To a.length - 1
        If get_foot(a, i) <> get_foot(b, i) Then Exit Function
    Next i
    bni_teq = -1
End Function

'a < b?
Function bni_tlt (a As bn_int, b As bn_int)
    'a.sign = b.sign so just a.sign throughout
    If a.sign > b.sign Or a.sign * a.length > a.sign * b.length Then Exit Function
    If a.sign < b.sign Or a.sign * a.length < a.sign * b.length Then
        bni_tlt = -1
        Exit Function
    End If
    Dim i, cmp
    For i = a.length - 1 To 0 Step -1
        cmp = a.sign * get_foot(a, i) - a.sign * get_foot(b, i)
        If cmp < 0 Then
            bni_tlt = -1
            Exit Function
        ElseIf cmp > 0 Then
            Exit Function
        End If
    Next i
End Function

'abs(a) < abs(b)?
Function bni_tltu (a As bn_int, b As bn_int)
    If a.length > b.length Then Exit Function
    If a.length < b.length Then
        bni_tltu = -1
        Exit Function
    End If
    Dim i, cmp
    For i = a.length - 1 To 0 Step -1
        cmp = get_foot(a, i) - get_foot(b, i)
        If cmp < 0 Then
            bni_tltu = -1
            Exit Function
        ElseIf cmp > 0 Then
            Exit Function
        End If
    Next i
End Function

'a > b?
Function bni_tgt (a As bn_int, b As bn_int)
    'a.sign = b.sign so just a.sign throughout
    If a.sign < b.sign Or a.sign * a.length < a.sign * b.length Then Exit Function
    If a.sign > b.sign Or a.sign * a.length > a.sign * b.length Then
        bni_tgt = -1
        Exit Function
    End If
    Dim i, cmp
    For i = a.length - 1 To 0 Step -1
        cmp = a.sign * get_foot(a, i) - a.sign * get_foot(b, i)
        If cmp > 0 Then
            bni_tgt = -1
            Exit Function
        ElseIf cmp < 0 Then
            Exit Function
        End If
    Next i
End Function

'abs(a) > abs(b)?
Function bni_tgtu (a As bn_int, b As bn_int)
    If a.length < b.length Then Exit Function
    If a.length > b.length Then
        bni_tgtu = -1
        Exit Function
    End If
    Dim i, cmp
    For i = a.length - 1 To 0 Step -1
        cmp = get_foot(a, i) - get_foot(b, i)
        If cmp > 0 Then
            bni_tgtu = -1
            Exit Function
        ElseIf cmp < 0 Then
            Exit Function
        End If
    Next i
End Function

'Set all feet in a biginteger to 0, regardless of length
Sub bni_zero (a As bn_int)
    _MemFill a.feet, a.feet.OFFSET, a.feet.SIZE, 0 As _UNSIGNED LONG
End Sub

'Ensure a biginteger has at least min_capacity feet
Sub bni_grow (a As bn_int, min_capacity)
    Dim current_capacity As _Offset, new_capacity As _Offset, new_feet As _MEM
    current_capacity = a.feet.SIZE / FOOT_SIZE
    If current_capacity >= min_capacity Then Exit Sub
    'Get new capacity with headroom by doublings (ensuring it's always an exact number of feet)
    new_capacity = current_capacity
    While new_capacity < min_capacity
        new_capacity = new_capacity * 2
    Wend
    'Create new mem block
    new_feet = _MemNew(FOOT_SIZE * new_capacity)
    If new_feet.SIZE <> FOOT_SIZE * new_capacity Then Error 257
    'Copy old feet across
    _MemCopy a.feet, a.feet.OFFSET, a.length * FOOT_SIZE To new_feet, new_feet.OFFSET
    'And put it all in-place
    _MemFree a.feet
    a.feet = new_feet
End Sub

Function get_foot (a As bn_int, p)
    get_foot = _MemGet(a.feet, a.feet.OFFSET + p * FOOT_SIZE, _Unsigned Long)
End Function

Sub set_foot (a As bn_int, p, v)
    _MemPut a.feet, a.feet.OFFSET + p * FOOT_SIZE, v
End Sub

Function min (a, b)
    If a < b Then min = a Else min = b
End Function

Function max (a, b)
    If a < b Then max = b Else max = a
End Function

4
Programs / Test runner
« on: March 06, 2021, 07:03:34 am »
About
--------
This is a tool for running a program many times with varying input, and checking the output against expected values. In this way a program's correctness can be tested, (hopefully) making the programmer more confident of the absence of bugs. It can also help with confirming no bugs have been introduced later on, and that fixed bugs stay fixed.

This was written as part of the L-BASIC project, but is fairly generic and should work with any program that takes a filename in COMMAND$ and prints output to the console (i.e. use $CONSOLE:ONLY). Thanks to @Ed Davis for providing Windows compatibility patches.

Usage
---------
Let's say we have a simple program, save it as sample.bas and compile:
Code: QB64: [Select]
  5.     Line Input #1, l$
  6.     If InStr(l$, "Q") Then
  7.         Print "Error, found a Q"
  8.         System 1 'Exit with an error if we read a Q
  9.     End If
  10.     Print UCase$(l$)
It reads a file and prints out the contents in upper case, but requires the input not contain the letter Q: that is considered invalid input and will give an error.

Now we can write some test cases! The format should be fairly clear; the file is one or more test cases, delimited with various $commands:
Code: [Select]
$title: Letters are uppercased
the rain in spain
$expect: stdout
THE RAIN IN SPAIN
$finish

$title: Uppercased letters stay uppercased
The rain in Spain
$expect: stdout
THE RAIN IN SPAIN
$finish

$title: Multi-line input
Now is the time for
all good men to
come to the aid
of their party
$expect: stdout
NOW IS THE TIME FOR
ALL GOOD MEN TO
COME TO THE AID
OF THEIR PARTY
$finish

$title: Bad input is caught
This has a Q in it
$expect: error

    The structure is:
    • Each test begins with $title to give the test an identifiying name.
    • The contents of the input file is provided
    • $expect: stdout indicates that we should check the standard (i.e. console) output of the program
    • The expected output is provided
    • $finish indicates the end of the expected output
    If instead an error is expected, we can $expect: error. No expected output or $finish is required then.

    $expect: stdout strips leading and trailing whitespace before comparing. Use $expect: stdout_exact if you don't want that.

    Now you can run it (on Mac/Linux, use './sample'):
Code: [Select]
test-runner.exe sample.exe our-tests.txt

and get an output similar to this:
Code: [Select]
test:Letters are uppercased: OK
test:Uppercased letters stay uppercased: OK
test:Multi-line input: OK
test:Bad input is caught: OK
Total 4/4 OK in 4 seconds

If any test failed, it would show us the expected and actual output to help fix the program.

Code: QB64: [Select]
  1. 'Copyright 2020 Luke Ceddia
  2. 'SPDX-License-Identifier: Apache-2.0
  3. 'test.bas - Run test suite
  4.  
  5. DefLng A-Z
  9.  
  10. Type test_unit_t
  11.     title As String
  12.     program As String
  13.     expect As String
  14.     expected_output As String
  16. ReDim tests(0) As test_unit_t
  17. Dim active_section '0 = none, 1 = program, 2 = output
  18.  
  19. On Error GoTo ehandler
  20.  
  22.     Print "Usage: "; Command$(0); " <test program> <test files>"
  23.     System 1
  25.  
  26. If InStr(_OS$, "WINDOWS") Then
  27.     tmpdir$ = Environ$("TEMP") + "\"
  29.     tmpdir$ = "/tmp/"
  31.  
  32. testbinary$ = Command$(1)
  34. For cmdline_index = 2 To _CommandCount
  35.     Open Command$(cmdline_index) For Binary As #1
  36.     While Not EOF(1)
  37.         Line Input #1, l$
  38.         lt$ = LTrim$(l$)
  39.         If Left$(lt$, 7) = "$title:" Then
  40.             active_test = UBound(tests) + 1
  41.             ReDim _Preserve tests(1 To active_test) As test_unit_t
  42.             tests(active_test).title = basename$(Command$(cmdline_index)) + ":" + LTrim$(Mid$(lt$, 8))
  43.             active_section = 1
  44.         ElseIf Left$(lt$, 8) = "$expect:" Then
  45.             tests(active_test).expect = LTrim$(Mid$(lt$, 9))
  46.             active_section = 2
  47.         ElseIf Left$(lt$, 7) = "$finish" Then
  48.             active_section = 0
  49.         ElseIf active_section = 1 Then
  50.             tests(active_test).program = tests(active_test).program + l$ + Chr$(10)
  51.         ElseIf active_section = 2 Then
  52.             tests(active_test).expected_output = tests(active_test).expected_output + l$ + Chr$(10)
  53.         ElseIf lt$ = "" Or Left$(lt$, 1) = "#" Or Left$(lt$, 1) = "'" Then
  54.             'Blank line or comment, do nothing
  55.         Else
  56.             Print "Must start with $title"
  57.             System 1
  58.         End If
  59.     Wend
  60.     Close #1
  61. Next cmdline_index
  62.  
  63. starttime! = Timer(0.001)
  64. For active_test = 1 To UBound(tests)
  65.     'print "TITLE: "; tests(active_test).title
  66.     'print "PROGRAM"
  67.     'print "-------"
  68.     'print tests(active_test).program;
  69.     'print "EXPECT: "; tests(active_test).expect
  70.     'print tests(active_test).expected_output;
  71.  
  72.     filename$ = tmpdir$ + "test-" + rndhex$(4)
  73.     Open filename$ + ".bas" For Output As #1
  74.     Print #1, tests(active_test).program
  75.     Close #1
  76.     retcode = Shell(testbinary$ + " " + filename$ + ".bas > " + filename$ + ".output")
  77.     Print tests(active_test).title; ": ";
  78.     Select Case tests(active_test).expect
  79.         Case "error"
  80.             If retcode > 0 Then
  81.                 Print "OK"
  82.                 successes = successes + 1
  83.             Else
  84.                 Print "Failed, expected error but ran successfully."
  85.             End If
  86.         Case "stdout", "stdout_exact"
  87.             Open filename$ + ".output" For Binary As #1
  88.             actual_output$ = Space$(LOF(1))
  89.             Get #1, , actual_output$
  90.             Close #1
  91.             actual_output$ = remove_char$(actual_output$, Chr$(13))
  92.             tests(active_test).expected_output = remove_char$(tests(active_test).expected_output, Chr$(13))
  93.  
  94.             If tests(active_test).expect <> "stdout_exact" Then
  95.                 actual_output$ = strip$(actual_output$)
  96.                 tests(active_test).expected_output = strip$(tests(active_test).expected_output)
  97.             End If
  98.  
  99.             If retcode > 0 Then
  100.                 Print "Failed with error, output was: "; actual_output$
  101.             ElseIf actual_output$ = tests(active_test).expected_output Then
  102.                 Print "OK"
  103.                 successes = successes + 1
  104.             Else
  105.                 Print "Failed!"
  106.                 Print "Expected: "; tests(active_test).expected_output;
  107.                 Print "  Actual: "; actual_output$;
  108.             End If
  109.         Case Else
  110.             Print "Unknown condition"
  111.     End Select
  112.     Kill filename$ + ".bas"
  113.     Kill filename$ + ".output"
  114. Next active_test
  115. endtime! = Timer(0.001)
  116.  
  117. Print "Total"; Str$(successes); "/"; LTrim$(Str$(UBound(tests))); " OK in"; Int((endtime! - starttime!) * 10) / 10; "seconds"
  118.  
  120.  
  121. ehandler:
  122. Print "Error"; Err; "on line"; _ErrorLine
  124.  
  125. Function basename$ (path$)
  126.     dot = _InStrRev(path$, ".")
  127.     slash = _InStrRev(path$, "/")
  128.     basename$ = Mid$(path$, slash + 1, dot - slash - 1)
  130.  
  131. Function rndhex$ (length)
  132.     For i = 1 To length
  133.         result$ = result$ + Hex$(Int(Rnd * 256))
  134.     Next i
  135.     rndhex$ = result$
  137.  
  138. 'Courtesy Ed Davis
  139. Function remove_char$ (s$, c$)
  140.     Dim s2$
  141.     Dim i As Integer
  142.  
  143.     s2$ = ""
  144.     For i = 1 To Len(s$)
  145.         If Mid$(s$, i, 1) <> c$ Then
  146.             s2$ = s2$ + Mid$(s$, i, 1)
  147.         End If
  148.     Next
  149.     remove_char$ = s2$
  151.  
  152. Function strip$ (s$)
  153.     start = 0
  154.     whitespace$ = Chr$(10) + Chr$(9) + Chr$(32)
  155.     Do
  156.         start = start + 1
  157.     Loop While InStr(whitespace$, Mid$(s$, start, 1))
  158.     finish = Len(s$) + 1
  159.     Do
  160.         finish = finish - 1
  161.     Loop While InStr(whitespace$, Mid$(s$, finish, 1))
  162.     strip$ = Mid$(s$, start, finish - start + 1)
  164.  

5
QB64 Discussion / $IF VERSION THEN $ERROR
« on: January 27, 2021, 06:53:44 am »
QB64 1.5 will feature a new metacommand and a new pre-compiler value. The below example shows them both:
Code: [Select]
$IF VERSION < 1.5 THEN
    $ERROR Requires QB64 version 1.5 or greater
$END IF

VERSION evaluates to the QB64 compiler version. $ERROR can be used in a $IF block to give a compilation error with a helpful message to the user if the programmer knows they will be using new features. You could also use $ERROR if you program is Windows-only or Linux-only, for instance. VERSION could also be used to implement a section of code two different ways if you're trying to work around differences in behaviour in QB64 versions.

See wiki for further details.

6
QB64 Discussion / SUB error handlers
« on: January 15, 2021, 08:22:38 am »
As We All Know(tm), ON ERROR can only go to a handler in the main program, not in a subroutine. However, the QB45 manual page for ON ERROR has this at the bottom:
Quote
SUB and FUNCTION procedures and DEF FN functions can contain their own
error handlers. The error handler must be located after the last
executable statement but before the END SUB, END FUNCTION, or END DEF
statement. To keep the error handler from executing when there is no
error, the procedure or function must terminate with an EXIT SUB, EXIT
FUNCTION, or EXIT DEF statement immediately ahead of the error
handler, as in the following example:

SUB InitializeMatrix (var1, var2, var3, var4)
      .
      .
      .
   ON ERR GOTO ErrorHandler
      .
      .
      .
   EXIT SUB

   ErrorHandler:
      .
      .
      .
   RETURN

END SUB
Which seems to suggest you can, but I couldn't get it to do anything in QB45.

The really strage part is that it's ON ERR, not ON ERROR, which seems to be more akin to the general ON ... GOTO ... which would take a list of line numbers and branch depending on the value of an expression. That at least explains why the example is syntactically correct. And it's terminated with RETURN, which is usually paired with GOSUB (I would expect to see RESUME in an error handler).

So were the manual writers at Microsoft smoking something when they did this page?

7
QB64 Discussion / Please log your input handling complaints here
« on: January 12, 2021, 10:55:12 pm »
I'm planning to do a pass through the input handling code (mainly keyboard) soon and I'd like to kill a few birds with one stone. I'm vaguely aware there are several issues with input handling, but the only one I've got a definite record of is https://github.com/QB64Team/qb64/issues/101

If you could post any input bugs you've found below, I'll collate them and attempt to work through them together.

Please keep this to reproducible examples; code demonstrating a problem is much easier for me to deal with than paragraphs of prose.

8
QB64 Discussion / Relative mouse movement repaired (I hope)
« on: January 11, 2021, 10:08:05 am »
The _MOUSEMOVEMENTX and _MOUSEMOVEMENTY commands should now function correctly in both 32 and 64 bit windows, as of development build 5a300c7.

On windows the mouse will be read even when it is outside the window (which I'm led to believe is these commands' major advantage), Linux unfortunately will only provide data when the mouse is over the window.

9
QB64 Discussion / Anyone got a hashing function?
« on: July 16, 2020, 09:33:11 am »
I need to take blocks of text and produce an MD5/SHA1 hash - I actually don't really care about what algorithm it is, I'm just using it for giving unique names for things.

I'd write my own but I'm lazy and I figure one of you would have one on hand.

10
QB64 Discussion / New command: OPTION _EXPLICITARRAY
« on: July 15, 2020, 07:35:07 am »
We're all (hopefully) familiar with OPTION _EXPLICIT, which demands all variables be DIMmed before use. We now also have OPTION _EXPLICITARRAY, which is similar but only applies to arrays. This means you need to DIM your arrays, but not your regular variables. Example:
Code: [Select]
OPTION _EXPLICITARRAY
x = 1 'This is fine, it's not an array so not affected
y(2) = 3 'This now generates an error

DIM z(5)
z(2) = 3 'All good again, we've explicitly DIMmed our array

Available in the development builds.

11
Programs / The L-BASIC Interpreter
« on: July 04, 2020, 11:09:05 am »
I've been fiddling away on a BASIC interpreter (because it's basically a rite of passage to write one yourself, right?) for a little while and thought I'd at least start a forum thread for it. It's primarily interactive, so you can just hit F5 in the IDE to launch it and start typing commands. You can also drag-and-drop source code files onto it (or give a command line argument) to run a file.

Latest source attached to this post. Project also at https://github.com/flukiluke/L-BASIC for the interested. There will be bugs, feel free to yell at me if you get an error with something that's on the "working" list.

What's different:
  • Variables with the same name but different types are an error, not different variables
  • No _ for INTEGER64
  • It's called QUAD instead of _FLOAT
  • $include should be written without a comment character or REM

What's working:
  • Apostrophe comments and REM
  • Line joining with :
  • Variable assignment
  • Arrays: multi-dimensional, arrays of UDTs.
  • Array resizing, including _PRESERVE
  • shared variables
  • UDTs
  • Optional arguments to user-defined functions
  • SUBs and FUNCTIONs, including recursive calls and pass by reference
  • Data types INTEGER %, LONG &, INTEGER64 &&, SINGLE !, DOUBLE #, QUAD ## and STRING $
  • Addition, subtraction, multiplication, division, integer division, exponentiation, negation, MOD, AND, OR, NOT, XOR, IMP, EQV, =, <>, <, >, <=, >=
  • PRINT and ?, handles ; and , as variable separators
  • DO, WHILE and FOR loops
  • IF THEN ELSEIF ELSE END IF (single and multi-line versions)
  • SELECT CASE
  • ABS, ASC (function), _ATAN2, ATN, _AUTODISPLAY
  • BEEP, _BLUE32
  • C* rounding functions, CALL, CHDIR, CHR$, CIRCLE, CLOSE, CLS, COLOR, COMMAND$, _COMMANDCOUNT, CONST, COS, CSRLIN, CV* functions
  • DATE$ (function), DEFINT and friends, _DEFINE, _DEFLATE, _DELAY, _DEST (statement), _DEST (function), DIM, _DISPLAY (statement), DRAW
  • END, ENVIRON$ (function), EOF, ERASE (one variant), EXIT, EXP
  • FILES, FIX, _FONTHEIGHT, _FONTWIDTH, FREEFILE
  • GET (file I/O), GOTO (line numbers only, no line labels), _GREEN32
  • _HEIGHT, HEX
  • _INFLATE, INKEY$, INPUT (command), INPUT$ (function), INSTR, INT
  • _KEYCLEAR, _KEYDOWN, _KEYHIT, KILL
  • LBOUND, LCASE, LEFT$, LEN, _LIMIT, LINE, LINE INPUT, _LOADIMAGE, LOCATE, LOF, LOG, LTRIM$
  • MID$ (function), _MOUSEBUTTON, _MOUSEINPUT, _MOUSEMOVEMENTX, _MOUSEMOVEMENTY, _MOUSEX, _MOUSEY
  • OPEN, OPTION _EXPLICIT
  • PAINT, _PI, PLAY, POINT, PRINT, _PRINTSTRING, _PRINTWIDTH, PSET, PUT (file I/O), _PUTIMAGE
  • RANDOMIZE, RIGHT$, RMDIR, RND, _RED32, _RGB, _RGB32, RTRIM$
  • SCREEN (statement), SGN, SIN, SLEEP, SOUND, _SOURCE (statement), _SOURCE (function), SPACE, SQR, STATIC (statement), STR, _STRCMP, _STRICMP, SWAP, SYSTEM
  • TAN, TIME$ (function), TIMER, _TITLE (statement), _TITLE$ (function), _TRIM$
  • UBOUND, UCASE
  • VAL
  • _WHEEL, _WIDTH

What's not working:
  • Arrays in UDTs
  • NEXT with multiple variables on the same line 'NEXT i, j'
  • Line labels
  • GOSUB
  • Error handling
  • Events
  • Line continuation with _
  • Everything else

12
Programs / The stable orbits game
« on: March 17, 2020, 08:25:58 am »
Of course, "game" is a bit of a stretch. I vaguely recall someone (probably @STxAxTIC ) mentioned Newtonian simulations a little while back on discord, then I came across this while looking for something else and figured I'd post it.

It's a pretty simple n-body simulator. I write this a while back, and I don't even remember if the physics is correct. I suppose it shows a use of the WINDOW command?

Set the first line to FALSE to ignore collisions.
Code: QB64: [Select]
  1. $LET COLLISIONS = TRUE
  2. TYPE particle_t
  3.     'position
  4.     px AS SINGLE
  5.     py AS SINGLE
  6.     'velocity
  7.     vx AS SINGLE
  8.     vy AS SINGLE
  9.     'mass
  10.     m AS SINGLE
  11.     'colour
  12.     c AS _UNSIGNED LONG
  14. DIM initial(0 TO 3) AS particle_t
  15. DIM particles(0 TO 3) AS particle_t
  16.  
  17.  
  18. initial(0).px = 320
  19. initial(0).py = 320
  20. initial(0).m = 100000
  21.  
  22. initial(0).c = _RGB32(255, 255, 255)
  23.  
  24. initial(1).px = 320
  25. initial(1).py = 130
  26. initial(1).m = 10
  27. initial(1).vx = 2.0
  28. initial(1).c = _RGB32(255, 0, 0)
  29.  
  30. initial(2).px = 320
  31. initial(2).py = 480
  32. initial(2).m = 20
  33. initial(2).vx = -2
  34. initial(2).c = _RGB32(0, 255, 0)
  35.  
  36. initial(3).px = 10
  37. initial(3).py = 0
  38. initial(3).m = 2
  39. initial(3).vx = 1.5
  40. initial(3).c = _RGB32(0, 0, 255)
  41. G = 0.01
  42. gscreen = _NEWIMAGE(640, 640, 32)
  43.  
  44. start:
  47. PRINT SPACE$(40 - 22 / 2); "The Stable Orbits Game"
  48. PRINT "Four bodies exist in 2D space. Your challenge is to define parameters for them"
  49. PRINT "(mass, initial position and initial velocity) so that they can orbit for as long"
  50. PRINT "as possible before they collide. You can also specify a value for G, the"
  51. PRINT "gravitational constant."
  52. PRINT "Use the arrow keys to move between the boxes, and numeric keys and the enter key"
  53. PRINT "to input values."
  54. PRINT "Press C to copy setup to clipboard, and P to paste setup from clipboard."
  55. PRINT "Press F5 to run the simulation, and Escape to exit simulation. Good luck!"
  56.  
  57. GOSUB print_table
  58.  
  59. selx = 17
  60. sely = 13
  62.     FOR p = 0 TO 3
  63.         _PRINTSTRING (16 * p + 17, 13), STR$(initial(p).px)
  64.         _PRINTSTRING (16 * p + 17, 14), STR$(initial(p).py)
  65.         _PRINTSTRING (16 * p + 17, 15), STR$(initial(p).vx)
  66.         _PRINTSTRING (16 * p + 17, 16), STR$(initial(p).vy)
  67.         _PRINTSTRING (16 * p + 17, 17), STR$(initial(p).m)
  68.     NEXT p
  69.     _PRINTSTRING (24, 19), STR$(G)
  70.     LOCATE sely, selx, 1
  71.     k$ = ""
  72.     DO
  73.         k = _KEYHIT
  74.         _LIMIT 20
  75.     LOOP UNTIL k > 0
  76.     SELECT CASE k
  77.         CASE 18432 'Up
  78.             IF seld > 0 THEN seld = seld - 1
  79.         CASE 19200 'Left
  80.             IF selp > 0 THEN selp = selp - 1
  81.         CASE 20480 'Down
  82.             IF seld < 5 THEN seld = seld + 1
  83.         CASE 19712 'Right
  84.             IF selp < 3 THEN selp = selp + 1
  85.         CASE 16128 'F5
  86.             GOTO sim
  87.         CASE 67, 99 'C
  88.             FOR p = 0 TO 3
  89.                 summary$ = summary$ + MKS$(initial(p).px) + MKS$(initial(p).py) + MKS$(initial(p).vx) + MKS$(initial(p).vy) + MKS$(initial(p).m)
  90.             NEXT p
  91.             summary$ = summary$ + MKS$(G)
  92.             _CLIPBOARD$ = encodeBASE64$(summary$)
  93.         CASE 80, 112 'P
  94.             summary$ = decodeBASE64$(_CLIPBOARD$)
  95.             FOR p = 0 TO 3
  96.                 initial(p).px = CVS(MID$(summary$, p * 20 + 1, 4))
  97.                 initial(p).py = CVS(MID$(summary$, p * 20 + 5, 4))
  98.                 initial(p).vx = CVS(MID$(summary$, p * 20 + 9, 4))
  99.                 initial(p).vy = CVS(MID$(summary$, p * 20 + 13, 4))
  100.                 initial(p).m = CVS(MID$(summary$, p * 20 + 17, 4))
  101.                 G = CVS(RIGHT$(summary$, 4))
  102.             NEXT p
  103.  
  104.         CASE ELSE
  105.             _PRINTSTRING (selx, sely), SPACE$(15)
  106.             LOCATE , POS(0) + 1
  107.             INPUT "", newval
  108.             _KEYCLEAR
  109.             _PRINTSTRING (selx, sely), SPACE$(15)
  110.  
  111.             IF seld = 5 THEN
  112.                 G = newval
  113.             ELSE
  114.                 SELECT CASE seld
  115.                     CASE 0: initial(selp).px = newval
  116.                     CASE 1: initial(selp).py = newval
  117.                     CASE 2: initial(selp).vx = newval
  118.                     CASE 3: initial(selp).vy = newval
  119.                     CASE 4: initial(selp).m = newval
  120.                 END SELECT
  121.             END IF
  122.     END SELECT
  123.     IF seld = 5 THEN
  124.         selx = 24
  125.         sely = 19
  126.     ELSE
  127.         selx = 16 * selp + 17
  128.         sely = 13 + seld
  129.     END IF
  131.  
  132.  
  133. sim:
  134. SCREEN gscreen
  135.  
  136. FOR p = 0 TO 3
  137.     particles(p) = initial(p)
  138.     'sanity check
  139.     IF particles(p).m <= 0 THEN
  140.         PRINT "Simulation error: particle"; p; "has non-positive mass."
  141.         SLEEP
  142.         _KEYCLEAR
  143.         GOTO start
  144.     END IF
  146.  
  147.  
  150.         CASE -27
  151.             GOSUB reset_sim
  152.             GOTO start
  153.  
  154.         CASE 16896
  155.             SCREEN 0
  156.             _AUTODISPLAY
  157.             PRINT SPACE$(40 - 12 / 2); "Current data"
  158.             PRINT "Press any key to return to simulation"
  159.             PRINT
  160.             GOSUB print_table
  161.             FOR p = 0 TO 3
  162.                 _PRINTSTRING (16 * p + 17, 7), STR$(particles(p).px)
  163.                 _PRINTSTRING (16 * p + 17, 8), STR$(particles(p).py)
  164.                 _PRINTSTRING (16 * p + 17, 9), STR$(particles(p).vx)
  165.                 _PRINTSTRING (16 * p + 17, 10), STR$(particles(p).vy)
  166.                 _PRINTSTRING (16 * p + 17, 11), STR$(particles(p).m)
  167.             NEXT p
  168.             _PRINTSTRING (24, 13), STR$(G)
  169.  
  170.             SLEEP
  171.             SCREEN gscreen
  172.     END SELECT
  173.     CLS
  174.     FOR p = 0 TO UBOUND(particles)
  175.         ax = 0
  176.         ay = 0
  177.         FOR p2 = 0 TO UBOUND(particles)
  178.             IF p2 <> p THEN 'avoid calculating when both particles are the same one
  179.                 'magnitude of force
  180.                 f = G * particles(p2).m * particles(p).m / ((particles(p2).px - particles(p).px) ^ 2 + (particles(p2).py - particles(p).py) ^ 2)
  181.                 'direction, taking p as reference particle
  182.                 ang = _ATAN2(-(particles(p2).py - particles(p).py), (particles(p2).px - particles(p).px))
  183.                 ax = ax + f * COS(ang) / particles(p).m
  184.                 ay = ay - f * SIN(ang) / particles(p).m
  185.             END IF
  186.         NEXT p2
  187.         'we now have net accelerations
  188.         particles(p).vx = particles(p).vx + ax
  189.         particles(p).vy = particles(p).vy + ay
  190.         particles(p).px = particles(p).px + particles(p).vx
  191.         particles(p).py = particles(p).py + particles(p).vy
  192.         IF particles(p).px < xmin THEN xmin = particles(p).px
  193.         IF particles(p).px > xmax THEN xmax = particles(p).px
  194.         IF particles(p).py < ymin THEN ymin = particles(p).py
  195.         IF particles(p).py > ymax THEN ymax = particles(p).py
  196.  
  197.         CIRCLE (particles(p).px, particles(p).py), 10, particles(p).c
  198.         $IF COLLISIONS = TRUE THEN
  199.             'check for collisions
  200.             p2 = 0
  201.             FOR p2 = 0 TO UBOUND(particles)
  202.                 IF p <> p2 THEN
  203.                     IF _HYPOT(particles(p2).px - particles(p).px, particles(p2).py - particles(p).py) < 20 THEN
  204.                         collision& = -1
  205.                         collisionx = particles(p).px + (particles(p2).px - particles(p).px) / 2
  206.                         collisiony = particles(p).py + (particles(p2).py - particles(p).py) / 2
  207.  
  208.                     END IF
  209.                 END IF
  210.             NEXT p2
  211.         $END IF
  212.     NEXT p
  213.  
  214.     WINDOW SCREEN(xmin - 20, ymin - 20)-(xmax + 20, ymax + 20)
  215.     t&& = t&& + 1
  216.     _PRINTSTRING (1, 1), "Time:" + STR$(t&&) + "   Escape: Abort      F8: View properties"
  217.  
  218.     $IF COLLISIONS = TRUE THEN
  219.         IF collision& THEN
  220.             CIRCLE (collisionx, collisiony), 40, _RGB32(255, 0, 0)
  221.             _DISPLAY
  222.             SLEEP
  223.             GOSUB reset_sim
  224.             GOTO start
  225.         END IF
  226.     $END IF
  227.  
  228.     _DISPLAY
  229.     _LIMIT 50
  231.  
  232.  
  233. reset_sim:
  234. t&& = 0
  235. collision& = 0
  236. xmin = 0
  237. ymin = 0
  238. xmax = 0
  239. ymax = 0
  240. active_obj = 0
  243.  
  244. print_table:
  245. PRINT "+--------------+---------------+---------------+---------------+---------------+"
  246. PRINT "| Body colour: |     White     |      Red      |      Blue     |     Green     |"
  247. PRINT "+--------------+---------------+---------------+---------------+---------------+"
  248. PRINT "|  Position X  |               |               |               |               |"
  249. PRINT "|  Position Y  |               |               |               |               |"
  250. PRINT "|  Velocity X  |               |               |               |               |"
  251. PRINT "|  Velocity Y  |               |               |               |               |"
  252. PRINT "|     Mass     |               |               |               |               |"
  253. PRINT "+--------------+---------------+---------------+---------------+---------------+"
  254. PRINT "Gravitational Constant: "
  256.  
  257. '-------------------------------------------------------------------------
  258. ' BASE64 Encoding / Decoding
  259. ' Original VBDOS Version by G. Balla, 1996 (Public Domain)
  260. ' QB 4.5 Conversion by Marc van den Dikkenberg, 1999
  261. ' From [http://www.qb45.com/download.php?id=1198], trimmed & optimized(no longer runs in QBASIC!) & updated (INTEGER->LONG for larger strings) & disabled input stream concatenation option --Galleon 2013
  262. '--------------------------------------------------------------------------
  263. DIM SHARED icChopMask AS LONG ' Constant 8-bit mask (Faster than using string constants)
  264. DIM SHARED icBitShift AS LONG ' Constant shift mask (Faster than using string constants)
  265. DIM SHARED icStartMask AS LONG ' Initial mask value  (Faster than using string constants)
  266. DIM SHARED iRollOver AS LONG ' Decoded Roll over value
  267. DIM SHARED iHighMask AS LONG ' Mask high bits of each char
  268. DIM SHARED iShift AS LONG ' Multiplier shift value
  269. DIM SHARED iLowShift AS LONG ' Mask low bits of each char
  270. DIM SHARED szAlphabet AS STRING ' Decode/Encode Lookup Table
  271. DIM SHARED szTemp AS STRING ' Working string
  272.  
  273. FUNCTION decodeBASE64$ (szEncoded AS STRING)
  274.     'iEndOfText AS LONG ''''removed from params
  275.     ' Initialize 2nd encoding pass lookup dictionary
  276.     szAlphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  277.     ' Initialize Constants
  278.     icChopMask = 255
  279.     icBitShift = 4
  280.     icStartMask = &H10
  281.     ' Initialize Masks
  282.     iShift = icBitShift
  283.     iLowShift = 0
  284.     iRollOver = 0
  285.     iHighMask = -1
  286.     iEndOfText = -1 ''''new
  287.     ' Create variables
  288.     DIM iPtr AS LONG
  289.     DIM iChar AS LONG
  290.     DIM iCounter AS LONG
  291.     ' Check if empty decoded string.
  292.     IF LEN(szEncoded) = 0 THEN
  293.         decodeBASE64$ = ""
  294.         EXIT FUNCTION
  295.     END IF
  296.     ' Initialize working string
  297.     szTemp = SPACE$(LEN(szEncoded) + 10) ''''changed
  298.     szTempLen = 0 ''''new
  299.     ' Begin Decoding
  300.     FOR iCounter = 1 TO LEN(szEncoded)
  301.         ' Get next alphabet
  302.         iChar = ASC(szEncoded, iCounter) ''''changed
  303.         ' Get Decoded value
  304.         iPtr = INSTR(szAlphabet, CHR$(iChar)) - 1
  305.         ' Check if character is valid
  306.         IF iPtr >= 0 THEN
  307.             ' Char is valid, process it
  308.             IF iShift = icBitShift THEN
  309.                 ' 1st char in block of 4, keep high part of character
  310.                 iRollOver = (iPtr * iShift) AND icChopMask
  311.                 ' Reset masks for next character
  312.                 iHighMask = &H30
  313.                 iLowShift = icStartMask
  314.                 iShift = icStartMask
  315.             ELSE
  316.                 ' Start saving decoded character
  317.                 szTempLen = szTempLen + 1: ASC(szTemp, szTempLen) = iRollOver OR ((iPtr AND iHighMask) / iLowShift) ''''changed
  318.                 ' Calculate next mask and shift values
  319.                 iRollOver = (iPtr * iShift) AND icChopMask
  320.                 iShift = iShift * icBitShift
  321.                 iHighMask = (iHighMask \ icBitShift) OR &H30
  322.                 iLowShift = iLowShift / icBitShift
  323.                 IF iShift > 256 THEN
  324.                     iShift = icBitShift
  325.                     iLowShift = 0
  326.                 END IF
  327.             END IF
  328.         END IF
  329.     NEXT
  330.     ' Concat last character if required
  331.     IF (iShift > icBitShift AND iShift < 256) THEN
  332.         ' Character remaining in    iRollOver
  333.         IF iEndOfText THEN
  334.             ' Last string to decode in file
  335.             szTempLen = szTempLen + 1: ASC(szTemp, szTempLen) = iRollOver ''''changed
  336.         END IF
  337.     END IF
  338.     ' Exit wth decoded string
  339.     decodeBASE64$ = LEFT$(szTemp, szTempLen) ''''changed
  341.  
  342. FUNCTION encodeBASE64$ (szUnEncoded AS STRING)
  343.     ' Create variables
  344.     DIM icLowFill AS LONG
  345.     DIM iChar AS LONG
  346.     DIM iLowMask AS LONG
  347.     DIM iPtr AS LONG
  348.     DIM iCounter AS LONG
  349.     ' Check if empty decoded string.
  350.     IF LEN(szUnEncoded) = 0 THEN
  351.         encodeBASE64$ = ""
  352.         EXIT FUNCTION
  353.     END IF
  354.     ' Initialize lookup dictionary and constants
  355.     szAlphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  356.     icBitShift = 4
  357.     icChopMask = 255
  358.     icLowFill = 3
  359.     ' Initialize Masks
  360.     szTemp = SPACE$(LEN(szUnEncoded) * 2 + 10) ''''changed
  361.     szTempLen = 0 ''''new
  362.     iHighMask = &HFC
  363.     iLowMask = &H3
  364.     iShift = &H10
  365.     iRollOver = 0
  366.     ' Begin Encoding process
  367.     FOR iCounter = 1 TO LEN(szUnEncoded)
  368.         ' Fetch ascii character in decoded string
  369.         iChar = ASC(szUnEncoded, iCounter) ''''changed
  370.         ' Calculate Alphabet lookup pointer
  371.         iPtr = ((iChar AND iHighMask) \ (iLowMask + 1)) OR iRollOver
  372.         ' Roll bit patterns
  373.         iRollOver = (iChar AND iLowMask) * iShift
  374.         ' Concatenate encoded character to working encoded string
  375.         szTempLen = szTempLen + 1: ASC(szTemp, szTempLen) = ASC(szAlphabet, iPtr + 1) ''''changed
  376.         ' Adjust masks
  377.         iHighMask = (iHighMask * icBitShift) AND icChopMask
  378.         iLowMask = iLowMask * icBitShift + icLowFill
  379.         iShift = iShift \ icBitShift
  380.         ' If last character in block, concat last RollOver and
  381.         '   reset masks
  382.         IF iHighMask = 0 THEN
  383.             szTempLen = szTempLen + 1: ASC(szTemp, szTempLen) = ASC(szAlphabet, iRollOver + 1) ''''changed
  384.             iRollOver = 0
  385.             iHighMask = &HFC
  386.             iLowMask = &H3
  387.             iShift = &H10
  388.         END IF
  389.     NEXT iCounter
  390.     ' If RollOver remains, concat it to the working string
  391.     IF iShift < &H10 THEN
  392.         szTempLen = szTempLen + 1: ASC(szTemp, szTempLen) = ASC(szAlphabet, iRollOver + 1) ''''changed
  393.     END IF
  394.     szTemp = LEFT$(szTemp, szTempLen) ''''new
  395.     ' Pad encoded string with required '=' pad characters
  396.     iPtr = (LEN(szTemp) MOD 4)
  397.     IF iPtr THEN szTemp = szTemp + STRING$(4 - iPtr, "=")
  398.     ' Return encoded string
  399.     encodeBASE64$ = szTemp
  401.  

13
Programs / HTTP 1.1 compliant web server (work in progress)
« on: January 01, 2020, 07:17:54 am »
There seemed to be lots of chat about web servers over on Discord, so I thought I'd throw my hat in the ring. This is an attempt at writing a web server that fully supports HTTP 1.1 (the most common version). It is very basic at the moment, and does not support most things - but it can do basic file serving.

By default it runs on port 8080 (change the CONST PORT line to change this) and will serve any files from the directory it's running in. For example, if you run it from your QB64 directory you can put http://localhost:8080/source/qb64.bas into your browser and it'll get the QB64 source file from your hard drive.

For the most recent version, see https://github.com/flukiluke/http-toy

14
Programs / A (simpler) timestamp function
« on: August 30, 2019, 09:07:32 am »
Steve has a function here that generates a timestamp based on the Unix timestamp, seconds since 1/1/1970. However, it's rather... complex, and doesn't take into account the silliness that is daylight saving.

Here's a simpler one. Works on both Windows & Linux, returns the Unix timestamp.

Code: [Select]
DECLARE LIBRARY
    FUNCTION time& (BYVAL null&)
END DECLARE

PRINT timestamp

FUNCTION timestamp&
    timestamp& = time&(0)
END FUNCTION

15
Programs / Split and join strings
« on: February 15, 2019, 04:11:07 am »
Given a string of words separated by spaces (or any other character), splits it into an array of the words. I've no doubt many people have written a version of this over the years and no doubt there's a million ways to do it, but I thought I'd put mine here so we have at least one version. There's also a join function that does the opposite array -> single string.

Code is hopefully reasonably self explanatory with comments and a little demo. Note, this is akin to Python/JavaScript split/join, PHP explode/implode.

Code: QB64: [Select]
  1. redim words$(0)
  2.  
  3. original$ = "The rain   in Spain  "
  4. print "Original string: "; original$
  6.  
  7. split original$, " ", words$()
  8.  
  9. print "Words:"
  10. for i = lbound(words$) to ubound(words$)
  11.     print words$(i)
  14.  
  15. print "Joined with commas: ";join$(words$(), ",")
  16.  
  17. 'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
  18. 'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
  19. '
  20. 'delimiter$ must be one character long.
  21. 'result$() must have been REDIMmed previously.
  22. sub split(in$, delimiter$, result$())
  23.     redim result$(-1)
  24.     start = 1
  25.     do
  26.         while mid$(in$, start, 1) = delimiter$
  27.             start = start + 1
  28.             if start > len(in$) then exit sub
  29.         wend
  30.         finish = instr(start, in$, delimiter$)
  31.         if finish = 0 then finish = len(in$) + 1
  32.         redim _preserve result$(0 to ubound(result$) + 1)
  33.         result$(ubound(result$)) = mid$(in$, start, finish - start)
  34.         start = finish + 1
  35.     loop while start <= len(in$)
  37.  
  38. 'Combine all elements of in$() into a single string with delimiter$ separating the elements.
  39. function join$(in$(), delimiter$)
  40.     result$ = in$(lbound(in$))
  41.     for i = lbound(in$) + 1 to ubound(in$)
  42.         result$ = result$ + delimiter$ + in$(i)
  43.     next i
  44.     join$ = result$

Pages: [1] 2