QB64 Surabikku is a clone of an online sliding block puzzle I was playing called Surabikku. Click the arrows to slide the blocks until the puzzle board looks the same as the smaller image shown. Simple to play but not so simple to solve. May update this to use images instead of blocks, one day.
- Dav
EDIT: bplus made an update to this puzzle, you can find it HERE. Thanks, bplus!
Code: (Select All)
'=============
'SURABIKKU.BAS
'=============
'QB64 version of a SURABIKKU like puzzle.
'Use Arrows to slide pieces so board matches the solved image.
'Coded by Dav, MAY/2022
SCREEN _NEWIMAGE(1024, 675, 32)
'=== define deminsions for board
DIM SHARED row, col, size: row = 3: col = 3: size = 175
DIM SHARED boxes: boxes = row * col
'=== define box value, x/y, values...
DIM SHARED bv&(boxes) 'box values (scrambled)
DIM SHARED slv&(boxes) 'box values (solved)
DIM SHARED bx1(boxes), by1(boxes) 'top x/y cords of box
DIM SHARED bx2(boxes), by2(boxes) ' bottom x/y cords of box
bc = 1 'counter
FOR r = 1 TO row
FOR c = 1 TO col
x = 75 + (c * size): y = 75 + (r * size)
bx1(bc) = x - size: bx2(bc) = x ' generate x/y values
by1(bc) = y - size: by2(bc) = y
bc = bc + 1
NEXT
NEXT
CLS , _RGB(32, 32, 32)
FOR b = 1 TO boxes
_PUTIMAGE (bx1(b), by1(b))-(bx2(b), by2(b)), bv&(b)
LINE (bx1(b), by1(b))-(bx2(b), by2(b)), _RGB(0, 0, 0), B
NEXT
'=== draw top arrows
FOR t = 0 TO 450 STEP 175
LINE (130 + t, 55)-(160 + t, 25), _RGB(128, 128, 128)
LINE (160 + t, 25)-(190 + t, 55), _RGB(128, 128, 128)
LINE (130 + t, 55)-(190 + t, 55), _RGB(128, 128, 128)
NEXT
'=== draw bottom arrows
FOR t = 0 TO 450 STEP 175
LINE (130 + t, 620)-(160 + t, 650), _RGB(128, 128, 128)
LINE (160 + t, 650)-(190 + t, 620), _RGB(128, 128, 128)
LINE (130 + t, 620)-(190 + t, 620), _RGB(128, 128, 128)
NEXT
'=== draw left arrows
FOR t = 0 TO 450 STEP 175
LINE (20, 160 + t)-(50, 130 + t), _RGB(128, 128, 128)
LINE (20, 160 + t)-(50, 190 + t), _RGB(128, 128, 128)
LINE (50, 130 + t)-(50, 190 + t), _RGB(128, 128, 128)
NEXT
'=== draw right arrows
FOR t = 0 TO 450 STEP 175
LINE (620, 130 + t)-(650, 160 + t), _RGB(128, 128, 128)
LINE (620, 190 + t)-(650, 160 + t), _RGB(128, 128, 128)
LINE (620, 130 + t)-(620, 190 + t), _RGB(128, 128, 128)
NEXT
_DISPLAY
slidespeed = 300
DO
IF _MOUSEBUTTON(1) = 0 THEN clicked = 0
mi = _MOUSEINPUT: mx = _MOUSEX: my = _MOUSEY
IF _MOUSEBUTTON(1) = -1 AND clicked = 0 THEN
clicked = 1
'===== if top-left button clicked...
IF mx > 75 AND mx < 250 AND my > 0 AND my < 75 THEN
'=== slide column up
FOR y = 0 TO size
'=== just move bottom two images up
_PUTIMAGE (bx1(4), by1(4) - y), bv&(4)
_PUTIMAGE (bx1(7), by1(7) - y), bv&(7)
'=== expand bottom location with top image
_PUTIMAGE (bx1(7), by2(7) - y)-(bx2(7), by2(7)), bv&(1)
'=== redraw boxes around them, for looks
LINE (bx1(1), by1(1))-(bx2(1), by2(1)), _RGB(0, 0, 0), B
LINE (bx1(4), by1(4))-(bx2(4), by2(4)), _RGB(0, 0, 0), B
LINE (bx1(7), by1(7))-(bx2(7), by2(7)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(1): t2& = bv&(4): t3& = bv&(7) 'old values
bv&(1) = t2&: bv&(4) = t3&: bv&(7) = t1& 'new values
END IF
'===== if bottom-left button clicked...
IF mx > 75 AND mx < 250 AND my > 600 AND my < 675 THEN
'=== slide column down
FOR y = 0 TO size
'=== expand top location with bottom image
_PUTIMAGE (bx1(1), by1(1))-(bx2(1), by2(1) + y), bv&(7)
'=== just move top two images down
_PUTIMAGE (bx1(1), by1(1) + y), bv&(1)
_PUTIMAGE (bx1(4), by1(4) + y), bv&(4)
'=== redraw boxes around them, for looks
LINE (bx1(1), by1(1))-(bx2(1), by2(1)), _RGB(0, 0, 0), B
LINE (bx1(4), by1(4))-(bx2(4), by2(4)), _RGB(0, 0, 0), B
LINE (bx1(7), by1(7))-(bx2(7), by2(7)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(1): t2& = bv&(4): t3& = bv&(7) 'old values
bv&(1) = t3&: bv&(4) = t1&: bv&(7) = t2& 'new values
END IF
'===== if top-middle button clicked...
IF mx > 250 AND mx < 425 AND my > 0 AND my < 75 THEN
'=== slide column up
FOR y = 0 TO size
'=== just move bottom two images up
_PUTIMAGE (bx1(5), by1(5) - y), bv&(5)
_PUTIMAGE (bx1(8), by1(8) - y), bv&(8)
'=== expand bottom location with top image
_PUTIMAGE (bx1(8), by2(8) - y)-(bx2(8), by2(8)), bv&(2)
'=== redraw boxes around them, for looks
LINE (bx1(2), by1(2))-(bx2(2), by2(2)), _RGB(0, 0, 0), B
LINE (bx1(5), by1(5))-(bx2(5), by2(5)), _RGB(0, 0, 0), B
LINE (bx1(8), by1(8))-(bx2(8), by2(8)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(2): t2& = bv&(5): t3& = bv&(8) 'old values
bv&(2) = t2&: bv&(5) = t3&: bv&(8) = t1& 'new values
END IF
'===== if bottom-middle button clicked...
IF mx > 250 AND mx < 425 AND my > 600 AND my < 675 THEN
'=== slide column down
FOR y = 0 TO size
'=== expand top location with bottom image
_PUTIMAGE (bx1(2), by1(2))-(bx2(2), by2(2) + y), bv&(8)
'=== just move top two images down
_PUTIMAGE (bx1(2), by1(2) + y), bv&(2)
_PUTIMAGE (bx1(5), by1(5) + y), bv&(5)
'=== redraw boxes around them, for looks
LINE (bx1(2), by1(2))-(bx2(2), by2(2)), _RGB(0, 0, 0), B
LINE (bx1(5), by1(5))-(bx2(5), by2(5)), _RGB(0, 0, 0), B
LINE (bx1(8), by1(8))-(bx2(8), by2(8)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(2): t2& = bv&(5): t3& = bv&(8) 'old values
bv&(2) = t3&: bv&(5) = t1&: bv&(8) = t2& 'new values
END IF
'===== if top-right button clicked...
IF mx > 425 AND mx < 600 AND my > 0 AND my < 75 THEN
'=== slide column up
FOR y = 0 TO size
'=== just move bottom two images up
_PUTIMAGE (bx1(6), by1(6) - y), bv&(6)
_PUTIMAGE (bx1(9), by1(9) - y), bv&(9)
'=== expand bottom location with top image
_PUTIMAGE (bx1(9), by2(9) - y)-(bx2(9), by2(9)), bv&(3)
'=== redraw boxes around them, for looks
LINE (bx1(3), by1(3))-(bx2(3), by2(3)), _RGB(0, 0, 0), B
LINE (bx1(6), by1(6))-(bx2(6), by2(6)), _RGB(0, 0, 0), B
LINE (bx1(9), by1(9))-(bx2(9), by2(9)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(3): t2& = bv&(6): t3& = bv&(9) 'old values
bv&(3) = t2&: bv&(6) = t3&: bv&(9) = t1& 'new values
END IF
'===== if bottom-right button clicked...
IF mx > 425 AND mx < 600 AND my > 600 AND my < 675 THEN
'=== slide column down
FOR y = 0 TO size
'=== expand top location with bottom image
_PUTIMAGE (bx1(3), by1(3))-(bx2(3), by2(3) + y), bv&(9)
'=== just move top two images down
_PUTIMAGE (bx1(3), by1(3) + y), bv&(3)
_PUTIMAGE (bx1(6), by1(6) + y), bv&(6)
'=== redraw boxes around them, for looks
LINE (bx1(3), by1(3))-(bx2(3), by2(3)), _RGB(0, 0, 0), B
LINE (bx1(6), by1(6))-(bx2(6), by2(6)), _RGB(0, 0, 0), B
LINE (bx1(9), by1(9))-(bx2(9), by2(9)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(3): t2& = bv&(6): t3& = bv&(9) 'old values
bv&(3) = t3&: bv&(6) = t1&: bv&(9) = t2& 'new values
END IF
'===== if left-top button clicked...
IF mx > 0 AND mx < 75 AND my > 75 AND my < 250 THEN
'=== slide column left
FOR x = 0 TO size
'=== just move right two images left
_PUTIMAGE (bx1(2) - x, by1(2)), bv&(2)
_PUTIMAGE (bx1(3) - x, by1(3)), bv&(3)
'=== and expand far right location with far left image
_PUTIMAGE (bx2(3) - x, by1(3))-(bx2(3) - x, by2(3)), bv&(1)
'=== redraw boxes around them, for looks
LINE (bx1(1), by1(1))-(bx2(1), by2(1)), _RGB(0, 0, 0), B
LINE (bx1(2), by1(2))-(bx2(2), by2(2)), _RGB(0, 0, 0), B
LINE (bx1(3), by1(3))-(bx2(3), by2(3)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(1): t2& = bv&(2): t3& = bv&(3) 'old values
bv&(1) = t2&: bv&(2) = t3&: bv&(3) = t1& 'new values
END IF
'===== if right-top button clicked...
IF mx > 600 AND mx < 675 AND my > 75 AND my < 250 THEN
'=== slide column left
FOR x = 0 TO size
'=== just move left two images right
_PUTIMAGE (bx1(1) + x, by1(1)), bv&(1)
_PUTIMAGE (bx1(2) + x, by1(2)), bv&(2)
'=== and expand far left location with far right image
_PUTIMAGE (bx1(1), by1(1))-(bx1(1) + x, by2(1)), bv&(3)
'=== redraw boxes around them, for looks
LINE (bx1(1), by1(1))-(bx2(1), by2(1)), _RGB(0, 0, 0), B
LINE (bx1(2), by1(2))-(bx2(2), by2(2)), _RGB(0, 0, 0), B
LINE (bx1(3), by1(3))-(bx2(3), by2(3)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(1): t2& = bv&(2): t3& = bv&(3) 'old values
bv&(1) = t3&: bv&(2) = t1&: bv&(3) = t2& 'new values
END IF
'===== if left-middle button clicked...
IF mx > 0 AND mx < 75 AND my > 250 AND my < 425 THEN
'=== slide column left
FOR x = 0 TO size
'=== just move right two images left
_PUTIMAGE (bx1(5) - x, by1(5)), bv&(5)
_PUTIMAGE (bx1(6) - x, by1(6)), bv&(6)
'=== and expand far right location with far left image
_PUTIMAGE (bx2(6) - x, by1(6))-(bx2(6) - x, by2(6)), bv&(4)
'=== redraw boxes around them, for looks
LINE (bx1(4), by1(4))-(bx2(4), by2(4)), _RGB(0, 0, 0), B
LINE (bx1(5), by1(5))-(bx2(5), by2(5)), _RGB(0, 0, 0), B
LINE (bx1(6), by1(6))-(bx2(6), by2(6)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(4): t2& = bv&(5): t3& = bv&(6) 'old values
bv&(4) = t2&: bv&(5) = t3&: bv&(6) = t1& 'new values
END IF
'===== if right-middle button clicked...
IF mx > 600 AND mx < 675 AND my > 250 AND my < 425 THEN
'=== slide column left
FOR x = 0 TO size
'=== just move left two images right
_PUTIMAGE (bx1(4) + x, by1(4)), bv&(4)
_PUTIMAGE (bx1(5) + x, by1(5)), bv&(5)
'=== and expand far left location with far right image
_PUTIMAGE (bx1(4), by1(4))-(bx1(4) + x, by2(4)), bv&(6)
'=== redraw boxes around them, for looks
LINE (bx1(4), by1(4))-(bx2(4), by2(4)), _RGB(0, 0, 0), B
LINE (bx1(5), by1(5))-(bx2(5), by2(5)), _RGB(0, 0, 0), B
LINE (bx1(6), by1(6))-(bx2(6), by2(6)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(4): t2& = bv&(5): t3& = bv&(6) 'old values
bv&(4) = t3&: bv&(5) = t1&: bv&(6) = t2& 'new values
END IF
'===== if left-bottom button clicked...
IF mx > 0 AND mx < 75 AND my > 425 AND my < 600 THEN
'=== slide column left
FOR x = 0 TO size
'=== just move right two images left
_PUTIMAGE (bx1(8) - x, by1(8)), bv&(8)
_PUTIMAGE (bx1(9) - x, by1(9)), bv&(9)
'=== and expand far right location with far left image
_PUTIMAGE (bx2(9) - x, by1(9))-(bx2(9) - x, by2(9)), bv&(7)
'=== redraw boxes around them, for looks
LINE (bx1(7), by1(7))-(bx2(7), by2(7)), _RGB(0, 0, 0), B
LINE (bx1(8), by1(8))-(bx2(8), by2(8)), _RGB(0, 0, 0), B
LINE (bx1(9), by1(9))-(bx2(9), by2(9)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(7): t2& = bv&(8): t3& = bv&(9) 'old values
bv&(7) = t2&: bv&(8) = t3&: bv&(9) = t1& 'new values
END IF
'===== if right-bottom button clicked...
IF mx > 600 AND mx < 675 AND my > 425 AND my < 600 THEN
'=== slide column left
FOR x = 0 TO size
'=== just move left two images right
_PUTIMAGE (bx1(7) + x, by1(7)), bv&(7)
_PUTIMAGE (bx1(8) + x, by1(8)), bv&(8)
'=== and expand far left location with far right image
_PUTIMAGE (bx1(7), by1(7))-(bx1(7) + x, by2(7)), bv&(9)
'=== redraw boxes around them, for looks
LINE (bx1(7), by1(7))-(bx2(7), by2(7)), _RGB(0, 0, 0), B
LINE (bx1(8), by1(8))-(bx2(8), by2(8)), _RGB(0, 0, 0), B
LINE (bx1(9), by1(9))-(bx2(9), by2(9)), _RGB(0, 0, 0), B
_DISPLAY
_LIMIT slidespeed
NEXT
'=== update/assign new values
t1& = bv&(7): t2& = bv&(8): t3& = bv&(9) 'old values
bv&(7) = t3&: bv&(8) = t1&: bv&(9) = t2& 'new values
END IF
'==== check if puzzle is solved....
solved = 1 'assume it is first
FOR s = 1 TO boxes
'=== if piece doesnt match, not solved
IF bv&(s) <> slv&(s) THEN solved = 0
NEXT
'=== Solved? END
IF solved = 1 THEN BEEP: BEEP: END
END IF
LOOP
END
SUB PPRINT (x, y, size, clr&, trans&, text$)
'This sub outputs to the current _DEST set
'It makes trans& the transparent color
'x/y is where to print text
'size is the font size to use
'clr& is the color of your text
'trans& is the background transparent color
'text$ is the string to print
'=== get users current write screen
orig& = _DEST
'=== if you are using an 8 or 32 bit screen
bit = 32: IF _PIXELSIZE(0) = 1 THEN bit = 256
'=== step through your text
FOR t = 0 TO LEN(text$) - 1
'=== make a temp screen to use
pprintimg& = _NEWIMAGE(16, 16, bit)
_DEST pprintimg&
'=== set colors and print text
CLS , trans&: COLOR clr&
PRINT MID$(text$, t + 1, 1);
'== make background color the transprent one
_CLEARCOLOR _RGB(0, 0, 0), pprintimg&
'=== go back to original screen to output
_DEST orig&
'=== set it and forget it
x1 = x + (t * size): x2 = x1 + size
y1 = y: y2 = y + size
_PUTIMAGE (x1 - (size / 2), y1)-(x2, y2 + (size / 3)), pprintimg&
_FREEIMAGE pprintimg&
NEXT
END SUB
I just ran into the problem again last night, checking out an old program that worked fine before version 1.5
This WAS a set of CONST's (without suffix because at one time you didn't need suffix for a CONST)
Code: (Select All)
Dim Shared As _Unsigned Long skyC, ballC, groundC, cannonC, printC ' fix color Const for v 2.0 and 1.5 broken too
skyC = &HFF9988FF
ballC = &HFF000000
groundC = &HFF405020
cannonC = &HFF884422
printC = &HFFEEDDCC
]
I was reviewing a Mod I made of Ken's Artillary program years ago and surprised the dang cannon balls were blowing up at the ends of the cannons not having moved a pixel!?!? WTH
The Point value for sky was not matching the color Const for skyC.
Oh yeah, something (not so) funny happened to Color constants and now they need suffix or the above fix.
I am classifying this as a bug because code is not compatible with the past.
the qb64 editor creates a temp directory in internal at each startup even if no code entry is made. to check, start qb64 and quit. there will be a new temp directory created each time.
if I select other colors in the editor (Options/IDE color). the next time I start up. the colors come back by default...
another strangeness, there is an addition of data in the config.ini file located in internal. It seems to be a bug :
Alien Skies is based off recollection of code from a book I read 25-30 years ago. I've made use of some code from the fine contributors in this forum.
to add: rocks, sky beams, oceans, flora
Code: (Select All)
' alienskies
' By James D. Jarvis
' also includes other folks fine code found here https://staging.qb64phoenix.com/index.php
' fun little image genreating program
'
'press q to quit, any othjer key to generate a new image
MS& = _NewImage(imgmax_x, imgmax_y, 32)
Screen MS&
Print "Some images can take a couple seconds to generate"
Do
'Cls
ectocheck = Int(Rnd * 100)
If ectocheck < 30 Then ectosky
starfield
moons
acheck = Int(Rnd * 100)
If acheck < 60 Then atm& = atmos
hrz = horizon
flatland hrz
gk& = Point(1, hrz)
mcheck = Int(Rnd * 100)
If mcheck < 60 Then mountains gk&, hrz
askagain:
ask$ = LCase$(InKey$)
If ask$ = "" Then GoTo askagain
Cls
Loop Until ask$ = "q"
Sub moons
mm = Int(Rnd * 6)
If mm > 0 Then
For m = 1 To mm
mx = Int(Rnd * imgmax_x)
my = Int(Rnd * imgmax_y * .75)
mkr = Int(Rnd * 100) + 50: mkg = Int(Rnd * 100) + 50: mkb = Int(Rnd * 100) + 50
mklr& = _RGB32(mkr, mkg, mkb)
moonsize = Int(((Rnd * 200) + (Rnd * 200)) / 2)
orb mx, my, moonsize, mklr&, 1.8
kk = 1
ccheck = Int(Rnd * 100)
If ccheck < 90 Then kk = craters(mx, my, moonsize, mklr&)
moonfuzz mx, my, moonsize, mklr&, 10 + (kk * 3)
Next m
End If
End Sub
Sub mountains (gk&, hrz)
gc& = gk&
mh = Int(Rnd * 10) + 2
md = 1
For by = hrz To imgmax_y Step 4
x = 0
Do
If md = -1 Then mh = mh - Int(Rnd * 4)
If mh > 0 Then
Line (x, by - mh)-(x, by), gc&
gc& = gk&
For b = (by - mh + mh / 4) To mh + Int(Rnd * 6)
PSet (x, b), gc&
gc& = brighter(gc&, 13.5)
Next b
End If
If md = 1 Then mh = mh + Int(Rnd * 4) - Int(Rnd * 4)
If mh > 100 Then md = md - 1
x = x + 1
Loop Until x > imgmax_x
Next by
End Sub
Function atmos&
'add atmosphereic color
ar = Int(Rnd * 255)
ag = Int(Rnd * 255)
ab = Int(Rnd * 255)
aa = Int(Rnd * 85) + 10
For y = imgmax_y To 0 Step -1
a2 = Int(aa - y / 3)
ak& = _RGBA32(ar, ag, ab, aa - a2)
Line (0, y)-(imgmax_x, y), ak&
Next y
atmos& = _RGBA32(ar, ag, ab, aa)
End Function
Function horizon
maxh = imgmax_y * .5
hh = maxh + (Int(Rnd * 300) + 30)
If hh > imgmax_y Then hh = maxh
horizon = hh
End Function
Sub flatland (hr)
'slap down the ground
fr = Int(Rnd * 185)
fg = Int(Rnd * 185)
fb = Int(Rnd * 185)
lk& = _RGB32(fr, fg, fb)
kc = 0
For y = hr To imgmax_y
Line (0, y)-(imgmax_x, y), lk&
If kc = 4 Then lk& = brighter&(lk&, 1.1)
kc = kc + 1
If kc > 4 Then kc = 0
Next y
End Sub
Function craters (mx, my, mrd, mk&)
' put craters on those moons
' well mostly on the moons sometimes one walks off the edge, that'll get fixed eventually.
crmax = mrd * .2
numk = Int(Rnd * 24) + 12
For k = 1 To numk
crad = Int(Rnd * crmax) + 1
cx = mx + Int(Rnd * crmax * 4) - Int(Rnd * crmax * 4)
cy = my + Int(Rnd * crmax * 4) - Int(Rnd * crmax * 4)
nk& = mk&
orb cx, cy, crad, nk&, 1.9
Next k
craters = numk
End Function
Sub starfield
' generate goofy fuzzy stars
maxstars = Int(Rnd * 6000) + 50
starsize = Int(((Rnd * 3 + 1) + (Rnd * 3 + 1)) / 2)
For s = 1 To maxstars
bc = Int(Rnd * 10 + 244)
sx = Int(Rnd * imgmax_x)
sy = Int(Rnd * imgmax_y)
bb = 0
For sv = 1 To (starsize * starsize)
PSet (sx + Int(Rnd * starsize) - (Rnd * starsize), sy - Int(Rnd * starsize) + Int(Rnd * starsize)), _RGB32(bc * (1 - bb), bc * (1 - bb), bc * (1 - bb))
bb = bb + .1
Next sv
Next s
End Sub
Function brighter& (ch&&, p)
'eventually going to replace this sub with a beter one
r = _Red(ch&&)
b = _Blue(ch&&)
g = _Green(ch&&)
If p < 0 Then p = 0
If p > 100 Then p = 100
p = p / 100
rdif = 255 - r: rc = rdif * p: brr = Int(r + rc): If brr > 255 Then brr = 255
gdif = 255 - g: gc = gdif * p: bgg = Int(g + gc): If bgg > 255 Then bgg = 255
bdif = 255 - b: bc = bdif * p: bbb = Int(b + bc): If bbb > 255 Then bbb = 255
brighter& = _RGB(brr, bgg, bbb)
End Function
Sub orb (XX As Long, YY As Long, Rd As Long, KK As Long, brt As Integer)
'false shaded 3d spheres
Dim nk As Long
nk = KK
ps = _Pi
p3 = _Pi / 3
p4 = _Pi / 4
If Rd < 10 Then ps = _Pi / 6 'so small radius orbs look cool too
rdc = p4 / Rd
For c = 0 To Int(Rd * .87) Step ps
nk = brighter&(nk, brt)
CircleFill XX, YY, Rd - (c), nk
XX = XX + rdc * (c * p3) ' could be fiddled with to move the center of the gradient
YY = YY - rdc * (c * 2 * p4) ' could be fiddled with to move the center of the gradient
Next c
End Sub
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
'sub by SMcNeill makes a filled circle without worrying about using the paint comamnd to fill an empty circle
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, 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), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub moonfuzz (CX As Long, CY As Long, R As Long, C As Long, CHNC As Integer)
'CX and CY are to plot of the circle center R is the radius, c is the primary color, CHNC is the chance for noise to vary from from primary color
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
'checking to see if we should use the base color or slap down some random noise
For tx = CX - X To CX + X
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84)) 'drawing each point in the line because color can change from pixel to pixel
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
For tx = CX - Y To CX + Y
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY - X), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
For tx = CX - Y To CX + Y
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY + X), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
For tx = CX - X To CX + X
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY - Y), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
For tx = CX - X To CX + X
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY + Y), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
'dotc = C let the color stay as drawn by orb
End If
Next tx
Wend
End Sub
Sub ectosky
Dim tim&
tim& = _NewImage(400, 300, 32)
_Dest tim&
sh = _Height
sw = _Width
Dim d, dv, vv
d = 1
dv = 1
vv = 1
replim = Int(Rnd * 12) + 1
nr = 0
Do
tm = Timer(.001)
dr = Int(Rnd * 255) + 1: dg = Int(Rnd * 255) + 1: db = Int(Rnd * 255) + 1
w = w + 5 / 83
For y = 0 To sh
'_limit 1000
For x = 0 To sw
vl = Sin(distance(x + tm * w, y, 128, 128) / 8 + w)
vl = vl + Sin(distance(x, y, 64, 64) / 8)
vl = vl + Sin(distance(x, y + tm / 7, 192, 64) / 7)
vl = vl + Sin(distance(x, y, 192, 100) / 8)
clr = 255 / (1.00001 * Abs(vl))
r = .9 * Abs(clr - dr): g = .4 * Abs(clr - dg): b = .5 * Abs(clr - db)
PSet (x, y), _RGB32(r, g, b)
Next
Next
If w > 1440 Or w < -1440 Then w = 0: d = d * -1
_Limit 6000
nr = nr + 1
Loop Until nr = replim 'genrating a still so we move through a few iterations for the ecto plasma
_PutImage , tim&, MS&
_Dest MS&
_FreeImage tim&
End Sub
Function distance (x1, y1, x2, y2) '//between two points x1,y1 and x2,y2
distance = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ (.5)
End Function
I'm making an RTS engine, hopefully with randomly generated landscapes. It's very very early days, just a simple map generator so far, just curious on how it runs on other hardware and if anyone has a flicker problem. Attachment required.
Use the mouse to scroll the landscape. Arrow keys also work. Use W and S to zoom in and out. Click to select a tile.
Code: (Select All)
REM RTS Engine
REM DP 2022
REM 0.1
REM icon, version info and error handler
ON ERROR GOTO errorhandler
LET consolelog$ = "data\consolelog.txt": REM sets console log file location
$EXEICON:'data\icon.ico'
_ICON
setup:
REM setup
LET setupboot = 1
REM timer
RANDOMIZE TIMER
LET itime = TIMER: REM timer function
LET ctime = 0: REM timer function
REM check os
IF INSTR(_OS$, "[WINDOWS]") THEN LET ros$ = "win"
IF INSTR(_OS$, "[LINUX]") THEN LET ros$ = "lnx"
IF INSTR(_OS$, "[MACOSX]") THEN LET ros$ = "mac"
REM check metadata exists, checks developer console settings and load engine values
IF _FILEEXISTS("data\engine.ddf") THEN
OPEN "data\engine.ddf" FOR INPUT AS #1
INPUT #1, devmode, displayconsole, consolelogging, title$, resx, resy, chunksizex, chunksizey, chunktotalx, chunktotaly, zoomscale, maxchunksizex, maxchunksizey, minchunksizex, minchunksizey, hertz, scrollspeed, selectboxblink, selectboxsize
CLOSE #1
IF ros$ = "win" THEN
REM finds metadata directory paths (windoze)
IF _FILEEXISTS("data\filelocwin.ddf") THEN
OPEN "data\filelocwin.ddf" FOR INPUT AS #1
INPUT #1, dloc$, sloc$, aloc$, cloc$, uiloc$, unitloc$, bloc$
CLOSE #1
ELSE
ERROR 420
END IF
ELSE
REM finds metadata directory paths (mac + linux)
IF _FILEEXISTS("data\filelocother.ddf") THEN
OPEN "data\filelocother.ddf" FOR INPUT AS #1
INPUT #1, dloc$, sloc$, aloc$, cloc$, uiloc$, unitloc$, bloc$
CLOSE #1
ELSE
ERROR 420
END IF
END IF
$CONSOLE
IF displayconsole = 1 THEN
_CONSOLE ON
IF title$ <> "" THEN
_CONSOLETITLE title$ + " Console"
ELSE
_CONSOLETITLE "RTS ENGINE Console"
END IF
END IF
IF displayconsole = 0 THEN _CONSOLE OFF
REM reports system info to console
LET eventtitle$ = "RTS ENGINE BOOTED"
LET eventdata$ = ""
LET eventnumber = 0
GOSUB consoleprinter
LET eventtitle$ = "OPERATING SYSTEM DETECTED:"
IF ros$ = "win" THEN LET eventdata$ = "Microsoft Windows"
IF ros$ = "lnx" THEN LET eventdata$ = "Linux"
IF ros$ = "mac" THEN LET eventdata$ = "Apple macOS"
LET eventnumber = 0
GOSUB consoleprinter
LET eventtitle$ = "LOADED METADATA:"
LET eventdata$ = dloc$ + "engine.ddf"
LET eventnumber = 0
GOSUB consoleprinter
ELSE
ERROR 420: REM error if directory unavailable
END IF
GOSUB screenload
_MOUSESHOW "CROSSHAIR"
GOSUB assetload
GOSUB dimmer
GOSUB menugenerator
LET setupboot = 0
GOTO game
dimmer:
REM assigns array values
LET chunktotal = chunktotalx * chunktotaly
DIM chunktype(chunktotal) AS INTEGER
DIM chunkgenerator(chunktotal) AS INTEGER
DIM chunkdata1(chunktotal) AS INTEGER
DIM chunkdata2(chunktotal) AS INTEGER
REM prints to console
LET eventtitle$ = "ARRAY VALUES ASSIGNED"
LET eventdata$ = ""
LET eventnumber = 0
GOSUB consoleprinter
RETURN
drawhud:
REM display controls / info
REM temp info box
IF selectedchunk > 0 THEN
IF chunktype(selectedchunk) = 1 THEN LET selectedchunkname$ = "Sand"
IF chunktype(selectedchunk) = 2 THEN LET selectedchunkname$ = "Rock"
IF chunktype(selectedchunk) = 3 THEN LET selectedchunkname$ = "Spice"
IF selectedchunkname$ <> "" THEN _PRINTSTRING(1, 1), selectedchunkname$
END IF
IF selectedchunk > 0 THEN GOSUB drawselectbox
RETURN
drawselectbox:
REM draws selectbox
LET drawposx = 0
LET drawposy = 0
FOR x = 1 TO chunktotal
REM detects if selextbox is on screen
IF camerax =< drawposx AND camerax =< (drawposx + resx) THEN LET drawpassx1 = 1
IF cameray =< (drawposy + chunksizey) AND cameray =< (drawposy + resy) THEN LET drawpassy1 = 1
IF (drawposx - chunksizex) <= (camerax + resx) THEN LET drawpassx2 = 1
IF drawposy <= (cameray + resy) ThEN LET drawpassy2 = 1
LET drawpasstotal = drawpassx1 + drawpassx2 + drawpassy1 + drawpassy2
REM draws selected chunk and select box if on screen
IF selectedchunk = x AND chunktype(selectedchunk) = 1 AND drawpasstotal = 4 THEN
REM sand chunk
_PUTIMAGE ((drawposx - camerax), (drawposy - cameray))-((drawposx - chunksizex) - camerax, (drawposy + chunksizey) - cameray), sandchunk
END IF
IF selectedchunk = x AND chunktype(selectedchunk) = 2 AND drawpasstotal = 4 THEN
REM rock chunk
_PUTIMAGE ((drawposx - camerax), (drawposy - cameray))-((drawposx - chunksizex) - camerax, (drawposy + chunksizey) - cameray), rockchunk
END IF
IF selectedchunk = x AND chunktype(selectedchunk) = 3 AND drawpasstotal = 4 THEN
REM spice chunk
_PUTIMAGE ((drawposx - camerax), (drawposy - cameray))-((drawposx - chunksizex) - camerax, (drawposy + chunksizey) - cameray), spicechunk
END IF
IF selectedchunk = x AND drawpasstotal = 4 THEN
REM select box
FOR y = 1 TO selectboxsize STEP zoomscale
LINE (((drawposx - camerax) - y), (drawposy - cameray) + (y - 1))-(((drawposx - chunksizex) - camerax) + (y - 1), ((drawposy + chunksizey) - cameray) - y), _RGBA(40, 250, 53, selectboxalpha), B
NEXT y
END IF
LET drawposx = drawposx + chunksizex
IF drawposx > ((chunksizex * chunktotalx) - chunksizex) THEN
LET drawposx = 0
LET drawposy = drawposy + chunksizey
END IF
LET drawpassx1 = 0
LET drawpassy1 = 0
LET drawpassx2 = 0
LET drawpassy2 = 0
LET drawpasstotal = 0
NEXT x
RETURN
assetload:
REM loads game assets
LET spicechunk = _LOADIMAGE(cloc$ + "spicechunk.png")
LET sandchunk = _LOADIMAGE(cloc$ + "sandchunk.png")
LET rockchunk = _LOADIMAGE(cloc$ + "rockchunk.png")
LET turbine = _LOADIMAGE(bloc$ + "turbine.png")
REM print to console
LET eventtitle$ = "GAME ASSETS LOADED"
LET eventdata$ = ""
LET eventnumber = 0
GOSUB consoleprinter
RETURN
assetunload:
REM unloads game assets
_FREEIMAGE spicechunk
_FREEIMAGE sandchunk
_FREEIMAGE rockchunk
_FREEIMAGE turbine
REM print to console
LET eventtitle$ = "GAME ASSETS UNLOADED"
LET eventdata$ = ""
LET eventnumber = 0
GOSUB consoleprinter
RETURN
savegame:
REM saves game
IF setupboot = 1 THEN
REM divert for if no game is available to be saved
LET eventtitle$ = "NO GAME AVAILABLE TO SAVE"
LET eventdata$ = sloc$ + "savedata.ddf"
LET eventnumber = frames
GOSUB consoleprinter
RETURN
END IF
OPEN sloc$ + "savedata.ddf" FOR OUTPUT AS #666
FOR x = 1 TO chunktotal
WRITE #666, chunktype(x), chunkdata1(x), chunkdata2(x)
NEXT x
WRITE #666, camerax, cameray, chunksizex, chunksizey, selectedchunk
CLOSE #666
REM prints to console
LET eventtitle$ = "GAME SAVED"
LET eventdata$ = sloc$ + "savedata.ddf"
LET eventnumber = frames
GOSUB consoleprinter
RETURN
loadgame:
REM loads game
REM checks if save file is available
IF _FILEEXISTS(sloc$ + "savedata.ddf") THEN
REM nothing
ELSE
LET eventtitle$ = "NO SAVE DATA FOUND"
LET eventdata$ = sloc$ + "savedata.ddf"
LET eventnumber = 0
GOSUB consoleprinter
RETURN
END IF
REM loads save file
OPEN sloc$ + "savedata.ddf" FOR INPUT AS #666
FOR x = 1 TO chunktotal
INPUT #666, chunktype(x), chunkdata1(x), chunkdata2(x)
NEXT x
INPUT #666, camerax, cameray, chunksizex, chunksizey, selectedchunk
CLOSE #666
REM prints to console
LET eventtitle$ = "GAME LOADED"
LET eventdata$ = sloc$ + "savedata.ddf"
LET eventnumber = frames
GOSUB consoleprinter
IF setupboot = 1 THEN LET setupboot = 0: GOTO game: REM launches game if loading from first boot
RETURN
generatelandscape:
REM generates landscape
PRINT "GENRATING LANDSCAPE..."
FOR x = 1 TO chunktotal
LET chunkgenerator(x) = INT(RND * 100) + 1
IF chunkgenerator(x) <= 60 THEN LET chunktype(x) = 1
IF chunkgenerator(x) > 60 AND chunkgenerator(x) <= 80 THEN LET chunktype(x) = 2
IF chunkgenerator(x) > 80 THEN LET chunktype(x) = 3
NEXT x
LET selectedchunk = -1
LET chunksizex = minchunksizex
LET chunksizey = minchunksizey
LET camerax = 0
LET cameray = 0
REM print to console
LET eventtitle$ = "LANDSCAPE GENERATED"
LET eventdata$ = ""
LET eventnumber = chunktotal
GOSUB consoleprinter
RETURN
consoleprinter:
REM prints extra engine data to console / error log
IF consolelogging = 1 THEN
IF _FILEEXISTS(consolelog$) THEN
REM nothing
ELSE
OPEN consolelog$ FOR OUTPUT AS #2
PRINT #2, DATE$, TIME$, "RTS ENGINE CONSOLE LOG"
CLOSE #2
END IF
OPEN consolelog$ FOR APPEND AS #2
IF eventnumber <> 0 THEN PRINT #2, DATE$, TIME$, eventtitle$, eventdata$; eventnumber
IF eventnumber = 0 THEN PRINT #2, DATE$, TIME$, eventtitle$, eventdata$
CLOSE #2
END IF
IF displayconsole = 1 THEN
REM displays in console
_DEST _CONSOLE
IF eventnumber <> 0 THEN PRINT DATE$, TIME$, eventtitle$, eventdata$; eventnumber
IF eventnumber = 0 THEN PRINT DATE$, TIME$, eventtitle$, eventdata$
_DEST 0
END IF
REM flush values
LET eventtitle$ = "": LET eventdata$ = "": LET eventnumber = 0
RETURN
errorhandler:
REM handles expected in-game errors
IF ERR = 423 THEN LET errdescription$ = "MISSING SCRIPT FILE - " + scriptname$
IF ERR = 424 THEN LET errdescription$ = "MISSING ANIMATION FILE - " + anifile$
IF ERR = 425 THEN LET errdescription$ = "MISSING TERMINAL FILE - " + runterminal$
IF consolelogging = 1 THEN
OPEN consolelog$ FOR APPEND AS #2
IF errdescription$ <> "" THEN
PRINT #2, DATE$, TIME$, "ERROR: "; ERR, "LINE: "; _ERRORLINE, errdescription$
ELSE
PRINT #2, DATE$, TIME$, "ERROR: "; ERR, "LINE: "; _ERRORLINE, UCASE$(_ERRORMESSAGE$)
END IF
CLOSE #2
END IF
REM PRINTS TO CONSOLE
IF displayconsole = 1 THEN
_DEST _CONSOLE
IF errdescription$ <> "" THEN
PRINT DATE$, TIME$, "ERROR: "; ERR, "LINE: "; _ERRORLINE, errdescription$
ELSE
PRINT DATE$, TIME$, "ERROR: "; ERR, "LINE: "; _ERRORLINE, UCASE$(_ERRORMESSAGE$)
END IF
_DEST 0
END IF
LET errdescription$ = "": REM scrub temp values
IF ERR < 420 THEN RESUME NEXT
REM halts program upon unexpected error
REM == FROM HERE, PROGRAM WILL HALT AND IS CONSIDERED NON-RECOVERABLE ==
ON ERROR GOTO errorduringerror: REM error handler for the error handler (ikr)
IF ERR = 420 THEN LET errdescription$ = "MISSING ENGINE METADATA - TRY REINSTALL"
IF ERR = 421 THEN LET errdescription$ = "MISSING METADATA DIRECTORY - TRY REINSTALL"
IF ERR = 422 THEN LET errdescription$ = "MISSING DEFAULT SAVE FILE - TRY REINSTALL"
IF ERR = 666 THEN LET errdescription$ = "DEMONIC ERROR - CONTACT LOCAL UAC REP"
IF ERR = 999 THEN LET errdescription$ = "UNSUPPORTED OPERATING SYSTEM - LOCATE UNFORKED BUILD"
LET errorcrash = 1: REM sets error crash value to 1
BEEP
PRINT "=== GURU MEDITATION ==="
PRINT DATE$, TIME$
PRINT "ERROR CODE: "; ERR
PRINT "LINE: "; _ERRORLINE
PRINT errdescription$
PRINT
IF title$ <> "" THEN
PRINT title$; " will now close."
ELSE
PRINT "RTS ENGINE will now close."
END IF
END
errorduringerror:
REM if error handler encounters an error
BEEP
PRINT "=== SUPER GURU ==="
PRINT "ERROR MANAGER HAS CRASHED!"
PRINT DATE$, TIME$
PRINT "ERROR CODE: "; ERR
PRINT "LINE: "; _ERRORLINE
PRINT errdescription$
PRINT "ERROR INFO WILL NOT BE DUMPED TO FILE."
PRINT
IF title$ <> "" THEN
PRINT title$; " will now close."
ELSE
PRINT "RTS ENGINE will now close."
END IF
END
drawlandscape:
REM draws landscape
LET drawposx = 0
LET drawposy = 0
LET chunkdrawcount = 0
FOR x = 1 TO chunktotal
REM detects if chunk is on screen
IF camerax =< drawposx AND camerax =< (drawposx + resx) THEN LET drawpassx1 = 1
IF cameray =< (drawposy + chunksizey) AND cameray =< (drawposy + resy) THEN LET drawpassy1 = 1
IF (drawposx - chunksizex) <= (camerax + resx) THEN LET drawpassx2 = 1
IF drawposy <= (cameray + resy) ThEN LET drawpassy2 = 1
LET drawpasstotal = drawpassx1 + drawpassx2 + drawpassy1 + drawpassy2
REM draws chunk if on screen
IF chunktype(x) = 1 AND drawpasstotal = 4 THEN
REM sand chunk
_PUTIMAGE ((drawposx - camerax), (drawposy - cameray))-((drawposx - chunksizex) - camerax, (drawposy + chunksizey) - cameray), sandchunk
LET chunkdrawcount = chunkdrawcount + 1
END IF
IF chunktype(x) = 2 AND drawpasstotal = 4 THEN
REM rock chunk
_PUTIMAGE ((drawposx - camerax), (drawposy - cameray))-((drawposx - chunksizex) - camerax, (drawposy + chunksizey) - cameray), rockchunk
LET chunkdrawcount = chunkdrawcount + 1
END IF
IF chunktype(x) = 3 AND drawpasstotal = 4 THEN
REM spice chunk
_PUTIMAGE ((drawposx - camerax), (drawposy - cameray))-((drawposx - chunksizex) - camerax, (drawposy + chunksizey) - cameray), spicechunk
LET chunkdrawcount = chunkdrawcount + 1
END IF
LET drawposx = drawposx + chunksizex
IF drawposx > ((chunksizex * chunktotalx) - chunksizex) THEN
LET drawposx = 0
LET drawposy = drawposy + chunksizey
END IF
LET drawpassx1 = 0
LET drawpassy1 = 0
LET drawpassx2 = 0
LET drawpassy2 = 0
LET drawpasstotal = 0
NEXT x
RETURN
screenload:
REM sets screen mode
_TITLE title$
SCREEN _NEWIMAGE(resx, resy, 32)
$RESIZE:STRETCH
IF screenmode = 2 THEN _FULLSCREEN _OFF
IF screenmode = 1 THEN _FULLSCREEN _SQUAREPIXELS
IF devmode = 0 THEN _MOUSEHIDE: REM hides mouse (if devmode is off)
LET eventtitle$ = "SCREEN MODE SET:"
IF screenmode = 2 THEN LET eventdata$ = "windowed"
IF screenmode = 1 THEN LET eventdata$ = "fullscreen"
LET eventnumber = screenmode
GOSUB consoleprinter
RETURN
keyinputter:
REM keyboard input
IF _KEYDOWN(18432) THEN LET cameray = cameray - scrollspeed: LET drawscreen = 1: REM up
IF _KEYDOWN(20480) THEN LET cameray = cameray + scrollspeed: LET drawscreen = 1: REM down
IF _KEYDOWN(19712) THEN LET camerax = camerax + scrollspeed: LET drawscreen = 1: REM right
IF _KEYDOWN(19200) THEN LET camerax = camerax - scrollspeed: LET drawscreen = 1: REM left
IF _KEYDOWN(119) THEN
IF chunksizex <> maxchunksizex AND chunksizey <> maxchunksizey THEN
REM zoom in
REM increase chunk size
LET chunksizex = chunksizex + zoomscale
LET chunksizey = chunksizey + zoomscale
REM pan camera to account for chunk size change
LET camerax = camerax + INT((camerax / chunksizex) * zoomscale)
LET cameray = cameray + INT((cameray / chunksizey) * zoomscale)
LET drawscreen = 1
END IF
END IF
IF _KEYDOWN(115) THEN
IF chunksizex <> minchunksizex AND chunksizey <> minchunksizey THEN
REM zoom out
REM decrease chunk size
LET chunksizex = chunksizex - zoomscale
LET chunksizey = chunksizey - zoomscale
REM pan camera to account for chunk size change
LET camerax = camerax - INT((camerax / chunksizex) * zoomscale)
LET cameray = cameray - INT((cameray / chunksizey) * zoomscale)
LET drawscreen = 1
END IF
END IF
IF UCASE$(b$) = "Q" THEN GOSUB menugenerator
IF UCASE$(b$) = "I" THEN GOSUB dropbuilding
LET temp = 0: REM clears temp values
RETURN
dropbuilding:
REM enables a building to drop onto the map
REM temp building selector
LET dropmode = 1
INPUT "TYPE OF BUILDING: "; x
LET builddroptype = x
IF builddroptype = 1 THEN LET builddropname$ = "turbine"
REM loads building metadata
OPEN bloc$ + builddropname$ + ".ddf" FOR INPUT AS #1
INPUT #1, dummy$, builddropsizex, builddropsizey
CLOSE #1
REM main drop loop
LET drawscreen = 1
_MOUSESHOW "LINK"
DO
LET invaliddrop = 0
_LIMIT hertz
REM captures mouse input
DO WHILE _MOUSEINPUT
LET mousex = _MOUSEX
LET mousey = _MOUSEY
LET leftclick = _MOUSEBUTTON (1)
LET rightclick = _MOUSEBUTTON (2)
LET scrollwheel = scrollwheel + _MOUSEWHEEL
LOOP
REM draw existsing landscape
IF drawscreen = 1 THEN GOSUB drawlandscape
GOSUB timeframecounter: REM time keeper
REM draws drop building
LET pointerx = INT((mousex + camerax) / chunksizex)
LET pointery = INT((mousey + cameray) / chunksizey)
LET pointerx = pointerx + 2: REM some weird correction i dont understand yet
LET selectedchunk = pointerx + (pointery * chunktotalx)
IF oldselectedchunk = selectedchunk THEN
LET drawscreen = 0
ELSE
LET drawscreen = 1
END IF
LET drawposx = 0
LET drawposy = 0
FOR x = 1 TO chunktotal
IF selectedchunk = x THEN
LET oldselectedchunk = selectedchunk
REM checks if build location is valid
FOR y = 0 TO builddropsizex
FOR v = 0 TO buildropsizey
IF chunktype((chunktotalx * v) + (selectedchunk - y)) = 2 THEN LET invaliddrop = 1
NEXT v
NEXT y
REM building image
_PUTIMAGE (((drawposx - camerax) - y), (drawposy - cameray) + (y - 1))-(((drawposx - (chunksizex * builddropsizex)) - camerax) + (y - 1), ((drawposy + (chunksizey * builddropsizey)) - cameray) - y), turbine
REM select box
FOR y = 1 TO selectboxsize STEP zoomscale
IF invaliddrop = 1 THEN
LINE (((drawposx - camerax) - y), (drawposy - cameray) + (y - 1))-(((drawposx - (chunksizex * builddropsizex)) - camerax) + (y - 1), ((drawposy + (chunksizey * builddropsizey)) - cameray) - y), _RGBA(255, 0, 0, selectboxalpha), B: REM ivalid location select box
ELSE
LINE (((drawposx - camerax) - y), (drawposy - cameray) + (y - 1))-(((drawposx - (chunksizex * builddropsizex)) - camerax) + (y - 1), ((drawposy + (chunksizey * builddropsizey)) - cameray) - y), _RGBA(40, 250, 53, selectboxalpha), B: REM valid location select box
END IF
NEXT y
END IF
LET drawposx = drawposx + chunksizex
IF drawposx > ((chunksizex * chunktotalx) - chunksizex) THEN
LET drawposx = 0
LET drawposy = drawposy + chunksizey
END IF
NEXT x
LOOP
_MOUSESHOW "CROSSHAIR"
RETURN
menugenerator:
REM temp menugenerator
CLS
LOCATE 1, 1: PRINT "1) NEW GAME"
LOCATE 2, 1: PRINT "2) LOAD GAME"
LOCATE 3, 1: PRINT "3) SAVE GAME"
LOCATE 4, 1: PRINT "4) SCREEN MODE"
LOCATE 5, 1: PRINT "5) QUIT"
IF setupboot = 0 THEN LOCATE 6, 1: PRINT "6) RESUME GAME"
REM print to console
LET eventtitle$ = "MAIN MENU LOADED"
LET eventdata$ = ""
LET eventnumber = 0
GOSUB consoleprinter
INPUT x
IF x = 1 THEN LET x = 0: GOSUB generatelandscape: RETURN
IF x = 2 THEN LET x = 0: GOSUB loadgame
IF x = 3 THEN LET x = 0: GOSUB savegame
IF x = 4 THEN PRINT "COMING SOON!": _DELAY 2
IF x = 5 THEN LET x = 0: GOTO endgame
IF setupboot = 0 THEN IF x = 6 THEN LET x = 0: RETURN
GOTO menugenerator
endgame:
REM quits the game
REM prints to console
LET eventtitle$ = "SYSTEM QUIT REQUESTED"
LET eventdata$ = "frames:"
LET eventnumber = frames
GOSUB consoleprinter
REM unloads game assets
GOSUB assetunload
REM prints to console
LET eventtitle$ = "RTS ENGINE CLOSED"
LET eventdata$ = ""
LET eventnumber = 0
GOSUB consoleprinter
SYSTEM
mapcollision:
REM keeps map on screen
REM zoom
REM zoom out
IF chunksizex < minchunksizex THEN LET chunksizex = minchunksizex
IF chunksizey < minchunksizey THEN LET chunksizey = minchunksizey
REM zoom in
IF chunksizex > maxchunksizex THEN LET chunksizex = maxchunksizex
IF chunksizey > maxchunksizey THEN LET chunksizey = maxchunksizey
REM camera
IF camerax < 0 THEN LET camerax = 0
IF cameray < 0 THEN LET cameray = 0
IF camerax > ((chunksizex * (chunktotalx - 1)) - resx) THEN LET camerax = (chunksizex * (chunktotalx - 1)) - resx
IF cameray > ((chunksizey * chunktotaly) - resy) THEN LET cameray = (chunksizey * chunktotaly) - resy
RETURN
mouseinputter:
REM mouse input
DO WHILE _MOUSEINPUT
LET mousex = _MOUSEX
LET mousey = _MOUSEY
LET leftclick = _MOUSEBUTTON (1)
LET rightclick = _MOUSEBUTTON (2)
LET scrollwheel = scrollwheel + _MOUSEWHEEL
LOOP
IF mousex >= (resx - 10) THEN LET camerax = camerax + scrollspeed: LET drawscreen = 1
IF mousey >= (resy - 10) THEN LET cameray = cameray + scrollspeed: LET drawscreen = 1
IF mousex <= 10 THEN LET camerax = camerax - scrollspeed: LET drawscreen = 1
IF mousey <= 10 THEN LET cameray = cameray - scrollspeed: LET drawscreen = 1
IF leftclick = -1 THEN
REM click to select
LET pointerx = INT((mousex + camerax) / chunksizex)
LET pointery = INT((mousey + cameray) / chunksizey)
LET pointerx = pointerx + 2: REM some weird correction i dont understand yet
LET selectedchunk = pointerx + (pointery * chunktotalx)
LET selectboxalpha = 255: REM sets select box to to visible
LET selectboxalphadirection = 1: REM sets select box to fade out
REM prints to console
LET eventtitle$ = "CHUNK SELECTED"
LET eventdata$ = "X: " + STR$(pointerx) + " Y: " + STR$(pointery) + " type:"
LET eventnumber = chunktype(selectedchunk)
GOSUB consoleprinter
LET leftclick = 0
LET drawscreen = 1
END IF
LET scrollwheel = 0
RETURN
timeframecounter:
REM time + frame counter
IF _EXIT THEN GOTO endgame: REM ends game on window close
IF TIMER < 0 OR ctime < 0 THEN
REM resets timer when value wraparound occurs
RANDOMIZE TIMER
LET itime = TIMER
IF ctime > 0 THEN
LET eventtitle$ = "TIMER RESET:"
ELSE
LET eventtitle$ = "COUNTER RESET:"
END IF
LET eventdata$ = TIME$
LET eventnumber = frames
GOSUB consoleprinter
END IF
REM timer keeper
LET ctime = (TIMER - itime): REM time keeper
LET frames = frames + 1: REM frame counter
REM select box fade
IF selectboxblink > 0 THEN
IF selectboxalphadirection = 1 THEN LET selectboxalpha = selectboxalpha - selectboxblink
IF selectboxalphadirection = 2 THEN LET selectboxalpha = selectboxalpha + selectboxblink
IF selectboxalpha =< 0 THEN LET selectboxalphadirection = 2
IF selectboxalpha => 255 THEN LET selectboxalphadirection = 1
END IF
REM calculate fps
LET temp7 = temp7 + 1
IF temp8 + 1 < ctime THEN
LET fps = temp7
LET temp7 = 0: REM scrub temp values
LET temp8 = ctime: REM reset temp values
END IF
RETURN
game:
REM game loop
_MOUSEMOVE 20, 20
LET frames = 0
REM prints to console
LET eventtitle$ = "ENGINE LOOP STARTED"
LET eventdata$ = ""
LET eventnumber = 0
LET drawscreen = 1
GOSUB consoleprinter
DO
_LIMIT hertz
LET b$ = INKEY$
IF drawscreen = 1 THEN GOSUB drawlandscape: LET drawscreen = 0
GOSUB drawhud
GOSUB keyinputter
GOSUB mouseinputter
GOSUB mapcollision
GOSUB timeframecounter
LOOP
<!-- @page { margin: 2cm } P { margin-bottom: 0.21cm } -->
I am having a problem with one of the example 'Help' programmes. Under LOC 'Help' is a simple programme for RS232 communication with a peripheral via COM1.
OPEN "COM1: 9600,N,8,1,OP0" FOR RANDOM AS #1 LEN = 2048 ' random mode = input and output
DO: t$ = INKEY$ ' get any transmit keypresses from user
IF LEN(t$) THEN PRINT #1, t$ ' send keyboard byte to transmit buffer
bytes% = LOC(1) ' bytes in buffer
IF bytes% THEN ' check receive buffer for data"
r$ = INPUT$(bytes%, 1) ' get bytes in the receive buffer
PRINT r$; ' print byte strings consecutively to screen"
END IF
LOOP UNTIL t$ = CHR$(27) 'escape key exit
CLOSE #
My peripheral is a Summagraphics digitising pad - this has a movable puck with four buttons; you position the puck, press one of the buttons, and it sends the numeric x y coordinates of the puck and a numeric flag for the button to its RS232 port in effectively csv format. Thus the output may be 16958,11142,1<CR><LF> for one press, ie 15 bytes. It also receives input from its RS232 port to configure it. It is thus acting very like a modem.
The above programme in QB64 2.0.2 fails at line 17 with the message "Bad file mode" when I press a keyboard key. Clearly it doesn't like the "Print #1" command.
Which I am not surprised at because isn't "Print #n" a sequential file command and the comms buffer has been opened as "Random"?
And then - if I eliminate the 't$=' and 'IF Len' lines to concentrate on the receive, I get an 'Input past end of file' error at the 'r$=" line, despite LOC returning 15 bytes in the buffer. If I overwrite bytes% with 1, to get the first character in the buffer, I still get 'Input past end of file'.
What is going on? Are these bugs? Any help gratefully received.
Here's a little prog I wrote that helps to keep old Al Zimers at bay. I guess I could use mouse buttons to move, but maybe later...
I know it's basic BASIC, but I'd appreciate a bit of advice on how I could improve it.
'Recall - the latest
Code: (Select All)
_FullScreen
Screen 12: Color , 1: Cls
Randomize Timer
' grid sizes 1-3 numtiles=18, 30, 42 for size 1-3 (A-C, A-E, A-G) 3x6, 5x6, 7x6 grids
' num horizontal rows always 6 numrows=6
' numcols calculated as number of cells / 6 ' numcols=numtiles/6
' grid top row always 2 gtop=2
' gridleft column calculated from numcols gleft= 40-int(numcols/2)
' Max players 4 maxplrs=4
' score 2 points per pair,
' letters read from data first char A-G
' colours (11, 12 and 14) in data as chr$(value of colour number + 76) W, X or Z colours 11, 12 and 14 are chr$(87, 88 and 90) or (W, X and Z) (colour 13 not used)
' Player names stored as names$(4), np is no of players, plr is current player default names PLAYER 1 etc
' scores stored as score(6) score(plr)
' grid frame left calculated from gleft gfleft= gleft*8-4
' grid frame top row always 28 gftop=28
' grid frame width calculated from numcols gfwidth= 8*numcols+8
' grid frame height always 102 gfheight=102
GetGridSize:
Color 14
Locate 15, 30
Print "Choose a grid size (1 to 3)"
While InKey$ <> "": Wend
Play move$
ChooseSize:
k$ = InKey$
If k$ = "" Then GoTo ChooseSize
Select Case k$
Case Is = "1"
numtiles = 18 ' numtiles is number of tiles for that size
Case Is = "2"
numtiles = 30
Case Else
numtiles = 42
End Select
numcols = numtiles / 6 ' numcols is number of columns for that numtiles; numrows is always 6
gleft = 39 - Int(numcols / 2) ' gleft is left column of grid
gright = gleft + numcols ' gright is right column of grid
gfleft = gleft * 8 - 4 ' gfleft is left pixels of grid-frame
gfwidth = 8 * numcols + 6 ' gfwidth is width of grid-frame
Cls
Locate 1, 40 - numtiles / 2
For A = 1 To numtiles
Color Asc(Right$(tiles$(A), 1)) - 76 ' color will be taken from right char of tiles$(..)
Print Left$(tiles$(A), 1); ' letter will be taken from left char of tiles$(..)
Next
PresentGgrid:
ShowGrid ' call showgrid sub to display the grid of tiles before shuffling
_Delay .5
Shuffle
ShowGrid ' call showgrid sub again to display shuffled tiles
Sleep 1
ShowHiddenGrid
GetNames:
np = 0
Color 14
Locate msgline, 26: Print "Enter a name for each player"
Print Tab(6); "Press <SPACE> for automatic names and <ENTER> to finish entering names"
GetAName:
Color 15
Locate msgline + 2, 35: Print Space$(10)
While InKey$ <> "": Wend
Locate msgline + 2, 35: Input n$ ' n$ temporary only
If n$ = "" Then GoTo NoMore ' <SPACE> to finish entering names
np = np + 1 ' np is number of players entered, up to maxplrs
If n$ = " " Then n$ = "PLAYER" + Str$(np) ' default names
n$ = UCase$(n$) ' change to upper-case
names$(np) = n$ ' store in names$()
Locate msgline + np + 2, 35
Print names$(np) ' show all capitalised names below msgline
Play ok$
If np = maxplrs Then GoTo NoMore
GoTo GetAName
NoMore:
Play move$
Locate msgline, 1: Print Space$(720) ' clear message area and names display
' _________________________________________________________________________________________________ Start of Game __________________________________________________
NextTurn: ' return here after every player's turn if not matched
ScreenPrep:
ShowScores ' update and redraw after each player's turn
Color 14
Locate csrline, 40: Print "*"
Locate pickline, 35: Print Space$(20)
namehoriz = 40 - Int(Len(names$(plr)) / 2)
Locate nameline, 1: Print Space$(80)
Locate nameline, namehoriz: Print names$(plr): Sleep 1 ' ensure correct player is named
Locate msgline, 23: Print " Press a key to move into the grid "
MoveIn: ' pick has already been set to 1
k$ = InKey$: If k$ = "" Then GoTo MoveIn
Play move$
Locate csrline, 40: Print " "
csrv = gbottom: csrh = 40: tile = numtiles - Int(numcols / 2)
Color 14: Locate csrv, csrh: Print "*"
Locate msgline, 1: Print Space$(80)
Locate msgline, 3: Print "Use the four arrow-keys to move to a tile, then press <SPACE> to select it"
pick = 1 ' first pick. don't inc player as this is done only if match fails
BeginAction:
Locate csrv, csrh: Color 14: Print "*"
k$ = InKey$: If k$ = "" Or k$ = Chr$(13) Then GoTo BeginAction
GetKey (k$) ' 32 for space (pick a tile), or 272, 275,277 or 280 for cursor
Color 15
Select Case keycode
Case Is = 272 ' up
If csrv > gtop Then
Play move$
Locate csrv, csrh
Color 15: If tiles$(tile) <> " N" Then Print Chr$(249) Else Print " "
csrv = csrv - 1: tile = tile - numcols
colr = Asc(Right$(tiles$(tile), 1)) - 76: letr$ = Left$(tiles$(tile), 1)
Locate csrv, csrh: Color 14: Print "*"
GoTo BeginAction
Else GoTo BeginAction
End If
Case Is = 280 ' down
If csrv < gbottom Then
Play move$
Locate csrv, csrh
Color 15: If tiles$(tile) <> " N" Then Print Chr$(249) Else Print " "
colr = Asc(Right$(tiles$(tile), 1)) - 76: letr$ = Left$(tiles$(tile), 1)
csrv = csrv + 1: tile = tile + numcols
colr = Asc(Right$(tiles$(tile), 1)) - 76: letr$ = Left$(tiles$(tile), 1)
Locate csrv, csrh: Color 14: Print "*"
GoTo BeginAction
Else GoTo BeginAction
End If
Case Is = 275 ' left
If csrh > gleft + 1 Then
Play move$
Locate csrv, csrh
Color 15: If tiles$(tile) <> " N" Then Print Chr$(249) Else Print " "
colr = Asc(Right$(tiles$(tile), 1)) - 76: letr$ = Left$(tiles$(tile), 1)
csrh = csrh - 1: tile = tile - 1
colr = Asc(Right$(tiles$(tile), 1)) - 76: letr$ = Left$(tiles$(tile), 1)
Locate csrv, csrh: Color 14: Print "*"
GoTo BeginAction
Else GoTo BeginAction
End If
Case Is = 277 ' right
If csrh < gright Then
Play move$
Locate csrv, csrh
Color 15: If tiles$(tile) <> " N" Then Print Chr$(249) Else Print " "
colr = Asc(Right$(tiles$(tile), 1)) - 76: letr$ = Left$(tiles$(tile), 1)
csrh = csrh + 1: tile = tile + 1
colr = Asc(Right$(tiles$(tile), 1)) - 76: letr$ = Left$(tiles$(tile), 1)
Locate csrv, csrh: Color 14: Print "*"
GoTo BeginAction
Else GoTo BeginAction
End If
Case Is = 32 ' pick a tile
' for both picks:
Play pick$
If tiles$(tile) = " N" Then ' check if already picked - if so, ignore and get another action
Play old$
Locate msgline, 1: Print Space$(80)
Locate msgline, 32
Print "Already matched!"
Sleep 1
ShowHiddenGrid
Locate msgline, 1: Print Space$(80)
GoTo BeginAction
End If
If pick = 2 And tile = picks(1) Then ' check if second pick is same tile as first - if so, get another action
Play nomatch$
Locate msgline, 1: Print Space$(80)
Locate msgline, 25
Print "You have already picked this tile!"
Sleep 1
Locate msgline, 25: Print Space$(40)
GoTo BeginAction
End If
' if we reached here, tile is still live. May be pick 1 or 2 if we got to here, tile is still valid
colr = Asc(Right$(tiles$(tile), 1)) - 76: letr$ = Left$(tiles$(tile), 1) ' show picked tile in situ
Locate csrv, csrh: Color colr: Print letr$; '
picks(pick) = tile ' identify tile as pick 1 or 2
If pick = 1 Then Locate pickline, 37 Else Locate pickline, 43 ' show picked tile in pickline
Print letr$
If pick = 1 Then
pick = 2
GoTo BeginAction
Else
CheckMatch
Locate msgline, 1: Print Space$(80)
GoTo ScreenPrep ' if first pick, change to second and go back for second. If second, check for a match then setup screen again
End If
End Select
' -------------------------------- SUBS BELOW --------------------------------------
Sub Instructions
Locate 1, 19
For a = 1 To 42
colr = Asc(Right$(tiles$(a), 1)) - 76: letr$ = Left$(tiles$(a), 1)
Color colr: Print letr$;
Next
Color
Locate 3, 37: Color 14: Print "Recall": Print Tab(20); "A Game for up to 6 players by Phil Taylor"
Color 15: Print
Print " This game is a fun way to exercise players' memory and recall skills."
Print
Print " A grid of tiles is displayed, each holding a coloured (but hidden) letter."
Print " There are two of each combination of letter and colour, as shown above."
Print
Print " Before the game starts, players choose the number of tiles to be used, either"
Print " 18, 30, or 42."
Print
Print " Players take turns to move within this grid with the ";: Color 14: Print "four cursor keys";: Color 15: Print " and"
Print " select two tiles with the";: Color 14: Print " <SPACE>";: Color 15: Print " key for each turn."
Print
Print " As each tile is selected it is revealed, and when the second one is selected,"
Print " the two are compared. If they match they are removed and the player scores 2"
Print " points and has another turn. But if not, they are re-hidden and the next"
Print " player plays."
Print
Print " Two points are scored for each matching pair of tiles found and when all the"
Print " tiles have been found, the game ends and the winner is announced."
Print
Color 14: Print Tab(27); " Press any key to commence."
Sleep: Cls: Play ok$
End Sub
Sub GetNames ' set names, np and plr=1
End Sub
Sub ShowGrid
For A = 0 To 5: For b = 1 To numcols
Locate gtop + A, gleft + b
Color Asc(Right$(tiles$(A * numcols + b), 1)) - 76
Print Left$(tiles$(A * numcols + b), 1)
Next: Next
PSet (gfleft, gftop): frame$ = "r" + Str$(gfwidth) + "d" + Str$(gfheight) + "l" + Str$(gfwidth) + "u" + Str$(gfheight): Draw frame$
End Sub
Sub ShowHiddenGrid
For A = 0 To numrows - 1
For b = 1 To numcols
Locate gtop + A, gleft + b
tilenum = A * numcols + b
Color 15: If tiles$(tilenum) <> " N" Then Print Chr$(249) Else Print " " ' show grid with tiles hidden
Next
Next
End Sub
Sub ShowScores
Locate 2, 1: For A = 1 To np: Print Tab(2); names$(A); Tab(12); score(A);: Next ' list names and scores at top left
End Sub
Sub GetKey (k$) ' will return asc of key for normal chars, or 200+ asc of second digit for control keys
If Len(k$) > 1 Then keycode = Asc(Right$(k$, 1)) + 200 Else keycode = Asc(UCase$(k$))
End Sub
Sub Shuffle
For A = 1 To numtiles - 1: t2 = Int(Rnd * numtiles) + 1: Swap tiles$(A), tiles$(t2): Next
End Sub
Sub CheckMatch
Locate msgline, 1: Print Space$(80): Locate msgline, 37
'
If tiles$(picks(1)) = tiles$(picks(2)) Then ' a match
Play match$
Print "A match"
score(plr) = score(plr) + 2 ' inc scores and display them
tiles$(picks(1)) = " N": tiles$(picks(2)) = " N"
numfound = numfound + 2
ShowScores
If numfound = numtiles Then EndGame: System
'
Else ' no match
Play nomatch$
Print "No match";: plr = plr + 1: If plr > np Then plr = 1 ' ready for next player's turn if no match
End If
Sleep 1
Locate msgline, 1: Print Space$(80) ' finished with check: clear message line
Locate pickline, 37: Print Space$(8)
csrh = 40: csrv = csrline: tile = numtiles - Int(numcols / 2)
picks1 = 0: picks2 = 0: pick = 1
ShowHiddenGrid
End Sub
Sub EndGame
Cls
Locate 10, 1
Color 14: Print Tab(34); "Final Scores"
Print: Color 15
For a = 1 To np
Print Tab(30); names$(a); Tab(50); score(a)
Next
Sleep
Cls
End Sub
I have written a program that has a number of files that it accesses, and I want to place it for comments/suggestions. Can I do this,? If so, I guess it goes in the Programs section, but I'm not sure how to do this with the other files being available to it. Also, how many files can it have associated with it?
Option _Explicit
_Define A-Z As _FLOAT
_Title "Triangle Dissection 2 user click" 'B+ 2020-01-29
' Turn a triangle into a square (and back)
' 2020-01-30 now for any triangle, oh and swap points around until back to original dissection! nice :)
' 2020-01-30 Oh now let user click his own triangle for dissection
Dim Ax, Ay, Fx, Fy, Jx, Jy '3 corners A is apex, F and J form iso triangle
Dim Bx, By, Cx, Cy 'midpoint AF and AJ
Dim Gx, Gy, Hx, Hy '1/4 lengths of base
Dim distFJ, aJ ' to calc points G and H
Dim Dx, Dy, Ex, Ey 'two crital points for forming 90 degree angles
Dim D2x, D2y, E2x, E2y, G2x, G2y 'copy points to move as independent blocks
Dim a, cnt, cc 'a = angle in degrees loop counter, cycle counter
Dim tx, ty ' for temp holders to swap points 3 way swap not 2 way
Dim mx(3), my(3), pi, oldMouse 'for mouse user input
getUserTri:
cc = 0
Cls: Circle (400, 370), 200
While pi < 3 'get 3 mouse clicks
_PrintString (5, 5), Space$(20)
_PrintString (5, 5), "Need 3 clicks inside circle, have" + Str$(pi)
While _MouseInput: Wend
mx(0) = _MouseX: my(0) = _MouseY
If _MouseButton(1) And oldMouse = 0 Then 'new mouse down
If Sqr((mx(0) - 400) ^ 2 + (my(0) - 370) ^ 2) < 200 Then
pi = pi + 1
mx(pi) = mx(0): my(pi) = my(0)
Circle (mx(pi), my(pi)), 2
End If
End If
oldMouse = _MouseButton(1)
_Display
_Limit 60
Wend
Ax = mx(1): Ay = my(1)
Jx = mx(2): Jy = my(2)
Fx = mx(3): Fy = my(3)
rotate D2x, D2y, Bx, By, -a
rotate Gx, Gy, Bx, By, -a
rotate Fx, Fy, Bx, By, -a
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
rotate Jx, Jy, Cx, Cy, a
rotate Hx, Hy, Cx, Cy, a
rotate Ex, Ey, Cx, Cy, a
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
rotate G2x, G2y, Cx, Cy, a
rotate E2x, E2y, Cx, Cy, a
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
cnt = cnt + 1
_Display
_Limit 60
Wend
_Delay 1
'swap points for different dissection
tx = Ax: ty = Ay
Ax = Jx: Ay = Jy
Jx = Fx: Jy = Fy
Fx = tx: Fy = ty
GoTo restart
Sub rotate (x, y, cx, cy, rAngle) 'replace x, y with new position
Dim angle, distance
angle = _Atan2(y - cy, x - cx)
distance = ((x - cx) ^ 2 + (y - cy) ^ 2) ^ .5
x = cx + distance * Cos(angle + _D2R(rAngle))
y = cy + distance * Sin(angle + _D2R(rAngle))
End Sub
Sub circleTangentXY (X1, Y1, X2, Y2, xC, yC, findXperp, findYperp)
'p1 and p2 form a line, with slop and y intersect y0
'xC, yC is a circle origin
'we find X, Y such that line x, y to xC, yC is perpendicular to p1, p2 line that is radius of tangent circle
Dim slope, y0, A, B
If X2 <> X1 Then
slope = (Y2 - Y1) / (X2 - X1)
y0 = slope * (0 - X1) + Y1
A = slope ^ 2 + 1
B = 2 * (slope * y0 - slope * yC - xC)
findXperp = -B / (2 * A)
findYperp = slope * findXperp + y0
Else
findXperp = X1
findYperp = yC
End If
End Sub
Sub ln (x1, y1, x2, y2)
Line (x1, y1)-(x2, y2)
End Sub
'2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
'update 2019-12-16 needs updated fTri 2019-12-16
'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (x1, y1, x2, y2, x3, y3, x4, y4, K As _Unsigned Long)
ftri x1, y1, x2, y2, x3, y3, K
ftri x3, y3, x4, y4, x1, y1, K
End Sub
Funny things might happen with narrow slivers of a triangle but any acute triangle should be fine.
A long time ago you mentioned about with dropbox that by having a "1" at the end of a link (instead of a "0"), made it easier for people to directly download a file in my free (for now) limited dropbox account. This technique had been working successfully for quite some time.
Recently, you and someone else now, has reported back to me that an error message occurs -... "You don't belong here...".
Any ideas how for me to share from dropbox a FOLDER to a particular person, with the minimum number of "hoops" to jump through to share - since what I did in the past (i.e. the "1" at end of link) does not now appear to work?
Note I am using the "free" version of dropbox with its known limitations - as I have been doing for some years now.
