Welcome, Guest |
You have to register before you can post on our site.
|
Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
draw_polyT (Polygons) |
Posted by: James D Jarvis - 09-02-2022, 03:56 AM - Forum: Utilities
- No Replies
|
|
draw filled equilateral polygons and circles using _MapTriangle
Code: (Select All) 'draw_polyT
' by James D. Jarvis
'draw filled equilateral polygons and circles
'
'HEADER
Dim Shared xmax, ymax
xmax = 800: ymax = 500
Screen _NewImage(xmax, ymax, 32)
Dim Shared pk&
pkt& = _NewImage(3, 3, 32)
'======================================
' demo
'======================================
Randomize Timer
Dim degr(10) As Long 'just to ahve a clean demonstration of randomly defiend shapes
degr(1) = 1
degr(2) = 3
degr(3) = 12
degr(4) = 30
degr(5) = 40
degr(6) = 45
degr(7) = 60
degr(8) = 72
degr(9) = 90
degr(10) = 120
t1 = Timer
For reps = 1 To 64000
polyT Int(Rnd * xmax), Int(Rnd * ymax), Int(10 + Rnd * 60), _RGB32(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256)), degr(Int(1 + Rnd * 10))
Next reps
t2 = Timer
Print "That took "; t2 - t1; " seconds to draw 64000 polygons"
'==========================================================================
'subroutines
'
' polyT draw a filled equilateral polygon or circle
'
' setklr is an sub to build the color image used byt triangles in polyT
'====================================== ==================================
Sub polyT (cx As Long, cy As Long, r As Long, klr As _Unsigned Long, deg As Long)
'draw an equilateral polygon
'if degrees dont' evenly divide into 360 it's goign to be ragged.
'circles will be drawn when the value for degree is low
setklr klr
d = 0
x = r * Sin(0)
y = r * Cos(0)
While d < 360
d = d + deg
x2 = r * Sin(0.01745329 * d)
y2 = r * Cos(0.01745329 * d)
_MapTriangle (0, 2)-(2, 2)-(2, 0), pk& To(cx, cy)-(cx + x, cy + y)-(cx + x2, cy + y2)
x = x2
y = y2
Wend
End Sub
Sub setklr (klr As Long)
'setup a image to copy a colored triangle
'called by polyT
_Dest pk&
Line (0, 0)-(2, 2), klr, BF
_Dest 0
End Sub
|
|
|
Convert IPv4 dotted quad into four decimal values |
Posted by: bert22306 - 09-01-2022, 08:58 PM - Forum: General Discussion
- Replies (6)
|
|
A trivially easy way to enter an IPv4 address into qb64, and extract the four decimals values 0-255 which make up the address, is to use commas as delimiters for each byte of the address. I've done that, and my program (to convert an IP multicast address into its derived MAC group address, per RFC 1112) works fine that way.
What would be even better is to be able to enter the IP address in its conventional form, with . instead of , for delimiters. So for example, given the multicast address
239.255.128.1
I'm now entering it as
239,255,128,1
It's okay, super easy to parse, but not really nice.
So far, I have this. It inputs the dotted quad as a single string variable, then changes the dots into commas, so that hopefully the four decimal numbers can be easily parsed by qb64. Just trying to figure out an easy way to make the ASCII list of numbers and commas, which you see in the output, into four separate decimal numbers. I'm not proficient in all the niceties of how numbers and characters can be converted in qb64. Any super clever ideas out there? There usually are.
Code: (Select All) Dim num(100), char$(100)
Input "Enter quad decimal IP multicast group ->", addr$
Print addr$
length = Len(addr$)
i = 0
Do
i = i + 1
num(i) = Asc(addr$, i)
If num(i) = 46 Then num(i) = 44
If i = length Then Exit Do
Loop
For i = 1 To length
char$(i) = Chr$(num(i))
Print num(i), char$(i)
Next i
|
|
|
Curiosities |
Posted by: MasterGy - 09-01-2022, 08:50 PM - Forum: MasterGy
- Replies (12)
|
|
while I'm selecting between the half-finished programs, I'll post the interesting ones here
from "the big chase" (flying on the neverend perlin field WASD+mouse)
Code: (Select All) CONST pip180 = 3.141592 / 180
CONST perlin_pers = 7 'amplitudo
CONST perlin_level = 5 'level of resolution wave
CONST perlin_multiplier = 0.006
CONST perlin_smooth_noise_interpolation_type = 0 '0-none '1-standard
CONST perlin_flat_soil_limit = .8
DIM SHARED rotating(2), cosrotz, sinrotz, cosrotx, sinrotx, map_zoom_xy, map_zoom_distance, rotx_bevel, see_point
monx = _DESKTOPWIDTH * .7: mony = monx / 16 * 9 'screen size
shadow_ratio = 1
text_deep = INT(40 * shadow_ratio)
map_shadow = 15 / shadow_ratio
text_height_scale = 15
position_speed = .9
map_resolution = 70
map_dimxy = 1200 * .8
map_dimz = 250 * .8
map_zoom_xy = 6
map_zoom_distance = 15
mouse_sens_xy = 1
mouse_sens_z = 1
cam(4) = pip180 * 270
me(0) = 2000: me(1) = 2000
DIM clmn(1999, 5): ration_column = 0.0003
'create pseudo random buffer
DIM SHARED noise_rand_c: noise_rand_c = 10000: DIM SHARED noise_rand(noise_rand_c - 1): FOR t = 0 TO noise_rand_c - 1: noise_rand(t) = RND(1): NEXT t
'create texture
DIM color_temp AS _INTEGER64: DIM SHARED mapz_min, mapz_max: text_size = 8: text_size_marg = 8: DIM texture(text_height_scale - 1, text_deep - 1)
FOR t = 0 TO text_deep - 1: FOR t2 = 0 TO text_height_scale - 1: dark = 1 - (1 / (text_deep - 1) * t)
color_temp = _RGBA32((255 * dark), (100 * dark), ((255 / text_height_scale * t2)) * dark, 255 * dark)
temp = _NEWIMAGE(text_size, text_size, 32): _DEST temp: CLS: marg = text_size * text_size_marg / 100
LINE (marg, marg)-(text_size - marg, text_size - marg), color_temp, BF: texture(t2, t) = _COPYIMAGE(temp, 33): _FREEIMAGE temp: NEXT t2, t
'find min/max Z
mapz_min = 9999999: mapz_max = -mapz_min: FOR t = 0 TO 1999: c = Perlin2D(1000 * RND(1), 1000 * RND(1))
IF mapz_min > c THEN mapz_min = c
IF mapz_max < c THEN mapz_max = c
NEXT t: temp_a = 1 / (mapz_max - mapz_min)
'fill map-buffer
DIM map(map_resolution - 1, map_resolution - 1, 9): perl_setx = INT(me(0)): perl_sety = INT(me(1))
FOR map_x = 0 TO map_resolution - 1: FOR map_y = 0 TO map_resolution - 1: map_z = Perlin2D(perl_setx + map_x, perl_sety + map_y)
map((map_x + perl_setx) MOD map_resolution, (map_y + perl_sety) MOD map_resolution, 0) = 1 / (mapz_max - mapz_min) * (map_z - mapz_min)
map((map_x + perl_setx) MOD map_resolution, (map_y + perl_sety) MOD map_resolution, 6) = noise(map_x, map_y) < ration_column: NEXT map_y, map_x
'MAP array
'0-perlin Z-data
'1-maptriangle calculate X
'2-maptriangle calculate Y
'3-maptriangle calculate Z
'4-distance from me (color)
'5-texture height scale
'6-is there a column ?
'7-is the point visible?
'ME array
'0-me X location
'1-me Y location
'2-me Z location
'3-vector_x
'4-vector_y
mon = _NEWIMAGE(monx, mony, 32): SCREEN mon: _FULLSCREEN: _MOUSEHIDE
DO: _LIMIT 40
IF INKEY$ = CHR$(27) THEN END
'control flight
kw = _KEYDOWN(119): ks = _KEYDOWN(115): mousex = 0: mousey = 0: WHILE _MOUSEINPUT: mousex = mousex + _MOUSEMOVEMENTX: mousey = mousey + _MOUSEMOVEMENTY: WEND
rotx = (rotx + mousex * mouse_sens_xy * .005) * .95: max_incli = 65: IF ABS(rotx) > (max_incli * pip180) THEN rotx = max_incli * pip180 * SGN(rotx)
actual_speed = 1 / position_speed * SQR(me(3) * me(3) + me(4) * me(4)): rotx_bevel2 = rotx * actual_speed * ABS(kw)
rotx_bevel = rotx_bevel + (rotx_bevel2 - rotx_bevel) * .05: cam(3) = cam(3) + rotx / 20
cam(4) = cam(4) + mousey * mouse_sens_z / 100: szog_z = -cam(4): me(2) = me(2) + COS(szog_z) * actual_speed * 5 * ABS(kw) 'calculating Z
position_accel = .02: ww = .9999: szog_xy = cam(3) + rotx 'calculating XY
new_vec_x = -SIN(szog_xy) * position_accel * ABS(kw)
new_vec_y = -COS(szog_xy) * position_accel * ABS(kw)
vec_x = (me(3) * ww + new_vec_x)
vec_y = (me(4) * ww + new_vec_y)
vec_sum = SQR(vec_x * vec_x + vec_y * vec_y): IF vec_sum > position_speed THEN vec_sum = position_speed / vec_sum ELSE vec_sum = 1
me(3) = vec_x * vec_sum: me(4) = vec_y * vec_sum: me(0) = me(0) + me(3): me(1) = (me(1) + me(4))
deacc = .97
IF ks THEN me(3) = me(3) * deacc: me(4) = me(4) * deacc
IF ks = 0 AND kw = 0 THEN me(3) = me(3) * .99: me(4) = me(4) * .99
'replace the missing row in the buffer line Y
DO WHILE INT(INT(me(0))) <> perl_setx: dir = -SGN(INT(me(0)) - perl_setx): perl_setx = perl_setx - dir
temp = perl_setx + ABS(dir = -1) * (map_resolution - 1): temp_m = INT(temp MOD map_resolution)
FOR map_y = 0 TO map_resolution - 1: map_z = Perlin2D(temp, perl_sety + map_y)
map(temp_m, (map_y + perl_sety) MOD map_resolution, 0) = temp_a * (map_z - mapz_min)
map(temp_m, INT((map_y + perl_sety) MOD map_resolution), 6) = noise(temp, perl_sety + map_y) < ration_column: NEXT map_y: LOOP
'replace the missing row in the buffer line X
DO WHILE INT(INT(me(1))) <> perl_sety: dir = -SGN(INT(me(1)) - perl_sety): perl_sety = perl_sety - dir
temp = perl_sety + ABS(dir = -1) * (map_resolution - 1): temp_m = INT(temp MOD map_resolution)
FOR map_x = 0 TO map_resolution - 1: map_z = Perlin2D(perl_setx + map_x, temp)
map(INT((map_x + perl_setx) MOD map_resolution), temp_m, 0) = temp_a * (map_z - mapz_min)
map((map_x + perl_setx) MOD map_resolution, temp_m, 6) = noise(perl_setx + map_x, temp) < ration_column: NEXT map_x: LOOP
cosrotz = COS(cam(3)): sinrotz = SIN(cam(3)): cosrotx = COS(cam(4)): sinrotx = SIN(cam(4)) 'to rotating angles
'calculating position and textures
clmn(0, 0) = 0 'reset column counter
FOR map_x = 0 TO map_resolution - 1: px = -map_dimxy / 2 + map_dimxy / map_resolution * (map_x - (me(0) - INT(me(0))))
FOR map_y = 0 TO map_resolution - 1: py = -map_dimxy / 2 + map_dimxy / map_resolution * (map_y - (me(1) - INT(me(1))))
read_mapx = INT((map_x + perl_setx) MOD map_resolution): read_mapy = INT((map_y + perl_sety) MOD map_resolution)
map_z = map(read_mapx, read_mapy, 0): IF map_z > perlin_flat_soil_limit THEN map_z = perlin_flat_soil_limit
pz2 = map_dimz * map_z - me(2): rotate px, py, pz2, 1: IF see_point THEN map(map_x, map_y, 7) = 1 ELSE map(map_x, map_y, 7) = 0: _CONTINUE
map(map_x, map_y, 1) = rotating(0): map(map_x, map_y, 2) = rotating(1): map(map_x, map_y, 3) = rotating(2)
map(map_x, map_y, 4) = INT(SQR(px * px + py * py) / map_shadow): IF map(map_x, map_y, 4) > text_deep - 1 THEN map(map_x, map_y, 4) = text_deep - 1
map(map_x, map_y, 5) = INT(text_height_scale * map_z): IF map(map_x, map_y, 5) > text_height_scale - 1 THEN map(map_x, map_y, 5) = text_height_scale - 1
IF map(map_x, map_y, 5) < 0 THEN map(map_x, map_y, 5) = 0
IF map(read_mapx, read_mapy, 6) THEN clmn(clmn(0, 0) + 1, 2) = map(map_x, map_y, 4): clmn(clmn(0, 0) + 1, 0) = px: clmn(clmn(0, 0) + 1, 1) = py: clmn(0, 0) = clmn(0, 0) + 1
NEXT map_y, map_x
'do maptriangle from squares !
FOR map_x = 0 TO map_resolution - 2: FOR map_y = 0 TO map_resolution - 2:
IF (map(map_x, map_y, 7) AND map(map_x + 1, map_y, 7) AND map(map_x, map_y + 1, 7) AND map(map_x + 1, map_y + 1, 7)) = 0 THEN _CONTINUE
m0x = map(map_x, map_y, 1): m0y = map(map_x, map_y, 2): m0z = map(map_x, map_y, 3)
m1x = map(map_x + 1, map_y, 1): m1y = map(map_x + 1, map_y, 2): m1z = map(map_x + 1, map_y, 3)
m2x = map(map_x, map_y + 1, 1): m2y = map(map_x, map_y + 1, 2): m2z = map(map_x, map_y + 1, 3)
m3x = map(map_x + 1, map_y + 1, 1): m3y = map(map_x + 1, map_y + 1, 2): m3z = map(map_x + 1, map_y + 1, 3)
atexture = texture(map(map_x, map_y, 5), map(map_x, map_y, 4))
_MAPTRIANGLE (0, 0)-(text_size - 1, 0)-(0, text_size - 1), atexture TO(m0x, m0y, m0z)-(m1x, m1y, m1z)-(m2x, m2y, m2z)
_MAPTRIANGLE (0, 0)-(text_size - 1, 0)-(0, text_size - 1), atexture TO(m3x, m3y, m3z)-(m1x, m1y, m1z)-(m2x, m2y, m2z)
NEXT map_y, map_x
'draw columns
ac_ang = 5: ac_rad = 20: column_height = 800: column_rot = column_rot + 1
FOR ac = 0 TO clmn(0, 0) - 1: FOR t = 0 TO ac_ang - 1: temp = (360 / ac_ang * t + column_rot) * pip180
px = clmn(ac + 1, 0) + SIN(temp) * ac_rad: py = clmn(ac + 1, 1) + COS(temp) * ac_rad
pz2 = 400: rotate px, py, pz2, 0: ac(t, 0, 0) = rotating(0): ac(t, 1, 0) = rotating(1): ac(t, 2, 0) = rotating(2)
pz2 = -300: rotate px, py, pz2, 0: ac(t, 0, 1) = rotating(0): ac(t, 1, 1) = rotating(1): ac(t, 2, 1) = rotating(2)
NEXT t
FOR t = 0 TO ac_ang - 1: t2 = (t + 1) MOD ac_ang
m0x = ac(t, 0, 0): m0y = ac(t, 1, 0): m0z = ac(t, 2, 0): m1x = ac(t2, 0, 0): m1y = ac(t2, 1, 0): m1z = ac(t2, 2, 0)
m2x = ac(t, 0, 1): m2y = ac(t, 1, 1): m2z = ac(t, 2, 1): m3x = ac(t2, 0, 1): m3y = ac(t2, 1, 1): m3z = ac(t2, 2, 1)
atexture = texture(0, clmn(ac + 1, 2))
_MAPTRIANGLE (0, 0)-(text_size - 1, 0)-(0, text_size - 1), atexture TO(m0x, m0y, m0z)-(m1x, m1y, m1z)-(m2x, m2y, m2z)
_MAPTRIANGLE (0, 0)-(text_size - 1, 0)-(0, text_size - 1), atexture TO(m3x, m3y, m3z)-(m1x, m1y, m1z)-(m2x, m2y, m2z)
NEXT t, ac
_DISPLAY: CLS
LOOP
FUNCTION noise (x, y) 'reading pseudo random buffer
x2 = INT(x): y2 = INT(y): a = INT(ABS(x2) + ABS(y2)) MOD noise_rand_c: b = ABS(x2) MOD noise_rand_c: c = noise_rand(a) + noise_rand(b): noise = c - INT(c)
END FUNCTION
FUNCTION SmoothNoise (x, y)
SELECT CASE perlin_smooth_noise_interpolation_type
CASE 0: SmoothNoise = noise(x, y)
CASE 1: corners = (noise(x - 1, y - 1) + noise(x + 1, y - 1) + noise(x - 1, y + 1) + noise(x + 1, y + 1)) / 16
sides = (noise(x - 1, y) + noise(x + 1, y) + noise(x, y - 1) + noise(x, y + 1)) / 8: center = noise(x, y) / 4: SmoothNoise = corners + sides + center
END SELECT: END FUNCTION
FUNCTION Perlin2D (x, y): total = 0: FOR t = 0 TO perlin_level - 1: frequency = 2 ^ t * perlin_multiplier: amplitude = perlin_pers ^ t
total = total + InterpolatedNoise(x * frequency, y * frequency) * amplitude: NEXT t: Perlin2D = total: END FUNCTION
FUNCTION InterpolatedNoise (x, y): integer_X = INT(x): fractional_X = x - integer_X: integer_y = INT(y): fractional_Y = y - integer_y
v1 = SmoothNoise(integer_X, integer_y): v2 = SmoothNoise(integer_X + 1, integer_y)
v3 = SmoothNoise(integer_X, integer_y + 1): v4 = SmoothNoise(integer_X + 1, integer_y + 1)
i1 = Interpolate(v1, v2, fractional_X): i2 = Interpolate(v3, v4, fractional_X): InterpolatedNoise = Interpolate(i1, i2, fractional_Y): END FUNCTION
FUNCTION Interpolate (a, b, x): Interpolate = a * (1 - x) + b * x: END FUNCTION
SUB rotate (px, py, pz2, see_analysis)
px3 = px * cosrotz - py * sinrotz: py2 = px * sinrotz + py * cosrotz: py3 = py2 * cosrotx - pz2 * sinrotx: pz3 = -(py2 * sinrotx + pz2 * cosrotx)
see_point = pz3 < 100: IF see_point = 0 AND see_analysis THEN EXIT SUB
px4 = (px3 * COS(rotx_bevel)) - (py3 * SIN(rotx_bevel)): py4 = (px3 * SIN(rotx_bevel)) + (py3 * COS(rotx_bevel))
rotating(0) = -px4 * map_zoom_xy: rotating(1) = -py4 * map_zoom_xy: rotating(2) = pz3 * map_zoom_distance: END SUB
|
|
|
Heart Beat |
Posted by: bplus - 09-01-2022, 04:06 PM - Forum: Programs
- Replies (5)
|
|
Code: (Select All) _Title "Heart Beat" 'b+ 2022-09-01 playing with Heart graphic code at JB
' https://justbasiccom.proboards.com/thread/883/heart-shapes
Screen _NewImage(600, 350, 32)
Color &HFFFF0000, &HFFEEEEEE
M = 313
P = 100
J = 1
Dim h(1 To 4) As Long
For stepper = .0005 To .0005004 Step .0000001
k = k + 1
Cls
For I = 0 To 1.567 Step stepper
J = 0 - J
Circle (Abs(P * (J * I + 3)), P * (2 + (I ^ .01 * (Abs(Cos(I)) ^ .5 * Cos(M * I)) - I ^ .3))), 1
Next
h(k) = _NewImage(600, 350, 32)
_PutImage , 0, h(k)
Next
k = 0: dk = 1
While 1
k = k + dk
If k > 4 Then k = 1
_PutImage , h(k), 0
toggle = 1 - toggle
If toggle Then _Delay .8 Else _Delay .08
Wend
https://www.youtube.com/watch?v=xos2MnVxe-c
|
|
|
Babeltype |
Posted by: James D Jarvis - 09-01-2022, 05:16 AM - Forum: Programs
- Replies (4)
|
|
A silly little program inspired by staying up too late and leaving youtube playing while I was programming, and a video came up on the Babel Library. Here's a small piece of that:
Code: (Select All) 'babeltype
'
'an experiment at 1,000,000 virtual chimpanzees typing away, with a couple rules
'
' press any key to pause the program, and the spacebar to continue
' take a screen shot if you get a miracle sentence.
'
' press escape to quit
Dim vowel$(6), cm$(7), word$(10)
vowel$(1) = "a"
vowel$(2) = "e"
vowel$(3) = "i"
vowel$(4) = "o"
vowel$(5) = "u"
vowel$(6) = "y"
cm$(1) = "t"
cm$(2) = "n"
cm$(3) = "s"
cm$(4) = "h"
cm$(5) = "r"
cm$(6) = "d"
cm$(7) = "l"
word$(1) = "the "
word$(2) = "be "
word$(3) = "and "
word$(4) = "a "
word$(5) = "of "
word$(6) = "to "
word$(7) = "in "
word$(8) = "I "
word$(9) = "you "
word$(10) = "it "
start$ = "yes"
Do
_Limit 90
r = Int(1 + Rnd * 2)
For n = 1 To r:
If start$ = "yes" Then
Select Case Int(1 + Rnd * 90)
Case 1 To 6
Print UCase$(cm$(1 + Int(Rnd * 7)));
Case 7 To 88
Print UCase$(Chr$(97 + Int(Rnd * 26)));
Case 89, 90
W$ = word$(Int(1 + Rnd * 10))
Mid$(W$, 1, 1) = UCase$(Left$(W$, 1))
Print W$;
End Select
start$ = "no"
Else
Select Case Int(1 + Rnd * 90)
Case 1 To 6
Print cm$(1 + Int(Rnd * 7));
Case 7 To 88
Print Chr$(97 + Int(Rnd * 26));
Case 89, 90
Print word$(Int(1 + Rnd * 10));
End Select
End If
Next
r = Int(1 + Rnd * 2)
For n = 1 To r: Print vowel$(Int(1 + Rnd * 6));: Next
r = Int(1 + Rnd * 2)
For n = 1 To r
If Rnd * 6 < 2.2 Then
Print cm$(1 + Int(Rnd * 7));
Else
Print Chr$(97 + Int(Rnd * 26));
End If
Next
If Rnd * 6 < 2.5 Then
Print vowel$(Int(1 + Rnd * 6));
If Rnd * 6 < 2.5 Then
r = Int(1 + Rnd * 2)
For n = 1 To r
If Rnd * 6 < 2.2 Then
Print cm$(1 + Int(Rnd * 7));
Else
Print Chr$(97 + Int(Rnd * 26));
End If
Next
End If
End If
If Rnd * 24 < 1.5 Then
p = Int(1 + Rnd * 88)
Select Case p
Case 1 To 18
Print ",";
Case 19 To 23
Print ";";
Case 24
Print ":";
Case 25 To 75
Print ".";
start$ = "yes"
Case 76 To 83
Print "?";
start$ = "yes"
Case 84 To 88
Print "!";
start$ = "yes"
End Select
End If
Print " ";
k$ = InKey$
If k$ <> "" And k$ <> Chr$(27) Then
Do
_Limit 30
a$ = InKey$
Loop Until a$ = " "
End If
Loop Until k$ = Chr$(27)
End
|
|
|
Hangman 2 with 2 to 12 letter words! |
Posted by: SierraKen - 08-30-2022, 07:07 PM - Forum: Programs
- Replies (17)
|
|
Whew, that was one of the harder apps I've done in awhile, but I had a blast! I didn't even need help on this specific version either. Although I would like you guys to use it and tell me if you find any problems, thanks.
There's 1000 words in this one on the DATA lines of different sizes, from 2 to 12 letters. They are also in alphabetical order because that's how I found them online. I removed a couple and added a couple as well. Feel free to remove any you wish and add any you wish. It will count them. Also, if you add any with symbols or capitol letters, it just won't use those. Plus if you add any that are over 12 letters or under 2 letters, it won't use those either. The main reason for the 12 letter limit is because I ran out of screen room.
These 1000 words are mostly the most common words used in the English language it says. I added the URL to the words next to the DATA lines.
The hardest part in making this was removing the 5 strings from the last Hangman and making loops instead, with arrays. It also seems a bit simple until you really dig into all the things needed. If you have any questions about the code, feel free to ask and I will try my best to answer.
Have fun!
(Note: I just found a small problem, I'll post the fix below.)
|
|
|
scale_print |
Posted by: James D Jarvis - 08-30-2022, 03:09 PM - Forum: Works in Progress
- Replies (3)
|
|
Some scalable text routines and a little demo program. This is meant to work with 8bit color (currently only supports a palette of colors from 0 to 127 due to encoding).
Basically, the default font is scanned and encoded into a string array that is later decoded to display the characters as part of a set of tiles. The default font is rescaled to 16 by 16 but can be redrawn at any size desired.
to do:
output a set of data statements to be copied and included in another program
ADDED loading a ttf and allow it to be added to the tileset
maybe a graphical editor to edit individual character tile ... this might be done in another program.
EDIT: updated see latest post to see most up to date version
Code: (Select All) 'Scale_print
'by James D. Jarvis
'scans default font and setup up routines to rescale output as a base tile of 16 x 16 pixels
'meant for use to create a larger editable display font without needing to make use of external font files
'
'=================================================================================
'header, needed in any programs that will make use of the subroutines
'=================================================================================
Dim Shared xmax
xmax = 800 'max horizontal screen size, reset as you wish
Screen _NewImage(xmax, 500, 256)
Dim Shared tile(256) As String 'note.... if you want to create a larger tile set you can as scan816 sub will just fill the first 255 entries
Dim Shared t_wid As _Byte 'really doesn't really have to be a bytefor these routines or program but is for compatibility with another program of mine
t_wid = 16 'tile width set here in main routine if could be moved inside of scan816
_ControlChr Off
'=================================================================================
'demo program
''=================================================================================
scan816 'scan the 8by16 default font and store it in an array of tiles that are 16 by 16 pixels in size
Randomize Timer 'for later demo output not needed by the routines otherwise
'a simple example tile to show one way to make an extended charcter set
tile(256) = Chr$(120) + Chr$(144) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130)
ptile 100, 100, tile(Asc("A")) 'just print the tile as scanned.
For x = 1 To 40
ptile (x - 1) * 16, 150, tile(Int(Rnd * 256)) 'showing how to
Next x
For x = 1 To 40
cptile (x - 1) * 16, 200, tile(33 + x), Int(1 + Rnd * 64) 'print a randomly generated series of characters randomly colored
Next x
tile_print 400, 10, " ÉÍÊÍ» ", 0 'print a string as scanned with no spacing
Input "press enter ", any$
Cls
scale_print 50, 50, "x8 by x2.5 text", 9, 8, 2.5 'print a colorized and scaled string
scale_print 10, 250, "x2 by x5", 10, 2, 5 'print a colorized and scaled string
_PrintString (50, 320), "aBcDeFgHi" 'just plain old _printstring for reference
scale_print 50, 350, "x1 by 0,5 text", 12, 1, 0.5 'print a tiny string
tile_print 50, 366, "String with spacing of 8 pixels", 8 'print a string with an extra 8 pixels between each tile
scale_print 0, 0, "press enter", 8, 1, 1
Locate 1, 23: Input any$
Cls
s = 0.1
Do 'show a string being scaled
_Limit 60
Cls
scale_print 0, 0, "AbC123", 15, s, s
s = s + .1
_Display
Loop Until s > 30
scale_print 0, 0, "press enter", 9, 1, 0.5
Locate 1, 13: Input any$
Cls
scale_print 10, 100, "Bonus Tile(256) :", 14, 1, 1
scale_tile 286, 100, tile(256), 15, 1, 1
scale_print 10, 117, "(just to show an example of a custom tile)", 8, 1, 0.5
End
'=================================================================================
'scale_print subroutines
'
' tile_print prints a string with added spacing between character tiles
' scale_print prinst a scaled and recolored string of character tiles
' scale_tile prints a single rescaled and recolored character tile
' ptile prints a single character tile as scanned
' cptile prints a single rrcolored character tile
' scan816
'=================================================================================
Sub tile_print (x, y, A$, spacing)
'print text as scanned, with spacing between the characters
px = x
py = y
cc = 0
For c = 1 To Len(A$)
cc = cc + 1
If px + (cc - 1) * 16 >= xmax Then
cc = 1
py = py + 16
End If
ptile px + (cc - 1) * (16 + spacing), py, tile(Asc(Mid$(A$, c, 1)))
Next
End Sub
Sub scale_print (x, y, A$, klr, Hscale, Wscale)
'print string A$ Hscale and Vscale are in relative values (1.0 would be 100%)
'klr can be 0 to 127 from the standard 8 bit palette
'text can wrap back to x if the string would print beyond the screen edge
px = x
py = y
cc = 0
For c = 1 To Len(A$)
cc = cc + 1
If px + (cc - 1) * (16 * Wscale) >= xmax Then
cc = 1
py = py + 16 * Hscale
End If
scale_tile px + (cc - 1) * (16 * Wscale), py, tile(Asc(Mid$(A$, c, 1))), klr, Hscale, Wscale
Next
End Sub
Sub scale_tile (px As Integer, py As Integer, im$, klr, HH, WW)
'print tile tt starting at point px,py
'klr can be 0 to 127 from the standard 8 bit palette
x = 0
For c = 1 To Len(im$)
n = Asc(Mid$(im$, c, 1)) - 128
If n < 1 Then aklr = Abs(n)
If n > 0 Then
If aklr > 0 Then
x2 = x + n
Line (px + ((x - 1) * WW), py + ((Y - 1) * HH))-(px + ((x2 - 1) * WW), py + ((Y - 1) * HH + HH - 1)), klr, BF
x = x2
Else
x = x + n
End If
End If
If x >= t_wid Then
x = 0
Y = Y + 1
End If
Next c
End Sub
Sub ptile (px As Integer, py As Integer, im$)
'print tile im$ starting at point px,py
x = 0
For c = 1 To Len(im$)
n = Asc(Mid$(im$, c, 1)) - 128
If n < 1 Then klr = Abs(n)
If n > 0 Then
If klr > 0 Then
x2 = x + n
Line (px + x, py + Y)-(px + x2, py + Y), klr
x = x2
Else
x = x + n
End If
End If
If x >= t_wid Then
x = 0
Y = Y + 1
End If
Next c
End Sub
Sub cptile (px As Integer, py As Integer, im$, klr)
'print tile im$ starting at point px,py
'recolor tile out put to color klr
'klr can be 0 to 127 from the standard 8 bit palette
x = 0
For c = 1 To Len(im$)
n = Asc(Mid$(im$, c, 1)) - 128
If n < 1 Then aklr = Abs(n)
If n > 0 Then
If aklr > 0 Then
x2 = x + n
Line (px + x, py + Y)-(px + x2, py + Y), klr
x = x2
Else
x = x + n
End If
End If
If x >= t_wid Then
x = 0
Y = Y + 1
End If
Next c
End Sub
Sub scan816
'scan the default font and load it into tile entries 0 to 255
'reads colors 0-127 in standard 8 bit palette
'each character will be rescaled to a tile 16 by 16 pixels in size
Dim p(t_wid, t_wid) As Integer 't_wid is set to 16 in main program
For c = 0 To 255
klr = -1
Cls
Locate 1, 1
Print Chr$(c)
For y = 0 To t_wid - 1
For x = 0 To t_wid - 1
p(x, y) = Point(Int(x / 2), y)
Next
Next
klr = p(0, 0)
tile(c) = Chr$(128 - klr)
For y = 0 To t_wid - 1
x = -1
Do
x = x + 1
If p(x, y) = klr Then n = n + 1
If p(x, y) <> klr Then
tile(c) = tile(c) + Chr$(128 + n)
klr = p(x, y)
If klr > 127 Then klr = 15 'if scanned color is over palette entry 127 it gets set to 15 for white in standard palette
tile(c) = tile(c) + Chr$(128 - klr)
n = 1
End If
If x = t_wid - 1 Then
tile(c) = tile(c) + Chr$(128 + n)
n = 0
End If
Loop Until x = t_wid - 1
Next
Next c
End Sub
|
|
|
|