Board Logo
« On a recurring theme »

Welcome Guest. Please Login or Register.
Jan 16th, 2018, 3:38pm


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 2  Notify Send Topic Print
 hotthread  Author  Topic: On a recurring theme  (Read 547 times)
bplus
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1255
xx Re: On a recurring theme
« Reply #15 on: Oct 4th, 2017, 08:51am »

on Oct 4th, 2017, 08:38am, tsh73 wrote:
Now that's some really cool patterns.
:)

Somehow - sometimes - some rectangles end up solid BLACK.
(I once seen central half black).
Is where a way around it?


Yes,
Code:
  
  a = int(rnd(0)*16)
  b = int(rnd(0)*16)
  'c = int(rnd(0)*16)
   c = int(rnd(0) *15) + 1
 


EDIT: sorry it should be c not a, I changed variable names around and it is coming back to haunt me.

APPEND:
Dang! that's not it. I set c = 0 to check, and ran, and I am getting lovely screens and variation???

Oh, for solid white instead of solid black try theme 2.
There is still something a little off in the way the quadrants are not mixing / flowing into a variation of theme, they kind of jump from one pattern to another.

I will experiment with known color combinations instead of random.
« Last Edit: Oct 4th, 2017, 09:07am by bplus » User IP Logged

B+
bplus
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1255
xx Re: On a recurring theme
« Reply #16 on: Oct 5th, 2017, 10:57am »

I don't know if blind luck or tsh73 has slightly different code.

I am not getting blank fills of screens or large ugly blank squares sections. There are some plain sections of color that I look at and see as like a flooring or pattern background, I see as nice.

This runs too slow to sit through and systematically watch all permutations of 3 colors 16X16x16...

Here is my current code and I have included a variable listing at bottom of screen. So if anyone testing this code does encounter whole blank sections please make note of numbers and report here, thanks.
Code:
'Persian Carpets.txt for Just Basic v1.01 [B+=MGA] 2017-10-01
'based on orig by Anne M Burns
'2017-10-04 bi-lateral symmetry fixed!

global H$, XMAX, YMAX
H$ = "gr" : XMAX = 532 : YMAX = 562

nomainwin

WindowWidth = XMAX + 8
WindowHeight = YMAX + 32
UpperLeftX = (1200 - XMAX) / 2
UpperLeftY = (700 - YMAX) / 2

open "Persian Carpets" for graphics_nsb_nf as #gr
#gr "setfocus"
#gr "trapclose quit"
#gr "down"
#gr "fill black"

xo = (XMAX - 512) / 2 : yo = (532 - 512) / 2
c = 3
while 1
  #gr "fill black"
  Dim vScreen(XMAX, YMAX)
  lft = xo : rght = 512 + xo : top = yo: bot = 512 + yo
  a = int(rnd(0)*16)
  'a = c
  b = int(rnd(0)*16)
  'b = c
  c = int(rnd(0)*16)
  #gr "color black"
  call ctext 552, "    b1 = ";a;",  b2 = ";b;",  and c (shifter) = ";c;"    "
  call vLINE lft+1, top, rght-1, top, a
  call vLINE lft+1, bot, rght-1, bot, a
  call vLINE lft, top, lft, bot, b
  call vLINE rght, top, rght, bot, b
  call DetermineColr lft, rght, top, bot, c
  call pause 2500
  'c = c + 1 : if c = 16 then c = 0

wend

' Determine the color based on function f
sub DetermineColr lft, rght, top, bot, a
    scan
    IF lft < rght -2 THEN  '<<<< if you like intricate paterns go -1, for speed go -5
        c = findClr(lft, rght, top, bot, a)
        middlecol = int((lft + rght) / 2)
        middlerow = int((top + bot) / 2)
        call vLINE lft, middlerow, rght, middlerow, c
        call vLINE middlecol, top, middlecol, bot, c
        call DetermineColr lft, middlecol, top, middlerow, a
        call DetermineColr middlecol, rght, top, middlerow, a
        call DetermineColr lft, middlecol, middlerow, bot, a
        call DetermineColr middlecol, rght, middlerow, bot, a
    else
        exit sub
    end if
end sub

function findClr(lft, rght, top, bot, a)
    'dang no POINT(x, y) oh well...
    p = (vScreen(lft, top) + vScreen(rght, top) + vScreen(lft, bot) + vScreen(rght, bot))*33
    'Try values of b = 4 or b = 7
    'b = 4
    'findClr = int(p + a) mod 16 'too much
    findClr = int(p/13 + a) mod 8 * 2   'less is more, yellow, green, red, brown theme
    'findClr = int(p/13 + a) mod 8 * 2 + 1  'less is more, blue and white theme
end function

'============================== sets drawing
#gr "flush"
wait

sub QBcolr colrNum
    select case colrNum
    case 0   : #gr "color black"
    case 1   : #gr "color darkblue"
    case 2   : #gr "color brown"
    case 3   : #gr "color darkcyan"
    case 4   : #gr "color darkred"
    case 5   : #gr "color darkpink"
    case 6   : #gr "color darkgreen"
    case 7   : #gr "color lightgray"
    case 8   : #gr "color darkgray"
    case 9   : #gr "color blue"
    case 10  : #gr "color green"
    case 11  : #gr "color cyan"
    case 12  : #gr "color red"
    case 13  : #gr "color pink"
    case 14  : #gr "color yellow"
    case 15  : #gr "color white"
    end select
end sub

sub vLINE x0, y0, x1, y1, QBc
    'record our line on the virtual screen
    if x0 = x1 then
        if y0 > y1 then start = y1 : fini = y0 else start = y0 : fini = y1
        for i = start+1 to fini-1
            vScreen(x0, i) = QBc
        next
    else
        if x0 > x1 then start = x1 : fini = x0 else start = x0 : fini = x1
        for i = start+1 to fini-1
            vScreen(i, y0) = QBc
        next
    end if
    call QBcolr QBc
    #gr "line ";x0;" ";y0;" ";x1;" ";y1  'add 1 to end point?
end sub

sub quit H$
    close #H$ 
    end
end sub

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

sub stext x, y, message$ 'note: have to reset fore or back color after ink
    #gr "place ";x;" ";y;";|";message$
end sub

sub ctext y, message$  'uses const XMAX and sub stext
    call stext (XMAX - len(message$) * 6) /2, y, message$
end sub

 
User IP Logged

B+
Pages: 1 2  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