Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 308
» Latest member: Donaldvem
» Forum threads: 1,741
» Forum posts: 17,901

Full Statistics

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

 
  Windows or Panels
Posted by: johnno56 - 09-02-2022, 06:39 AM - Forum: Help Me! - Replies (8)

Before starting on a game I need to know if QB64 is capable of creating multiple (3) display "screens or panels" that can handle scrolling text; not re-sizeable and without GUI borders....

Each panel will need to be able to have text and or graphics directed to them. I am not sure that I am explaining this properly.

This is a sample of the panel sizes....

   
Overall image size is 1024x768.


Top left panel: Graphics and a little text. Top right panel: Graphics and text: Bottom panel: Text only. (this panel may need to be able to scroll... but not too sure)

Print this item

  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

Print this item

  Vocab65
Posted by: johnno56 - 09-02-2022, 01:17 AM - Forum: Works in Progress - Replies (5)

Back in 1979, Tom Rugg and Phil Feldman, wrote a vocabulary quiz program for the TRS-80. Text only. It only had 15 words and meanings. I had converted it to several other Basic dialects in the past. Today is QB64's turn ... with a few modifications.

This is the first version for QB64. I am not sure about RND() as some dialects have slightly different formats. The program seems to work but is inefficient. I would appreciate extra sets of eyes to help with the streamlining of the conversion. I am only familiar with the basic (no pun intended) QB64 commands.

As always, all constructive criticism and advice, will be gratefully appreciated.

J


.zip   vocab65.zip (Size: 313.86 KB / Downloads: 33)

Print this item

  Tesla Coil That Dances With Your Music
Posted by: SierraKen - 09-01-2022, 11:19 PM - Forum: Programs - Replies (14)

Just like the real thing. Smile 

Put one of your sound files, like a .mp3 file, in the same folder as this. When it starts it asks for the file name, and you will also need the ending (like .mp3). Then it will play the song
and shoot lightning in the frequencies of the music. After it ends it will go back to asking for a song name again. 

Tell me what you think. I got almost all the code from the Wiki Help page with an example of sound frequency display here: https://qb64phoenix.com/qb64wiki/index.php/MEMSOUND 
I just turned the frequency waves into lightning bolts pretty much on a rod. 

(Code deleted, scroll down to my next code I posted.)

Print this item

  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

Print this item

  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

Print this item

  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

Print this item

  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

Print this item

  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. Smile 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.)

Print this item

  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

Print this item