Proggies - Printable Version

Code: (Select All)

_Title "Bird Math - BAM translation to QB64" 'b+ 2022-06-22

' ref Charlie's post   http://basic4all.epizy.com/index.php?topic=159.0

' The trigonometric functions by Hamid Naderi Yeganeh from his original artwork (Parrot)

' https://www.huffpost.com/entry/mathematical-birds_b_8876904

' Missing parts of functions found at https://www.flerlagetwins.com/2018/04/parrot.html



Dim pi, k, k1, k2, a, b As Double

Screen _NewImage(751, 720, 32): _ScreenMove 250, 20

pi = 3.1415929: k1 = -10000: k2 = 10000: c~& = _RGB32(130, 0, 0)

Window (0, 0)-(6000, -5750)

Color , &HFF8888FF: Cls

For k = k1 To k2

    a = Int(((3 * k / 20000) + (Cos(37 * pi * k / 10000)) ^ 6 * Sin((k / 10000) ^ 7 * (3 * pi / 5)) + (9 / 7) * (Cos(37 * pi * k / 10000)) ^ 16 * (Cos(pi * k / 20000)) ^ 12 * Sin(pi * k / 10000)) * 1000)

    b = -1 * Int(((-5 / 4) * (Cos(37 * pi * k / 10000)) ^ 6 * Cos((k / 10000) ^ 7 * (3 * pi / 5)) * (1 + 3 * (Cos(pi * k / 20000) * Cos(3 * pi * k / 20000)) ^ 8) + (2 / 3) * (Cos(3 * pi * k / 200000) * Cos(9 * pi * k / 200000) * Cos(9 * pi * k / 100000)) ^ 12) * 1000)

    Circle (3000 - a, -1000 - b), 60, c~&

Next k

Sleep

Code: (Select All)

_Title "Minutes Timer"

Screen _NewImage(300, 33, 32)

Color &HFFAAAADD

Input "Enter the minutes to alarm "; minutes##

start## = Timer

startT$ = Time$

Do

    Cls

    Locate 1, 1: Print startT$; "  Minute Timer Set:";

    Print Using "####.##"; minutes##;

    Locate 2, 1: Print Time$; "    Minutes so far:";

    Print Using "####.##"; MinutesPassed##(start##);

    If minutes## <= MinutesPassed##(start##) Then

        Beep

        _Title "Press any to stop beeping..."

        If Len(InKey$) Then System

    End If

    _Limit 10

Loop Until theCowsComeHome



Function MinutesPassed## (started##)

    If started## > Timer Then started## = started## - 86400 ' midnight problem fix

    MinutesPassed## = Int(100 * (Timer - started##) / 60) / 100

End Function

100 Prisoners Problem

' I saw this last night and just have to check out the solution in code!

' https://www.youtube.com/watch?v=iSNsgj1OCLA

' So 100 prisoners go into a room one at a time and have 50 chances to draw their number from mailbox slots
' they must return the numbers in same box they checked.

' If all the prisoners find their number they go free else they are all executed. Whew!

' But there is a strategy that if used gives them around a 31% chance of being set free!

' A 31% Change of being set free, how can this be!?

' Here is the startegy, go into the room and pull the number from slot that matches your number.
' From that number go to the number found in the box, contimue in this manner until you find your
' number or you've drawn from 50 slots. If you hit 50 then everyone is doomed might as well start
' another run on the experiment.

' If we run this strategy 100000 times will we get around 31,000 Set Frees and 69,000 Executions?

' Let's see...

' Wow! as predicted

Code: (Select All)
_Title "100 Prisoners Problem"

Randomize Timer

Dim slots(1 To 100) As Long

For i = 1 To 100

    slots(i) = i

Next

Do

    freed = 0: executions = 0

    Do

        GoSub shuffle

        For p = 1 To 100 ' prisoner number

            count = 1: test = p: madeit = -1

            While count <= 50

                If slots(test) = p Then Exit While Else test = slots(test)

                count = count + 1

                If count > 50 Then madeit = 0: Exit For

            Wend

        Next

        If madeit Then freed = freed + 1 Else executions = executions + 1

    Loop Until (freed + executions) = 100000

    Print "Freed"; freed

    Print "Exceutions"; executions

    Print

    Print "Press any for another run of 100,000... "

    Sleep

    Cls

Loop Until _KeyDown(27)

End

shuffle:

For i = 100 To 2 Step -1

    Swap slots(Int(Rnd * i) + 1), slots(i)

Next

Return

'  I saw this last night and just have to check out the solution in code!

' https://www.youtube.com/watch?v=iSNsgj1OCLA

' So 100 prisoners go into a room one at a time and have 50 chances to draw their number from mailbox slots

' they must return the numbers in same box they checked.

' If all the prisoners find their number they go free else they are all executed. Whew!

' But there is a strategy that if used gives them around a 31% chance of being set free!

'       A 31% Change of being set free, how can this be!?

' Here is the startegy, go into the room and pull the number from slot that matches your number.

' From that number go to the number found in the box, contimue in this manner until you find your

' number or you've drawn from 50 slots. If you hit 50 then everyone is doomed might as well start

' another run on the experiment.

' If we run this strategy 100000 times will we get around 31,000 Set Frees and 69,000 Executions?

' Let's see...

' Wow! as predicted

Rotating Star Mouse Chaser

Code: (Select All)
Option _Explicit

_Title "Rotating Star Mouse Chaser" 'b+ 2022-07-19 trans from:

'Rotating Stars Mouse Chaser.bas for SmallBASIC 0.12.0 2015-11-09 MGA/B+

'code is based on code: mouse chaser by tsh73

'for the Just Basic contest, November 2008, I am 7 years later

Const nPoints = 20, xMax = 1280, yMax = 700, pi = _Pi

Screen _NewImage(xMax, yMax, 32)

_FullScreen

Dim Shared x(nPoints), y(nPoints), i, twist

Dim As Long mx, my

Dim As Single dx, dy, v, r, dxN, dyN

For i = 1 To nPoints

    x(i) = xMax

    y(i) = yMax 'set it offscreen

Next

While _KeyDown(27) = 0

    Cls

    twist = twist + .05

    While _MouseInput: Wend

    mx = _MouseX: my = _MouseY

    For i = 1 To nPoints

        If i = 1 Then 'first sees mouse

            dx = mx - x(i)

            dy = my - y(i)

            v = 4

        Else 'others see previous

            dx = x(i - 1) - x(i)

            dy = y(i - 1) - y(i)

            v = 0.6 * v + 0.2 * 3 * (2 - i / nPoints) 'use 0.8 v of previous, to pick up speed

        End If

        r = Sqr(dx ^ 2 + dy ^ 2)

        dxN = dx / r

        dyN = dy / r

        x(i) = x(i) + v * dxN

        y(i) = y(i) + v * dyN

        drawstar

    Next i

    _Display

    _Limit 60

Wend

Sub drawstar ()

    Dim sp, s, t, u, j, b, v, w

    sp = (nPoints + 1 - i) * 2 + 3 'star points when i is low, points are high

    s = 5 * (50 ^ (1 / nPoints)) ^ (nPoints + 1 - i)

    t = x(i) + s * Cos(0 + twist)

    u = y(i) + s * Sin(0 + twist)

    For j = 1 To sp

        b = b + Int(sp / 2) * 2 * pi / sp

        v = x(i) + s * Cos(b + twist)

        w = y(i) + s * Sin(b + twist)

        Line (t, u)-(v, w), _RGB32(255, 255, 100)

        t = v: u = w

    Next

End Sub