A Collaboration: Mechanical Odometer algorithm

[TDarcos]

My son's coding of a locomotive powertrain modeling ap gave me the inspiration to try this one. A mechanical multi-wheel style counter. It's something of a father/son collaboration and was a fun head scratcher. I was pleased to see it would run in reverse too, except that it didn't like going below zero much. That would have to be trapped outside the SUB. Enjoy.

I have made an adjustment to "fix" the rollover function so it handles rolling back below 0 or above 999999. These keys were added:
* Up - Odometer rolls forward (increment)
* End - Odometer stops
* Down - Odometer rolls backward (decrement)
* Insert - Reset odometer to 999999.5
* Delete - Reset odometer to 0.5
* Escape still quits

It is shown below and for easy downloading is attached to this message.

I wish I could take credit for the smooth rollover below 0 or above 999999, but that is thanks to OldMoses' great work!

Code: (Select All)

'Odometer.bas  Richard & Erik Wessel

'  Added up/down to change odometer direction and

'  to adjust for rollover - Paul Robinson 2025-04-16



'  Functions:

'  Key UP  - Odometer increases

'  Key END  - Odometer stops

'  Key DOWN - Odometer decreases

'  Insert - Reset odometer to 999999.5

'  Delete - Reset odometer to 0.5

'  Escape - quits





$Color:32

Option _Explicit



Screen _NewImage(256, 216, 32)

Dim Shared As Long slot, wheel, wheel10th

Dim As Double miles, advance

Const up = 18432, down = 20480, escape = 27

Const insert = 20992, delete = 21248

Const KeyEnd = 20224





slot = _NewImage(56, 16, 32) '                                  numeral display window/limits

wheel = _NewImage(8, 176, 32) '                                whole number counter wheels

wheel10th = _CopyImage(wheel, 32) '                            1/10th counter wheel



makewheel Black, Bisque, wheel10th

makewheel Bisque, Black, wheel



miles = 0

GoSub up



Do

    Cls

    miles = miles + advance

    If miles >= 1000000 Then miles = 0

    If miles < 0 Then miles = 1000000.0!

    Line (50, 50)-(206, 166), &HFF909090, BF

    Odometer miles

    _PutImage (100, 100), slot

    _Limit 30

    _Display



    If _KeyDown(up) Then GoSub up

    If _KeyDown(KeyEnd) Then advance = 0

    If _KeyDown(down) Then GoSub down

    If _KeyDown(insert) Then miles = 999999.5

    If _KeyDown(delete) Then miles = 0.5

Loop Until _KeyDown(escape)



End

up:

advance = .002

Return

down:

advance = -.002

Return

Sub Odometer (m As Double)

    Dim As String mile_str

    Dim As Single mile_dec, roll

    Dim As Integer dot_pos, overnine, dec_pos, dec_val, xpos, ypos, break

    mile_str = _Trim$(Str$(m)) '

    If InStr(mile_str, "D") Then '                              trap for early exponents here

        dot_pos = 1 '                                          give a non-zero value for computing mile_dec

    Else

        dot_pos = InStr(mile_str, ".") '                        get decimal position if not an exponential

    End If

    mile_dec = -(m - Int(m)) * (dot_pos <> 0) '                get the decimal portion of the number

    roll = (mile_dec * 160) * (dot_pos <> 0) '                  roll factor of 1/10ths wheel mapped to number wheel

    overnine = ((mile_dec - .9) * -160) * (mile_dec > .9) '    get amount of roll past .9 if any

    overnine = overnine * (overnine < 17)

    _Dest slot '                                                draw to numeral display window

    _PutImage (_Width(slot) - 8, Int(roll)), wheel10th '        set the 1/10ths wheel position & place in slot image

    For dec_pos = 1 To Int(_Width(slot) / 8) '                  iterate through whole number decimal places

        xpos = _Width(slot) - 1 - 8 * (dec_pos + 1) '          get number wheel x position

        dec_val = Val(Mid$(mile_str, dot_pos - dec_pos, 1)) '  get decimal place value

        ypos = -16 * dec_val '                                  get whole number rotation position

        If overnine And Not break Then '                        if 1/10th wheel past .9 and no non-nine numbers previous

            ypos = ypos + overnine '                            add 9 to 0 rotation to decimal place

            If dec_val <> 9 Then break = -1 '                  if the number is not a 9 break from advancing the rest

        End If

        _PutImage (xpos, ypos), wheel '                        set number wheel in slot window

    Next dec_pos

    _Dest 0 '                                                  done with slot image, return to screen

End Sub 'OdometerII





Sub makewheel (letter As _Unsigned Long, back As _Unsigned Long, dst As Long)

    Dim x%

    _Dest dst

    Cls , back

    Color letter

    _PrintMode _KeepBackground

    For x% = 0 To 9

        _PrintString (-8, x% * 16), Str$(x%)

    Next x%

    _PrintString (0, x% * 16), "0"

    _Dest 0

End Sub