Board Logo
« On a recurring theme »

Welcome Guest. Please Login or Register.
Aug 17th, 2017, 06:31am


Conforums Terms of Service | Membership Rules | Home | Search | Recent Posts | Notification | Format Your Message | Installation FAQ

Please use the forums Search feature before asking.
Please post code using the code box described in Format Your Messages.
This will keep indentation, separate it better form the message and prevent gibberish.
If the code is too long for one post or additional files are needed, upload a ZIP archive to the Just BASIC Files Archive Site.

« Previous Topic | Next Topic »
Pages: 1  Notify Send Topic Print
 thread  Author  Topic: On a recurring theme  (Read 92 times)
bplus
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1132
xx On a recurring theme
« Thread started on: Aug 7th, 2017, 2:15pm »

Hi John!

Here is a mod of some old code that I always liked. I wonder why?

Code:
'pulse plus.txt for JB (B+=MGA) 2017-08-07

global H$, XMAX, YMAX
H$ = "gr"
XMAX = 729
YMAX = 729

nomainwin

WindowWidth = XMAX + 8
WindowHeight = YMAX + 32
UpperLeftX = (1200 - XMAX) / 2  'or delete if XMAX is 1200 or above
UpperLeftY = (700 - YMAX) / 2   'or delete if YMAX is 700 or above
ttl$ = "press or click any to quit...";space$(57);"Pulsing Plus"
open ttl$ for graphics_nsb_nf as #gr
#gr "setfocus"
#gr "trapclose quit"
#gr "when leftButtonUp lButtonUp"
#gr "when characterInput charIn"
#gr "down"
#gr "fill white"

global sq, pulse
sq = 729 'needs to be power of 3 because recursive tile 1/3 of last sq side
while 1
    scan
   call PlusX4 0, 0, 1
   if pulse then pulse = 0 else pulse = 1
wend
wait

sub PlusX4 x,y,r
    s = sq / 3 ^ r
    if pulse then
        call hue 255-r*35, 0, 0
    else
        call hue r*35, 0, 0
    end if
    call fbox x+s, y, x+2*s, y+3*s
    call fbox x, y+s, x+3*s, y+2*s
    if r > 4 then exit sub
    call PlusX4 x, y, r+1
    call PlusX4 x+2*s, y, r+1
    call PlusX4 x, y+2*s, r+1
    call PlusX4 x+2*s, y+2*s, r+1
end sub

sub hue r, g, b 'fore and back
    #gr "color ";r;" ";g;" ";b
    #gr "backcolor ";r;" ";g;" ";b
end sub

sub fbox x0, y0, x1, y1
    #gr "place ";x0;" ";y0
    #gr "boxfilled ";x1+1;" ";y1+1
end sub

sub lButtonUp H$, mx, my  'must have handle and mouse x,y
    call quit H$          '<=== H$ global window handle
end sub

sub charIn H$, c$ 
    call quit H$
end sub

sub quit H$
    close #H$ '<=== this needs Global H$ = "gr"
    end       'Thanks Facundo, close graphic wo error
end sub

sub pause mil   'tsh version has scan built-in
    t0 = time$("ms")
    while time$("ms") < t0 + mil : scan : wend
end sub

 
User IP Logged

B+
tenochtitlanuk ( John F)
Full Member
ImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 417
xx Re: On a recurring theme
« Reply #1 on: Aug 7th, 2017, 3:44pm »

A-plus, bplus!!
Recursion is fun.
Try the following- easily modified for '+' rather than 'H'...
Code:

    '***************************************************
    '**                                               **
    '**  Recursive4.bas Aug 2017 tenochtitlanuk       **
    '**                                               **
    '***************************************************


    nomainwin

    WindowWidth  = 760
    WindowHeight = 760

    open "Recursive H" for graphics_nsb_nf as #wg

    #wg "trapclose quit"

    #wg "down ; color white"
    #wg "cls ; fill 40 40 40 ; size 2"

    global length

    for index =0 to 8
        length =int( 700 /2^index)
        call H 380, 380, 680
        #wg "getbmp scr 1 1 760 760"
        bmpsave "scr", "recH" +str$( index) +".bmp"
        timer 4000, [p]
        wait
        [p]
        timer 0
    next index

    wait
    end
    '   ________________________________________________

    sub H x, y, size    '    position x, y of figure centre and size to draw
        scan
        XX =x: YY =y -5

        if size > length then
            select case
            case size >  340
                #wg "backcolor  red;       color  red        ; size 16"
            case size >  170
                #wg "backcolor  green ;    color  green      ; size  8"
            case size >   85
                #wg "backcolor  blue;      color  blue       ; size  4"
            case size >   42
                #wg "backcolor  cyan;      color  cyan       ; size  2"
            case size >   21
                #wg "backcolor  255 0 255; color  255 0 255  ; size  1"
            case size >   10
                #wg "backcolor  yellow;    color  yellow"
            case size >    5
                #wg "backcolor  white ;    color  white"
            end select

            #wg "up ; goto "; int( XX); " ";  int( YY); " ; north"

            #wg "up;    goto "; XX -size /4; " "; YY -size /4
            #wg "down ; goto "; XX -size /4; " "; YY +size /4
            #wg "up;    goto "; XX -size /4; " "; YY
            #wg "down ; goto "; XX +size /4; " "; YY
            #wg "up;    goto "; XX +size /4; " "; YY -size /4
            #wg "down ; goto "; XX +size /4; " "; YY +size /4

            call H XX -size /4, YY -size /4, int( size /2)
            call H XX -size /4, YY +size /4, int( size /2)
            call H XX +size /4, YY +size /4, int( size /2)
            call H XX +size /4, YY -size /4, int( size /2)

        end if

    end sub

    sub quit h$
        close #wg
        end
    end sub
 
User IP Logged

Visit my LB/JB pages at http://www.diga.me.uk/index.html
I use XP and Ubuntu Linux on old machines!
tenochtitlanuk ( John F)
Full Member
ImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 417
xx Re: On a recurring theme
« Reply #2 on: Aug 7th, 2017, 4:55pm »

User Image
User IP Logged

Visit my LB/JB pages at http://www.diga.me.uk/index.html
I use XP and Ubuntu Linux on old machines!
bplus
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1132
xx Re: On a recurring theme
« Reply #3 on: Aug 7th, 2017, 7:38pm »

Very lovely!

Four Square:
Code:
'recurring four square.txt for JB (B+=MGA) 2017-08-07

global H$, XMAX, YMAX
H$ = "gr"
XMAX = 729
YMAX = 729

nomainwin

WindowWidth = XMAX + 8
WindowHeight = YMAX + 32
UpperLeftX = (1200 - XMAX) / 2  'or delete if XMAX is 1200 or above
UpperLeftY = (700 - YMAX) / 2   'or delete if YMAX is 700 or above
ttl$ = "press or click any to quit...";space$(57);"Four Square"
open ttl$ for graphics_nsb_nf as #gr
#gr "setfocus"
#gr "trapclose quit"
#gr "when leftButtonUp lButtonUp"
#gr "when characterInput charIn"
#gr "down"
#gr "fill black"
#gr "size 2"

oset = 0 : dir = 1
while 1
    scan
    call hue 255, 255, 255
    call drawrect .25 * XMAX, .25 * YMAX, .5 * XMAX, .5 * YMAX, oset
    oset = oset + .01 * dir
    if oset > .25 then oset = .25 : dir = dir * -1
    if oset < 0 then
        call pause 2500
        oset = 0 : dir = dir * -1
        call hue 0, 0, 0
        call fbox 0, 0, XMAX, YMAX
    end if
    call pause 200
wend

sub drawrect x, y, w, h, oset
    scan
    call box x, y, w, h
    if h > 20 then
        call hue 0, 0, 255
        call drawrect x - oset * w, y - oset * h, 2 * oset * w, 2 * oset * h, oset
        call hue 255, 255, 0
        call drawrect x + w - oset * w, y - oset * h, 2 * oset * w, 2 * oset * h, oset
        call hue 0, 160, 0
        call drawrect x - oset * w, y +  h - oset * h, 2 * oset * w, 2 * oset * h, oset
        call hue 255, 0, 0
        call drawrect x +  w  - oset * w, y +  h - oset * h, 2 * oset * w, 2 * oset * h, oset
    end if
end sub

sub hue r, g, b 'fore and back
    #gr "color ";r;" ";g;" ";b
    #gr "backcolor ";r;" ";g;" ";b
end sub

sub box x0, y0, x1, y1
    #gr "place ";x0;" ";y0
    #gr "box ";x0+x1+1;" ";y0+y1+1
end sub

sub fbox x0, y0, x1, y1
    #gr "place ";x0;" ";y0
    #gr "boxfilled ";x0+x1+1;" ";y0+y1+1
end sub

sub lButtonUp H$, mx, my  'must have handle and mouse x,y
    call quit H$          '<=== H$ global window handle
end sub

sub charIn H$, c$ 
    call quit H$
end sub

sub quit H$
    close #H$ '<=== this needs Global H$ = "gr"
    end       'Thanks Facundo, close graphic wo error
end sub

sub pause mil   'tsh version has scan built-in
    t0 = time$("ms")
    while time$("ms") < t0 + mil : scan : wend
end sub

 
User IP Logged

B+
tsh73
JB-Supporter


member is offline

Avatar




PM

Gender: Male
Posts: 3545
xx Re: On a recurring theme
« Reply #4 on: Aug 8th, 2017, 01:06am »

John you got me puzzled in Reply#1
Surely recursion should not work like this?

Indeed if changed to
Code:
for index =8 to 8 

it works as I expect ;)
User IP Logged

Q: "And if I took your codes and compile them, and sell them for a profit"?
A: Go ahead. I had my share of good then I coded it for fun, if you can make better use of it - please do.
(enjoying JB 1.01 on WinXP, netbook and desktop)
tsh73
JB-Supporter


member is offline

Avatar




PM

Gender: Male
Posts: 3545
xx Re: On a recurring theme
« Reply #5 on: Aug 8th, 2017, 01:08am »

Bplus, Reply #3 - feathers!
User IP Logged

Q: "And if I took your codes and compile them, and sell them for a profit"?
A: Go ahead. I had my share of good then I coded it for fun, if you can make better use of it - please do.
(enjoying JB 1.01 on WinXP, netbook and desktop)
bplus
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1132
xx Re: On a recurring theme
« Reply #6 on: Aug 8th, 2017, 10:24am »

Feathers?

Then here are eggs (maybe for Easter or Peacocks or pontificating mathematicians)
Code:
'recurring ellipsii.txt for JB (B+=MGA) 2017-08-07

global H$, XMAX, YMAX
H$ = "gr"
XMAX = 1000
YMAX = 700

nomainwin

WindowWidth = XMAX + 8
WindowHeight = YMAX + 32
UpperLeftX = (1200 - XMAX) / 2  'or delete if XMAX is 1200 or above
UpperLeftY = (700 - YMAX) / 2   'or delete if YMAX is 700 or above
ttl$ = "press or click any to quit...";space$(100);"Recurring Ellipsii"
open ttl$ for graphics_nsb_nf as #gr
#gr "setfocus"
#gr "trapclose quit"
#gr "when leftButtonUp lButtonUp"
#gr "when characterInput charIn"
#gr "down"
#gr "fill black"

oset = 0 : dr = 1
while 1
    scan
    call hue 255, 255, 255
    call drawEllipsii XMAX/2, YMAX/2, XMAX, YMAX, oset
    oset = oset + .0025 * dr
    if oset >= .25 then dr = dr * -1 : oset = .25
    if oset < 0 then dr = dr * -1 : oset = 0
    'call pause 200
wend

sub drawEllipsii x, y, w, h, oset
    if w <> 0 then call ellips x, y, w, h
    scan
    if h > 40 then
        call hue 225, 0, 0
        call drawEllipsii x + w*oset, y, 2*w*oset, 2*h*oset, oset
        call hue 0, 0, 225
        call drawEllipsii x - w*oset, y, 2*w*oset, 2*h*oset, oset
        call hue 0, 180, 0
        call drawEllipsii x, y + h*oset, 2*w*oset, 2*h*oset, oset
        call hue 255, 255, 0
        call drawEllipsii x, y - h*oset, 2*w*oset, 2*h*oset, oset
    end if
end sub

sub hue r, g, b 'fore and back
    #gr "color ";r;" ";g;" ";b
    #gr "backcolor ";r;" ";g;" ";b
end sub

sub ellips x, y, w, h
    #gr "place ";x;" ";y;"; ellipse ";w;" ";h
end sub

sub lButtonUp H$, mx, my  'must have handle and mouse x,y
    call quit H$          '<=== H$ global window handle
end sub

sub charIn H$, c$ 
    call quit H$
end sub

sub quit H$
    close #H$ '<=== this needs Global H$ = "gr"
    end       'Thanks Facundo, close graphic wo error
end sub

sub pause mil   'tsh version has scan built-in
    t0 = time$("ms")
    while time$("ms") < t0 + mil : scan : wend
end sub

 
User IP Logged

B+
tenochtitlanuk ( John F)
Full Member
ImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 417
xx Re: On a recurring theme
« Reply #7 on: Aug 8th, 2017, 4:03pm »

Bplus, Yup, another nice one.

Anatoly- the for /next loop is so I could grab the screen at each depth of recursion for display as an animated GIF. It shows the need for a limit on any recursive function- otherwise it'd just draw a filled box completely full! Try say 10 or 11...

Also, oops- I left in a '-5' that shouldn't be there....
User IP Logged

Visit my LB/JB pages at http://www.diga.me.uk/index.html
I use XP and Ubuntu Linux on old machines!
Pages: 1  Notify Send Topic Print
« Previous Topic | Next Topic »

Conforums Terms of Service | Membership Rules | Home | Search | Recent Posts | Notification | Format Your Message | Installation FAQ

Donate $6.99 for 50,000 Ad-Free Pageviews!


This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls