My scatter-brained self, as I was studying QB64's SOUND and PLAY statements, and the "Web Audio API", got caught up in sound theory in general and then waveforms in particular.
Just in case anybody else feels like geeking out on this stuff while enjoying a hot/cold brew :
Posted by: OldMoses - 08-06-2022, 03:39 AM - Forum: Programs
- No Replies
...could use a magnifier. I had done something similar on the old forum, but wanted something more portable. It mainly consists of two SUBs, one to create a color masking image and the other to acquire the portion to be magnified and apply the mask. Right mouse click magnifies the portion the mouse is hovering over, while the mousewheel controls the magnification factor. Hotkeys are "+" and "-" to increase or decrease magnifier size, and "s" to toggle a rifle scoop type reticle. Esc to quit.
It uses the screen image for navigation, but takes the magnified content from the original loaded image.
I also zipped it with several demo images, both big and small, or comment out the _LOADIMAGE code and use one of your own. It comes enabled to Bruegel's "Triumph of Death". Not so much to be macabre, but because Bruegel is the medieval periods answer to Richard Scarry. It's just chock full of details, perfect for magnification.
The '63 Chevy P/U image is a smaller image that is stretched to fit the screen so it will be noticed that Mag factor 1 will actually shrink it. The other images are larger and shrunk to fit.
SCREEN _NEWIMAGE(_DESKTOPWIDTH, _DESKTOPHEIGHT - 80, 32)
DO UNTIL _SCREENEXISTS: LOOP
_SCREENMOVE 0, 0
'VARIABLES
DIM SHARED msk& ' reticle mask handle
DIM hratio ' height ratio: screen / image
DIM wratio ' width ratio: screen / image
DIM ratio ' ratio to shrink image to screen
DIM magsiz%
DIM magfactor%
DIM scope%%
hratio = _HEIGHT(0) / _HEIGHT(img&)
wratio = _WIDTH(0) / _WIDTH(img&)
ratio = -hratio * (hratio < wratio) - wratio * (wratio <= hratio)
magsiz% = 250
magfactor% = 2
scope%% = 0
Make_Mask magsiz%, scope%%
DO
CLS
Image_Resize 0, 0, _WIDTH(0) - 1, _HEIGHT(0) - 1, img&, 0, "l", "u" 'placeimage to fit screen upper left corner
_PRINTSTRING (0, 0), "Original size " + STR$(_WIDTH(img&)) + " x " + STR$(_HEIGHT(img&))
_PRINTSTRING (0, 16), "Ratio= " + STR$(ratio) + " Mag. factor= " + STR$(magfactor%)
k$ = INKEY$
IF k$ <> "" THEN
IF k$ = CHR$(43) THEN ' "+" to increase magnifier size
magsiz% = magsiz% + 25: vin%% = -1
END IF
IF k$ = CHR$(45) THEN ' "-" to decrease magnifier size
magsiz% = magsiz% - 25: vin%% = -1
IF magsiz% < 25 THEN magsiz% = 25
END IF
IF k$ = "s" THEN ' "s" to toggle scope reticle
scope%% = NOT scope%%: vin%% = -1
END IF
IF vin%% THEN Make_Mask magsiz%, scope%% ' if valid input then redo mask overlay
k$ = "": vin%% = 0 ' clear input & and valid input flag
END IF
ms = MBS
IF ms AND 1 THEN ' left mouse button to show magnifier
_MOUSEHIDE
Magnify magfactor%, img&, magsiz%, ratio
ELSE
_MOUSESHOW "crosshair"
END IF
IF ms AND 512 THEN ' mousewheel to change magnification factor
magfactor% = magfactor% - 1
IF magfactor% < 1 THEN magfactor% = 1
END IF
IF ms AND 1024 THEN
magfactor% = magfactor% + 1
IF magfactor% > 30 THEN magfactor% = 30
END IF
_LIMIT 30
_DISPLAY
LOOP UNTIL _KEYDOWN(27)
END
SUB Make_Mask (s%, sc%)
cn% = _SHR(s%, 1) - 1 ' image center
IF msk& < -1 THEN _FREEIMAGE msk& ' remove old mask if any
IF sc% THEN ' if scope enabled, draw crosshairs
ret& = _NEWIMAGE(s%, s%, 32) ' define reticle image
_DEST ret& ' destination to reticle
CLS '
_CLEARCOLOR _RGB32(0, 0, 0) ' background transparent
CIRCLE (cn%, cn%), cn%, &HFFFF0000 ' circular border
CIRCLE (cn%, cn%), cn% - 1, &HFFFF0000
CIRCLE (cn%, cn%), cn% - 2, &HFFFF0000
LINE (0, cn%)-(s% - 1, cn%), &HFFFF0000 ' scope reticle
LINE (s% / 3, cn% + 1)-(s% * (2 / 3), cn% + 1), &HFFFF0000
LINE (cn% + 1, s% / 3)-(cn% + 1, s% * (2 / 3)), &HFFFF0000
LINE (cn%, 0)-(cn%, s% - 1), &HFFFF0000
END IF
msk& = _NEWIMAGE(s%, s%, 32) ' create mask image
_DEST msk&
COLOR , _RGB32(255, 0, 255) ' fill mask with purple to clear color in SUB Magnify
CLS
FCirc cn%, cn%, cn%, _RGB32(0, 0, 0) ' apply centered black circle to clearcolor in SUB Magnify
IF ret& < -1 THEN _PUTIMAGE , ret&: _FREEIMAGE ret& '
_DEST 0 '
END SUB 'Make_Mask
SUB Magnify (mf%, src&, s%, r!)
hs% = _SHR(s%, 1): hf% = hs% / mf% ' radius and mag at radius
x% = map!(_MOUSEX, 0, _WIDTH(src&) * r!, 0, _WIDTH(src&) - 1) 'map mouse position relative to image
y% = map!(_MOUSEY, 0, _HEIGHT(src&) * r!, 0, _HEIGHT(src&) - 1)
mag& = _NEWIMAGE(s%, s%, 32) ' Create magnifier lense
_PUTIMAGE , src&, mag&, (x% - hf%, y% - hf%)-(x% + hf%, y% + hf%) 'portion of src& to mag&
_DEST mag&
_CLEARCOLOR _RGB32(0, 0, 0), msk& ' set clearcolor to inner circle of mask
_PUTIMAGE , msk&, mag& ' overlay on magnifier
_CLEARCOLOR _RGB32(255, 0, 255), mag& ' clearcolor purple corners of mag& placed by mask
_PUTIMAGE (_MOUSEX - hs% - 1, _MOUSEY - hs% - 1), mag&, 0 ' place finished magnifier to screen, mouse centered
_FREEIMAGE mag&
END SUB 'Magnify
SUB FCirc (CX AS INTEGER, CY AS INTEGER, RR AS INTEGER, C AS _UNSIGNED LONG) 'by Steve McNeill
DIM R AS INTEGER, RError AS INTEGER
DIM X AS INTEGER, Y AS INTEGER
R = ABS(RR)
RError = -R
X = R
Y = 0
IF R = 0 THEN PSET (CX, CY), C: EXIT SUB
LINE (CX - X, CY)-(CX + X, CY), C, BF
WHILE X > Y
RError = RError + Y * 2 + 1
IF RError >= 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
RError = RError - 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 'FCirc
SUB Image_Resize (xpos AS INTEGER, ypos AS INTEGER, xlim AS INTEGER, ylim AS INTEGER, i AS LONG, d AS LONG, xj AS STRING, yj AS STRING)
DIM AS INTEGER xs, ys, xp, yp, xl, yl ' ready for OPTION EXPLICIT programs
xp = xpos: yp = ypos: xl = xlim: yl = ylim ' isolate sent parameters from any changes
DIM AS SINGLE rt, xrt, yrt
xrt = (xl - xp) / _WIDTH(i) ' width of area divided by width of image
yrt = (yl - yp) / _HEIGHT(i) ' height of area divided by height of image
rt = -xrt * (xrt < yrt) - yrt * (yrt <= xrt) ' pick the smaller of the two ratios to fit area
xs = _WIDTH(i) * rt ' final image size ratio in x
ys = _HEIGHT(i) * rt ' final image size ratio in y
xp = -xp * (xj = "l") - (_SHR(xl - xp, 1) + xp - _SHR(xs, 1)) * (xj = "c") - (xl - xs) * (xj = "r")
xl = xp + xs
yp = -yp * (yj = "u") - (_SHR(yl - yp, 1) + yp - _SHR(ys, 1)) * (yj = "c") - (yl - ys) * (yj = "d")
yl = yp + ys
_PUTIMAGE (xp, yp)-(xl, yl), i, d
END SUB 'Image_Resize
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION 'map!
FUNCTION MBS% 'by Steve McNeill
STATIC StartTimer AS _FLOAT
STATIC ButtonDown AS INTEGER
'STATIC ClickCount AS INTEGER
CONST ClickLimit## = .4 'Less than 1/2 of a second to down, up a key to count as a CLICK.
' Down longer counts as a HOLD event.
SHARED Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
WHILE _MOUSEINPUT 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.
SELECT CASE SGN(_MOUSEWHEEL)
CASE 1: tempMBS = tempMBS OR 512
CASE -1: tempMBS = tempMBS OR 1024
END SELECT
WEND
IF _MOUSEBUTTON(1) THEN tempMBS = tempMBS OR 1
IF _MOUSEBUTTON(2) THEN tempMBS = tempMBS OR 2
IF _MOUSEBUTTON(3) THEN tempMBS = tempMBS OR 4
IF StartTimer = 0 THEN
IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)
ButtonDown = 1: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
ELSEIF _MOUSEBUTTON(2) THEN
ButtonDown = 2: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
ELSEIF _MOUSEBUTTON(3) THEN
ButtonDown = 3: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
END IF
ELSE
BD = ButtonDown MOD 3
IF BD = 0 THEN BD = 3
IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit. It's a click
IF _MOUSEBUTTON(BD) = 0 THEN tempMBS = 4 * 2 ^ ButtonDown: ButtonDown = 0: StartTimer = 0
ELSE
IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended
tempMBS = 0: ButtonDown = 0: StartTimer = 0
Mouse_EndX = _MOUSEX: Mouse_EndY = _MOUSEY
ELSE 'We've now started the hold event
tempMBS = tempMBS OR 32 * 2 ^ ButtonDown
END IF
END IF
END IF
MBS% = tempMBS
END FUNCTION 'MBS%
Posted by: CharlieJV - 08-06-2022, 02:56 AM - Forum: Programs
- No Replies
Nothing fancy, just a small bit of code I wanted to mindlessly play with. In case you want to put your own "spin" on it ...
A GW-BASIC program I modified in BASIC Anywhere Machine (view source code, run the program) before bringing it over to QB64.
Code: (Select All)
' Based on https://github.com/Zannick/qbasic-programs/blob/master/ROTATE.BAS by Benjamin Wolf (April 8, 2003)
SCREEN 12 : x = 0.5
DO
CLS
if x < 1 then
CIRCLE (320, 240), 230, 11
CIRCLE (320, 240), 75, 11
else
CIRCLE (320, 240), 230, 11, , , x
CIRCLE (320, 240), 75, 11, , , x
end if
if int(x*250000) < 1000000 then
FOR z = 1 TO 1000000 - int(x * 250000)
NEXT z
end if
_delay 0.0125
IF x = 75 THEN y = 2
IF x < 1 THEN y = 1
SELECT CASE y
CASE 1
x = x + 0.5
CASE 2
x = x - 0.5
END SELECT
LOOP
IF MID$(a$, 1, 1) = "-" THEN neg_a = -1
IF MID$(b$, 1, 1) = "-" THEN neg_b = -1
IF INSTR(a$, ".") THEN
dec_a1$ = MID$(a$, 1, INSTR(a$, ".") - 1): dec_a2$ = MID$(a$, INSTR(a$, ".") + 1)
ELSE
dec_a1$ = a$
END IF
IF INSTR(b$, ".") THEN
dec_b1$ = MID$(b$, 1, INSTR(b$, ".") - 1): dec_b2$ = MID$(b$, INSTR(b$, ".") + 1)
ELSE
dec_b1$ = b$
END IF
DO
' Test for sign.
SELECT CASE neg_a + neg_b
CASE 0, -2 ' Both positive or negative
IF dec_a1$ = dec_b1$ AND dec_a2$ = dec_b2$ THEN a_less_b = 0: EXIT DO ' Same number.
IF LEN(dec_a1$) AND dec_b1$ = "" THEN a_less_b = 1: EXIT DO ' a >=1 and b is a decimal.
IF LEN(dec_b1$) AND dec_a1$ = "" THEN a_less_b = -1: EXIT DO ' b >=1 and a is a decimal.
IF LEN(dec_a1$) AND dec_a1$ <> dec_b1$ OR LEN(dec_b1$) AND dec_a1$ <> dec_b1$ THEN ' One or both >=1 and non-decimal parts are not equal.
IF LEN(dec_a1$) > LEN(dec_b1$) THEN a_less_b = 1: EXIT DO
IF LEN(dec_a1$) < LEN(dec_b1$) THEN a_less_b = -1: EXIT DO
IF LEN(dec_a1$) = LEN(dec_b1$) THEN
FOR i = 1 TO LEN(dec_a1$)
IF MID$(dec_a1$, i, 1) <> MID$(dec_b1$, i, 1) THEN EXIT FOR
NEXT
IF MID$(dec_a1$, i, 1) < MID$(dec_b1$, i, 1) THEN a_less_b = -1: EXIT DO ELSE a_less_b = 1: EXIT DO
END IF
ELSE ' Both decimals or non-decimal digits are the same and cancel out.
j = LEN(dec_a2$)
IF LEN(dec_b2$) > j THEN j = LEN(dec_b2$)
FOR i = i TO j
IF MID$(dec_a2$, i, 1) <> MID$(dec_b2$, i, 1) THEN EXIT FOR
NEXT
IF MID$(dec_a2$, i, 1) < MID$(dec_b2$, i, 1) THEN a_less_b = -1: EXIT DO ELSE a_less_b = 1: EXIT DO
END IF
CASE -1 ' One is negative.
j = -999
IF neg_a THEN a_less_b = -1: EXIT DO ELSE a_less_b = 1: EXIT DO
END SELECT
EXIT DO
LOOP
IF neg_a OR neg_b THEN IF j <> -999 THEN a_less_b = a_less_b * -1
IF a_less_b < 0 THEN PRINT "a$ < b$" ELSE IF a_less_b = 0 THEN PRINT "a$ = b$" ELSE PRINT "a$ > b$"
REM PRINT dec_a1$, dec_a2$, dec_b1$, dec_b2$, neg_a, neg_b
PRINT
SLEEP
RUN
The point I'm at now, I can get away with using string comparison as long as I disallow -0 and flip the results for two negatives. A single negative is always the smaller number but as I came to realize in string comparisons from a different tread, when faced with two negatives, a string evaluation will not change the fact that the larger numeric value of string is all that is considered. You need a sub-routine to invert the results.
So, can anyone see anything I missed here in the shortcut routine, or is this cake all backed?
So testing out number comparison using STRING$() instead of the very limited VAL() function. What i discovered is string$() comparison does a great job, even on very large numbers, decimals included, until you get to comparing two negative string numbers. Note in the last comparison the string evaluation is true and should be false for [-11.2 > -11.1] as it is in the numeric variable comparison.
Ha! Just viewed all latest updates in Portal. Seems they don't get around to newest stuff in Prolific Programmers Board so here is a little message, GUI Waffle has just been posted here: https://staging.qb64phoenix.com/showthre...21#pid4921
I tried to update the Help file (Update all pages) and was told "It may take a while", so I sat back and waited. After about 10 seconds I got another message that there was an "Internal error in the IDE". Does this mean my QB64 file may be outdated, or corrupted? Should I re-install QB64PE?
I'm getting a message "Can't save program" when I try to save a new program. I tried closing the prog and opening an existing one; the existing one opens ok and runs, but when I try to re-save it I get the same message. It has Error Code 26306-12305, whatever that means! It's only just started happening (or at least, I've only just had it happen). Maybe I have used up all my allocated space? (I have plenty of space on my drive). Any Ideas please?
