Persian Carpets - shop today!

[plus]

'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! thanks tsh73 for help!
'2017-10-05 add varaibles report at bottom of screen, ask for help finding bad combos

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"
'  #gr "size 2"  ' <<< something to try

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 + 8   '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