RetroBASIC
Basicprogramming(.org) => Code and examples => Topic started by: B+ on November 30, 2018, 05:15:41 PM
-
_TITLE "Christmas Star Tree" 'B+ for QB64 2018-11-30
RANDOMIZE TIMER
CONST xmax = 1280
CONST ymax = 720
COMMON SHARED cN, pR, pG, Plasma AS _UNSIGNED LONG
'for Plasma writing
DIM SHARED maxIndex AS INTEGER
maxIndex = 3200
REDIM SHARED xyDat%(maxIndex, 1)
DIM SHARED cNw, pRw, pGw, pBw, indexP, DOTi
loadPlasmaData
resetPlasmaWrite
SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 75, 5
'begin drawing background stars&
stars& = _NEWIMAGE(xmax, ymax, 32)
_DEST stars&
FOR i = 0 TO ymax - 80 ' sky
LINE (0, i)-(xmax, i), _RGB32(50, 0, i / ymax * 68)
NEXT
FOR s = 1 TO 100 ' stars
c = rand(155, 255)
COLOR _RGBA32(c, c, c, RND * 100 + 155)
fcirc RND * xmax, rand(0, 520), rand(0, 3)
NEXT
FOR i = ymax - 80 TO ymax 'ground
LINE (0, i)-(xmax, i), _RGB32(50, 30, 20)
NEXT
' setup for main screen
_DEST 0
midx = 400
starCenterY = 30
maxd = ((ymax - starCenterY) ^ 2 + (midx - xmax) ^ 2) ^ .5
ofs = 0
dir = 1
DO WHILE _KEYDOWN(27) = 0 'main loop
'update message
_DEST stars&
changePlasmaWrite
DOTi = DOTi + 1
IF DOTi <= indexP THEN fcirc xyDat%(DOTi, 0), xyDat%(DOTi, 1), 10
'show update
_DEST 0
_PUTIMAGE , stars&, 0
'main star over tree
resetPlasma
FOR a = 0 TO _PI(2) STEP _PI(1 / 36)
IF a = 0 THEN
lastx = midx + maxd * COS(a)
lasty = starCenterY + maxd * SIN(a)
ELSE
x1 = midx + maxd * COS(a)
y1 = starCenterY + maxd * SIN(a)
changePlasma
ftri midx, starCenterY, lastx, lasty, x1, y1, Plasma
lastx = x1: lasty = y1
END IF
NEXT
FOR R = 25 TO 0 STEP -1
COLOR _RGBA(255, 255, 205, (25 - R) ^ 2 / 2.5)
fcirc midx, starCenterY, R
NEXT
'tree
stepper = stepper + dir
IF stepper > 75 THEN dir = dir * -1: stepper = 75
IF stepper < 14 THEN dir = dir * -1: stepper = 14
FOR y = 80 TO ymax - 20 STEP stepper
star midx, y, 5 + .1 * y, 15 + .5 * y, 6, ofs + _PI(y / 720)
NEXT
_DISPLAY
ofs = ofs + _PI(1 / 36)
IF ofs > _PI(2) THEN ofs = 0
_LIMIT 8
LOOP
SUB changePlasma ()
cN = cN + 1
Plasma = _RGBA(200 + 56 * SIN(pR * cN), 200 + 56 * SIN(pG * cN), 128, RND * 64 + 30)
END SUB
SUB resetPlasma ()
pR = RND ^ 2: pG = RND ^ 2
END SUB
SUB ftri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
a& = _NEWIMAGE(1, 1, 32)
_DEST a&
PSET (0, 0), K
_DEST 0
_MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
_FREEIMAGE a& '<<< this is important!
END SUB
SUB fatLine (x1, y1, x2, y2)
stepx = x2 - x1: stepy = y2 - y1
length = INT((stepx ^ 2 + stepy ^ 2) ^ .5)
IF length THEN
dx = stepx / length: dy = stepy / length
FOR i = 0 TO length
CIRCLE (x1 + dx * i, y1 + dy * i), 5
NEXT
END IF
END SUB
SUB star (x, y, rInner, rOuter, nPoints, angleOffset)
' x, y are same as for circle,
' rInner is center circle radius
' rOuter is the outer most point of star
' nPoints is the number of points,
' angleOffset = angle offset in radians
' this is to allow us to spin the star
'modified a bit for stacking up a tree
DIM ar(INT(nPoints) * 4 + 3) 'add two for origin
pAngle = _PI(2) / nPoints: radAngleOffset = angleOffset - _PI(1 / 2)
x1 = x + rOuter * COS(radAngleOffset)
y1 = y + .2 * rOuter * SIN(radAngleOffset)
idx = 4
FOR i = 0 TO nPoints - 1
x2 = x + rInner * COS(i * pAngle + radAngleOffset + .5 * pAngle)
y2 = y + .2 * rInner * SIN(i * pAngle + radAngleOffset + .5 * pAngle)
COLOR _RGB32(rand(0, 40), rand(40, 120), rand(0, 35))
fatLine x1, y1, x2, y2
x1 = x2
y1 = y2
x2 = x + rOuter * COS((i + 1) * pAngle + radAngleOffset)
y2 = y + .2 * rOuter * SIN((i + 1) * pAngle + radAngleOffset)
COLOR _RGB32(rand(0, 40), rand(40, 120), rand(0, 35))
fatLine x1, y1, x2, y2
x1 = x2
y1 = y2
NEXT
END SUB
FUNCTION rand% (lo%, hi%)
rand% = INT(RND * (hi% - lo% + 1)) + lo%
END FUNCTION
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
DIM subRadius AS LONG, RadiusError AS LONG
DIM X AS LONG, Y AS LONG
subRadius = ABS(R)
RadiusError = -subRadius
X = subRadius
Y = 0
IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
LINE (CX - X, CY)-(CX + X, CY), , BF
WHILE X > Y
RadiusError = RadiusError + Y * 2 + 1
IF RadiusError >= 0 THEN
IF X <> Y + 1 THEN
LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
END IF
X = X - 1
RadiusError = RadiusError - X * 2
END IF
Y = Y + 1
LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
WEND
END SUB
'separatePlasma for writing than main star
SUB changePlasmaWrite ()
cNw = cNw + .5
COLOR _RGB(127 + 127 * SIN(pRw * cNw), 127 + 127 * SIN(pGw * cNw), 127 + 127 * SIN(pBw * cNw))
END SUB
SUB resetPlasmaWrite ()
pRw = RND ^ 2: pGw = RND ^ 2: pBw = RND ^ 2
END SUB
SUB loadPlasmaData
indexP = 0
WHILE dx <> 9999
READ dx, dy
IF dx <> 9999 THEN xyDat%(indexP, 0) = dx: xyDat%(indexP, 1) = dy: indexP = indexP + 1
WEND
END SUB
DATA 877,65,877,65,877,65,877,65,877,65,877,67,877,70,877,74,877,79,878,85
DATA 878,89,878,95,879,100,881,105,881,111,881,116,882,120,882,122,883,126,883,131
DATA 883,135,883,140,883,144,883,148,883,153,883,159,883,164,883,166,883,177,883,179
DATA 883,183,883,188,884,191,884,194,884,197,884,201,884,203,884,205,884,207,884,208
DATA 884,210,884,211,883,211,883,211,878,211,874,211,859,210,853,210,843,210,840,210
DATA 828,211,824,211,817,211,806,210,799,209,797,208,795,207,795,207,795,207,795,207
DATA 795,207,795,207,795,207,795,207,795,207,795,207,795,207,795,207,795,207,795,207
DATA 795,207,795,207,795,207,795,207,943,154,942,154,940,156,938,159,937,162,936,164
DATA 935,167,935,170,934,173,934,174,934,177,934,179,934,183,935,186,937,189,937,192
DATA 938,195,939,197,939,199,940,200,940,201,941,202,941,203,942,203,943,203,943,204
DATA 944,204,945,204,945,204,948,205,949,205,952,206,956,206,962,206,966,206,968,205
DATA 969,205,970,203,972,201,974,200,976,199,978,198,978,197,979,196,980,194,980,192
DATA 980,190,980,186,980,183,980,182,980,181,980,180,980,179,980,178,980,177,978,175
DATA 977,173,975,171,974,169,971,167,970,166,968,165,968,165,968,165,968,164,968,164
DATA 967,164,965,163,963,163,962,162,962,161,961,161,961,161,961,161,960,161,960,161
DATA 960,161,960,161,960,161,960,161,960,161,960,161,960,161,960,161,960,161,960,161
DATA 960,161,960,161,960,161,960,161,960,161,960,161,960,161,960,161,960,161,1020,159
DATA 1020,159,1020,159,1020,159,1020,159,1020,159,1020,162,1020,166,1021,172,1022,173,1024,178
DATA 1026,180,1027,185,1028,188,1029,190,1030,192,1031,193,1031,195,1032,196,1033,197,1034,199
DATA 1034,201,1036,203,1036,204,1037,205,1037,205,1037,205,1037,205,1037,205,1037,205,1037,205
DATA 1037,205,1037,205,1037,205,1037,205,1037,205,1037,205,1037,205,1037,205,1037,205,1037,205
DATA 1037,205,1037,205,1037,205,1037,205,1038,205,1038,204,1039,203,1040,200,1040,198,1041,195
DATA 1042,192,1043,188,1044,187,1046,181,1046,180,1047,176,1047,175,1049,171,1051,169,1051,168
DATA 1052,167,1052,166,1052,165,1053,164,1053,164,1053,163,1054,162,1055,161,1055,160,1055,159
DATA 1055,158,1055,157,1056,157,1056,156,1056,155,1056,154,1056,154,1057,153,1057,153,1057,153
DATA 1057,153,1057,153,1057,153,1057,153,1057,153,1057,153,1057,153,1057,153,1057,153,1036,204
DATA 1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204
DATA 1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204
DATA 1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204,1036,204
DATA 1036,204,1036,204,1036,204,1035,207,1035,209,1035,211,1035,214,1034,218,1034,221,1033,225
DATA 1032,229,1031,234,1030,237,1029,241,1028,243,1028,245,1028,246,1027,247,1026,249,1026,250
DATA 1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251
DATA 1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251
DATA 1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251,1026,251
DATA 1026,251,1026,251,1025,252,1024,254,1024,256,1024,257,1024,257,1024,257,1024,257,1024,257
DATA 1024,257,1024,257,1024,257,1024,257,1024,257,1024,257,1024,257,1024,257,1024,257,1024,257
DATA 1024,257,1024,257,843,318,843,318,843,318,843,318,843,318,843,318,843,318,843,318
DATA 843,319,843,319,844,323,845,325,845,334,846,341,846,350,847,363,848,375,848,387
DATA 849,400,850,405,850,408,851,411,851,413,851,414,851,414,851,414,851,414,851,414
DATA 851,414,851,414,851,416,851,416,851,416,851,416,851,416,851,416,831,375,831,375
DATA 831,375,831,375,831,375,831,375,831,375,831,375,832,375,835,375,850,375,866,375
DATA 883,375,891,375,894,375,898,375,899,375,899,375,899,375,899,375,900,375,900,375
DATA 900,375,900,375,900,375,900,375,900,375,900,375,900,375,900,375,931,374,931,374
DATA 931,374,928,377,927,380,924,384,922,387,921,389,921,391,921,394,921,394,923,397
DATA 924,398,924,399,925,400,927,402,928,404,929,405,930,406,930,407,930,407,930,407
DATA 931,407,931,407,933,407,941,405,944,404,946,402,947,401,948,399,948,398,948,397
DATA 948,397,949,395,949,394,949,393,949,392,949,391,949,390,949,389,949,388,949,387
DATA 949,385,949,383,949,383,949,381,948,380,947,380,947,380,947,380,947,380,947,380
DATA 947,380,947,380,947,380,947,380,947,380,947,380,947,380,947,380,947,380,1023,303
DATA 1023,303,1023,303,1022,306,1022,309,1022,314,1022,318,1023,323,1024,332,1025,341,1026,350
DATA 1026,356,1026,361,1027,369,1028,371,1028,373,1028,375,1028,377,1028,380,1028,383,1028,386
DATA 1028,388,1028,391,1028,392,1028,393,1029,393,1029,393,1029,393,1029,393,1029,393,1029,393
DATA 1029,393,1029,393,1029,393,1029,393,1029,393,1029,393,1029,393,1029,395,1029,397,1030,398
DATA 1030,398,1030,398,1030,398,1030,398,1030,398,1030,400,1030,401,1030,403,1030,404,1030,404
DATA 1030,404,1030,404,1030,404,1030,405,1030,405,1030,405,1030,405,1030,405,1030,405,1030,405
DATA 997,352,997,352,997,352,997,352,997,352,997,352,997,352,997,352,997,352,998,352
DATA 1003,352,1011,353,1023,353,1028,352,1030,351,1031,351,1031,351,1031,351,1031,351,1031,351
DATA 1031,351,1031,351,1031,351,1031,351,1031,351,1031,351,1031,351,1032,351,1032,351,1032,351
DATA 1032,351,1032,351,1032,351,1032,351,1032,351,1032,351,1032,351,1032,351,1032,351,1032,351
DATA 1032,351,1032,351,1032,351,1032,351,1032,351,1032,351,1032,351,1032,351,1033,351,1035,351
DATA 1036,350,1037,350,1037,350,1037,350,1038,350,1039,350,1040,350,1041,349,1042,349,1042,349
DATA 1042,349,1042,349,1042,349,1042,349,1042,349,1042,349,1042,349,1042,349,1059,296,1059,296
DATA 1059,296,1059,296,1059,296,1059,296,1059,298,1059,302,1059,305,1059,314,1059,321,1059,327
DATA 1059,333,1059,338,1059,343,1059,347,1059,351,1060,358,1060,364,1060,371,1060,378,1060,384
DATA 1061,389,1061,392,1061,396,1061,398,1062,402,1062,404,1062,404,1062,405,1062,405,1062,405
DATA 1062,405,1062,405,1062,405,1062,405,1062,405,1062,405,1062,405,1062,405,1062,405,1062,405
DATA 1062,405,1062,405,1062,405,1062,405,1062,399,1063,395,1063,391,1064,386,1064,383,1065,376
DATA 1066,370,1067,365,1069,361,1070,358,1072,354,1073,352,1074,351,1074,350,1075,349,1076,349
DATA 1077,348,1078,348,1079,348,1080,348,1081,348,1081,347,1081,347,1081,347,1081,347,1081,349
DATA 1083,352,1085,356,1087,361,1089,367,1090,369,1092,376,1094,378,1094,380,1094,381,1095,384
DATA 1095,386,1095,387,1095,388,1095,389,1095,389,1095,389,1095,389,1095,389,1095,389,1095,389
DATA 1095,389,1095,389,1095,389,1095,389,1095,389,1095,389,1096,391,1096,392,1096,392,1096,393
DATA 1097,393,1098,396,1099,397,1099,397,1099,398,1099,398,1099,398,1099,398,1099,398,1099,398
DATA 1099,398,1099,398,1099,398,1099,398,1099,398,1106,366,1106,366,1106,366,1106,366,1106,366
DATA 1106,366,1106,366,1106,366,1106,366,1106,366,1106,366,1106,366,1106,366,1106,366,1106,366
DATA 1106,366,1110,365,1111,364,1115,364,1118,363,1123,362,1124,362,1125,362,1126,362,1129,361
DATA 1133,360,1137,359,1141,357,1142,356,1142,356,1143,356,1143,354,1144,353,1145,352,1146,350
DATA 1146,349,1146,348,1146,347,1146,347,1146,347,1146,347,1146,347,1146,347,1146,347,1145,346
DATA 1141,345,1138,344,1137,344,1135,344,1134,344,1132,344,1129,346,1126,347,1122,348,1119,350
DATA 1117,351,1117,352,1116,353,1113,357,1111,360,1110,363,1109,366,1108,368,1107,372,1106,377
DATA 1106,378,1106,382,1106,384,1106,386,1106,388,1106,389,1106,390,1108,390,1108,391,1109,391
DATA 1114,392,1120,393,1129,393,1139,393,1147,393,1152,392,1158,391,1163,389,1164,389,1169,386
DATA 1172,385,1175,383,1176,383,1177,381,1177,381,1177,381,1177,381,1177,381,1177,381,1177,381
DATA 1177,381,1177,381,1177,381,1177,381,1177,381,1177,381,1177,381,1177,381,797,495,797,495
DATA 797,495,797,495,797,495,797,495,797,495,797,495,797,495,797,499,800,507,802,517
DATA 804,526,811,542,816,554,820,563,822,569,825,575,826,581,827,583,828,590,829,595
DATA 830,598,831,602,832,608,832,609,834,614,834,618,835,620,837,623,838,624,838,624
DATA 840,624,841,619,843,613,845,607,847,601,849,595,852,585,854,580,856,575,858,570
DATA 859,564,861,560,864,552,865,548,866,544,867,540,869,534,870,529,873,522,873,516
DATA 876,509,877,503,878,500,879,498,879,496,879,496,879,496,879,496,879,496,879,496
DATA 879,496,879,496,879,496,879,496,879,496,879,496,879,496,880,500,881,507,883,516
DATA 884,527,885,538,889,550,891,557,892,562,894,568,894,569,896,575,896,576,896,580
DATA 897,581,898,585,898,587,900,590,902,594,904,596,906,599,907,600,908,601,909,602
DATA 911,604,911,606,912,606,912,606,912,606,913,606,913,606,913,606,913,606,913,606
DATA 914,606,914,606,915,606,915,606,916,606,916,606,916,606,917,606,917,606,918,607
DATA 920,609,920,610,920,610,920,610,920,610,920,610,920,610,921,610,921,610,921,609
DATA 924,600,925,595,926,588,927,581,928,573,930,565,931,550,932,538,932,530,933,522
DATA 934,515,936,509,936,506,936,504,936,503,937,502,937,501,937,500,937,499,937,498
DATA 937,498,937,498,937,498,937,498,937,498,937,498,937,498,937,498,937,498,937,498
DATA 937,498,937,498,937,498,937,498,937,498,989,563,989,563,988,562,988,562,987,562
DATA 985,562,983,563,981,564,977,569,975,572,973,573,970,577,968,582,967,585,966,588
DATA 966,590,966,593,966,596,966,599,967,601,968,603,969,605,971,607,972,609,974,612
DATA 975,614,976,615,977,615,977,615,977,615,977,615,980,613,985,609,989,606,992,603
DATA 994,600,994,599,997,596,997,594,999,591,1000,590,1001,587,1003,584,1004,582,1004,580
DATA 1005,579,1005,577,1005,574,1005,573,1005,571,1005,570,1005,569,1005,568,1005,568,1005,567
DATA 1005,566,1005,566,1004,566,1004,566,1004,566,1004,566,1003,563,999,561,998,560,998,560
DATA 998,560,998,560,998,560,998,560,998,560,998,560,1028,562,1028,562,1028,562,1028,562
DATA 1027,562,1027,563,1027,564,1026,566,1026,567,1026,571,1026,574,1028,581,1030,585,1033,590
DATA 1035,594,1036,597,1037,599,1038,600,1038,600,1038,600,1038,600,1038,600,1038,600,1038,600
DATA 1038,600,1038,600,1038,599,1038,599,1038,599,1038,599,1038,597,1037,591,1036,589,1035,583
DATA 1035,581,1034,577,1034,575,1034,572,1034,568,1034,566,1034,564,1034,563,1034,561,1034,560
DATA 1035,560,1036,559,1037,558,1037,558,1037,558,1037,558,1037,558,1038,558,1038,557,1038,557
DATA 1041,557,1043,556,1044,555,1044,555,1044,555,1044,555,1044,555,1044,555,1044,555,1044,555
DATA 1044,555,1044,555,1044,555,1071,499,1071,499,1071,499,1071,499,1071,499,1071,507,1071,512
DATA 1071,518,1071,525,1071,532,1071,539,1072,546,1074,554,1074,561,1075,566,1077,574,1078,580
DATA 1079,585,1080,588,1080,590,1081,593,1081,593,1081,594,1081,594,1081,594,1081,594,1081,594
DATA 1081,596,1082,597,1082,599,1082,600,1082,601,1083,602,1083,603,1083,603,1083,603,1083,603
DATA 1083,603,1083,604,1083,605,1084,605,1084,605,1084,605,1084,605,1084,605,1159,563,1159,563
DATA 1158,563,1158,563,1155,561,1153,560,1148,559,1147,559,1139,559,1135,559,1132,560,1131,561
DATA 1130,562,1129,565,1128,567,1127,569,1127,573,1126,576,1126,580,1126,583,1125,587,1125,591
DATA 1125,595,1126,601,1128,604,1130,605,1132,607,1133,609,1136,611,1138,612,1139,612,1140,612
DATA 1145,609,1151,603,1155,601,1158,598,1161,595,1164,594,1166,592,1167,589,1169,585,1171,581
DATA 1172,576,1172,573,1172,570,1172,568,1172,564,1172,561,1172,558,1171,554,1170,548,1170,542
DATA 1170,537,1170,531,1169,526,1169,521,1168,517,1167,509,1167,505,1167,502,1167,497,1167,493
DATA 1167,491,1167,489,1167,487,1167,487,1167,487,1167,486,1167,485,1167,484,1167,482,1167,480
DATA 1167,479,1167,477,1167,476,1167,475,1167,475,1167,475,1167,475,1167,475,1167,475,1167,475
DATA 1167,475,1167,475,1167,475,1167,476,1167,480,1167,487,1167,492,1168,497,1169,505,1170,511
DATA 1171,518,1174,524,1176,536,1177,542,1178,548,1180,553,1181,558,1182,562,1183,567,1184,572
DATA 1185,577,1187,584,1188,589,1189,592,1190,595,1190,598,1191,601,1191,603,1192,604,1192,605
DATA 1193,606,1193,607,1194,608,1194,609,1194,609,1195,611,1195,611,1195,612,1195,613,1196,613
DATA 1196,613,1196,613,1196,613,1196,613,1196,613,1196,613,1196,613,1196,613,1196,613,1196,613
DATA 1196,613,1196,613,1196,613,1196,613,1196,613,1196,613,1131,51,1131,51,1131,51,1131,51
DATA 1131,51,1131,51,1131,52,1131,56,1131,61,1131,71,1131,79,1131,89,1131,97,1130,106
DATA 1130,112,1130,117,1130,122,1130,122,1130,129,1130,131,1130,134,1129,136,1129,141,1128,147
DATA 1127,160,1126,164,1126,174,1126,180,1126,183,1126,183,1126,183,1125,183,1125,183,1125,183
DATA 1125,183,1125,183,1125,183,1125,183,1125,183,1125,183,1125,183,1125,183,1125,183,1125,183
DATA 1118,232,1118,232,1118,232,1118,232,1118,232,1118,232,1118,232,1118,232,1118,232,1118,232
DATA 1118,232
DATA 9999,9999
-
The attached animated Xmas card was originally written by Peter Wirbelauer (not sure if he's still a member here) for his GDI sprite library implemented in OxygenBasic.
FBSL has its strongest point in being able to follow the low level Windows SDK programming style in BASIC code but wrapping the WinAPI's in higher level macros (simplified GUI, gfx primitives, sprites, extra resolution timers, music and video) in an 85 liner mingfx.inc include file enabled me to emulate his coding style and semantics almost 1:1. Probably the same or similar things can also be done in other kiddie BASIC implementations.
The attached zip contains a precompiled executable (just unblock and ignore false AV alarms) and the assets to run it.
The FBSL code is as follows:
#Option Implicit
#Include "mingfx.inc"
width = 800
height = 600
w = 11: h = 11
flakes = width
wallpaper = LoadSprite("xmas.bmp", width, height, 1)
snowflake = LoadSprite("snowflake.gif", w, h, 1)
Type PARTICLE
!x !y
!speed
!angle
End Type
Dim !x, !y, !s, !a, snow[flakes] As PARTICLE
For flakes = 0 To width
snow[flakes].x = Rnd() * width
snow[flakes].y = Rnd() * height - height
snow[flakes].speed = Rnd() * w / 4 + w / 4
snow[flakes].angle = Rnd() * h + h * h
Next
Window(width, height, FALSE, "Peter's Greets")
Screen(220, 210, 250)
Ink(255, 255, 0)
Animate
DrawSprite(wallpaper, 0, 0, width, height, 0)
For flakes = 0 To width
@x = @snow[flakes].x: @y = @snow[flakes].y
@s = @snow[flakes].speed: @a = @snow[flakes].angle
x = x + Cos(a) * s: y = y + Sin(a) * s
DrawSprite(snowflake, x + Cos * s, y + y + Sin * s, w, h, 0)
If y > Rnd() * height / 3 + height / 2 Then
x = Rnd() * width: y = -h
End If
If x < 0 Then x = width Else If x > width Then x = 0
Next
Message(200,20, 20, "MERRY CHRISTMAS!", Ink)
Redraw()
Wait(10)
Forever
-
Hi Mike,
Thanks for sharing. Is Peter W also known as PeterMaria (whom I knew at SdlBasic forum for awhile)?
SdlBasic sample:
'Plasma Mystery by PeterMaria 2016-06-16 copy
option Qbasic
setdisplay(400,400,32,1)
autoback(0)
sub plasma(im, ii, st)
dim fx, fy, i, c
for x=0 to 400
i =1
fy=0
for y=0 to 400
c = i*cos(fx)+i*sin(fy)/8
plot(x, y, c)
i=i*im+ii
fy = fy+st
next
fx = fx+st
next
end sub
dim m, n
while key(27)=0
m=1.0
n=1.0
for i=1 to 120
plasma(m,n,0.02)
n=n+111
screenswap
next
m=1.0
n=1.0
for i=1 to 120
plasma(m,n,0.05)
n=n+111
screenswap
next
m=1.0
n=1.0
for i=1 to 120
plasma(m,n,0.015)
n=n+111
screenswap
next
wend
Oh yeah, he was at one of Aurel's forums for awhile too. Like Aurel, he was O2 fan which is why I think it was same Peter.
Append: Also I think I can size the flakes and create a 3d effect with snow.
-
Yeah add snow to any scene:
_TITLE "Snowjob, a B+ mod" 'from Mike's mod of Peter W, to QB64 copied and B+ mod 2018-12-5
' Cyber font.bmp from Cybermonkey at Walter's forum RIP
' 2018-12-05 repost with better math
CONST XMAX = 800
CONST YMAX = 600
' background pick an image
wallpaper& = _LOADIMAGE("xmas.bmp", 32)
wallpaper& = _LOADIMAGE("xmas1.jpg", 32)
'wallpaper& = _LOADIMAGE("snow1.jpg", 32)
'flake
snowflake& = _LOADIMAGE("snowflake.gif", 32)
FOR i = 0 TO 50
_CLEARCOLOR _RGB32(i, i, i), snowflake&
NEXT
'cyber font
DIM SHARED cf&, cfW, cfH
cf& = _LOADIMAGE("Cyber font.bmp", 32)
cfW = 40
cfH = 34
'snow making machine
TYPE PARTICLE
x AS SINGLE
y AS SINGLE
size AS SINGLE
speed AS SINGLE
angle AS SINGLE
maxy AS SINGLE
END TYPE
nLayers = 11
flakes = 2 ^ (nLayers + 1) - 1
DIM snow(flakes) AS PARTICLE
FOR layer = nLayers TO 0 STEP -1
FOR flake = 0 TO 2 ^ layer
snow(flake).x = RND * XMAX
snow(flake).y = RND * YMAX - YMAX
snow(flake).size = nLayers - layer
snow(flake).speed = .1 * (nLayers - layer)
snow(flake).angle = RND * (_PI - _PI(1 / 6)) + _PI(1 / 12)
snow(flake).maxy = .5 * YMAX + (nLayers - layer) * (.5 * YMAX / nLayers)
NEXT
NEXT
SCREEN _NEWIMAGE(XMAX, YMAX, 32)
_SCREENMOVE 200, 100
DO
_PUTIMAGE , wallpaper&, 0
FOR flake = flakes TO 0 STEP -1
snow(flake).x = snow(flake).x + COS(snow(flake).angle) * snow(flake).speed + RND * 2 - .75
snow(flake).y = snow(flake).y + SIN(snow(flake).angle) * snow(flake).speed + RND * 2 - .5
_PUTIMAGE (snow(flake).x, snow(flake).y)-STEP(snow(flake).size, snow(flake).size), snowflake&, 0
IF snow(flake).y > snow(flake).maxy THEN
snow(flake).x = RND * XMAX: snow(flake).y = RND * YMAX - 1.1 * YMAX
END IF
IF snow(flake).x < 0 THEN
snow(flake).x = XMAX
ELSEIF snow(flake).x > XMAX THEN
snow(flake).x = 0
END IF
NEXT
'LINE (180, YMAX - 65)-STEP(420, 50), _RGBA32(128, 0, 0, 180), BF
cfMessage "MERRY CHRISTMAS!", 200, YMAX - 60, 400, 40 'Cybermonkey's font
_DISPLAY
_LIMIT 60
LOOP
SUB cfMessage (message$, xBox, yBox, wBox, hBox)
lm = LEN(message$)
bm = .125 * hBox
px = lm * (cfW + bm) + 2 * bm
py = cfH + 2 * bm
xScale = wBox / px
yScale = hBox / py
FOR i = 1 TO LEN(message$)
c$ = MID$(message$, i, 1)
cfLetter c$, xBox + (i - 1) * (cfW + bm) * xScale + bm, yBox + bm, xScale, yScale
NEXT
END SUB
SUB cfLetter (L$, x, y, xScale, yScale)
_CLEARCOLOR _RGB32(0, 0, 0), cf&
lNum = INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ!'()-.?:0123456789, ", UCASE$(L$))
IF lNum = 0 THEN EXIT SUB ' couldn't find it
lNum = lNum - 1
lRow = lNum \ 8 '5 + rows
lCol = lNum MOD 8 '8 chars per row
lW = 40
lH = 34
_PUTIMAGE (x, y)-STEP(lW * xScale, lH * yScale), cf&, 0, (lCol * lW, lRow * lH)-STEP(lW - 1, lH - 1)
END SUB
EDIT: oops got some numbers backwards, reposting with corrections
-
Repost: other images with snow machine
-
Is Peter W also known as PeterMaria (whom I knew at SdlBasic forum for awhile)?
Yep, I guess that would be him. He used to have difficulty expressing himself in English but his code was mostly fun and spake for itself, even though his libraries were closed-source and certainly needed some experience to be reproduced/reverse engineered in other BASIC flavors from scratch. I think he also used to be a member of the old BP dot org before his wife passed away and he ceased socializing on the forums.
Your colorful and grayscale snow-blow jobs look real nice. I'm not planning on running your QB64 code myself (got practically no spare time for hobbies lately). Just tell me if your snowflake velocity and direction randomization resembles Peter's visually? I find his version very neat in this respect and closely resembling what real snow would look like blown by some sideways wind.
-
Yes I preserved the method of updating the X and Y position of the flake adding a little more random walking so flakes "feel" light and fluffy with a slight tendency to drift right while floating down.
Oops, now I realize I need to start them wider than width of screen for this tendency, the bottom left corner will have tendency to be empty. I also want to melt them into landing spot because then look bubbles popping and rotate them randomly to distinguish more from stars. Trying drawn flakes instead of image.
-
Your flakes look really cool! :)
And if you look closely at my animation, you'll also notice that the flakes are leaving sort of grayish buildup on top of snowy white "surfaces" they're flying over. Very realistic, I'd say. But it's just a side effect of blending several sprite transparencies on top of one another. I could've gotten rid of it easily but decided against it -- I like it better this way. :)
Here comes another very very cool Xmas card/quest created by a Joseph E. in Liberty BASIC quite a while ago. I believe you can still find his original LB code at their forum.
I came across it 6 years ago and ported it to FBSL BASIC recreating LB's sprite system, animation scripting, and sound in the process just by looking at Joseph's code and reading their help manual. That was quite fun to do. You can look into the animation scripts and see that they are 100% original as used by the poor fellows that paid their hard earned $$$ to buy that piece of utter bloatware. ;)
The only difference with the original is that I'm using .GIFs instead of lossless .BMPs/.PNGs/.TGAs/.TIFs to meet the archive size allowed here, even though it impairs the quality of sprites. In fact, I have a special Russian build of this app with double sized wallpapers and hi-res sprites that used to be very popular with my grands a few years ago. :)
The entire app script is a 1K liner included for reference. Those who still have an installation of at least FBSL v3.5 RC1 can run it from the Eclecta editor, and those who haven't can download the zip, unblock it, and run the precompiled executable ignoring false AV alarms.
Make sure your audio gear is turned on and both MIDI and WAV audio/MP3 channels are made equally audible because the app uses rich stereo sound mixed asynchronously in both channels.
Enjoy! :)
-
Ho, Ho! very nice!
I saw a mouse in assets and said, "Wait, I didn't see that used." Went back and ran it again and found a whole bunch of other things happening. Fun! ;)