Option _Explicit

$Color:32

Type ToggleButton

    active As Integer

    state As Integer

    x As Integer

    y As Integer

End Type

ReDim Shared Toggles(1000) As ToggleButton

ReDim Shared As Integer TogglesInUse

Dim Shared As Long Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY



Screen _NewImage(640, 480, 32)



Dim As Long foo, fred, MBS



foo = CreateToggle(100, 100) 'create a name for the toggle and decide where to place it on the screen

fred = CreateToggle(300, 300) 'a second toggle to make certain we work with multiples well

Do

    Cls

    MBS = MouseButtonStatus 'get the mouse status once here, to be used anywhere else in our processes

    ProcessToggles MBS 'check to see if we've clicked on the active toggles

    DisplayToggles 'display them after any change

    Print "Toggle foo's value:"; GetToggleValue(foo) 'we can get the value back here

    Print "Toggle fred's value:"; GetToggleValue(fred) 'we can get the value back here

    _Limit 30

    _Display

Loop Until _KeyDown(27)

FreeToggle 0 'free all toggles for use later

System





Function GetToggleValue (handle As Long)

    If handle < 0 Or handle > 1000 Then Exit Function

    GetToggleValue = Toggles(handle).state

End Function



Sub FreeToggle (handle As Long)

    If handle < 0 Or handle > 1000 Then Exit Sub

    If handle = 0 Then TogglesInUse = 0

    Toggles(handle).active = 0

End Sub





Sub ProcessToggles (MBS As Long)

    Dim As Long i

    If MBS And 8 Then 'left button was clicked

        For i = 1 To TogglesInUse

            If _MouseX >= Toggles(i).x And _MouseX <= Toggles(i).x + 100 Then

                If _MouseY >= Toggles(i).y And _MouseY <= Toggles(i).y + 24 Then

                    Toggles(i).state = Not Toggles(i).state

                End If

            End If

        Next

    End If

End Sub



Sub DisplayToggles

    Dim As Long i, x, y, state, w, t, cx, cy

    Dim As Long DC, BGC

    DC = _DefaultColor: BGC = _BackgroundColor

    w = 25: t = 12

    Color White, 0

    For i = 1 To TogglesInUse

        If Toggles(i).active Then

            x = Toggles(i).x

            y = Toggles(i).y

            state = Toggles(i).state

            'draw the whole toggle

            cx = x + 2 * w: cy = y + t

            Line (x, y)-Step(100, 24), DarkGray, BF

            If state Then 'the toggle has been clicked to the right (ON by default)

                EllipseFill cx + w, cy, w, t, Green

                _PrintString (cx + w - 8, cy - 8), "ON"

            Else

                EllipseFill cx - w, cy, w, t, Red

                _PrintString (cx - w - 12, cy - 8), "OFF"

            End If

        End If

    Next

    Color DC, BGC

End Sub



Function CreateToggle (x As Long, y As Long)

    Dim As Long i

    For i = 1 To TogglesInUse

        If Toggles(i).active = 0 Then

            Toggles(i).active = -1

            Toggles(i).x = x

            Toggles(i).y = y

            CreateToggle = i

            Exit Function

        End If

    Next

    TogglesInUse = i

    Toggles(i).active = -1

    Toggles(i).x = x

    Toggles(i).y = y

    CreateToggle = i

End Function



Sub EllipseFill (CX As Integer, CY As Integer, a As Integer, b As Integer, C As _Unsigned Long)

    ' CX = center x coordinate

    ' CY = center y coordinate

    ' a = semimajor axis

    ' b = semiminor axis

    ' C = fill color

    If a = 0 Or b = 0 Then Exit Sub

    Dim h2 As _Integer64

    Dim w2 As _Integer64

    Dim h2w2 As _Integer64

    Dim x As Integer

    Dim y As Integer

    w2 = a * a

    h2 = b * b

    h2w2 = h2 * w2

    Line (CX - a, CY)-(CX + a, CY), C, BF

    Do While y < b

        y = y + 1

        x = Sqr((h2w2 - y * y * w2) \ h2)

        Line (CX - x, CY + y)-(CX + x, CY + y), C, BF

        Line (CX - x, CY - y)-(CX + x, CY - y), C, BF

    Loop

End Sub



Function MouseButtonStatus% 'Mouse Button Status

    Static StartTimer As _Float

    Static ButtonDown As Integer

    Const ClickLimit## = 0.2 'Less than 1/4th 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

    Dim As Long tempMBS, BD

    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

    MouseButtonStatus = tempMBS

End Function

OPTION _EXPLICIT

f 2



SUB f (x)

    DIM x AS LONG

    PRINT x

END SUB

OPTION _EXPLICIT

f 2



SUB f (x)

    DIM x AS LONG

    PRINT x, x!

END SUB

Line drawing using Rotoline a routine made possible by RotoZoom

DECLARE LIBRARY

    FUNCTION glutGet& (BYVAL what&)

    SUB glutReshapeWindow (BYVAL width&, BYVAL height&)

END DECLARE



$RESIZE:ON

_DELAY 2

ClearTheFlag = _RESIZE



DO

    CLS , 3

    IF _RESIZE THEN

        RSW = _RESIZEWIDTH

        RSH = _RESIZEHEIGHT

        W = RSW \ _FONTWIDTH

        H = RSH \ _FONTHEIGHT

        IF W < 40 THEN W = 40

        IF H < 15 THEN H = 15

        IF W > 120 THEN W = 120

        IF H > 50 THEN H = 50

        f = _FONT

        WIDTH W, H

        _FONT f

        IF _WIDTH * _FONTWIDTH <> WindowWidth OR _HEIGHT * _FONTHEIGHT <> WindowHeight THEN

            glutReshapeWindow _WIDTH * _FONTWIDTH, _HEIGHT * _FONTHEIGHT

        END IF

        ClearTheFlag = _RESIZE

    END IF

    PRINT _WIDTH, _HEIGHT

    _DISPLAY

LOOP



FUNCTION WindowWidth

    WindowWidth = glutGet(102) '102 is the const value of GLUT_WINDOW_WIDTH

END FUNCTION



FUNCTION WindowHeight

    WindowHeight = glutGet(103) '103 is the const value of GLUT_WINDOW_HEIGHT

END FUNCTION

A friend asked me to help him out how making a notebook paper screen that would work for various screen sizes and font size.  He was trying to use an image&, but couldn't get the LOCATE/PRINT to fit in the paper lines.  I suggested this way to him, using _FONTWIDTH/_FONTHEIGHT to scale drawing text LINEs instead. Thought I'd share it here because it may be something others may want.  I commented this code more than usual to help my friend learn.  This SUB draws a yellow legal pad paper, but you can make other papers styles fairly easy.

- Dav

'yellowpaper.bas

'by Dav, OCT/2023



SCREEN _NEWIMAGE(800, 600, 32)



'Here's where you can load another font you want to use....

'fnt& = _LOADFONT("lucon.ttf", 24, "monospace")

'_FONT fnt&



'Call the SUB, with your title$ message

YellowPaper "John's QB64-PE Code Notebook"



'You need to call below so PRINTing text doesn't destroy background.

_PRINTMODE _KEEPBACKGROUND



'=== show some sample information....

COLOR _RGB(64, 64, 64)

FOR y = 5 TO 16

    LOCATE y, 2: PRINT DATE$;

    LOCATE , 16: PRINT "Random Data ="; RND; RN;

NEXT: PRINT



'Use location 2 to print in left column, 16 for printing in the text lines.



PRINT

LOCATE , 16: PRINT "This is another line."

PRINT

LOCATE , 2: PRINT "Tuesday:"

LOCATE , 16: PRINT "Dear diary, today I wrote this...."

SLEEP



SUB YellowPaper (title$)



    'This SUB draws yellow notebook paper, scaled to fit current font settings.

    'It also prints and centers title$ in the top title area.



    fw = _FONTWIDTH: fh = _FONTHEIGHT 'get current font width/height settings

    '(the fw & fh we will use to calculate LINE drawing so they line up right with PRINT)



    CLS , _RGB(255, 245, 154) 'clear screen to yellow color



    'draw the two vertical brown lines, to make column/text area

    LINE (fw * 12, 0)-(fw * 12, _HEIGHT), _RGB(205, 185, 98)

    LINE (fw * 12.5, 0)-(fw * 12.5, _HEIGHT), _RGB(205, 185, 98)



    'draw the text lines to bottom of screen

    FOR y = fh - 1 TO _HEIGHT STEP fh

        LINE (0, y)-(_WIDTH, y), _RGB(152, 160, 74)

    NEXT



    'draw top brown tile area (remove this if not wanted)

    LINE (0, 0)-(_WIDTH, fh * 3), _RGB(102, 19, 15), BF '<< enough for 3 lines

    COLOR _RGB(255, 255, 0)



    'Next we print title$, centering the text in the top area

    'For this we need to calcuale how many letters fit on one line, INT(_WIDTH/fw) / 2.

    'I divided that by 2 to find the center spot on the line.

    'So, subtract half of the title$ length from that spot to make it centered nice.

    LOCATE 2, INT((_WIDTH / fw) / 2) - INT(LEN(title$) / 2)



    'Now we PRINT the text, but we need to print a certain way so the background isn't

    'messed up.  We will use _PRINTMODE _KEEPBACKGROUND to do that.

    'First, let's save the current printmode so we can restore that when SUB is done.

    pmode = _PRINTMODE

    _PRINTMODE _KEEPBACKGROUND



    PRINT title$; 'finally, PRINT the title$



    'All done, so let's restore previous printmode setting

    IF pmode = 1 THEN _PRINTMODE _KEEPBACKGROUND

    IF pmode = 2 THEN _PRINTMODE _ONLYBACKGROUND

    IF pmode = 3 THEN _PRINTMODE _FILLBACKGROUND



END SUB

why doesn't this work?

Something I've been tinkering with. I created the QB64PE fire logo on the tutorial site and decided to keep going with the code to create animated logos.

I've created a demo animation in the "main code" section to show how the graphics can be used. The zip file includes the sprite sheets and phoenix sound.

I envision the demo I made as a "Made With QB64 Phoenix Edition" intro to game programs.

At the top of the code is a complete chart of all assets brought in and their locations on the sprite sheet as well as where they should be placed on the screen to create a logo (of course you can choose to put them any where you like). Play around and see what you can come up with.

The ZIP file below contains the sprite sheets, sound file, and the .BAS file.

Attached Files

  QB64Logo.zip (Size: 8.53 MB / Downloads: 45)

If you are interested in this, even just to see Feather Wiki in action for release notes:

Release Notes

Quite often I find the need to clear an image other than the current screen or _DISPLAY and have to do this:

oDest& = _DEST
_DEST MyImage&
CLS
_DEST oDest&

Perhaps CLS could be modified:

CLS [method%][, bgColor&][, ImageHandle&]

so this could be done:

CLS , , MyImage&

Just a thought.

If you have a better way of handing a situation like this than I'm doing let me know.

Hi all
Need help with a Scientific Notation to real number converter.   Below is a mockup for testing the Function but if I do the
calculations by hand the outputs don't match.  

Thanks in advance

R1

FOR L1 = 1 TO 9

    IF L1 = 1 THEN A = 75 / 130

    IF L1 = 2 THEN A =  1 / 103

    IF L1 = 3 THEN A =  7 / 27

    IF L1 = 4 THEN A = 11 / 42

    IF L1 = 5 THEN A = 15 / 63

    IF L1 = 6 THEN A = 35 / 118

    IF L1 = 7 THEN A = 60 / 142

    IF L1 = 8 THEN A = 47 / 125

    IF L1 = 9 THEN A = 93 / 148



    A=A^2

    A$ = StrNum$(A)

    A$=MID$(A$,1,6)

    P=P + VAL(A$)



    PRINT A$

NEXT



P = (P/9)

A$ = STRNUM$(P)

A$=MID$(A$,1,6)

PRINT A$ + " <- averaged"

color 10

print "Press any key"

SLEEP

SYSTEM



FUNCTION StrNum$ (n)

    value$ = UCASE$(LTRIM$(STR$(n)))

    XPOS1 = INSTR(value$, "D") + INSTR(value$, "E")

    IF XPOS1 THEN

        expo = VAL(MID$(value$, XPOS1 + 1))

        IF VAL(value$) < 0 THEN

            sign$ = "-": value$ = MID$(value$, 2, XPOS1 - 2)

        ELSE value$ = MID$(value$, 1, XPOS1 - 1)

        END IF

        dot = INSTR(value$, "."): L = LEN(value$)

        IF expo > 0 THEN ADD$ = StrNum$(expo - (L - dot), "0")

        IF expo < 0 THEN min$ = StrNum$(ABS(expo) - (dot - 1), "0"): DP$ = "."

        FOR N = 1 TO L

            IF MID$(value$, N, 1) <> "." THEN num$ = num$ + MID$(value$, N, 1)

        NEXT

    ELSE StrNum$ = value$: EXIT FUNCTION

    END IF

    StrNum$ = sign$ + DP$ + min$ + num$ + ADD$

END FUNCTION