JB Gears 1 from drawString update
#1
Finally able to draw a decent set of gears. So decent that this demo illustrates why square teeth need corners shaved down! Also a demo of my latest drawStrings procedure translated to JB and now can draw filled rectangles at any angle(which might be demo'd in next post).

Code:
'Gear 1.txt for JB v2 B+ 2018-05-22
'from spiral.txt for JB v2 B+ 2018-05-21
'from DrawString Tester Sampler.txt for JB v2 B+ 2018-05-11, 2018-05-18 finish angled tiles challenge

global xmax, ymax, pi, sz, goON, tx, ty, ta, tc$, tz, tv, tw, th
xmax = 1200
ymax = 700
pi = acs(-1)
nomainwin

WindowWidth = xmax + 8
WindowHeight = ymax + 32
UpperLeftX = 100
UpperLeftY = 20

open "  *** Gears 1 - Sample  post 2018-05-22 *** " for graphics_nsb_nf as #gr
#gr "setfocus"
#gr "trapclose quit"
#gr "when leftButtonUp lButtonUp"
#gr "when characterInput charIn"
#gr "down"
#gr "color white"
#gr "fill black"
sz = 1
#gr "size ";sz  'drawing rectangle fills needs a fatter line

cx = xmax/2 : cy = ymax/2
Homer$ = "JP-1A0S0X";cx;"Y";cy  'erase screen, pen off = -1, 0 out Angle, x, y at center of screen
teeth = 8
sections = 2 * teeth
innerA = 360 / sections
innerB = (180 - innerA)/2
polyAngle = 180 - 2 * innerB
side = 40
radius = .5 * side / sin( pi/180 * ( .5 * innerA ) )

Bteeth =  2*teeth
Bsections = 2 * Bteeth
BinnerA = 360 / Bsections
BinnerB = (180 - BinnerA)/2
BpolyAngle = 180 - 2 * BinnerB
'side the same!
Bradius = .5 * side / sin( pi/180 * ( .5 * BinnerA ) )

'debug with nomainwin commented out
'print "teeth ";teeth, Bteeth
'print "sections ";sections, Bsections
'print "innerA ";innerA, BinnerA
'print "innerB ";innerB, BinnerB
'print "polyAngle ";polyAngle, BpolyAngle
'print "radius ";radius, Bradius

call drawString Homer$
'good gear but need to control center and radius
'call drawString "s";side;"r";teeth;"p009fzt";polyAngle;"p-1fzt-90p009fzt-90fzt-90fzt-90p-1fzt";polyAngle
while 1
   scan
   call drawString "J"
   ao = ao + 5
   if ao > 359 then ao = 0
   for a = 0 to 360 step (360/teeth)
       call drawString "A"; a + ao;"X";cx;"Y";cy;"p-1f";radius;"t";180 - innerB
       call drawString "s";side;"p-1fzt-90p009fzt-90fzt-90fzt-90p-1fzt";polyAngle;"p009fz"
   next
   for a = 0 to 360 step (360/teeth)
       call drawString "A"; a - ao ;"X";cx-2*radius-side;"Y";cy;"p-1f";radius;"t";180 - innerB
       call drawString "s";side;"p-1fzt-90p009fzt-90fzt-90fzt-90p-1fzt";polyAngle;"p009fz"
   next
   'for a = 0 to 360 step (360/teeth)
   '    call drawString "A"; a - ao ;"X";cx+2*radius+side;"Y";cy;"p-1f";radius;"t";180 - innerB
   '    call drawString "s";side;"p-1fzt-90p009fzt-90fzt-90fzt-90p-1fzt";polyAngle;"p009fz"
   'next
   for a = 0 to 360 step (360/Bteeth)
       call drawString "A"; a - .5 * ao ;"X";cx+radius+Bradius+side;"Y";cy;"p-1f";Bradius;"t";180 - BinnerB
       call drawString "s";side;"p-1fzt-90p009fzt-90fzt-90fzt-90p-1fzt";BpolyAngle;"p009fz"
   next
   call pause 100
wend
wait

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$
   if asc(c$) = 32 then
       goON = 1 - goON
   else
       call quit H$
   end if
end sub

sub wait4Spacebar 'when pause is just too rigid a time to wait
   call label "999", "002", 20, 40, "press spacebar to continue..."
   goON = 0
   while goON = 0
       scan
   wend
end sub

sub quit H$
   close #gr
   end
end sub


'drawing procedures for testing and sampling

sub drawString tstring$  'can't use E????
   'global tx, ty, ta, tc, tv
   tstring$ = upper$(tstring$);" " 'needed in case tstring$ end with command
   cmd$ = "" : ds$ = ""
   for i = 1 to len(tstring$)
       c$ = mid$(tstring$, i, 1)
       if c$ = "Z" then ds$ = str$(tz)  'Z is a varaible set with S or incremented with I
       if instr("0123456789.-", c$) then ds$ = ds$ + c$
       if instr("RXYPATCDFHWLBMJISUV", c$) or i = len(tstring$) then
           'execute last cmd if one
           if cmd$ <> ""  then
               d = val(ds$)
               select case cmd$
               case "R"                'repeat a drawstring d times
                   tst$ = mid$(tstring$, i)
                   call repete tst$, d
                   exit sub
               case "X" : tx = d       'hard x
               case "Y" : ty = d       'hard y
               case "P" : tc$ = ds$       'reset color
                   if val(tc$) >= 0 then call RGB tc$
               case "A" : ta = d       'hard angle
               case "T" : ta = ta + d  'mod angle
               case "C" : #gr "place ";tx;" ";ty;"; circle ";d
               case "D" : #gr "place ";tx;" ";ty;"; circlefilled ";d

               case "F"  'this draws a line!!!! forward d = distance ( from current x, y at angle)
                   across = d * cos(pi/180 * ta - pi/2)
                   down   = d * sin(pi/180 * ta - pi/2)
                   if val(tc$) > -1 then
                       #gr "line ";tx;" ";ty;" ";tx + across;" ";ty + down
                   end if
                   '#gr "line ";tx;" ";ty;" ";tx + across;" ";ty + down
                   tx = tx + across : ty = ty + down

               case "H" : th = d  'h for height
               case "W" : tw = d  'w for width
               case "L" : #gr "line ";tx;" ";ty;" ";tx+tw;" ";ty+th
               case "B"
                   if d = 0 then
                       #gr "place ";tx;" ";ty;";box ";tx+tw;" ";ty+th
                   else
                       call drawRect ta, tx, ty, tw, th
                   end if
               case "M"
                   if d = 0 then 'normal rectangle a = 0
                       #gr "place ";tx;" ";ty;";boxfilled ";tx+tw;" ";ty+th
                   else
                       call dfrt ta, tx, ty, tw, th
                   end if

               case "J" : #gr "cls;fill black" 'e (for erase) doesn't work

               case "I" : tz = tz + d  'increment variable
               case "S" : tz = d       'set variable

               case "U" : tx = tx + d  'mod x step
               case "V" : ty = ty + d  'mod y step
               end select
               ds$ = "" : cmd$ = ""
           end if
           cmd$ = c$
       end if
   next
end sub

'                                   4 procedures needed for drawString
sub repete tts$, times
  for i = 1 to times
    call drawString tts$
  next
end sub

sub RGB s3$      ' New Color System 1000 colors with 3 digits!!!!!!!!!!!!!!!!
   l = len(s3$)
   if l    then r = 28 * val(mid$(s3$, 1, 1)) + 3
   if l>=2 then g = 28 * val(mid$(s3$, 2, 1)) + 3
   if l>=3 then b = 28 * val(mid$(s3$, 3, 1)) + 3
   #gr "color ";r;" ";g;" ";b
   #gr "backcolor ";r;" ";g;" ";b
   tc$ = s3$ 'update turtle with color?
end sub

sub drawRect a, x, y, w, h  'draw a rectangle frame at a given angle
   #gr "size 2"
   ra = a * pi/180
   x1 = x + w * cos(ra)
   y1 = y + w * sin(ra)
   x2 = x + h * cos(ra + pi/2)
   y2 = y + h * sin(ra + pi/2)
   x3 = x2 + w * cos(ra)
   y3 = y2 + w * sin(ra)
   #gr "line ";x;" ";y;" ";x1;" ";y1
   #gr "line ";x1;" ";y1;" ";x3;" ";y3
   #gr "line ";x3;" ";y3;" ";x2;" ";y2
   #gr "line ";x2;" ";y2;" ";x;" ";y
   #gr "size ";sz
end sub

'draw string commands use this turtle method command mn where n = 1
sub dfrt a, x, y, w, h  '(d)raw (f)illed (r)ectangle at given angle (t)urtle method
   #gr "size 2;north;turn 180;turn ";a
   for i = 1 to h  'draw *part of* bigger and bigger rectangles, tsh fixed and cut 1/2 drawing
       #gr "place ";x;" ";y;";go ";i;";turn -90;go ";w;";turn 90"
   next
   #gr "size 1"
end sub

' handy supplemental procedures ==============================================

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

sub label fColor$, bColor$, x, y, text$
   call fRGB fColor$
   call bRGB bColor$
   #gr "place ";x;" ";y;";\";text$
end sub

sub fRGB s3$ 'foreground New Color System 1000 colors with 3 digits!!!!!!!!!!!!!!!!
   l = len(s3$)
   if l    then r = 28 * val(mid$(s3$, 1, 1)) + 3
   if l>=2 then g = 28 * val(mid$(s3$, 2, 1)) + 3
   if l>=3 then b = 28 * val(mid$(s3$, 3, 1)) + 3
   #gr "color ";r;" ";g;" ";b
end sub

sub bRGB s3$ 'background New Color System 1000 colors with 3 digits!!!!!!!!!!!!!!!!
   l = len(s3$)
   if l    then r = 28 * val(mid$(s3$, 1, 1)) + 3
   if l>=2 then g = 28 * val(mid$(s3$, 2, 1)) + 3
   if l>=3 then b = 28 * val(mid$(s3$, 3, 1)) + 3
   #gr "backcolor ";r;" ";g;" ";b
end sub

I think I can do gears now with solid fills without PAINT, stay tuned!


Attached Files Thumbnail(s)

B += x
Reply
#2
Loaded JB on my Linux machine and loaded your program. Firstly, JB actually ran!! Secondly, Your program loaded and ran... Cool.  A little flickering... But that is probably because JB is running through Wine... But run it did... Cool.

One serious question though... Does it come in yellow or orange? lol

J
May your journey be free of incident.

Live long and prosper.
Reply
#3
Hi Johnno,

Nope, not Linux fault. Graphics in JB is no QB64, slow and no corrections for flickering.

Did you happen to download JB v 2.0 ? It has excellent html Help system, well developed GUI also, just not great graphics.

I will work on the yellow and orange versions with Solid Fill gears that I have an idea for. Funny, I was blocked by my own blunders trying to get the bigger gear going and came up with a different idea to drawing gears. Plan B might be better than first.
B += x
Reply
#4
Cool..

JB seems to have a 'logo-style' set of commands 'built-in'... Do you think QB64 could benefit from that or do you think it might be 'bloat'? Sorry. Over thinking. Made my own coffee... Weather too wet to cycle to MacDonalds... lol

How long have you been using JB?

By the way, I keyed in the JB fractal sample into QB64 (converting the usual stuff of course) and it ran WAY too fast. Had to pop in a for... next loop just to slow it down enough to enjoy! (_DELAY seems to work in whole seconds - could be wrong...)

Were you hoping to 'go somewhere' with the gear program or was it just for 'the fun of it'?

Just a thought... Has a logo-type program been done for QB64? I recall it for 'other' basics but not sure for QB64. If not... could be fun...
May your journey be free of incident.

Live long and prosper.
Reply
#5
I have just downloaded and installed the version 2 candidate. It too also runs using Wine. I have not 'taken it out for a spin' yet. Only ran you 'gears' program... I wonder how this would run if converted to QB64? I think the 'logo' commands could be a bit of a 'stick in the eye'... But still... might be fun...

J
May your journey be free of incident.

Live long and prosper.
Reply
#6
Yellow and orange coming right up! ;-))

Code:
'gears 2.txt for JB v2 B+ 2018-05-22
'from spiral.txt for JB v2 B+ 2018-05-21
'DrawString Tester Sampler.txt for JB v2 B+ 2018-05-11, 2018-05-18 finish angled tiles challenge

' try filled in grear colors

global xmax, ymax, pi, sz, goON, tx, ty, ta, tc$, tz, tv, tw, th
xmax = 1200
ymax = 700
pi = acs(-1)
nomainwin

WindowWidth = xmax + 8
WindowHeight = ymax + 32
UpperLeftX = 100
UpperLeftY = 20

open "  *** Gears 2 - Sample  post 2018-05-22 *** " for graphics_nsb_nf as #gr
#gr "setfocus"
#gr "trapclose quit"
#gr "when leftButtonUp lButtonUp"
#gr "when characterInput charIn"
#gr "down"
#gr "fill black"
sz = 1
#gr "size ";sz  'drawing rectangle fills needs a fatter line

cx = xmax/2 : cy = ymax/2
Homer$ = "JP-1A0S0X";cx;"Y";cy  'erase screen, pen off = -1, 0 out Angle, x, y at center of screen

nteeth = 8
sqtooth = 20
radius = .5 * sqtooth / sin( .5 * pi / nteeth )

Bteeth =  2 * nteeth
BinnerA = pi / Bteeth
Bradius = .5 * sqtooth / sin( .5 * pi / Bteeth )

for ra = 0 to 2 * pi step pi/90   'one turn of gears
   scan
   call drawString "J"
   'gear x, y, nteeth, sqtooth - 2, raOffset, clr3$
   call gear cx, cy + 1, nteeth, sqtooth - 1, ra, "990"
   call gear cx - radius - Bradius - sqtooth - 2, cy, Bteeth, sqtooth, -.5 * ra + BinnerA, "950"
   call pause 600
next

call wait4Spacebar
call drawString Homer$;"x";450;"y";250;"h";200;"w";300;"p002mu";20;"v";20;"h";160;"w";260;"p039b"
call label "999", "002", 550, 350, "That's All Folks!"
wait

'========================================================    procedures for gear 2

sub gear x, y, nteeth, sqtooth, raOffset, clr3$
   sections = 2 * nteeth
   innerRA = 2 * pi / sections
   radius = .5 * sqtooth / sin( .5 * innerRA )
   for ra = 0 to 2 * pi step 2 * pi / nteeth
       x2 = x + (radius + sqtooth) * cos(ra + raOffset)
       y2 = y + (radius + sqtooth) * sin(ra + raOffset)
       call tline x, y, x2, y2, sqtooth, clr3$
   next
   'to speed things up and reduce blicking just do a circle fill x, y already set and pen color too
   #gr "place ";x;" ";y;"; circlefilled ";radius
end sub

sub tline x1, y1, x2, y2, thick, clr3$
   d = ((x1-x2)^2 + (y1-y2)^2)^.5
   t2 = thick/2
   ra = Atan2((y1-y2),(x1-x2))
   a = ra * 180/pi
   x3 = x1 + t2 * cos(ra - pi/2)
   y3 = y1 + t2 * sin(ra - pi/2)
   call drawString "x";x3;"y";y3;"w";d;"h";thick;"a";a;"p";clr3$;"m1"
end sub

' procedures this window controls

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$
   if asc(c$) = 32 then
       goON = 1 - goON
   else
       call quit H$
   end if
end sub

sub wait4Spacebar 'when pause is just too rigid a time to wait
   call label "999", "002", 20, 40, "press spacebar to continue..."
   goON = 0
   while goON = 0
       scan
   wend
end sub

sub quit H$
   close #gr
   end
end sub

'==================================   drawing procedures for testing and sampling drawString

sub drawString tstring$  'can't use E????
   'global tx, ty, ta, tc, tv
   tstring$ = upper$(tstring$);" " 'needed in case tstring$ end with command
   cmd$ = "" : ds$ = ""
   for i = 1 to len(tstring$)
       c$ = mid$(tstring$, i, 1)
       if c$ = "Z" then ds$ = str$(tz)  'Z is a varaible set with S or incremented with I
       if instr("0123456789.-", c$) then ds$ = ds$ + c$
       if instr("RXYPATCDFHWLBMJISUV", c$) or i = len(tstring$) then
           'execute last cmd if one
           if cmd$ <> ""  then
               d = val(ds$)
               select case cmd$
               case "R"                'repeat a drawstring d times
                   tst$ = mid$(tstring$, i)
                   call repete tst$, d
                   exit sub
               case "X" : tx = d       'hard x
               case "Y" : ty = d       'hard y
               case "P" : tc$ = ds$       'reset color
                   if val(tc$) >= 0 then call RGB tc$
               case "A" : ta = d       'hard angle
               case "T" : ta = ta + d  'mod angle
               case "C" : #gr "place ";tx;" ";ty;"; circle ";d
               case "D" : #gr "place ";tx;" ";ty;"; circlefilled ";d

               case "F"  'this draws a line!!!! forward d = distance ( from current x, y at angle)
                   across = d * cos(pi/180 * ta - pi/2)
                   down   = d * sin(pi/180 * ta - pi/2)
                   if val(tc$) > -1 then
                       #gr "line ";tx;" ";ty;" ";tx + across;" ";ty + down
                   end if
                   '#gr "line ";tx;" ";ty;" ";tx + across;" ";ty + down
                   tx = tx + across : ty = ty + down

               case "H" : th = d  'h for height
               case "W" : tw = d  'w for width
               case "L" : #gr "line ";tx;" ";ty;" ";tx+tw;" ";ty+th
               case "B"
                   if d = 0 then
                       #gr "place ";tx;" ";ty;";box ";tx+tw;" ";ty+th
                   else
                       call drawRect ta, tx, ty, tw, th
                   end if
               case "M"
                   if d = 0 then 'normal rectangle a = 0
                       #gr "place ";tx;" ";ty;";boxfilled ";tx+tw;" ";ty+th
                   else
                       call dfrt ta, tx, ty, tw, th
                   end if

               case "J" : #gr "cls;fill black" 'e (for erase) doesn't work

               case "I" : tz = tz + d  'increment variable
               case "S" : tz = d       'set variable

               case "U" : tx = tx + d  'mod x step
               case "V" : ty = ty + d  'mod y step
               end select
               ds$ = "" : cmd$ = ""
           end if
           cmd$ = c$
       end if
   next
end sub

'                                   4 procedures needed for drawString
sub repete tts$, times
  for i = 1 to times
    call drawString tts$
  next
end sub

sub RGB s3$      ' New Color System 1000 colors with 3 digits!!!!!!!!!!!!!!!!
   l = len(s3$)
   if l    then r = 28 * val(mid$(s3$, 1, 1)) + 3
   if l>=2 then g = 28 * val(mid$(s3$, 2, 1)) + 3
   if l>=3 then b = 28 * val(mid$(s3$, 3, 1)) + 3
   #gr "color ";r;" ";g;" ";b
   #gr "backcolor ";r;" ";g;" ";b
   tc$ = s3$ 'update turtle with color?
end sub

sub drawRect a, x, y, w, h  'draw a rectangle frame at a given angle
   #gr "size 2"
   ra = a * pi/180
   x1 = x + w * cos(ra)
   y1 = y + w * sin(ra)
   x2 = x + h * cos(ra + pi/2)
   y2 = y + h * sin(ra + pi/2)
   x3 = x2 + w * cos(ra)
   y3 = y2 + w * sin(ra)
   #gr "line ";x;" ";y;" ";x1;" ";y1
   #gr "line ";x1;" ";y1;" ";x3;" ";y3
   #gr "line ";x3;" ";y3;" ";x2;" ";y2
   #gr "line ";x2;" ";y2;" ";x;" ";y
   #gr "size ";sz
end sub

'draw string commands use this turtle method command mn where n = 1
sub dfrt a, x, y, w, h  '(d)raw (f)illed (r)ectangle at given angle (t)urtle method
   #gr "size 2;north;turn 180;turn ";a
   for i = 1 to h  'draw *part of* bigger and bigger rectangles, tsh fixed and cut 1/2 drawing
       #gr "place ";x;" ";y;";go ";i;";turn -90;go ";w;";turn 90"
   next
   #gr "size 1"
end sub

' handy supplemental procedures ==============================================

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

sub label fColor$, bColor$, x, y, text$
   call fRGB fColor$
   call bRGB bColor$
   #gr "place ";x;" ";y;";\";text$
end sub

sub fRGB s3$ 'foreground New Color System 1000 colors with 3 digits!!!!!!!!!!!!!!!!
   l = len(s3$)
   if l    then r = 28 * val(mid$(s3$, 1, 1)) + 3
   if l>=2 then g = 28 * val(mid$(s3$, 2, 1)) + 3
   if l>=3 then b = 28 * val(mid$(s3$, 3, 1)) + 3
   #gr "color ";r;" ";g;" ";b
end sub

sub bRGB s3$ 'background New Color System 1000 colors with 3 digits!!!!!!!!!!!!!!!!
   l = len(s3$)
   if l    then r = 28 * val(mid$(s3$, 1, 1)) + 3
   if l>=2 then g = 28 * val(mid$(s3$, 2, 1)) + 3
   if l>=3 then b = 28 * val(mid$(s3$, 3, 1)) + 3
   #gr "backcolor ";r;" ";g;" ";b
end sub

Function Atan2(y,x)
   'Atan2 is a function which determines the angle between points
   'x1, y1 and x2, y2. The angle returned is in radians
   'The angle returned is always in the range of
   '-PI to PI radians (-180 to 180 degrees)
   '==============================================================
   'NOTE the position of Y and X arguments
   'This keeps Atan2 function same as other language versions
   '==============================================================
  If x = 0 Then
      If y < 0 Then
           Atan2 = -1.5707963267948967
       Else
           Atan2 = 1.5707963267948967
       End If
  Else
      chk = atn(y/x)
      If x < 0 Then
          If y < 0 Then
               chk = chk - 3.1415926535897932
           Else
               chk = chk + 3.1415926535897932
           End If
      End If
       Atan2 = chk
  End If
  'thanks Andy Amaya
End Function



Hi Johnno!

Yes, QB64 _DELAY works in seconds but can use .01 for 1/100 th of sec.

Also good in loops is _LIMIT n  'where n is the number of times max you want the loop to loop in a second. This one is great for keeping the CPU fan from kicking on.

As for LOGO like commands, yes JB graphics does have a lot built in that has the LOGO feel.
I call it turtle drawing and my drawString procedure can do LOGO like commands or turtle drawing in simple strings of letters and digits, punctuation only needed to use variables from program for values in the drawString commands.

JB has a built in tutorial that comes with v 2.0, might get you up to speed. 

I am curious, how easy is it for you to access the samples that come with JB? In Windows 10 they are stored under Roaming which is not easily accessible. 

You might like my drawString stuff, I will translate it into QB64 so it can kick JB's butt with filled gear drawing!
At moment, still getting Battleship working to my sense of perfection.

Oh yeah, for gears, I have this fantasy of doing a clock's gear box and pendulum with levels of transparencies... nice dream!
B += x
Reply
#7
I cannot use the JB html tutorial because it crashes when I try. I think it's looking for Internet Explorer. (best guess) But everything else seems to work just fine...

Hmm... 'Perfection'. There are times that the machine 'kills me off'... Will your 'sense of perfection' increase the odds that I the computer will get me 'killed off' even quicker? lol

J

ps: Many thanks for the 'yellow' and 'orange'... Cool...
May your journey be free of incident.

Live long and prosper.
Reply
#8
Hi Johnno, 

What handles HTML files in Wine?
B += x
Reply