Author Topic: Happy St Patrick's Day  (Read 4208 times)

0 Members and 1 Guest are viewing this topic.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
Happy St Patrick's Day
« on: March 07, 2018, 02:50:27 pm »
Code: QB64: [Select]
  1. _TITLE "Happy St Patrick's Day by bplus 2018-03-07"
  2. ' from
  3. ' Draw Angled Heart.bas SmallBASIC 0.12.11 (B+=MGA) 2018-03-07
  4. CONST xmax = 1280
  5. CONST ymax = 760
  6. SCREEN _NEWIMAGE(xmax, ymax, 32)
  7.  
  8.  
  9.     cc1&& = _RGB32(0, RND * 100 + 50, 0)
  10.     cc2&& = _RGB32(0, RND * 100 + 50, 0)
  11.     xp = RND * xmax
  12.     yp = RND * ymax
  13.     size = INT(RND * 100) + 10
  14.     ang = RND * _PI(2)
  15.     COLOR cc1&&
  16.     FOR r = 1 TO size
  17.         drawShamrock xp + 1, yp, r, ang
  18.         drawShamrock xp - 1, yp, r, ang
  19.         drawShamrock xp, yp + 1, r, ang
  20.         drawShamrock xp, yp - 1, r, ang
  21.         drawShamrock xp + 1, yp + 1, r, ang
  22.     NEXT
  23.     COLOR cc2&&
  24.     FOR r = 1 TO size
  25.         drawShamrock xp, yp, r, ang
  26.     NEXT
  27.     _DISPLAY
  28.     _LIMIT 20
  29.  
  30.  
  31. 'draws an arc with center at xCenter, yCenter, radius from center is arcRadius
  32. SUB myArc (xCenter, yCenter, arcRadius, dAStart, dAMeasure)
  33.     'notes:
  34.     'you may want to adjust size and color for line drawing
  35.     'using angle measures in degrees to match Just Basic ways with pie and piefilled
  36.     'this sub assumes drawing in a CW direction if dAMeasure positive
  37.  
  38.     'for Just Basic angle 0 degrees is due East and angle increases clockwise towards South
  39.  
  40.     'dAStart is degrees to start Angle, due East is 0 degrees
  41.  
  42.     'dAMeasure is degrees added (Clockwise) to dAstart for end of arc
  43.  
  44.     rAngleStart = RAD(dAStart)
  45.     rAngleEnd = RAD(dAMeasure) + rAngleStart
  46.     Stepper = RAD(1 / (.1 * arcRadius)) 'fixed
  47.     FOR rAngle = rAngleStart TO rAngleEnd STEP Stepper
  48.         IF rAngle = rAngleStart THEN
  49.             lastX = xCenter + arcRadius * COS(rAngle)
  50.             lastY = yCenter + arcRadius * SIN(rAngle)
  51.         ELSE
  52.             nextX = xCenter + arcRadius * COS(rAngle)
  53.             IF nextX <= lastX THEN useX = nextX - 1 ELSE useX = nextX + 1
  54.             nextY = yCenter + arcRadius * SIN(rAngle)
  55.             IF nextY <= lastY THEN useY = nextY - 1 ELSE useY = nextY + 1
  56.             LINE (lastX, lastY)-(nextX, nextY)
  57.             lastX = nextX
  58.             lastY = nextY
  59.         END IF
  60.     NEXT
  61.  
  62. SUB drawHeart (x, y, r, a)
  63.     'local x1, x2, x3, x4, x5, x6, y1, y2, y3, y4, y5, y6
  64.     'clockwise from due East, the V
  65.     x1 = x + r * COS(a)
  66.     y1 = y + r * SIN(a)
  67.     x2 = x + r * COS(a + _PI(1 / 2))
  68.     y2 = y + r * SIN(a + _PI(1 / 2))
  69.     x3 = x + r * COS(a + _PI)
  70.     y3 = y + r * SIN(a + _PI)
  71.     x4 = x + r * COS(a + 3 * _PI / 2)
  72.     y4 = y + r * SIN(a + 3 * _PI / 2)
  73.     x5 = (x3 + x4) / 2
  74.     y5 = (y3 + y4) / 2
  75.     x6 = (x4 + x1) / 2
  76.     y6 = (y4 + y1) / 2
  77.     LINE (x1, y1)-(x2, y2)
  78.     LINE (x2, y2)-(x3, y3)
  79.     'left hump
  80.     myArc x5, y5, .5 * r * 2 ^ .5, DEG(a) + 135, 180
  81.     'right hump
  82.     myArc x6, y6, .5 * r * 2 ^ .5, DEG(a) + 225, 180
  83.  
  84. SUB drawShamrock (x, y, r, a)
  85.     'local x1, x2, x3, y1, y2, y3
  86.     x1 = x + r * COS(a + 3 * _PI / 2)
  87.     y1 = y + r * SIN(a + 3 * _PI / 2)
  88.     x2 = x + r * COS(a + _PI / 6)
  89.     y2 = y + r * SIN(a + _PI / 6)
  90.     x3 = x + r * COS(a + 5 * _PI / 6)
  91.     y3 = y + r * SIN(a + 5 * _PI / 6)
  92.     drawHeart x1, y1, r, a
  93.     drawHeart x2, y2, r, a + 2 * _PI / 3
  94.     drawHeart x3, y3, r, a + 4 * _PI / 3
  95.  
  96. FUNCTION RAD (a)
  97.     RAD = _PI(a / 180)
  98.  
  99. FUNCTION DEG (a)
  100.     DEG = a * 180 / _PI
  101.  
QB Happy.PNG
* QB Happy.PNG (Filesize: 161.35 KB, Dimensions: 900x737, Views: 420)

FellippeHeitor

  • Guest
Re: Happy St Patrick's Day
« Reply #1 on: March 07, 2018, 03:40:16 pm »
That's gorgeous, bplus!

Since you've been setting a high bar, I was kinda expecting those would be rotating, but it was still gorgeous, that's unquestionable.

I wonder where's the beer-filling screensaver from TheBOB. Is the search working ok at N54, @Pete?
« Last Edit: March 07, 2018, 03:46:08 pm by FellippeHeitor »

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
Re: Happy St Patrick's Day
« Reply #2 on: March 07, 2018, 04:28:18 pm »
Oh spinning, piece of cake...

Maybe with some green beer, code won't be needed.

:)

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
Re: Happy St Patrick's Day
« Reply #3 on: March 07, 2018, 05:07:48 pm »
@ Fell: Well, I'm working...

http://www.network54.com/Forum/648955/message/1489795926

Oh, and Bob updated it to an even better version, here: http://www.network54.com/Forum/648955/message/1520462755/

Run it a few times and maybe we'll get some smileys around here!

Pete :D

- Search me!
« Last Edit: March 07, 2018, 06:01:22 pm by Pete »
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/

FellippeHeitor

  • Guest
Re: Happy St Patrick's Day
« Reply #4 on: March 07, 2018, 05:47:40 pm »
That's the one, many thanks Pete!

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
Re: Happy St Patrick's Day
« Reply #5 on: March 07, 2018, 06:03:52 pm »
Welcome! Smileys?

Well, also see Bob's newer version, see my edit above addition, and my comment to it, here: http://www.network54.com/Forum/648955/message/1520463629

Pete

A day without smileys is like a day without moonshine.
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/

FellippeHeitor

  • Guest
Re: Happy St Patrick's Day
« Reply #6 on: March 07, 2018, 07:16:04 pm »
Oh yeah, IDE remains blue, I remember this updated version as well. TheBOB's graphics are always spot on.

Maybe we can have a new _STPATRICK statement.

Where's Clippy so we can check his blood pressure now?

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
Re: Happy St Patrick's Day
« Reply #7 on: March 07, 2018, 08:03:16 pm »
Last sighting...

http://petesqbsite.com/phpBB3/viewtopic.php?f=4&p=30206&sid=53a8fb64e8ac9a739af64a3e06ff45c0#p30206

We chipped him while he was registered at N54.

Pete :D
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/

FellippeHeitor

  • Guest
Re: Happy St Patrick's Day
« Reply #8 on: March 07, 2018, 08:27:40 pm »
He tweeted a day ago, so still alive.

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
Re: Happy St Patrick's Day
« Reply #9 on: March 07, 2018, 11:20:24 pm »
OK, you let us know when he tweets, and I'll let you know when he croaks!

Actually, I'm getting on in age, myself: http://www.network54.com/Forum/183705/message/1520456635/I+just+got+a+job+playing+a+firefighter+in+a+commercial

Pete :D
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
Re: Happy St Patrick's Day
« Reply #10 on: March 08, 2018, 12:54:36 am »
Oh, this thread reminded me of how Rob got sidetracked with the making IDE instead of finishing the compiler. Here's what really happened...

Code: QB64: [Select]
  1. DECLARE SUB instructions ()
  2. DECLARE SUB qbide ()
  3. DECLARE SUB mship (imothership)
  4. REM Adds multiple bullets (5) max.
  5. REM Adds firing delay and ship turns red while reloading.
  6. REM Adds aliens.
  7. REM Adds collision for bullets from base to aliens.
  8. REM Adds Mouse support.
  9. REM Adds alien motion.
  10. REM Adds 3 progressive levels.
  11. REM Adds aliens move all the way to both sides.
  12. REM Adds Aliens shoot back.
  13. REM Adds sub-routines.
  14. REM Adds counter.
  15. REM Adds alien bullets finish before moving on to next level.
  16. REM Adds mothership.
  17.  
  18. DECLARE SUB alienattack (ialiencolstat, ialiencol)
  19. DECLARE SUB alienmissile (iresults)
  20. DECLARE SUB checkcollision (ihitaliens, ialiencol, i4, i)
  21. DECLARE SUB mdriver (ex%, key$, tankx%)
  22. DECLARE SUB marchdown (ialiencol, ialiencolstat, imotion, iresults)
  23. DECLARE SUB movealiens (ialiencol, ialiencolstat, iresults)
  24. DECLARE SUB reprintaliens (ialiencol, ihitaliens, iresults, i4, i, imothership)
  25.  
  26. TYPE RegType
  27.     AX AS INTEGER
  28.     BX AS INTEGER
  29.     CX AS INTEGER
  30.     DX AS INTEGER
  31.     BP AS INTEGER
  32.     SI AS INTEGER
  33.     DI AS INTEGER
  34.     FLAGS AS INTEGER
  35.     DS AS INTEGER
  36.     ES AS INTEGER
  37.  
  38. DIM SHARED MOUSE$
  39. DIM SHARED Registers AS RegType
  40. DIM SHARED LB%, RB%, MB%, DX, CX
  41. DIM SHARED lmargin%, rmargin%, topmargin%, screenwidth%, level, ibk, ileadingrow
  42. DIM SHARED irow, icol, inextrnd, imaxalienmissiles, alienforce%, ileadingmax, imaxalienforce, ihits
  43.  
  44. imaxalienforce = 6
  45. imaxalienmissiles = 3
  46. lmargin% = 2
  47. rmargin% = 79
  48. topmargin% = 3
  49. ialiencolstat = 6
  50. iwin = 3
  51. screenwidth% = rmargin% - lmargin% + 1
  52. ibk = 1
  53.  
  54. DIM SHARED a(imaxalienforce) AS STRING * 68
  55.  
  56. SCREEN 0, 0, 0, 0
  57. COLOR 7, 1: CLS
  58.  
  59. REM Make aliens
  60. a1$ = "-<" + CHR$(237) + ">-  "
  61. a$ = a1$ + a1$ + a1$ + a1$ + a1$ + a1$ + a1$ + a1$ + a1$ + a1$
  62.  
  63. CALL qbide
  64. CALL instructions
  65.  
  66.     IF inextrnd = -1 THEN PCOPY 3, 0
  67.     tank$ = CHR$(218) + CHR$(127) + CHR$(191): icolor = 7
  68.     REDIM SHARED bullet%(5), bulletcol%(5), bulletdelay%(5), iltalien(imaxalienforce)
  69.     REDIM SHARED ia(imaxalienmissiles), iy(imaxalienmissiles), ix(imaxalienmissiles)
  70.     REDIM SHARED matrix(imaxalienforce) AS STRING * 10
  71.     alienforce% = imaxalienforce
  72.     level = .65
  73.     iround = iround + 1
  74.     level = level - iround / 15
  75.     inextrnd = -1
  76.     COLOR 7, ibk
  77.  
  78.     REM Set up aliens
  79.     ialiencol = ialiencolstat
  80.     LOCATE 2, ialiencol
  81.     FOR i = 1 TO imaxalienforce
  82.         IF i MOD 1 = 0 THEN PRINT
  83.         LOCATE , ialiencol
  84.         IF i = imaxalienforce THEN ileadingrow = CSRLIN: ileadingmax = ileadingrow
  85.         a(i) = a$
  86.         PRINT a(i)
  87.     NEXT
  88.  
  89.     REM Station
  90.     LOCATE 24, 40, 1, 7, 7
  91.     PRINT tank$;: LOCATE , POS(1) - 2: tanky% = CSRLIN: tankx% = POS(1) + 1
  92.     key$ = INKEY$: SLEEP 1
  93.     ex% = 1: CALL mdriver(ex%, key$, tankx%)
  94.     DO
  95.         z1 = TIMER
  96.         DO
  97.             IF topmargin% + ileadingmax - (imaxalienforce * 2) >= topmargin% + 2 THEN
  98.                 IF imothership <> 0 THEN CALL mship(imothership)
  99.             END IF
  100.             IF ABS(TIMER - z1aliens) > level THEN
  101.                 CALL movealiens(ialiencol, ialiencolstat, iresults)
  102.                 z1aliens = TIMER
  103.             END IF
  104.             IF iresults < 0 THEN EXIT DO
  105.             IF ABS(TIMER - z1ia) > .3 THEN CALL alienmissile(iresults): z1ia = TIMER
  106.             key$ = INKEY$
  107.             IF key$ = "" THEN ex% = 2: CALL mdriver(ex%, key$, tankx%)
  108.             SELECT CASE key$
  109.                 CASE CHR$(0) + "K"
  110.                     IF POS(1) > lmargin% + 1 THEN COLOR icolor, ibk: LOCATE , POS(1) - 2: PRINT tank$ + " ";: LOCATE , POS(1) - 3
  111.                     tanky% = CSRLIN: tankx% = POS(1)
  112.                     IF SCREEN(tanky%, tankx% - 2) = 25 OR SCREEN(tanky%, tankx% + 2) = 25 THEN result = -1: EXIT DO
  113.                 CASE CHR$(0) + "M"
  114.                     IF POS(1) < screenwidth% THEN COLOR icolor, ibk: LOCATE , POS(1) - 1: PRINT " " + tank$;: LOCATE , POS(1) - 2
  115.                     tanky% = CSRLIN: tankx% = POS(1)
  116.                     IF SCREEN(tanky%, tankx% - 2) = 25 OR SCREEN(tanky%, tankx% + 2) = 25 THEN result = -1: EXIT DO
  117.                 CASE CHR$(32)
  118.                     IF icolor = 7 THEN
  119.                         FOR i2 = 1 TO 5
  120.                             IF bullet%(i2) = 0 THEN
  121.                                 icolor = 12: COLOR icolor, ibk: GOSUB redraw
  122.                                 bullet%(i2) = -1: reload = TIMER: EXIT FOR
  123.                             END IF
  124.                         NEXT
  125.                     END IF
  126.                 CASE CHR$(27): SYSTEM
  127.             END SELECT
  128.  
  129.             IF ABS(z1 - reload) > .7 AND reload <> 0 THEN
  130.                 GOSUB redraw
  131.                 icolor = 7: reload = 0
  132.             END IF
  133.  
  134.             REM Fire
  135.             FOR i = 1 TO 5
  136.                 SELECT CASE bullet%(i)
  137.                     CASE -1: bullet%(i) = tanky% - 1: bulletcol%(i) = tankx%
  138.                     CASE IS > 0
  139.                         IF bulletdelay%(i) = -1 OR bullet%(i) = tanky% - 1 THEN
  140.                             CALL checkcollision(ihitaliens, ialiencol, i4, i)
  141.                             z2bullet = TIMER: bulletdelay%(i) = 0
  142.                             COLOR 7, ibk
  143.                             LOCATE bullet%(i), bulletcol%(i)
  144.                             IF bullet%(i) = topmargin% AND imothership <> 0 THEN
  145.                                 IF SCREEN(ABS(bullet%(i)), bulletcol%(i)) <> 32 THEN
  146.                                     SOUND 1000, .75
  147.                                     LOCATE topmargin%, lmargin%: PRINT SPACE$(screenwidth%);
  148.                                     imothership = 0
  149.                                 END IF
  150.                             END IF
  151.                             PRINT CHR$(24)
  152.                             IF CSRLIN <> 24 THEN LOCATE , bulletcol%(i): PRINT " ";
  153.                             IF ihitaliens <> 0 THEN CALL reprintaliens(ialiencol, ihitaliens, iresults, i4, i, imothership)
  154.                             LOCATE tanky%, tankx%
  155.                             IF bullet%(i) > topmargin% THEN
  156.                                 bullet%(i) = bullet%(i) - 1
  157.                             ELSE
  158.                                 GOSUB erasebullet
  159.                             END IF
  160.                         END IF
  161.                 END SELECT
  162.             NEXT
  163.  
  164.             REM Bullet timer delay
  165.             IF z2bullet <> 0 THEN
  166.                 IF z1 < z2bullet THEN z2bullet = z2bullet - 86400
  167.                 IF z1 - z2bullet >= .06 THEN
  168.                     FOR i2 = 1 TO 5
  169.                         IF bullet%(i2) <> 0 THEN bulletdelay%(i2) = -1
  170.                     NEXT i2
  171.                 END IF
  172.                 EXIT DO
  173.             END IF
  174.         LOOP
  175.         IF iresults < 0 THEN EXIT DO
  176.         IF alienforce% = 0 OR iresults = iwin THEN
  177.             FOR i = 1 TO imaxalienmissiles
  178.                 IF ia(i) <> 0 THEN EXIT FOR
  179.             NEXT
  180.             IF i > imaxalienmissiles THEN iwait = -1
  181.             IF iwait = -1 THEN
  182.                 EXIT DO
  183.             END IF
  184.         ELSE
  185.             iwait = 1
  186.         END IF
  187.     LOOP
  188.     ex% = -1: CALL mdriver(ex%, key$, tankx%)
  189.     key$ = INKEY$
  190.     SLEEP 2
  191.     IF iresults = iwin OR iresults < 0 THEN
  192.         REM end game
  193.         EXIT DO
  194.     END IF
  195.     inextrnd = -1
  196. SELECT CASE iresults
  197.     CASE IS < 0
  198.         COLOR 7, ibk
  199.         LOCATE tanky% - 1, lmargin%
  200.         PRINT SPACE$(screenwidth%);
  201.         LOCATE tanky%, lmargin%
  202.         PRINT SPACE$(screenwidth%);
  203.         key$ = INKEY$
  204.         SOUND 140, 2
  205.         SLEEP 2
  206. CALL qbide
  207. CALL instructions
  208.  
  209. erasebullet:
  210. LOCATE ABS(bullet%(i)), bulletcol%(i): PRINT " ";
  211. bullet%(i) = 0: bulletcol%(i) = 0: bulletdelay%(i) = 0
  212. LOCATE tanky%, tankx%
  213.  
  214. redraw:
  215. COLOR , ibk: LOCATE tanky%, tankx% - 1: PRINT tank$;: LOCATE tanky%, tankx%: COLOR 7, ibk
  216.  
  217. DATA "Well, I better get busy and finish the compiler..."
  218. DATA "Or... I'll just do some more work on this IDE, instead..."
  219. DATA ""
  220. DATA " Loading..."
  221. DATA "EOF"
  222. DATA "Game Over. Thanks for playing..."
  223. DATA ""
  224. DATA "Now finish the compiler!"
  225. DATA "EOF2"
  226.  
  227. SUB alienattack (ialiencolstat, ialiencol)
  228. z2alienfire = TIMER
  229.  
  230. i3 = INT(RND * 10)
  231. FOR i = 1 TO imaxalienmissiles
  232.     IF ia(i) = 0 THEN
  233.         FOR i2 = imaxalienforce TO 1 STEP -1
  234.             IF RTRIM$(a(i2)) <> "" THEN
  235.                 IF MID$(matrix(i2), i3 + 1, 1) <> "0" THEN
  236.                     i4 = INSTR(i3 * 7 + 1, a(i2), CHR$(237)) + ialiencol
  237.                     EXIT FOR
  238.                 END IF
  239.             END IF
  240.         NEXT i2
  241.         IF i4 <> 0 THEN
  242.             ia(i) = (ileadingmax - (imaxalienforce - i2) * 2) * 80 + i4
  243.             EXIT FOR
  244.         END IF
  245.     END IF
  246.  
  247.  
  248. SUB alienmissile (iresults)
  249. irow = CSRLIN: icol = POS(1)
  250. FOR i = 1 TO imaxalienmissiles
  251.     IF ia(i) <> 0 THEN
  252.         IF iy(i) = 0 THEN
  253.             iy(i) = ia(i) \ 80: ix(i) = ia(i) MOD 80
  254.             IF ix(i) = 0 THEN ix(i) = screenwidth%
  255.         END IF
  256.         LOCATE iy(i) + 1, ix(i)
  257.         COLOR 7, ibk
  258.         IF CSRLIN <= 24 THEN
  259.             IF CSRLIN = 24 THEN IF SCREEN(CSRLIN, ix(i)) <> 32 THEN iresults = -1
  260.             PRINT CHR$(25);
  261.         ELSE
  262.             ia(i) = 0
  263.             LOCATE iy(i), ix(i)
  264.             PRINT " ";: iy(i) = 0
  265.             ia(i) = 0
  266.             LOCATE irow, icol
  267.             EXIT SUB
  268.         END IF
  269.         LOCATE iy(i), ix(i): PRINT " ";
  270.         iy(i) = iy(i) + 1
  271.     END IF
  272. LOCATE irow, icol
  273.  
  274.  
  275. SUB checkcollision (ihitaliens, ialiencol, i4, i)
  276. ihitaliens = 0
  277. IF ileadingmax MOD 2 = bullet%(i) MOD 2 THEN
  278.     i4 = imaxalienforce - (ileadingmax - bullet%(i)) \ 2
  279.     IF bullet%(i) <= ileadingrow AND i4 > 0 AND i4 <= imaxalienforce THEN
  280.         IF RTRIM$(a(i4)) <> "" THEN
  281.             IF bulletcol%(i) >= iltalien(i4) AND bulletcol%(i) - ialiencol <= LEN(RTRIM$(a(i4))) THEN
  282.                 IF MID$(a(i4), bulletcol%(i) - ialiencol, 1) > CHR$(32) THEN
  283.                     ihitaliens = bulletcol%(i) - ialiencol + 1
  284.                     i3 = ihitaliens - 7 + 1: IF i3 < 1 THEN i3 = 1: REM count from the "<" symbol.
  285.                     i2 = INSTR(i3 + 1, a(i4), "<") - 1
  286.                     MID$(a(i4), i2, 7) = SPACE$(7)
  287.                     MID$(matrix(i4), (i2 + 1) \ 7 + 1, 1) = "0"
  288.                 END IF
  289.             END IF
  290.         END IF
  291.     END IF
  292.  
  293. FOR i2 = 1 TO imaxalienmissiles
  294.     IF ia(i2) <> 0 THEN
  295.         IF iy(i2) >= bullet%(i) AND ix(i2) = bulletcol%(i) THEN
  296.             ihitaliens = -i2
  297.             EXIT FOR
  298.         END IF
  299.     END IF
  300.  
  301.  
  302. SUB instructions
  303.  
  304. '''in$ = "EOF"
  305. IF in$ = "" THEN
  306.     key$ = INKEY$
  307.     LOCATE 3, 3, 1, 7, 7: COLOR 7, ibk
  308.     SLEEP 2
  309.     DO
  310.         READ in$
  311.         IF MID$(in$, 1, 3) = "EOF" THEN EXIT DO
  312.         FOR i = 1 TO LEN(in$)
  313.             SOUND 400, .1
  314.             LOCATE , 2 + i
  315.             PRINT MID$(in$, i, 1);
  316.             z = TIMER
  317.             DO
  318.                 IF ABS(z - TIMER) > .1 THEN EXIT DO
  319.             LOOP
  320.         NEXT
  321.         LOCATE , , 0, 7, 0
  322.         key$ = INKEY$
  323.         SLEEP 1
  324.         PRINT
  325.         LOCATE , 3
  326.     LOOP
  327.     key$ = INKEY$
  328.     SLEEP 1
  329.  
  330. IF in$ = "EOF" THEN
  331.     COLOR 7, 1
  332.     FOR i = 1 TO 5
  333.         LOCATE 2 + i, 2: PRINT SPACE$(78)
  334.     NEXT
  335.     FOR i = 3 TO 24
  336.         LOCATE i, 80: PRINT CHR$(179);
  337.     NEXT
  338.     LOCATE 21, 2: PRINT STRING$(78, " ");
  339.     LOCATE 22, 1: PRINT CHR$(179);
  340.     LOCATE 22, 80: PRINT CHR$(179);
  341.     LOCATE 22, 2: PRINT STRING$(78, " ");
  342.     COLOR 0, 3
  343.  
  344. COLOR 0, 3
  345. yy% = CSRLIN: xx% = POS(1)
  346. LOCATE 25, 76 - LEN(LTRIM$(STR$(ihits)))
  347. PRINT LTRIM$(STR$(ihits));
  348. LOCATE 25, 80 - LEN(LTRIM$(STR$(imaxalienforce - alienforce%)))
  349. PRINT "0";
  350. LOCATE yy%, xx%
  351.  
  352. PCOPY 0, 3: REM save skin
  353.  
  354.  
  355. SUB marchdown (ialiencol, ialiencolstat, imotion, iresults)
  356. COLOR 7, ibk
  357. ileadingrow = ileadingrow + 1
  358. ileadingmax = ileadingmax + 1
  359. COLOR 7, ibk
  360. FOR i = 1 TO imaxalienforce
  361.     IF RTRIM$(a(i)) <> "" THEN
  362.         ialiencol = ialiencolstat + imotion
  363.         LOCATE ileadingmax - (imaxalienforce * 2) + i * 2 - 1, lmargin%
  364.         PRINT STRING$(screenwidth%, " ")
  365.         LOCATE , ialiencol + INSTR(a(i), "-")
  366.         iltalien(i) = POS(1)
  367.         PRINT LTRIM$(RTRIM$(a(i)))
  368.     END IF
  369. LOCATE irow, icol
  370. level = level - .025
  371. IF ileadingrow = 22 THEN iresults = -2
  372.  
  373. SUB mdriver (ex%, key$, tankx%)
  374. STATIC MOUSEACT%
  375.  
  376. REM INITIATE MOUSE
  377. IF MOUSEACT% = 0 OR ex% = -1 THEN
  378.     Registers.AX = 0: GOSUB CALLI
  379.     MOUSEACT% = 1
  380.  
  381. IF ex% = 1 THEN
  382.     Registers.AX = 4: Registers.DX = 184: Registers.CX = 304
  383.     Registers.AX = 8: Registers.DX = 184: Registers.CX = 184
  384.     GOSUB CALLI
  385.     EXIT SUB
  386.  
  387. Registers.AX = 3: GOSUB CALLI
  388.  
  389. DX = Registers.DX
  390. CX = Registers.CX
  391. y% = DX \ 8 + 1: x% = CX \ 8 + 1
  392.  
  393. REM MOUSE BUTTONS
  394. LB% = Registers.BX AND 1
  395. RB% = (Registers.BX AND 2) \ 2
  396. MB% = (Registers.BX AND 4) \ 4
  397.  
  398. IF LB% <> 0 THEN
  399.     key$ = CHR$(32)
  400.     IF x% > tankx% THEN key$ = CHR$(0) + "M"
  401.     IF x% < tankx% THEN key$ = CHR$(0) + "K"
  402.  
  403. CALLI:
  404. CALL INTERRUPT(&H33, Registers, Registers)
  405.  
  406.  
  407. SUB movealiens (ialiencol, ialiencolstat, iresults)
  408. STATIC imotion, imarch, imotiondir
  409. IF inextrnd = -1 THEN inextrnd = 0: imotion = 0: imarch = 0: imotiondir = 0
  410. irow = CSRLIN: icol = POS(1)
  411. yy% = CSRLIN: xx% = POS(1)
  412. PCOPY 0, 1: SCREEN 0, 0, 1, 0: LOCATE yy%, xx%, 0, 7, 0
  413. IF imotiondir = 0 THEN imotion = imotion - 1 ELSE imotion = imotion + 1
  414. COLOR 7, ibk
  415.  
  416. FOR i = imaxalienforce TO 1 STEP -1
  417.     IF RTRIM$(a(i)) <> "" THEN
  418.         i2 = i2 + 2
  419.         SOUND 400, .03
  420.         ialiencol = ialiencolstat + imotion
  421.         LOCATE ileadingmax - (imaxalienforce - i) * 2, ialiencol + INSTR(a(i), "-")
  422.         IF POS(1) = lmargin% THEN imarch = 1
  423.         iltalien(i) = POS(1)
  424.         IF imotiondir = 0 THEN
  425.             PRINT LTRIM$(RTRIM$(a(i))); " "
  426.         ELSE
  427.             LOCATE , POS(1) - 1
  428.             PRINT " "; LTRIM$(RTRIM$(a(i)))
  429.         END IF
  430.         IF ialiencol + LEN(RTRIM$(a(i))) = screenwidth% THEN imarch = -1
  431.     END IF
  432.  
  433. IF imarch = 1 THEN imotiondir = 1: CALL marchdown(ialiencol, ialiencolstat, imotion, iresults)
  434. IF imarch = -1 THEN imotiondir = 0: CALL marchdown(ialiencol, ialiencolstat, imotion, iresults)
  435. IF imarch = 0 THEN
  436.     IF ABS(TIMER - z2alienfire) > firerate THEN
  437.         firerate = (INT(RND * 10) + 1) / 20
  438.         IF iwait = 0 THEN CALL alienattack(ialiencolstat, ialiencol)
  439.     END IF
  440.     imarch = 0
  441. PCOPY 1, 0: SCREEN 0, 0, 0, 0
  442. LOCATE irow, icol, 1, 7, 7
  443.  
  444. SUB mship (imothership)
  445. STATIC x%, mov%, z4, mothership$
  446.  
  447. yy% = CSRLIN: xx% = POS(1): COLOR 7, ibk
  448. IF imothership = -1 THEN
  449.     imothership = 1
  450.     x% = lmargin%
  451.     mothership$ = CHR$(254) + CHR$(254) + "O" + CHR$(254) + CHR$(254)
  452.     mov% = 1
  453.  
  454. IF ABS(TIMER - z4) > .05 THEN GOSUB mothership: z4 = TIMER: LOCATE yy%, xx%: EXIT SUB
  455. ''IF ABS(TIMER - z2) > .2 THEN GOSUB bullets: z2 = TIMER
  456. LOCATE yy%, xx%
  457.  
  458. mothership:
  459. IF x% + LEN(mothership$) = screenwidth% + lmargin% THEN mov% = -1 ELSE IF x% = lmargin% THEN mov% = 1
  460. x% = x% + mov%
  461. LOCATE topmargin%, x%
  462. PRINT mothership$;
  463. IF x% > 1 AND mov% = 1 THEN
  464.     LOCATE , POS(1) - LEN(mothership$) - 1: PRINT " ";
  465. IF mov% = -1 THEN PRINT " ";
  466.  
  467.  
  468. DEFINT A-H, J-Z
  469. SUB qbide
  470. PALETTE 2, 59
  471. COLOR 15, 1
  472.  
  473. COLOR 0, 7
  474. LOCATE 1, 1
  475. LOCATE 1, 1: PRINT "   File  Edit  View  Search  Run  Debug  Calls  Options                   Help"
  476.  
  477. COLOR 7, 1
  478.  
  479. LOCATE 2, 1: PRINT CHR$(218)
  480. LOCATE 2, 2: PRINT STRING$(78, CHR$(196))
  481. LOCATE 2, 80: PRINT CHR$(191)
  482.  
  483. LOCATE 2, 76: PRINT CHR$(180)
  484. LOCATE 2, 78: PRINT CHR$(195)
  485.  
  486. COLOR 1, 7
  487. LOCATE 2, 77: PRINT CHR$(24)
  488. LOCATE 2, 36: PRINT " Untitled "
  489.  
  490. COLOR 7, 1
  491. FOR Rows = 3 TO 24
  492.     LOCATE Rows, 1: PRINT CHR$(179);
  493.     LOCATE Rows, 80: PRINT CHR$(179);
  494. NEXT Rows
  495.  
  496. LOCATE 22, 1: PRINT CHR$(195)
  497. LOCATE 22, 80: PRINT CHR$(180)
  498. LOCATE 22, 2: PRINT STRING$(78, CHR$(196))
  499. LOCATE 22, 35
  500. PRINT " Immediate "
  501.  
  502. COLOR 0, 7
  503. LOCATE 21, 3: PRINT STRING$(76, CHR$(176))
  504. LOCATE 21, 2: PRINT CHR$(27)
  505. LOCATE 21, 3: PRINT CHR$(219)
  506. LOCATE 21, 79: PRINT CHR$(26)
  507. FOR Rows = 4 TO 19
  508.     LOCATE Rows, 80: PRINT CHR$(176)
  509. NEXT Rows
  510. LOCATE 3, 80: PRINT CHR$(24)
  511. LOCATE 4, 80: PRINT CHR$(219)
  512. LOCATE 20, 80: PRINT CHR$(25)
  513.  
  514. COLOR 0, 3: LOCATE 25, 1: PRINT " <Shift+F1=Help> <F6=Window> <F2=Subs> <F5=Run> <F8=Step> ";
  515. LOCATE 25, 59: PRINT SPACE$(4);
  516. COLOR 0, 3
  517. LOCATE 25, 63: PRINT CHR$(179);
  518. LOCATE 25, 64: PRINT SPACE$(6);
  519. LOCATE 25, 68: PRINT "C  00001:001 ";
  520.  
  521.  
  522. DEFSNG A-H, J-Z
  523. SUB reprintaliens (ialiencol, ihitaliens, iresults, i4, i, imothership)
  524. IF ihitaliens > 0 THEN
  525.     ihits = ihits + 1
  526.     IF (ihits + 15) MOD 20 = 0 AND imothership = 0 THEN imothership = -1
  527.     LOCATE bullet%(i), lmargin%: PRINT SPACE$(screenwidth%);
  528.     iltalien(i4) = POS(1)
  529.  
  530.     IF RTRIM$(a(i4)) = "" THEN
  531.         alienforce% = alienforce% - 1
  532.         IF alienforce% = 0 THEN iresults = iresults + 1
  533.         IF bullet%(i) = ileadingrow THEN ileadingrow = ileadingrow - 2
  534.     ELSE
  535.         LOCATE bullet%(i), ialiencol + INSTR(a(i4), "-"): PRINT LTRIM$(RTRIM$(a(i4)))
  536.     END IF
  537.     i2 = ABS(ihitaliens)
  538.     LOCATE iy(i2), ix(i2)
  539.     PRINT " ";: iy(i2) = 0
  540.     ia(i2) = 0
  541.     LOCATE irow, icol
  542.     SOUND 1000, .5
  543.  
  544. ihitaliens = 0
  545. bullet%(i) = -bullet%(i)
  546.  
  547. COLOR 0, 3
  548. yy% = CSRLIN: xx% = POS(1)
  549. LOCATE 25, 76 - LEN(LTRIM$(STR$(ihits)))
  550. PRINT LTRIM$(STR$(ihits));
  551. LOCATE 25, 80 - LEN(LTRIM$(STR$(imaxalienforce - alienforce%)))
  552. PRINT LTRIM$(STR$(imaxalienforce - alienforce%));
  553. LOCATE yy%, xx%
  554. COLOR 7, ibk
  555.  
  556.  

Use mouse and space bar. I don't think I programmed in any arrow keys.

Pete :D
« Last Edit: May 20, 2019, 12:04:50 am by Pete »
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/

Offline Ashish

  • Forum Resident
  • Posts: 630
  • Never Give Up!
Re: Happy St Patrick's Day
« Reply #11 on: March 08, 2018, 02:54:28 am »
Looks cool!
if (Me.success) {Me.improve()} else {Me.tryAgain()}


My Projects - https://github.com/AshishKingdom?tab=repositories
OpenGL tutorials - https://ashishkingdom.github.io/OpenGL-Tutorials

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
Re: Happy St Patrick's Day
« Reply #12 on: March 08, 2018, 06:01:35 pm »
OK so someone on another forum asks for Lucky 4 Leafer Shamrock.

I said why stop at 4? and made a game for Petr's kid:
Code: QB64: [Select]
  1. _TITLE "N Leafed Shamrocks, How Lucky Are You? (Find the 7 Leafer when this stops drawing.)   by bplus 2018-03-08"
  2. ' from
  3. ' Draw Angled Heart.bas SmallBASIC 0.12.11 (B+=MGA) 2018-03-07
  4. CONST xmax = 1280
  5. CONST ymax = 740
  6. SCREEN _NEWIMAGE(xmax, ymax, 32)
  7.  
  8.  
  9. WHILE nLeafs < 7
  10.     IF RND < .2 THEN
  11.         IF RND < .2 THEN
  12.             IF RND < .2 THEN
  13.                 IF RND < .2 THEN
  14.                     nLeafs = 7
  15.                 ELSE
  16.                     nLeafs = 6
  17.                 END IF
  18.             ELSE
  19.                 nLeafs = 5
  20.             END IF
  21.         ELSE
  22.             nLeafs = 4
  23.         END IF
  24.     ELSE
  25.         nLeafs = 3
  26.     END IF
  27.  
  28.     cc1&& = _RGB32(0, RND * 100 + 50, 0)
  29.     cc2&& = _RGB32(0, RND * 100 + 50, 0)
  30.     xp = RND * (xmax - 100) + 50
  31.     yp = RND * (ymax - 100) + 50
  32.     size = INT(RND * 40) + 10
  33.     ang = RND * _PI(2)
  34.     COLOR cc1&&
  35.     FOR r = 1 TO size STEP .3
  36.         drawShamrockN xp + 1, yp, r, ang, nLeafs
  37.         drawShamrockN xp - 1, yp, r, ang, nLeafs
  38.         drawShamrockN xp, yp + 1, r, ang, nLeafs
  39.         drawShamrockN xp, yp - 1, r, ang, nLeafs
  40.         drawShamrockN xp + 1, yp + 1, r, ang, nLeafs
  41.     NEXT
  42.     COLOR cc2&&
  43.     FOR r = 1 TO size STEP 1
  44.         drawShamrockN xp, yp, r, ang, nLeafs
  45.     NEXT
  46.     ns = ns + 1
  47.     _TITLE STR$(ns) + " N Leafed Shamrocks, How Lucky Are You? (Find the 7 Leafer when this stops drawing.)   by bplus 2018-03-08"
  48.     _DISPLAY
  49.     _LIMIT 20
  50.  
  51.  
  52. 'draws an arc with center at xCenter, yCenter, radius from center is arcRadius
  53. SUB myArc (xCenter, yCenter, arcRadius, dAStart, dAMeasure)
  54.     'notes:
  55.     'you may want to adjust size and color for line drawing
  56.     'using angle measures in degrees to match Just Basic ways with pie and piefilled
  57.     'this sub assumes drawing in a CW direction if dAMeasure positive
  58.  
  59.     'for Just Basic angle 0 degrees is due East and angle increases clockwise towards South
  60.  
  61.     'dAStart is degrees to start Angle, due East is 0 degrees
  62.  
  63.     'dAMeasure is degrees added (Clockwise) to dAstart for end of arc
  64.  
  65.     rAngleStart = RAD(dAStart)
  66.     rAngleEnd = RAD(dAMeasure) + rAngleStart
  67.     Stepper = RAD(1 / (.1 * arcRadius)) 'fixed
  68.     FOR rAngle = rAngleStart TO rAngleEnd STEP Stepper
  69.         IF rAngle = rAngleStart THEN
  70.             lastX = xCenter + arcRadius * COS(rAngle)
  71.             lastY = yCenter + arcRadius * SIN(rAngle)
  72.         ELSE
  73.             nextX = xCenter + arcRadius * COS(rAngle)
  74.             IF nextX <= lastX THEN useX = nextX - 1 ELSE useX = nextX + 1
  75.             nextY = yCenter + arcRadius * SIN(rAngle)
  76.             IF nextY <= lastY THEN useY = nextY - 1 ELSE useY = nextY + 1
  77.             LINE (lastX, lastY)-(nextX, nextY)
  78.             lastX = nextX
  79.             lastY = nextY
  80.         END IF
  81.     NEXT
  82.  
  83. FUNCTION RAD (a)
  84.     RAD = _PI(a / 180)
  85.  
  86. FUNCTION DEG (a)
  87.     DEG = a * 180 / _PI
  88.  
  89.  
  90. SUB drawSqueezedHeart (x, y, r, rl, a)
  91.     'local x1, x2, x3, x4, x5, x6, y1, y2, y3, y4, y5, y6
  92.     'clockwise from due East, the V
  93.     x1 = x + r * COS(a)
  94.     y1 = y + r * SIN(a)
  95.     x2 = x + rl * COS(a + _PI / 2)
  96.     y2 = y + rl * SIN(a + _PI / 2)
  97.     x3 = x + r * COS(a + _PI)
  98.     y3 = y + r * SIN(a + _PI)
  99.     x4 = x + r * COS(a + 3 * _PI / 2)
  100.     y4 = y + r * SIN(a + 3 * _PI / 2)
  101.     x5 = (x3 + x4) / 2
  102.     y5 = (y3 + y4) / 2
  103.     x6 = (x4 + x1) / 2
  104.     y6 = (y4 + y1) / 2
  105.     LINE (x1, y1)-(x2, y2)
  106.     LINE (x2, y2)-(x3, y3)
  107.     'left hump
  108.     myArc x5, y5, .5 * r * 2 ^ .5, DEG(a) + 135, 180
  109.     'right hump
  110.     myArc x6, y6, .5 * r * 2 ^ .5, DEG(a) + 225, 180
  111.  
  112. SUB drawShamrockN (x, y, r, a, nLeafed)
  113.     'local bigR, x1, x2, x3, y1, y2, y3
  114.     np1 = nLeafed + 1
  115.     noLeaf = INT(np1 / 2)
  116.     bigR = 2.2 * r * np1 / (2 * _PI)
  117.     IF nLeafed MOD 2 = 0 THEN aoff = _PI / np1
  118.     FOR leaf = 0 TO nLeafed
  119.         IF leaf <> noLeaf THEN
  120.             x1 = x + bigR * COS(a + leaf * 2 * _PI / np1 + 3 * _PI / 2 + aoff)
  121.             y1 = y + bigR * SIN(a + leaf * 2 * _PI / np1 + 3 * _PI / 2 + aoff)
  122.             drawSqueezedHeart x1, y1, r, bigR, a + leaf * 2 * _PI / np1 + aoff
  123.         END IF
  124.     NEXT
  125.  
  126.  

N Leafed Shamrocks.PNG
* N Leafed Shamrocks.PNG (Filesize: 238.49 KB, Dimensions: 1075x761, Views: 255)

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
Re: Happy St Patrick's Day
« Reply #13 on: March 08, 2018, 06:16:52 pm »
Really? It's the last one printed. That took a while. In the meantime, someone polished off my unattended bowl of Lucky Charms. That was tragically malicious.

Pete :D
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
Re: Happy St Patrick's Day
« Reply #14 on: March 09, 2018, 10:16:14 pm »
A makeover of the Shamrock Luck code from lessons learned improving the JB version with tsh73 tips.
On the surface, the leaves are spread out more evenly and the title bar runs stats on the leaf counts.
The code now draws a solid Shamrock shape in one go and then draws contour line leaf details.
Code: QB64: [Select]
  1. _TITLE "N Leafed Shamrocks, How many shamrocks until you get a 7 leafed one?    by bplus 2018-03-09"
  2. ' Shamrock 2018-03-09 mod to lessons learned with JB version 2018-03-09 tsh tips
  3. ' from N Leafed Shamrocks 2018-03-08
  4. ' Draw Angled Heart.bas SmallBASIC 0.12.11 (B+=MGA) 2018-03-07
  5. CONST xmax = 1280
  6. CONST ymax = 740
  7. SCREEN _NEWIMAGE(xmax, ymax, 32)
  8. DIM counts(7)
  9. CLS , _RGB32(60, 30, 15)
  10. WHILE nLeafs < 7
  11.     luck = RND
  12.     SELECT CASE luck
  13.         CASE IS < 1 / 625: nLeafs = 7
  14.         CASE IS < 1 / 125: nLeafs = 6
  15.         CASE IS < 1 / 25: nLeafs = 5
  16.         CASE IS < 1 / 5: nLeafs = 4
  17.         CASE ELSE: nLeafs = 3
  18.     END SELECT
  19.     counts(nLeafs) = counts(nLeafs) + 1
  20.     counts(1) = counts(1) + 1
  21.     stat$ = STR$(counts(3))
  22.     FOR i = 4 TO 7
  23.         stat$ = stat$ + " :" + STR$(counts(i))
  24.     NEXT
  25.     stat$ = stat$ + " =" + STR$(counts(1))
  26.     _TITLE stat$ + " N Leafed Shamrocks, How many shamrocks until you get a 7 leafed one? (1 in 625 chance)  by bplus 2018-03-09"
  27.     cc1% = RND * 100 + 50
  28.     cc2% = RND * 100 + 50
  29.     WHILE ABS(cc1% - cc2%) < 30 'for contrast of 2 colors
  30.         cc2% = RND * 100 + 50
  31.     WEND
  32.     xp = RND * (xmax - 100) + 50
  33.     yp = RND * (ymax - 100) + 50
  34.     size = INT(RND * 40) + 10
  35.     ang = RND * _PI(2)
  36.     COLOR _RGB32(0, cc1%, 0)
  37.     drawShamrockN xp + 1, yp, size, ang, nLeafs, 1
  38.     COLOR _RGB32(0, cc2%, 0)
  39.     FOR r = 1 TO size STEP 1
  40.         drawShamrockN xp, yp, r, ang, nLeafs, 0
  41.     NEXT
  42.     _DISPLAY
  43.     _LIMIT 10
  44.  
  45. 'draws an arc with center at xCenter, yCenter, radius from center is arcRadius
  46. SUB myArc (xCenter, yCenter, arcRadius, dAStart, dAMeasure)
  47.     'notes:
  48.     'you may want to adjust size and color for line drawing
  49.     'using angle measures in degrees to match Just Basic ways with pie and piefilled
  50.     'this sub assumes drawing in a CW direction if dAMeasure positive
  51.  
  52.     'for Just Basic angle 0 degrees is due East and angle increases clockwise towards South
  53.  
  54.     'dAStart is degrees to start Angle, due East is 0 degrees
  55.  
  56.     'dAMeasure is degrees added (Clockwise) to dAstart for end of arc
  57.  
  58.     rAngleStart = RAD(dAStart)
  59.     rAngleEnd = RAD(dAMeasure) + rAngleStart
  60.     Stepper = RAD(1 / (.1 * arcRadius)) 'fixed
  61.     FOR rAngle = rAngleStart TO rAngleEnd STEP Stepper
  62.         IF rAngle = rAngleStart THEN
  63.             lastX = xCenter + arcRadius * COS(rAngle)
  64.             lastY = yCenter + arcRadius * SIN(rAngle)
  65.         ELSE
  66.             nextX = xCenter + arcRadius * COS(rAngle)
  67.             IF nextX <= lastX THEN useX = nextX - 1 ELSE useX = nextX + 1
  68.             nextY = yCenter + arcRadius * SIN(rAngle)
  69.             IF nextY <= lastY THEN useY = nextY - 1 ELSE useY = nextY + 1
  70.             LINE (lastX, lastY)-(nextX, nextY)
  71.             lastX = nextX
  72.             lastY = nextY
  73.         END IF
  74.     NEXT
  75.  
  76. FUNCTION RAD (a)
  77.     RAD = _PI(a / 180)
  78.  
  79. FUNCTION DEG (a)
  80.     DEG = a * 180 / _PI
  81.  
  82. SUB drawHeart (x, y, r, rl, a, solid)
  83.     'local x1, x2, x3, x4, x5, x6, y1, y2, y3, y4, y5, y6
  84.     'clockwise from due East, the V
  85.     x1 = x + r * COS(a)
  86.     y1 = y + r * SIN(a)
  87.     x2 = x + rl * COS(a + _PI / 2)
  88.     y2 = y + rl * SIN(a + _PI / 2)
  89.     x3 = x + r * COS(a + _PI)
  90.     y3 = y + r * SIN(a + _PI)
  91.     x4 = x + r * COS(a + 3 * _PI / 2)
  92.     y4 = y + r * SIN(a + 3 * _PI / 2)
  93.     x5 = (x3 + x4) / 2
  94.     y5 = (y3 + y4) / 2
  95.     x6 = (x4 + x1) / 2
  96.     y6 = (y4 + y1) / 2
  97.     IF solid THEN
  98.         filltri x1, y1, x2, y2, x3, y3
  99.         filltri x2, y2, x3, y3, x4, y4
  100.         fcirc x5, y5, .5 * r * 2 ^ .5
  101.         fcirc x6, y6, .5 * r * 2 ^ .5
  102.     ELSE
  103.         LINE (x1, y1)-(x2, y2)
  104.         LINE (x2, y2)-(x3, y3)
  105.         'left hump
  106.         myArc x5, y5, .5 * r * 2 ^ .5, DEG(a) + 135, 180
  107.         'right hump
  108.         myArc x6, y6, .5 * r * 2 ^ .5, DEG(a) + 225, 180
  109.     END IF
  110.  
  111. SUB drawShamrockN (x, y, r, a, nLeafed, solid)
  112.     bigR = 2.05 * r * nLeafed / (2 * _PI) '<<<<<<<<<<<< EDIT for fuller leaves
  113.     FOR leaf = 0 TO nLeafed - 1
  114.         x1 = x + bigR * COS(a + leaf * 2 * _PI / nLeafed + 3 * _PI / 2)
  115.         y1 = y + bigR * SIN(a + leaf * 2 * _PI / nLeafed + 3 * _PI / 2)
  116.         drawHeart x1, y1, r, bigR, a + leaf * 2 * _PI / nLeafed, solid
  117.     NEXT
  118.  
  119. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
  120. SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
  121.     DIM subRadius AS LONG, RadiusError AS LONG
  122.     DIM X AS LONG, Y AS LONG
  123.  
  124.     subRadius = ABS(R)
  125.     RadiusError = -subRadius
  126.     X = subRadius
  127.     Y = 0
  128.  
  129.     IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
  130.  
  131.     ' Draw the middle span here so we don't draw it twice in the main loop,
  132.     ' which would be a problem with blending turned on.
  133.     LINE (CX - X, CY)-(CX + X, CY), , BF
  134.  
  135.     WHILE X > Y
  136.         RadiusError = RadiusError + Y * 2 + 1
  137.         IF RadiusError >= 0 THEN
  138.             IF X <> Y + 1 THEN
  139.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
  140.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
  141.             END IF
  142.             X = X - 1
  143.             RadiusError = RadiusError - X * 2
  144.         END IF
  145.         Y = Y + 1
  146.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
  147.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
  148.     WEND
  149.  
  150. SUB filltri (xx1, yy1, xx2, yy2, xx3, yy3)
  151.     'make copies before swapping
  152.     x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
  153.     'thanks Andy Amaya!
  154.     'triangle coordinates must be ordered: where x1 < x2 < x3
  155.     IF x2 < x1 THEN SWAP x1, x2: SWAP y1, y2
  156.     IF x3 < x1 THEN SWAP x1, x3: SWAP y1, y3
  157.     IF x3 < x2 THEN SWAP x2, x3: SWAP y2, y3
  158.     IF x1 <> x3 THEN slope1 = (y3 - y1) / (x3 - x1)
  159.  
  160.     'draw the first half of the triangle
  161.     length = x2 - x1
  162.     IF length <> 0 THEN
  163.         slope2 = (y2 - y1) / (x2 - x1)
  164.         FOR x = 0 TO length
  165.             LINE (INT(x + x1), INT(x * slope1 + y1))-(INT(x + x1), INT(x * slope2 + y1))
  166.             'lastx2% = lastx%
  167.             lastx% = INT(x + x1)
  168.         NEXT
  169.     END IF
  170.  
  171.     'draw the second half of the triangle
  172.     y = length * slope1 + y1: length = x3 - x2
  173.     IF length <> 0 THEN
  174.         slope3 = (y3 - y2) / (x3 - x2)
  175.         FOR x = 0 TO length
  176.             'IF INT(x + x2) <> lastx% AND INT(x + x2) <> lastx2% THEN  'works! but need 2nd? check
  177.             IF INT(x + x2) <> lastx% THEN
  178.                 LINE (INT(x + x2), INT(x * slope1 + y))-(INT(x + x2), INT(x * slope3 + y2))
  179.             END IF
  180.         NEXT
  181.     END IF
  182.  
  183.  

I had my best and worst Shamrock Luck counts one right after the other, law of averages?

EDIT: 2018-03-10 changed one line to get fuller leaves.
4 shamrocks!.PNG
* 4 shamrocks!.PNG (Filesize: 41.02 KB, Dimensions: 1159x721, Views: 235)
1588 Shamrocks.PNG
* 1588 Shamrocks.PNG (Filesize: 324.48 KB, Dimensions: 1282x768, Views: 246)
« Last Edit: March 10, 2018, 07:42:59 am by bplus »